takestock.cls

金算盘软件代码

                If lngC <> lngCol Then
                    .col = lngC
                End If
            End If
        Else
            If lngCol = 20 Then
                .TextMatrix(lngRow, lngCol) = IIf(C2lng(strText) = 0, "", C2lng(strText))
            Else
                .TextMatrix(lngRow, lngCol) = strText
            End If
        End If
    End With
    My.blnRefresh = blnRefreshBak
End Sub
'------------------------------
'从GRID上某一单元格内取出字符串
'------------------------------
Public Function strGrdCell(ByVal lngRow As Long, ByVal lngCol As Long, Optional blnBackRowCol As Boolean = True) As String
'    Dim lngR As Long, lngC As Long
'    Dim blnB As Boolean
'    If lngRow > frmName.grdCol.Rows - 1 Or lngCol > frmName.grdCol.Cols - 1 Or _
'       lngRow < 0 Or lngCol < 0 Then
'        Exit Function
'    End If
'    If frmName.grdCol.ColAlignment(lngCol) = flexAlignRightCenter Then
'        blnB = My.blnCtrlBinding
'        My.blnRefresh = False
'        My.blnCtrlBinding = False
'        lngR = frmName.grdCol.Row
'        lngC = frmName.grdCol.col
'        frmName.grdCol.Row = lngRow
'        frmName.grdCol.col = lngCol
'        If CLng(frmName.grdCol.CellForeColor) = CLng(RGB(255, 0, 0)) Then
'            strGrdCell = "-" & FilterString(frmName.grdCol.TextMatrix(lngRow, lngCol))
'        Else
'            strGrdCell = FilterString(frmName.grdCol.TextMatrix(lngRow, lngCol))
'        End If
'
'        frmName.grdCol.Row = lngR
'        frmName.grdCol.col = lngC
'        My.blnCtrlBinding = blnB
'        My.blnRefresh = True
'    Else
'        strGrdCell = frmName.grdCol.TextMatrix(lngRow, lngCol)
'    End If
    Dim lngR As Long, lngC As Long
    Dim blnB As Boolean
    Dim blnRefreshBak As Boolean
    Dim strTmp As String
    
    blnRefreshBak = My.blnRefresh
    
    With frmName.GrdCol
        If lngRow > .Rows - 1 Or lngCol > .Cols - 1 Or _
           lngRow < 0 Or lngCol < 0 Then
            Exit Function
        End If
        If .ColAlignment(lngCol) = flexAlignRightCenter Then
            My.blnRefresh = False
            If blnBackRowCol Then
                lngR = .Row
                lngC = .col
            End If
            If lngR <> lngRow Then
                .Row = lngRow
            End If
            If lngC <> lngCol Then
                .col = lngCol
            End If
            If CLng(.CellForeColor) = CLng(RGB(255, 0, 0)) Then
                strTmp = "-" & .TextMatrix(lngRow, lngCol)
            Else
                strTmp = .TextMatrix(lngRow, lngCol)
            End If
            If blnBackRowCol Then
                If lngR <> lngRow Then
                    .Row = lngR
                End If
                If lngC <> lngCol Then
                    .col = lngC
                End If
            End If
            strGrdCell = FilterString(strTmp, ",")
            My.blnRefresh = blnRefreshBak
        Else
            strGrdCell = .TextMatrix(lngRow, lngCol)
        End If
    End With
End Function

Private Sub Class_Terminate()
    Set mclsSubClass = Nothing
    Set mclsHook = Nothing
    Set HookHe = Nothing
    Erase Field
'    Erase PicLbl
    Erase ColProperty
    Erase lngPosition
    Erase strColRow
    Erase arrItemProperty
    Erase strTranGrid
    Set ColBill = Nothing  '单据内容集合(不包括ActivityID和DetailID)
    Set ctrInput = Nothing
    Set ctrPicInput = Nothing
    Set frmName = Nothing
    Set clsRecord = Nothing
    Set NewQ = Nothing
End Sub

Private Sub HookHe_OnMessage(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCancel As Long)
    Dim lngSelStart As Long
    If Msg = WM_CHAR Or Msg = WM_KEYDOWN Or Msg = WM_KEYUP Then
        If m_bBusy Then
            bCancel = 1
            GoTo EndProc
        End If
        If blnMenuVisible Then
            GoTo EndProc
        End If
    End If
    If Msg = WM_KEYDOWN Then
        If wParam = 37 Or wParam = 39 Then
            If Not ctrInput Is Nothing Then
                If UCase(ctrInput.Name) = UCase("QuanInput") Then
                    lngSelStart = NewQ.SelStart
                Else
                    lngSelStart = ctrInput.SelStart
                End If
            End If
        End If
    
        If wParam = 38 Or wParam = 40 Or wParam = 9 Or wParam = 13 Then      'TAB键处理程序
            If wParam = 13 And UCase(frmName.ActiveControl.Name) = "CMDBUTTON" Then
                If frmName.ActiveControl.Index < 4 Then
                    blnKeyInForm = False
                Else
                    blnKeyInForm = True
                End If
            Else
                blnKeyInForm = True
            End If
        ElseIf wParam = 37 Then
            If Not ctrInput Is Nothing And My.bytRegion <> FcmdButton And My.bytRegion <> FCheck Then
                If lngSelStart = 0 Then
                    blnKeyInForm = True
                End If
            Else
                blnKeyInForm = True
            End If
        ElseIf wParam = 39 Then
            If Not ctrInput Is Nothing And My.bytRegion <> FcmdButton And My.bytRegion <> FCheck Then
                If lngSelStart = Len(TextOfCtrInput) Then
                    blnKeyInForm = True
                End If
            Else
                blnKeyInForm = True
            End If
        ElseIf wParam = 27 Then 'ESCAPE
            blnKeyInForm = True
            If ctrInput Is Nothing Then

            Else
                If UCase(ctrInput.Name) = "REFINPUT" Or UCase(ctrInput.Name) = "DTMINPUT" Or UCase(ctrInput.Name) = "CURINPUT" Or UCase(ctrInput.Name) = "RECLIST" Then
                    If UCase(ctrInput.Name) = "REFINPUT" Then
                        If ctrInput.ReferVisible Then
'                            ctrInput.PopRefer False
                            blnEscNoCancel = True
                            GoTo EndProc
                        End If
                    ElseIf UCase(ctrInput.Name) = "DTMINPUT" Or UCase(ctrInput.Name) = "CURINPUT" Then
                        If ctrInput.IsDropDown Then
                            blnEscNoCancel = True
                            GoTo EndProc
                        End If
                    ElseIf UCase(ctrInput.Name) = "RECLIST" Then
                        If ctrInput.ReferVisible Then
'                            ctrInput.PopRefer False
                            blnEscNoCancel = True
                            GoTo EndProc
                        End If
                    End If
                End If
            End If
            blnEscNoCancel = False
            
        End If
    End If
    If Msg = WM_KEYUP Then
        If Not blnKeyInForm Then GoTo EndProc
        blnKeyInForm = False
        If wParam = 37 Or wParam = 38 Or wParam = 39 Or wParam = 40 Or wParam = 9 Or wParam = 13 Then      'TAB键处理程序
            If wParam = 13 Then
                If GetKeyState(17) < 0 Then
                    GoTo EndProc
                End If
            End If
            If Not m_bBusy Then
                m_bBusy = True
                TabOrder (wParam)
'                bCancel = 1
                m_bBusy = False
            End If
        ElseIf wParam = 27 Then 'ESCAPE
            If Not blnEscNoCancel Then
                #If conWan = 1 Then
                  If My.bytRegion = FCheck Then
                      Unload frmName
                  Else
                      ChkSetFocus 0
                  End If
                #Else
                  If My.bytRegion = FcmdButton And My.bytIndex = 0 Then
                      Unload frmName
                  Else
                      cmdButton_Click 0
                  End If
                #End If
            Else
                blnEscNoCancel = False
            End If
'            Reload
'            bCancel = 1
        End If
    End If
EndProc:
    #If conWan = 1 Then
      If Msg <> WM_MOUSEMOVE And Msg <> 280 Then
         If My.bytRegion = FcmdButton Then
            ChkSetFocus 0
         End If
      End If
'      If frmName.ActiveControl Is Nothing Then
'         ChkSetFocus 0
'      ElseIf frmName.ActiveControl.Name = "cmdButton" Then
'        ChkSetFocus 0
'      End If
    #End If
End Sub

Private Sub mclsSubClass_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    Dim lngX As Long, lngY As Long
    Dim sinX As Single, sinY As Single
    Dim lngCnt As Long
    Dim i As Integer, mOldRow As Integer, mOldCol As Integer
    Dim intRow As Integer
    Static blnColDrag As Boolean

    lngX = (lParam Mod (2 ^ 16)) * Screen.TwipsPerPixelX
    lngY = (lParam \ (2 ^ 16)) * Screen.TwipsPerPixelY
    sinX = lngX
    sinY = lngY
    If Msg = WM_LBUTTONUP Then
        mclsSubClass.CallWndProc Msg, wParam, lParam
        '确保第0列不被拖出
        If frmName.GrdCol.ColWidth(0) > 0 Then frmName.GrdCol.ColWidth(0) = 0
        For i = 1 To 18
            If ColProperty(xlngColNo(i)).blnUsable = False And frmName.GrdCol.ColWidth(xlngColNo(i)) <> 0 Then
                frmName.GrdCol.ColWidth(xlngColNo(i)) = 0
            End If
            If ColProperty(xlngColNo(i)).blnUsable = True And frmName.GrdCol.ColWidth(xlngColNo(i)) < 490 Then
                frmName.GrdCol.ColWidth(i) = 490
            End If
        Next i
        For i = 19 To frmName.GrdCol.Cols - 1
            If frmName.GrdCol.ColWidth(i) <> 0 Then
                frmName.GrdCol.ColWidth(i) = 0
            End If
        Next
        If blnColDrag Then
            blnColDrag = False
            With frmName.GrdCol
                My.blnRefresh = False
'                If frmName.grdCol.ColWidth(frmName.grdCol.col) < 490 Then
'                    frmName.grdCol.ColWidth(frmName.grdCol.col) = 490
'                End If
                If My.bytRegion = FGrid Or My.bytRegion = FPicture Then
'                    If My.bytIndex <> .col Then .col = My.bytIndex
                    If My.lngOldCol <> .col Then .col = My.lngOldCol
                    If My.lngOldRow <> .Row Then .Row = My.lngOldRow
                     GrdInputButtonLocal .Row, .col
                End If
                TotalRowAdjust
'                frmName.LblBack.Refresh
'                RefreshRect frmName.hwnd, frmName.GrdCol.Left, frmName.GrdCol.top + frmName.GrdCol.Height + 1 * Screen.TwipsPerPixelY, frmName.LblBack.Left + frmName.LblBack.width - 9 * Screen.TwipsPerPixelX, frmName.lblNote(1).top - 2 * Screen.TwipsPerPixelY
                My.blnRefresh = True
                'frmname.Refresh
            End With
        End If
        Exit Sub
    End If
    
    If Msg = WM_LBUTTONDOWN Then        '鼠标左键按下
        With frmName.GrdCol
            If .MouseRow < .FixedRows Then    '点中固定行
                '判断鼠标是否点中列线以便拖动
                i = .MouseCol
                If lngX >= .ColPos(i) + .ColWidth(i) - 50 Or lngX <= .ColPos(i) + 50 Then
                    blnColDrag = True
                End If
            End If
        End With
        mclsSubClass.CallWndProc Msg, wParam, lParam
        Exit Sub
    End If
    
    If Msg = WM_PAINT Then
    '取Paint事件矩形区域
        If My.blnRefresh Then
            '取Paint事件矩形区域
            If Not m_pBusy Then
                m_pBusy = True
                GetUpdateRect frmName.GrdCol.hWnd, GridClipRect, False
                mclsSubClass.CallWndProc Msg, wParam, lParam
                If frmName.GrdCol.Visible Then
                    DrawReadOnlyCol
                    DrawGridLine
    '               Debug.Print Time
                End If
                m_pBusy = False
            End If