frmwarnlistcard.frm

金算盘软件代码

    mclsList.InitFlexGrid
    Set datTerm.Recordset = GetList()
    If Not datTerm.Recordset.EOF Then datTerm.Recordset.MoveLast
    datTerm.Recordset.Close
    'Set datTerm.Recordset = Nothing
    mclsList.SetFlexGrid
    'mclsList.InitcboFindKind
    mclsList.FlexNoChange = False
   ' mclsList.FindNoChange = False
    With msgTerm
        If .Rows > 1 Then msgTerm.Row = 1
        .col = 0
        .ColSel = .Cols - 1
    End With
    Debug.Print "Load End: ", Timer
    mclsList.DoShowAll False
   ' UpdateMenuStatus
    'If msgTerm.Rows > 1 Then AccountTotail
    mclsList.SetFlexRow
     
 
  
    '设置钩子对象
    Set mclsSubClass = New SubClass32.SubClass
    mclsSubClass.hwnd = msgTerm.hwnd
    mclsSubClass.Messages(WM_PAINT) = True
    mclsSubClass.Messages(WM_LBUTTONUP) = True
    mclsSubClass.Messages(WM_LBUTTONDOWN) = True
    mclsSubClass.Messages(WM_MOUSEMOVE) = True
    Set mclsSubClassform = New SubClass32.SubClass
    mclsSubClassform.hwnd = Me.hwnd
    mclsSubClassform.Messages(WM_GETMINMAXINFO) = True
    Unload MsgForm
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
     Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload MsgForm
         Unload Me
    End If
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'    If UnloadMode = vbFormControlMenu And mIsShowCard Then
'        MsgBox "请先关闭付款条件卡片！", vbExclamation
'        Cancel = True
'       ' frmTermCard.SetFocus
'    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    mclsList.SaveListSet
    Set mclsSubClass = Nothing
    Set mclsSubClassform = Nothing
    Set mclsList = Nothing
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.WindowState = 1 Then Exit Sub
    If Me.Left + Me.width < 0 Or Me.Left > Screen.width Then
       Me.Left = 300
    End If
    RedrawForm
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyEscape Then
        Unload Me
    End If
End Sub
Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
    gclsSys.CurrFormName = Me.hwnd
    mclsMainControl_ChildActive
    'If msgTerm.Enabled Then msgTerm.SetFocus
    msgTerm.Redraw = True
    If (Me.Left + Me.width < 0 Or Me.Left > Screen.width) Then Me.Left = 300
    If Me.WindowState = 1 Then Me.WindowState = 0
End Sub

Private Sub mclsMainControl_ChildActive()
    Dim vntMessage As Variant
    
    SetHelpID Me.HelpContextID
    '响应消息
    For Each vntMessage In mclsMainControl.Messages
        If vntMessage = Message.msglog Then '接收到付款条件改变消息
            'mclsMainControl_ToolRefresh
            mclsMainControl.Messages.Remove CStr(vntMessage) '清除付款条件改变消息
        End If
    Next
    mclsMainControl.Messages.Clear
    'UpdateMenuStatus
End Sub

Private Sub mclsMainControl_EditInActive()
    If UpdateTermInActive(TermID, Not TermIsInActive) Then
        With msgTerm
            If chkShowAll.Value Then
                If .TextMatrix(.Row, 1) = "" Then
                    .TextMatrix(.Row, 1) = "√"
                Else
                    .TextMatrix(.Row, 1) = ""
                End If
            Else
                .TextMatrix(.Row, 1) = "√"
                .RowHeight(.Row) = 0
                mclsList.SetFlexRow
            End If
        End With
        gclsSys.SendMessage CStr(Me.hwnd), Message.msgnote
    End If
    'UpdateMenuStatus
End Sub



Private Sub mclsMainControl_FilePrintSetup()
    Dim MyPrintSet As PrintClass
    Set MyPrintSet = New PrintClass
    MyPrintSet.PrintSetUp gclsBase.BaseDB, mclsList.FlexGrid, , , , 66, " " & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
    Set MyPrintSet = Nothing
End Sub

Private Sub mclsSubClassForm_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 = 430
        MinMax.ptMinTrackSize.y = 250
        
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
        Result = 0
    End If
End Sub
'双击FLEXGRID调用卡片
Private Sub msgTerm_DblClick()
    Dim intID As Integer
    Dim intRowheight As Integer
    Dim intRow As Integer
    Dim intCol As Integer
    Dim intOldRow As Integer
    With msgTerm
    .Redraw = False
    mclsList.FindNoChange = True
    intOldRow = .Row
    If .MouseRow > 0 And .ColSel > 0 And .MouseCol > 1 And .TextMatrix(.Row, 1) = "T" And frmMain.mnuEditEdit.Enabled Then
       intID = .TextMatrix(.Row, 0)
       intRowheight = .RowHeight(0)
       
       For intRow = 1 To .Rows - 1
            If .TextMatrix(intRow, 0) = intID And .TextMatrix(intRow, 1) <> "T" Then
                If .RowHeight(intRow) = 0 Then
                    .RowHeight(intRow) = intRowheight
                    .Row = intRow
                    For intCol = 2 To .Cols - 2
                        .col = intCol
                        .CellFontBold = False
                    Next
                Else
                    .RowHeight(intRow) = 0
                End If
            End If
       Next
    ElseIf .MouseRow > 0 And .ColSel > 0 And .MouseCol > 1 And .TextMatrix(.Row, 1) <> "T" Then
'        Select Case .TextMatrix(.Row, 0)
'            Case 1
'
'            Case 2
'
'            Case 3
'
'            Case 4
'
'            Case 4
'
'            Case 6
'
'            Case 7
'
'        End Select
    End If
    mclsList.FindNoChange = False
    .Row = intOldRow
    .col = 0
    .ColSel = .Cols - 1
    .Redraw = True
    End With
End Sub
Private Sub msgTerm_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim blnCancel As Boolean
    
    With msgTerm
        If Button = vbLeftButton Then
            If chkShowAll.Value = 1 And .ColSel > 0 Then
                If x > .ColPos(1) And x < .ColPos(2) Then
                    .MousePointer = flexHourglass
                    mclsMainControl_EditInActive
                    .MousePointer = flexDefault
                End If
            End If
        Else
           ' Form_MouseDown Button, Shift, x, y
        End If
    End With
End Sub

'鼠标左键弹起时，更新菜单
Private Sub msgTerm_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  
   With msgTerm
        If Button = vbLeftButton Then
            If chkShowAll.Value = 1 And .ColSel > 0 And .MouseRow > 0 And .Row > 0 Then
                If x > .ColPos(1) And x < .ColPos(2) Then
                    mclsMainControl_EditInActive
                End If
            End If
           ' UpdateMenuStatus
        End If
    End With
End Sub



'“钩子”事件
Private Sub mclsSubClass_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    '“钩子”事件处理
    mclsList.HookProc Msg, wParam, lParam, mclsSubClass
End Sub