frmvouchermultilist.frm

金算盘软件代码

    Me.ScaleHeight = 4710
    Me.ScaleWidth = 8025
    Set mclsList = New list
    Set mclsVoucher = New clsVoucherMethod
    mclsVoucher.SethWnd Me.hwnd
    mclsList.NoSort = True
    SetForm
    
    Set mclsList.Parent = Me
    Set mclsList.FlexGrid = grdList
    mclsList.ListSet.ViewId = intViewID
    
    grdList.Redraw = False
    mclsList.InitFlexGrid
    
'    Set datGrid.Resultset = GetList()
'    datGrid.Resultset.Close
'
''    HideColOfMe
'    mclsList.SetFlexGrid
'
'    grdList.ColWidth(1) = 500
'    RedrawForm
'    With grdList
'        If .Rows > 1 Then .Row = 1
'        .col = 0
'        .ColSel = .Cols - 1
'    End With
    '设置钩子对象
    Set mclsSubClass = New SubClass32.SubClass
    mclsSubClass.hwnd = grdList.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
    
    
'    '屏蔽‘作废’‘错误’栏
'    With frmVoucherMultiList.grdList
'
'        For i = 1 To .Cols - 1
'            Select Case Trim(.TextArray(i))
'                   Case "作废", "错误"
'                        .ColWidth(i) = 0
'                   Case "MultiYear"
'                        .ColWidth(i) = 0
'                        IntYearcol = i
'                   Case "MultiPeriod"
'                        .ColWidth(i) = 0
'                        intPeriodcol = i
'            End Select
'        Next i
'
'        If intFormType = 2 Then
'           If grdList.Rows > 1 Then
'              For i = 1 To grdList.Rows - 1
'                  intYear = .TextMatrix(i, IntYearcol)
'                  bytPeriod = .TextMatrix(i, intPeriodcol)
'
'                  For j = 1 To UBound(strPeriodList)
'                    If intYear & bytPeriod & "0" = strPeriodList(j) Then
'                        blnPeriodCanPost = False
'                        GoTo OK
'                        Exit For
'                    ElseIf intYear & bytPeriod & "1" = strPeriodList(j) Then
'                        blnPeriodCanPost = True
'                        GoTo OK
'                        Exit For
'                    End If
'                  Next j
'                  blnPeriodCanPost = mclsVoucher.blnPeriodCanPost(intYear, bytPeriod)
'                  ReDim Preserve strPeriodList(UBound(strPeriodList) + 1)
'                  strPeriodList(UBound(strPeriodList)) = intYear & bytPeriod & IIf(blnPeriodCanPost, "1", "0")
'OK:
'                  If Not blnPeriodCanPost Then
'                     .RowHeight(i) = 0
'                  End If
'              Next
'
'           End If
'        End If
'
'    End With
'
    Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    If mclsList.ListSet.ListID < 0 Then
       mclsList.SaveListSet
       DefaultCurrentDate mclsList.ListSet.ListID, 9975
    Else
       mclsList.SaveListSet
    End If
    Utility.UnLoadFormResPicture Me
    Set datGrid.Resultset = Nothing
    Set mclsSubClassform = Nothing
    Set mclsSubClass = Nothing
    Set mclsList = Nothing
    Set mclsVoucher = Nothing
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
    gclsSys.CurrFormName = Me.hwnd
    grdList.Redraw = True
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If (Me.Left + Me.width < 0 Or Me.Left > Screen.width) And Me.WindowState <> 2 Then
        Me.Left = 300
    End If
    RedrawForm
End Sub


'弹出右键菜单
Private Sub grdlist_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
End Sub
'Private Sub grdList_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
'    With grdList
'        If x > .ColPos(1) And x < .ColPos(2) Then
'            .MousePointer = vbCustom
'        Else
'            .MousePointer = flexDefault
'        End If
'    End With
'End Sub
'恢复“停用”列光标
Private Sub grdList_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
     
    With grdList
        If Button = vbLeftButton Then
            If .ColSel > 0 Then
                If X > .ColPos(1) And X < .ColPos(2) Then
                    .MousePointer = flexHourglass
                        ChangeState
                    .MousePointer = flexDefault
                End If
            End If
        End If
    
    End With
     
End Sub

Private Sub ChangeState()
    Dim strFlag As String '要设置的选定状态
    Dim lngRow As Long
    Dim lngVoucherID As Long
    Dim i As Long
    lngVoucherID = GetlngVoucherID
    
    With grdList
        If .Row > 1 Then '判断本行与上行是否为同一张凭证
            If CLng(.TextArray(pos(.Row, 0))) = CLng(.TextArray(pos(.Row - 1, 0))) Then Exit Sub
        End If
    End With
    
    With grdList
        If Trim(.TextArray(pos(.Row, 1))) = "√" Then
            strFlag = ""
        Else
            strFlag = "√"
        End If
            
        '从本行开始往上找到与本ID相同的最上面一行
        i = .Row
        If .Row = 1 Then
            .TextArray(pos(1, 1)) = strFlag
            Exit Sub
        End If
        Do While i > 0
            If CLng(.TextArray(pos(i, 0))) = lngVoucherID Then
                i = i - 1
            Else
                .TextArray(pos(i + 1, 1)) = strFlag
                Exit Do
            End If
        Loop
    End With
End Sub

Public Sub HookPaint(Optional ByVal blnPrint As Boolean = False)
    Dim lngVoucherID As Long
    Dim lngRow As Long
        
    With grdList
        If .TopRow = 1 Then
            lngVoucherID = 0
        Else
            lngRow = CLng(.TopRow - 1) '
            lngVoucherID = CLng(.TextArray(pos(lngRow, 0)))
        End If
        lngRow = .TopRow
        If grdList.Rows = 1 Then Exit Sub
        If blnPrint = True Then
           Do While lngRow < grdList.Rows '.RowIsVisible(lngRow)
              If lngVoucherID <> CLng(.TextArray(pos(lngRow, 0))) Then
                 lngVoucherID = CLng(.TextArray(pos(lngRow, 0)))
              Else
                 If .TextMatrix(lngRow, 2) <> "" Then
                    .TextArray(pos(lngRow, 2)) = ""
                 End If
                 If .TextMatrix(lngRow, 3) <> "" Then
                    .TextArray(pos(lngRow, 3)) = ""
                 End If
              End If
              lngRow = lngRow + 1
              If lngRow = .Rows Then Exit Do
           Loop
        Else
           Do While .RowIsVisible(lngRow)
              If lngVoucherID <> CLng(Val(.TextArray(pos(lngRow, 0)))) Then
                 lngVoucherID = CLng(Val(.TextArray(pos(lngRow, 0))))
              Else
                 If .TextMatrix(lngRow, 2) <> "" Then
                    .TextArray(pos(lngRow, 2)) = ""
                 End If
                 If .TextMatrix(lngRow, 3) <> "" Then
                    .TextArray(pos(lngRow, 3)) = ""
                 End If
              End If
              lngRow = lngRow + 1
              If lngRow = .Rows Then Exit Do
           Loop
        End If
    End With
   
End Sub

Public Property Get MuliListID() As Long
    MuliListID = mlistID
End Property

Public Property Let MuliListID(ByVal vNewValue As Long)
    mlistID = vNewValue
End Property
Public Function BindingResultSet()
    Dim intYear As Integer, bytPeriod As Integer, IntYearcol As Integer, intPeriodcol As Integer
    Dim strPeriodList() As String
    Dim blnPeriodCanPost As Boolean
    ReDim strPeriodList(0)
    Dim i As Long, j As Long
    Me.Hide
    Set datGrid.Resultset = GetList()
    datGrid.Resultset.Close
    
'    HideColOfMe
    mclsList.SetFlexGrid
    
    grdList.ColWidth(1) = 500
    RedrawForm
    With grdList
        If .Rows > 1 Then .Row = 1
        .col = 0
        .ColSel = .Cols - 1
    End With
    '屏蔽‘作废’‘错误’栏
    With frmVoucherMultiList.grdList
        
        For i = 1 To .Cols - 1
            Select Case UCase(Trim(.TextArray(i)))
                   Case "作废", "错误"
                        .ColWidth(i) = 0
                   Case "MULTIYEAR"
                        .ColWidth(i) = 0
                        IntYearcol = i
                   Case "MULTIPERIOD"
                        .ColWidth(i) = 0
                        intPeriodcol = i
            End Select
        Next i
        
        If intFormType = 2 Then
           If grdList.Rows > 1 Then
              For i = 1 To grdList.Rows - 1
                  intYear = .TextMatrix(i, IntYearcol)
                  bytPeriod = .TextMatrix(i, intPeriodcol)

                  For j = 1 To UBound(strPeriodList)
                    If intYear & bytPeriod & "0" = strPeriodList(j) Then
                        blnPeriodCanPost = False
                        GoTo OK
                        Exit For
                    ElseIf intYear & bytPeriod & "1" = strPeriodList(j) Then
                        blnPeriodCanPost = True
                        GoTo OK
                        Exit For
                    End If
                  Next j
                  blnPeriodCanPost = mclsVoucher.blnPeriodCanPost(intYear, bytPeriod)
                  ReDim Preserve strPeriodList(UBound(strPeriodList) + 1)
                  strPeriodList(UBound(strPeriodList)) = intYear & bytPeriod & IIf(blnPeriodCanPost, "1", "0")
OK:
                  If Not blnPeriodCanPost Then
                     .RowHeight(i) = 0
                  End If
              Next
              
           End If
        End If
            
    End With
    
    Me.Show vbModal
End Function