receiptlist.ctl

金算盘软件代码

VERSION 5.00
Begin VB.UserControl ReceiptList 
   ClientHeight    =   1230
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3270
   ScaleHeight     =   1230
   ScaleWidth      =   3270
   Begin VB.TextBox TxtRefer 
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      Height          =   375
      Left            =   30
      TabIndex        =   0
      Top             =   30
      Width           =   2535
   End
   Begin VB.CommandButton cmdBrow 
      Height          =   405
      Left            =   2550
      Picture         =   "ReceiptList.ctx":0000
      Style           =   1  'Graphical
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   30
      UseMaskColor    =   -1  'True
      Width           =   255
   End
End
Attribute VB_Name = "ReceiptList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Const m_def_Appearance = 1
Const m_def_BorderStyle = 1
Const m_def_CodeIdCol = -1
Const m_def_SubIdCol = -1
Const m_def_CodeId = 0
Const m_def_SubId = 0
Const m_def_ReferRow = -1
Const m_def_CurRow = -1

Dim m_Appearance As Integer
Dim m_BorderStyle As Byte
Dim m_rstForGrid As rdoResultset
Dim m_rstForCombox As rdoResultset
Dim m_blnShowCombox As Boolean
Dim m_intCodeIdCol As Integer
Dim m_intSubIdCol As Integer
Dim m_intTextCols As Integer
Dim m_arrTextCol() As Integer
Dim m_intTotalCols As Integer
Dim m_arrTotalCol() As Integer
Dim m_arrTotalDec() As String
Dim m_blnReferVisible As Boolean
Dim m_SubId As Long
Dim m_CodeId As Long
Dim m_ReferRow As Long
Dim m_CurRow As Long

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private m_ParenthWnd As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Const WM_RBUTTONUP = &H205

Dim blnChange As Boolean


Public Event ChangeCode()


'''''''''''''''''''''''''''''''
'
'        属     性
'
'''''''''''''''''''''''''''''''
Public Property Get Appearance() As Integer
    Appearance = m_Appearance
End Property

Public Property Let Appearance(New_Appearance As Integer)
    m_Appearance = New_Appearance
    PropertyChanged "Appearance"
    UserControl_Resize
End Property

'背景色
Public Property Get BackColor() As OLE_COLOR
    BackColor = TxtRefer.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    TxtRefer.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

Public Property Get BorderStyle() As Byte
    BorderStyle = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Byte)
    m_BorderStyle = New_BorderStyle
    PropertyChanged "BorderStyle"
    UserControl_Resize
End Property

Public Property Get CodeId() As Long
Attribute CodeId.VB_Description = "编码ID"
    CodeId = m_CodeId
End Property

Public Property Let CodeId(New_CodeId As Long)
    m_CodeId = New_CodeId
    PropertyChanged "CodeId"
End Property

Public Property Get CodeIdCol() As Integer
Attribute CodeIdCol.VB_Description = "编码ID对应的列号"
    CodeIdCol = m_intCodeIdCol
End Property

Public Property Let CodeIdCol(New_CodeIdCol As Integer)
    m_intCodeIdCol = New_CodeIdCol
    PropertyChanged "CodeIdCol"
End Property

Public Property Get CurRow() As Long
    CurRow = m_CurRow
End Property

Public Property Let CurRow(New_CurRow As Long)
    m_CurRow = New_CurRow
    PropertyChanged "CurRow"
End Property

Public Property Get Enabled() As Boolean
    Enabled = TxtRefer.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    TxtRefer.Enabled = New_Enabled
    PropertyChanged "Enabled"
End Property

Public Property Get ReferRow() As Long
Attribute ReferRow.VB_Description = "选中行"
    ReferRow = m_ReferRow
End Property

Public Property Let ReferRow(New_ReferRow As Long)
    m_ReferRow = New_ReferRow
    PropertyChanged "ReferRow"
End Property


Public Property Get ReferVisible() As Boolean
Attribute ReferVisible.VB_Description = "参照窗口是否可见"
    ReferVisible = m_blnReferVisible
End Property

Public Property Let ReferVisible(New_ReferVisible As Boolean)
    m_blnReferVisible = New_ReferVisible
End Property

Public Property Set RstForCombox(New_Rst As rdoResultset)
Attribute RstForCombox.VB_Description = "COMBOX绑定的记录集"
    Set m_rstForCombox = New_Rst
End Property

Public Property Get RstForCombox()
    Set RstForGrid = m_rstForCombox
End Property

Public Property Set RstForGrid(New_Rst As rdoResultset)
Attribute RstForGrid.VB_Description = "参照列表绑定的记录集"
    Set m_rstForGrid = New_Rst
End Property

Public Property Get RstForGrid()
    Set RstForGrid = m_rstForGrid
End Property

Public Property Get SelStart() As Integer
    SelStart = TxtRefer.SelStart
End Property

Public Property Let SelStart(ByVal New_SelStart As Integer)
    TxtRefer.SelStart = New_SelStart
End Property

Public Property Get SelLength() As Integer
    SelLength = TxtRefer.SelLength
End Property

Public Property Let SelLength(ByVal New_SelLength As Integer)
    TxtRefer.SelLength = New_SelLength
End Property

Public Property Let ShowCombox(New_ShowCombox As Boolean)
Attribute ShowCombox.VB_Description = "是否显示COMBOX"
    m_blnShowCombox = New_ShowCombox
End Property

Public Property Get ShowCombox() As Boolean
    ShowCombox = m_blnShowCombox
End Property

Public Property Get SubId() As Long
Attribute SubId.VB_Description = "分录ID"
    SubId = m_SubId
End Property

Public Property Let SubId(New_SubId As Long)
    m_SubId = New_SubId
    PropertyChanged "SubId"
End Property

Public Property Get SubIdCol() As Integer
Attribute SubIdCol.VB_Description = "分录ID列"
    SubIdCol = m_intSubIdCol
End Property

Public Property Let SubIdCol(New_SubIdCol As Integer)
    m_intSubIdCol = New_SubIdCol
    PropertyChanged "SubIdCol"
End Property

Public Property Get Text() As String
    Text = TxtRefer.Text
End Property

Public Property Let Text(New_Text As String)
    TxtRefer.Text = New_Text
End Property

Public Property Get TotalCols() As Integer
Attribute TotalCols.VB_Description = "合计列数"
    TotalCols = m_intTotalCols
End Property

Public Property Let TotalCols(New_TotalCols As Integer)
    m_intTotalCols = New_TotalCols
    ReDim m_arrTotalCol(New_TotalCols)
    ReDim m_arrTotalDec(New_TotalCols)
End Property

Public Property Get TotalCol(ByVal Index As Integer) As Integer
Attribute TotalCol.VB_Description = "合计列，如：TotalCol(1)=3"
    TotalCol = m_arrTotalCol(Index)
End Property

Public Property Let TotalCol(ByVal Index As Integer, New_TotalCol As Integer)
    m_arrTotalCol(Index) = New_TotalCol
End Property

Public Property Get TotalDec(ByVal Index As Integer) As String
    TotalDec = m_arrTotalDec(Index)
End Property

Public Property Let TotalDec(ByVal Index As Integer, New_TotalDec As String)
    m_arrTotalDec(Index) = New_TotalDec
End Property

Public Property Get TextCols() As Integer
Attribute TextCols.VB_Description = "TEXT对应的列数"
    TextCols = m_intTextCols
End Property

Public Property Let TextCols(New_TextCols As Integer)
    m_intTextCols = New_TextCols
    ReDim m_arrTextCol(New_TextCols)
End Property

Public Property Get TextCol(ByVal Index As Integer) As Integer
Attribute TextCol.VB_Description = "TEXT对应的列,如：TextCol(1)=3,TextCol(2)=4"
    TextCol = m_arrTextCol(Index)
End Property

Public Property Let TextCol(ByVal Index As Integer, New_TextCol As Integer)
    m_arrTextCol(Index) = New_TextCol
End Property

'''''''''''''''''''''''''''''''
'
'        方     法
'
'''''''''''''''''''''''''''''''
Public Sub AddId(ByVal tSubId As Long, ByVal tCodeId As Long)
   m_SubId = SubId
   m_CodeId = CodeId
End Sub

Public Sub AddText(ByVal strText As String)
   blnChange = False
   TxtRefer.Text = strText
End Sub

Private Sub cmdBrow_Click()
   PopRefer Not m_blnReferVisible
End Sub

Public Function PopRefer(Optional ByVal blnPop As Boolean = True) As Boolean
Attribute PopRefer.VB_Description = "弹出参照"
   Dim wPic As POINTAPI
   Dim wControl As POINTAPI
   Dim x As Long, y As Long, ListTop As Long
   Dim lngLeft As Long, lngTop As Long
   
   UserControl_EnterFocus
   If Not blnPop Then
      m_blnReferVisible = False
      ReleaseCapture
      Unload frmReceiptList
      Set mobjRpList = Nothing
   Else
      On Error Resume Next
      Set mobjRpList = Me
      Unload frmReceiptList
      Load frmReceiptList
      
      frmReceiptList.Form_Resize
      
      ClientToScreen UserControl.hwnd, wControl
      If frmReceiptList.width < UserControl.width Then
          frmReceiptList.width = UserControl.width
      End If
      lngLeft = wControl.x * Screen.TwipsPerPixelX + UserControl.width - frmReceiptList.width
      lngTop = wControl.y * Screen.TwipsPerPixelY + UserControl.Height

      If lngLeft < 0 Then
         lngLeft = wControl.x * Screen.TwipsPerPixelX
         If lngLeft + frmReceiptList.width > Screen.width - 100 Then
             lngLeft = Screen.width - frmReceiptList.width - 100
         End If
      End If
      
      If lngTop + frmReceiptList.Height > Screen.Height Then
         lngTop = wControl.y * Screen.TwipsPerPixelY - frmReceiptList.Height
      End If
      frmReceiptList.Move lngLeft, lngTop
      SetWindowPos frmReceiptList.hwnd, HWND_TOPMOST, lngLeft, lngTop, frmReceiptList.width, frmReceiptList.Height, SWP_NOACTIVATE Or SWP_NOMOVE Or SWP_NOSIZE
      frmReceiptList.Show
      TxtRefer.SetFocus
      m_blnReferVisible = True
   End If
End Function

Public Sub RaiseCtlEvent(ByVal Index As Integer)
   Select Case Index
      Case 1
        RaiseEvent ChangeCode
   End Select
End Sub

Public Function SeekId(Optional ByVal tSubId As Long = 0, Optional ByVal tCodeId As Long = 0) As Boolean
  Dim intRow As Integer, intCol As Integer
  Dim strText As String
  
   If tSubId <> 0 And tCodeId = 0 And m_intSubIdCol > 0 Then
        With m_rstForGrid
            If .RowCount = 0 Then
               Exit Function
            End If
            .MoveFirst
            intRow = 1
            Do While Not .EOF
                If .rdoColumns(m_intSubIdCol - 1).Value = tSubId Then
                    SeekId = True
                    Exit Do
                End If
                .MoveNext
                intRow = intRow + 1
            Loop
        End With
   End If
   
   If tSubId = 0 And tCodeId <> 0 And m_intCodeIdCol > 0 Then
        With m_rstForGrid
            If .RowCount = 0 Then
               Exit Function
            End If
            .MoveFirst
            intRow = 1
            Do While Not .EOF
                If .rdoColumns(m_intCodeIdCol - 1).Value = tCodeId Then
                    SeekId = True
                    Exit Do
                End If
                .MoveNext