submitadjust.cls

金算盘软件代码

'------------------------------
'在GRID上写红字
'------------------------------
Public Sub WriteGrd(ByVal strText As String, ByVal lngRow As Long, ByVal lngCol As Long)
    Dim lngR As Long, lngC As Long
    Dim blnB As Boolean
    Dim blnOldR As Boolean
    Dim strNew As String
    If lngRow > frmName.GrdCol.Rows - 1 Or lngCol > frmName.GrdCol.Cols - 1 Or _
       lngRow < 0 Or lngCol < 0 Then
        Exit Sub
    End If
    strText = Trim(strText)
    If (ColProperty(lngCol).lngCtrType = tCurrency Or frmName.GrdCol.ColAlignment(lngCol) = flexAlignRightCenter) And Len(strText) > 0 Then
        blnOldR = My.blnRefresh
        My.blnRefresh = False
        lngR = frmName.GrdCol.Row
        lngC = frmName.GrdCol.col
        frmName.GrdCol.Row = lngRow
        frmName.GrdCol.col = lngCol
        strNew = Left(strText, 1)
        If strNew = "-" Then
            frmName.GrdCol.CellForeColor = RGB(255, 0, 0)
            frmName.GrdCol.TextMatrix(lngRow, lngCol) = Mid(strText, 2)
        ElseIf Val(strText) = 0 Then
            frmName.GrdCol.CellForeColor = RGB(0, 0, 0)
            frmName.GrdCol.TextMatrix(lngRow, lngCol) = ""
        Else
            frmName.GrdCol.TextMatrix(lngRow, lngCol) = strText
            frmName.GrdCol.CellForeColor = RGB(0, 0, 0)
        End If
        frmName.GrdCol.Row = lngR
        frmName.GrdCol.col = lngC
        My.blnRefresh = blnOldR
    Else
        frmName.GrdCol.TextMatrix(lngRow, lngCol) = strText
    End If

End Sub
'------------------------------
'从GRID上某一单元格内取出字符串
'------------------------------
Public Function strGrdCell(ByVal lngRow As Long, ByVal lngCol As Long) As String
    Dim lngR As Long, lngC As Long
    Dim blnB As Boolean
    Dim blnOldR 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
        blnOldR = My.blnRefresh
        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 = "-" & frmName.GrdCol.TextMatrix(lngRow, lngCol)
        Else
            strGrdCell = frmName.GrdCol.TextMatrix(lngRow, lngCol)
        End If

        frmName.GrdCol.Row = lngR
        frmName.GrdCol.col = lngC
        My.blnCtrlBinding = blnB
        My.blnRefresh = blnOldR
    Else
        strGrdCell = frmName.GrdCol.TextMatrix(lngRow, lngCol)
    End If
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
    Set ColBill = Nothing  '单据内容集合(不包括ActivityID和DetailID)
    Set ctrInput = Nothing
    Set ctrPicInput = Nothing
    Set frmName = Nothing
    Set NewQ = Nothing
End Sub
Public Sub Form_key_Down(ByVal KeyCode As Long, ByVal Shift As Integer)
    Dim bCancel As Long
    ShiftDown = (Shift And vbShiftMask)
    HookHe_OnMessage frmName.hWnd, WM_KEYDOWN, KeyCode, 0, bCancel
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)
    On Error Resume Next
    
    If Msg = WM_CHAR Or Msg = WM_KEYDOWN Or Msg = WM_KEYUP Then
        If m_bBusy Then
            bCancel = 1
            GoTo EndProc
        End If
    End If
    If Msg = WM_KEYDOWN Then
        If Not (frmName.refInput.ReferVisible Or frmName.refInput1.ReferVisible Or frmName.refInput2.ReferVisible Or frmName.dtmInput.IsDropDown = 1) Then
            If wParam = 38 Or wParam = 40 Then    'TAB键处理程序
                mblnReadOnly = (Not My.blnMayChange) Or frmName.chkPrint(1).Value = 1 '权限控制
                If mblnReadOnly Then
                    If My.bytRegion = FNote Then
                        If wParam = 38 Then
                            If frmName.GrdCol.Row = 1 Then
                                mblnKeyDown = True
                            End If
                        ElseIf wParam = 40 Then
                            If frmName.GrdCol.Row = frmName.GrdCol.Rows - 1 Then
                                mblnKeyDown = True
                            End If
                        End If
                    Else
                        mblnKeyDown = True
                    End If
                Else
                    mblnKeyDown = True
                End If
            ElseIf wParam = 37 Or wParam = 39 Then
                mblnKeyDown = True
            ElseIf wParam = 27 Then
                mblnKeyDown = True
            End If
        End If
        If wParam = 9 Or wParam = 13 Then
            If wParam = 13 And UCase(frmName.ActiveControl.Name) = "CMDBUTTON" Then
                If frmName.ActiveControl.index < 4 Then
                    mblnKeyDown = False
                Else
                    mblnKeyDown = True
                End If
            Else
                mblnKeyDown = True
            End If
        End If
    End If
    If Msg = WM_KEYUP Then
        If mblnKeyDown = False Then GoTo EndProc
        mblnKeyDown = False
        If wParam = 13 Then
            If GetKeyState(17) < 0 Then
                GoTo EndProc
            End If
        End If
        If wParam = 37 Or wParam = 38 Or wParam = 39 Or wParam = 40 Or wParam = 9 Or wParam = 13 Then     'TAB键处理程序
            m_bBusy = True
            TabOrder (wParam)
            m_bBusy = False
        ElseIf wParam = 27 Then
            Reload
        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
        If blnColDrag Then
            blnColDrag = False
            With frmName.GrdCol
                For i = 1 To .Cols - 1
                    If ColProperty(i).blnUsable = False Then
                        If .ColWidth(i) > 0 Then .ColWidth(i) = 0
                    Else
                        If ColProperty(i).lngCtrType = TRefer Or ColProperty(i).lngCtrType = TRecList Or ColProperty(i).lngCtrType = tdate Then
                            If frmName.GrdCol.ColWidth(i) < 500 Then frmName.GrdCol.ColWidth(i) = 500
                        Else
                            If frmName.GrdCol.ColWidth(i) < 100 Then frmName.GrdCol.ColWidth(i) = 100
                        End If
                    End If
                Next i
                My.blnRefresh = False
                If My.bytRegion = FGrid Or My.bytRegion = FPicture Then
                    If My.bytIndex <> .col Then
                        .col = My.bytIndex
                    End If
                    If My.lngOldRow <> .Row Then
                        .Row = My.lngOldRow
                    End If
                     GrdInputButtonLocal .Row, .col
                End If
                TotalRowAdjust
'                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
                    DrawGridLine
                    DrawReadOnlyCol
    '               Debug.Print Time
                End If
                m_pBusy = False
            End If
        End If
    Else
        mclsSubClass.CallWndProc Msg, wParam, lParam
    End If
End Sub
Private Sub mclsHook_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    Dim MinMax As MINMAXINFO

    If Msg = WM_GETMINMAXINFO Then
        CopyMemory MinMax, ByVal lParam, Len(MinMax)
        
        MinMax.ptMinTrackSize.x = lngDefaultWidth \ Screen.TwipsPerPixelX
        MinMax.ptMinTrackSize.y = lngDefaultHeight \ Screen.TwipsPerPixelY
        MinMax.ptMaxTrackSize.x = 1800
        MinMax.ptMaxTrackSize.y = 1600
        
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
        Result = 0
        Exit Sub
    End If
        

    If Msg = WM_PAINT Then
        If My.blnRefresh Then
            '取Paint事件矩形区域
            GetUpdateRect frmName.hWnd, FormClipRect, False
            mclsHook.CallWndProc Msg, wParam, lParam
            If frmName.lblHead(5).Visible Then DrawTotalBox
            If frmName.lblHead(5).Visible Then DrawAllButton
        End If
    Else
        mclsHook.CallWndProc Msg, wParam, lParam
    End If
End Sub

Private Sub DrawGridLine()
    
    Dim intI As Integer
    Dim lngHdc As Long
    My.blnRefresh = False
    SeparateLineColor = fccolor.lngGridLineColor
    With frmName.GrdCol
        lngHdc = GetDC(.hWnd)
        '画GRID网格线
        '画竖线
        For intI = 0 To .Cols - 1
            If .ColWidth(intI) = 0 Or .ColPos(intI) + .ColWidth(intI) >= .width - Screen.TwipsPerPixelX Or (Not .ColIsVisible(intI)) Then
            Else
                DrawALine lngHdc, .ColPos(intI) + .ColWidth(intI) - 15, 0, _
                                   .ColPos(intI) + .ColWidth(intI) - 15, .Height, _
                                   GridClipRect.Left, GridClipRect.top, GridClipRect.Right, GridClipRect.Bottom, SeparateLineColor