receiptlist.ctl

金算盘软件代码

                intRow = intRow + 1
            Loop
        End With
   End If
   
   If tSubId <> 0 And tCodeId <> 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 And .rdoColumns(m_intSubIdCol - 1).Value = tSubId _
                    And m_intSubIdCol > 0 And m_intCodeIdCol > 0 Then
                    SeekId = True
                    Exit Do
                End If
                .MoveNext
                intRow = intRow + 1
            Loop
        End With
   End If
   
   If SeekId Then
       m_ReferRow = intRow
       For intCol = 1 To m_intTextCols
           If strText = "" Then
               strText = m_rstForGrid.rdoColumns(m_arrTextCol(intCol) - 1).Value
           Else
               strText = strText & " " & m_rstForGrid.rdoColumns(m_arrTextCol(intCol) - 1).Value
           End If
       Next
       blnChange = False
       TxtRefer.Text = strText
   End If
End Function

Public Function SeekText(ByVal strData As String, Optional IsPopUp As Boolean = True, Optional IsChoose As Boolean = False, Optional AllSame As Boolean = False) As Boolean
  Dim intRow As Integer, intCol As Integer
  Dim intCount As Integer
  Dim intLenth As Integer
  Dim StrSeek As String, blnFound As Boolean, intColLen As Integer, strText As String
  
  On Error GoTo ErrHandle
  intLenth = Len(strData)
  If Trim(strData) = "" Then
     SeekText = True
     Exit Function
  End If
  
  blnFound = False
  With m_rstForGrid
         If .RowCount = 0 Then
            Exit Function
         End If
         .MoveFirst
         intRow = 1
         Do While Not .EOF
             intColLen = 0
             For intCount = 1 To m_intTextCols
               If m_arrTextCol(intCount) >= 1 And m_arrTextCol(intCount) <= .rdoColumns.Count Then
                    If StrSeek = "" Then
                       StrSeek = .rdoColumns(m_arrTextCol(intCount) - 1)
                    Else
                       StrSeek = StrSeek & " " & .rdoColumns(m_arrTextCol(intCount) - 1)
                    End If
                    If InStr(.rdoColumns(m_arrTextCol(intCount) - 1), strData) = 1 And (Not AllSame) Then
                        blnFound = True
                        Exit For
                    End If
                    intColLen = intColLen + Len(.rdoColumns(m_arrTextCol(intCount) - 1)) + 1
               End If
             Next intCount
             
             If (InStr(StrSeek, strData) = 1 And (Not AllSame)) Or blnFound Or Trim(StrSeek) = Trim(strData) Then
                  If m_ReferRow = -1 Then
                     m_ReferRow = intRow
                     m_CurRow = intRow
                  Else
                     m_CurRow = intRow
                     frmReceiptList.ChangeCurRow intRow
                  End If
                  If Not blnFound Then
                     intColLen = 0
                  End If
                  
                  For intCol = 1 To m_intTextCols
                     If strText = "" Then
                         strText = .rdoColumns(m_arrTextCol(intCol) - 1).Value
                     Else
                         strText = strText & " " & .rdoColumns(m_arrTextCol(intCol) - 1).Value
                     End If
                  Next
                  blnChange = False
                  TxtRefer.Text = strText
                  TxtRefer.SetFocus
                  
                  If StrSeek = strData And m_intTextCols = intCount Then
                    TxtRefer.SelStart = Len(TxtRefer.Text)
                    SendKeys "+{HOME}"
                  Else
                    If intCount <> 1 Or (intCount = 1 And m_intTextCols = 1) Then
                         TxtRefer.SelStart = intLenth + intColLen
                         TxtRefer.SelLength = Len(Trim$(TxtRefer.Text)) - (intLenth + intColLen)
                    Else
                         TxtRefer.SelStart = 0
                         TxtRefer.SelLength = Len(TxtRefer)
                    End If
                  End If
                  
                  SeekText = True
                  
                  If IsPopUp And Not m_blnReferVisible Then
                      PopRefer True
                  End If
                  Exit Function
             End If
             StrSeek = ""
             .MoveNext
             intRow = intRow + 1
         Loop
  End With
  If IsPopUp And Not m_blnReferVisible Then
      PopRefer True
  End If

ErrHandle:
End Function

Private Sub TxtRefer_Change()
  If blnChange Or Trim(TxtRefer.Text) = "" Then
     If Not SeekText(TxtRefer.Text) Or Trim(TxtRefer.Text) = "" Then
         If m_ReferRow > -1 Then
            frmReceiptList.ChooseRow m_ReferRow, False
            frmReceiptList.ChangeCurRow -1
            m_ReferRow = -1
            m_CurRow = -1
         End If
     End If
  Else
     blnChange = True
  End If
End Sub

Private Sub TxtRefer_KeyDown(KeyCode As Integer, Shift As Integer)
  blnChange = True
  'Alt + Down(弹出参照)
  'Space     (弹出参照)
  If Shift = 4 And KeyCode = 40 Then
     If m_blnReferVisible Then
         Exit Sub
     End If
     PopRefer True
  ElseIf KeyCode = vbKeySpace Then
    If Not m_blnReferVisible Then
        PopRefer True
    End If
  End If
  Select Case KeyCode
     Case vbKeyTab
         PopRefer False
     Case vbKeyReturn
         PopRefer False
     Case vbKeyDelete, vbKeyBack
         If Trim(TxtRefer.Text) <> "" Then
             blnChange = False
         End If
     Case vbKeyDown
         If m_blnReferVisible Then
            frmReceiptList.grdRefer.SetFocus
            If m_CurRow > 0 Then
               frmReceiptList.ChangeCurRow m_CurRow + 1
            End If
         End If
     Case vbKeyUp
         If m_blnReferVisible Then
            frmReceiptList.grdRefer.SetFocus
            If m_CurRow > 0 Then
               frmReceiptList.ChangeCurRow m_CurRow - 1
            End If
         End If
     Case vbKeyPageUp
         If m_blnReferVisible Then
            frmReceiptList.grdRefer.SetFocus
            If m_CurRow > 0 Then
               If m_CurRow - 15 > 0 Then
                  frmReceiptList.ChangeCurRow m_CurRow - 15
               Else
                  frmReceiptList.ChangeCurRow 1
               End If
            End If
         End If
     Case vbKeyPageDown
         If m_blnReferVisible Then
            frmReceiptList.grdRefer.SetFocus
            If m_CurRow > 0 Then
               frmReceiptList.ChangeCurRow m_CurRow + 15
            End If
         End If
     Case Else
  End Select
End Sub

Private Sub TxtRefer_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim po As POINTAPI
    Dim l As Long
    Select Case Button
        Case 2
            Button = -1
            If m_ParenthWnd <> 0 Then
                ReleaseCapture
                po.x = x
                po.y = y
                ClientToScreen TxtRefer.hwnd, po
                ScreenToClient m_ParenthWnd, po
                l = po.y * 65536 + po.x
                SendMessage m_ParenthWnd, WM_RBUTTONUP, 0, l
            End If
    End Select
End Sub

Private Sub UserControl_EnterFocus()
  Dim intCount As Integer
   blnChange = True
   Set UserControls.mrstForCombox = m_rstForCombox
   Set UserControls.mrstForGrid = m_rstForGrid
   UserControls.mblnShowCombox = m_blnShowCombox
   UserControls.mintCodeIdCol = m_intCodeIdCol
   UserControls.mintSubIdCol = m_intSubIdCol
   UserControls.mintTextCols = m_intTextCols
   ReDim UserControls.marrTextCol(m_intTextCols)
   For intCount = 1 To m_intTextCols
        UserControls.marrTextCol(intCount) = m_arrTextCol(intCount)
   Next intCount

   UserControls.mintTotalCols = m_intTotalCols
   
   ReDim UserControls.marrTotalCol(m_intTotalCols)
   For intCount = 1 To m_intTotalCols
        UserControls.marrTotalCol(intCount) = m_arrTotalCol(intCount)
   Next intCount

   ReDim UserControls.marrTotalDec(m_intTotalCols)
   For intCount = 1 To m_intTotalCols
        UserControls.marrTotalDec(intCount) = m_arrTotalDec(intCount)
   Next intCount
End Sub

Private Sub UserControl_InitProperties()
    m_Appearance = m_def_Appearance
    m_BorderStyle = m_def_BorderStyle
    m_blnReferVisible = False
    m_intSubIdCol = -1
    m_intCodeIdCol = -1
    m_ReferRow = -1
    m_CurRow = -1
End Sub

Private Sub UserControl_Paint()
    UserControl.AutoRedraw = False
    If m_BorderStyle = 1 Then
        UserControl.DrawWidth = 1
        UserControl.DrawMode = 13
        '3D 效果
        If m_Appearance = 1 Then
            
            '深灰
            UserControl.ForeColor = &H80000003
            UserControl.Line (10, 2)-(UserControl.ScaleWidth - 10, 2)
            UserControl.Line (5, 5)-(5, UserControl.ScaleHeight - 10)
            
            '黑
            UserControl.ForeColor = &H80000007
            UserControl.Line (10, 10)-(UserControl.ScaleWidth - 30, 10)
            UserControl.Line (10, 10)-(10, UserControl.ScaleHeight - 30)
            
            '灰
            UserControl.ForeColor = &H8000000F
            UserControl.Line (10, UserControl.ScaleHeight - 40)-(UserControl.ScaleWidth - 20, UserControl.ScaleHeight - 40)
            UserControl.Line (UserControl.ScaleWidth - 20, 10)-(UserControl.ScaleWidth - 20, UserControl.ScaleHeight - 30)
            
            '白
            UserControl.ForeColor = &H80000005
            UserControl.Line (10, UserControl.ScaleHeight - 35)-(UserControl.ScaleWidth - 20, UserControl.ScaleHeight - 35)
            UserControl.Line (UserControl.ScaleWidth - 20, 10)-(UserControl.ScaleWidth - 20, UserControl.ScaleHeight - 10)
        Else
            '黑
            UserControl.ForeColor = &H80000007
            UserControl.Line (10, 5)-(UserControl.ScaleWidth, 5)
            UserControl.Line (5, 5)-(5, UserControl.ScaleHeight)
            UserControl.Line (10, UserControl.ScaleHeight - 10)-(UserControl.ScaleWidth, UserControl.ScaleHeight - 10)
            UserControl.Line (UserControl.ScaleWidth - 20, 10)-(UserControl.ScaleWidth - 20, UserControl.ScaleHeight)
        End If
    End If
End Sub

Private Sub UserControl_Resize()
     On Error Resume Next
     If UserControl.width < 500 Then
         UserControl.width = 500
     End If
         
     If UserControl.Height < 225 And m_BorderStyle = 0 Then
          UserControl.Height = 225
     End If
     
     If UserControl.Height < 320 And m_BorderStyle = 1 Then
          UserControl.Height = 320
     End If
    
     '有边框
     If m_BorderStyle = 1 Then
        '三维效果时
        If m_Appearance = 1 Then
             
             TxtRefer.top = 30
             TxtRefer.Left = 30
             TxtRefer.Height = UserControl.Height - 70
             TxtRefer.width = UserControl.width - 325
             cmdBrow.top = 30
             cmdBrow.Height = UserControl.Height - 70
             cmdBrow.width = UserControl.width - TxtRefer.width - 50
             cmdBrow.Left = TxtRefer.width + TxtRefer.Left - 10
             cmdBrow.ZOrder
        '二维效果时
        Else
             TxtRefer.top = 20
             TxtRefer.Left = 20
             TxtRefer.Height = UserControl.Height - 40
             TxtRefer.width = UserControl.width - 295
             cmdBrow.top = 20
             cmdBrow.Height = UserControl.Height - 40
             cmdBrow.width = UserControl.width - TxtRefer.width - 30
             cmdBrow.Left = TxtRefer.width + TxtRefer.Left - 10
        End If
     '无边框
     Else
        TxtRefer.top = 0
        TxtRefer.Left = 0
        TxtRefer.Height = UserControl.Height
        TxtRefer.width = UserControl.width - 255
        cmdBrow.top = 0
        cmdBrow.Height = UserControl.Height
        cmdBrow.width = UserControl.width - TxtRefer.width
        cmdBrow.Left = TxtRefer.width + TxtRefer.Left
        cmdBrow.ZOrder
     End If
    
     UserControl.Refresh
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Dim Index As Integer
    Dim intCount As Integer
    
    TxtRefer.BackColor = PropBag.ReadProperty("BackColor", &HC0C0C0)
    TxtRefer.Enabled = PropBag.ReadProperty("Enabled", False)
    m_Appearance = PropBag.ReadProperty("Appearance", m_def_Appearance)
    m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
    m_intSubIdCol = PropBag.ReadProperty("SubIdCol", m_def_SubIdCol)
    m_intCodeIdCol = PropBag.ReadProperty("CodeIdCol", m_def_CodeIdCol)
    m_SubId = PropBag.ReadProperty("SubId", m_def_SubId)
    m_CodeId = PropBag.ReadProperty("CodeId", m_def_CodeId)
    m_ReferRow = PropBag.ReadProperty("ReferRow", m_def_ReferRow)
    m_CurRow = PropBag.ReadProperty("CurRow", m_def_CurRow)
End Sub

Private Sub UserControl_Terminate()
    Unload frmReceiptList
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Dim Index As Integer
    Dim intCount As Integer
    Call PropBag.WriteProperty("BackColor", TxtRefer.BackColor, &H8000000E)
    Call PropBag.WriteProperty("Enabled", TxtRefer.Enabled, False)
    Call PropBag.WriteProperty("Appearance", m_Appearance, m_def_Appearance)
    Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
    Call PropBag.WriteProperty("SubIdCol", m_intSubIdCol, m_def_SubIdCol)
    Call PropBag.WriteProperty("CodeIdCol", m_intCodeIdCol, m_def_CodeIdCol)
    Call PropBag.WriteProperty("SubId", m_SubId, m_def_SubId)
    Call PropBag.WriteProperty("CodeId", m_CodeId, m_def_CodeId)
    Call PropBag.WriteProperty("ReferRow", m_ReferRow, m_def_ReferRow)
    Call PropBag.WriteProperty("CurRow", m_CurRow, m_def_CurRow)
End Sub

Public Property Let ParenthWnd(ByVal hwnd As Long)
    m_ParenthWnd = hwnd
End Property

Public Property Get ParenthWnd() As Long
    ParenthWnd = m_ParenthWnd
End Property