frmwarnlist.frm

金算盘软件代码

'    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
    mblnLoad = False
    mclsList.SaveListSet
    frmMain.mnuToolAlert.Tag = 0
    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)
    On Error Resume Next
    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
            ToolRefash
            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, , , , 89, " " & 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
    
    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
Private Sub ToolRefash()
    Dim strOldSort As String
    Dim strOldText As String
   ' Me.MousePointer = vbHourglass
    With msgTerm
        '保存当前排序列
        'strOldSort = cboFindKind.Text
       ' strOldText = .TextMatrix(.Row, mclsList.SortCol)
        mclsList.SaveListColWidth
        .Redraw = False
        '刷新列表记录
        .Cols = 0
        Set datTerm.Resultset = GetList()
        If Not datTerm.Resultset.EOF Then datTerm.Resultset.MoveLast
        datTerm.Resultset.Close
        'Set datTerm.Recordset = Nothing
        mclsList.SetFlexGrid
        '恢复以前排序列
       ' cboFindKind.Text = strOldSort
       ' cboFindKind.Text = strOldSort
        .Redraw = False
'        If .Rows > 1 Then
'            txtFind.Text = strOldText
'        End If
        
        If chkShowall.Value = 0 Then mclsList.DoShowAll False
        '更新菜单状态
       ' UpdateMenuStatus
        .Redraw = True
        '发出付款条件消息
        If .Row = 0 Then
            If .Rows > 1 Then
                .Row = 1
                .ColSel = 0
            Else
                .col = 0
            End If
        End If
    End With
End Sub

Public Function BindingResultSet()
    If mblnLoad Then Exit Function
    Me.Hide
    Set datTerm.Resultset = GetList()
    If Not datTerm.Resultset.EOF Then datTerm.Resultset.MoveLast
    datTerm.Resultset.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
    Me.Show
    Me.ZOrder 0
End Function