frmvouchervolume.frm

金算盘软件代码

                    ElseIf Me.ActiveControl.Name = "lstInput" Then
                            If Me.ActiveControl.Index = 0 Then
                                cmdOk(cmdOk.Count - 1).SetFocus
                            Else
                                lstInput(0).SetFocus
                            End If
                    End If
                Else
                    If Me.ActiveControl.Name = "txtInput" Then
                        SaveInput2Form
                        If DataValid1() = False Then
                            blnBusy = False
                            Exit Sub
                        End If
                        If mlngRow = GrdCol.Rows - 1 And mlngCol = 1 And Trim(GrdCol.TextMatrix(mlngRow, 1)) = "" Then
                            cmdOk(0).SetFocus
                        ElseIf mlngCol < 3 Then
                            GrdCol.col = 3
                            EnterCell
                        ElseIf mlngRow < GrdCol.Rows - 1 Then
                            GrdCol.col = 1
                            GrdCol.Row = mlngRow + 1
                            EnterCell
                        ElseIf mlngRow = GrdCol.Rows - 1 And Trim(GrdCol.TextMatrix(mlngRow, 1)) <> "" Then
                            InsertARow
                            GrdCol.col = 1
                            GrdCol.Row = mlngRow + 1
                            EnterCell
                        Else
                            cmdOk(0).SetFocus
                        End If
                    ElseIf Me.ActiveControl.Name = "cmdOK" Then
                        If wParam = 9 Then
                            If Me.ActiveControl.Index = cmdOk.Count - 1 Then
                                lstInput(0).SetFocus
                            Else
                                cmdOk(Me.ActiveControl.Index + 1).SetFocus
                            End If
                        End If
                    ElseIf Me.ActiveControl.Name = "lstInput" Then
                        If Me.ActiveControl.Index = 1 Then
                            GrdCol.col = 1
                            If GrdCol.Rows = 1 Then InsertARow
                            GrdCol.Row = 1
                            mlngRow = GrdCol.Row
                            mlngCol = GrdCol.col
                            EnterCell
                        Else
                            lstInput(1).SetFocus
                        End If
                    Else
'                        cmdOK(0).SetFocus
                    End If
                End If
                blnBusy = False
            End If
        End If
    End If

End Sub

Private Sub lstInput_AddNew(Index As Integer)
    If Index = 0 Then Exit Sub
    #If conHos = 1 Then
    #Else
        Dim lngID As Long, lngItemID As Long
        lngID = frmEntryTypeCard.AddCard(lstInput(1).Text, vbModal)
        InitLst1 lngID
        mblnIsChanged = True
    #End If
End Sub

Private Sub LstInput_Choose(Index As Integer)
    If Me.Visible = False Then Exit Sub
    If Change() = False Then
        DoEvents
        EnterCell
    End If
End Sub

Private Sub lstInput_Delete(Index As Integer)
    If Index = 0 Then Exit Sub
        Dim lngID As Long
        lngID = lstInput(1).ID
        If lstInput(1).ID = 0 Then
            ShowMsg Me.hwnd, "请选择一参照！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "提示信息"
            Exit Sub
        End If
        If frmEntryTypeCard.DelCard(lstInput(1).ID, Me.hwnd) = False Then
            mlngOldLst = lngID
        End If
        InitLst1 mlngOldLst
        mblnIsChanged = True
End Sub

Private Sub lstInput_Edit(Index As Integer)
    If Index = 0 Then Exit Sub
        If lstInput(1).ID = 0 Then
            ShowMsg Me.hwnd, "请选择一参照！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "提示信息"
            Exit Sub
        End If
        Dim lngID As Long
        lngID = lstInput(1).ID
        frmEntryTypeCard.EditCard lstInput(1).ID, vbModal

        InitLst1 lngID

        'lngID = mlngOldLst

        If lstInput(1).Text = "" Then mlngOldLst = 0
End Sub

Private Function PartsIsSelected(strPartsName As String) As Boolean
    Dim i As Integer
    
    PartsIsSelected = False
    For i = 1 To GrdCol.Rows - 1
        If GrdCol.TextMatrix(i, 2) = strPartsName Then
            PartsIsSelected = True
            Exit For
        End If
    Next i
End Function
Private Sub InitGrid(ByVal intYear As Long, ByVal bytPeriod As Long, ByVal lngVoucherTypeID As Long)
    Dim strSql As String, recItem As rdoResultset, i As Integer, bytDec As Byte
    GrdCol.Rows = 1
        strSql = "SELECT VoucherVolume.strVolume,VoucherVolume.intNoStart," _
            & "VoucherVolume.intNoEnd,VouchersOfAVol.VouchersNo " _
            & " FROM VoucherVolume," & _
            "(SELECT count(*) VouchersNo, strVolume FROM Voucher" & _
            " Where Voucher.intYear = " & intYear & " And Voucher.bytPeriod =" & bytPeriod & " And Voucher.lngVoucherTypeID = " & lngVoucherTypeID & _
            " GROUP BY strVolume)" & _
            "  VouchersOfAVol " _
            & " WHERE VoucherVolume.strVolume =VouchersOfAVol.strVolume(+)" & _
            " AND VoucherVolume.intYear=" & intYear & " AND VoucherVolume.bytPeriod=" & bytPeriod & " AND VoucherVolume.lngVoucherTypeID=" & lngVoucherTypeID
        Set recItem = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        Do While Not recItem.EOF
            GrdCol.Rows = GrdCol.Rows + 1
            i = GrdCol.Rows - 1
            GrdCol.TextMatrix(i, 1) = Trim(recItem(0))
            GrdCol.TextMatrix(i, 2) = Format(recItem(1), "0000")
            GrdCol.TextMatrix(i, 3) = Format(recItem(2), "0000")
            
            GrdCol.TextMatrix(i, 4) = IIf(IsNull(recItem(3)), "", Format(recItem(3), "#,###"))
            recItem.MoveNext
        Loop
    recItem.Close
    Set recItem = Nothing
    lblNote(3).Caption = SumOtherVoucher()
    mblnExit = True
    mlngCol = 0
    mlngRow = 0
End Sub
Private Function TotalAmount() As Double
    Dim dblTmp As Double
    Dim i As Long
    dblTmp = 0
    For i = 1 To GrdCol.Rows - 1
        dblTmp = dblTmp + C2Dbl(GrdCol.TextMatrix(i, 3))
    Next
    TotalAmount = dblTmp
End Function

Private Function LstIsValid() As Boolean
    Dim i As Integer
    
    LstIsValid = True
End Function

Private Function SaveCard() As Boolean
    Dim i As Integer
    Dim strTmp As String
    Dim strSql As String
    Dim strDetailID As String
    If mblnIsChanged = False Then
        SaveCard = True
        Exit Function
    End If
    SaveCard = False
'        If C2Dbl(lblNote(5).Caption) > 0 And C2Dbl(lblNote(7).Caption) < 0 Or C2Dbl(lblNote(5).Caption) < 0 And C2Dbl(lblNote(7).Caption) > 0 Then
'            ShowMsg Me.hwnd, "现金流量分配不应该超过凭证分录金额。", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "提示信息"
'            Exit Function
'        End If
'        If ShowMsg(Me.hwnd, "分配金额不等于明细金额。是否确认？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
    With GrdCol
    If DataValid() = False Then Exit Function
    gclsBase.BaseWorkSpace.BeginTrans
    strSql = "DELETE FROM VoucherVolume" & _
            " WHERE intYear=" & mintYear & " AND bytPeriod=" & mbytPeriod & _
            " AND lngVoucherTypeID=" & mlngVoucherTypeID
    If gclsBase.ExecSQL(strSql) = False Then GoTo TheError
    If GrdCol.Rows = 2 Then
        i = 0
        If C2lng(.TextMatrix(1, 3)) = 0 Then GoTo ClearStrVolume
    End If
    For i = 1 To .Rows - 1
        strSql = " INSERT INTO VoucherVolume " & _
                " ( intYear,bytPeriod,lngVoucherTypeID,strVolume,intNoStart,intNoEnd)" & _
                " VALUES ( " & mintYear & "," & mbytPeriod & "," & mlngVoucherTypeID & "," & _
                "'" & .TextMatrix(i, 1) & "'," & C2lng(.TextMatrix(i, 2)) & "," & C2lng(.TextMatrix(i, 3)) & ")"
        If gclsBase.ExecSQL(strSql) = False Then GoTo TheError
        strSql = " UPDATE Voucher SET strVolume='" & .TextMatrix(i, 1) & "'" & _
            " WHERE intYear=" & mintYear & " AND bytPeriod=" & mbytPeriod & _
            " AND lngVoucherTypeID=" & mlngVoucherTypeID & _
            " AND intVoucherNo>=" & C2lng(.TextMatrix(i, 2)) & " AND intVoucherNo<=" & C2lng(.TextMatrix(i, 3))
        If gclsBase.ExecSQL(strSql) = False Then GoTo TheError

    Next i
    For i = .Rows - 1 To 1 Step -1
        If C2lng(.TextMatrix(i, 3)) > 0 Then Exit For
    Next
ClearStrVolume:
    strSql = " UPDATE Voucher SET strVolume='00'" & _
        " WHERE intYear=" & mintYear & " AND bytPeriod=" & mbytPeriod & _
        " AND lngVoucherTypeID=" & mlngVoucherTypeID & _
        " AND intVoucherNo>" & C2lng(.TextMatrix(i, 3))
    If gclsBase.ExecSQL(strSql) = False Then GoTo TheError
   
    End With
EndProc:
    SaveCard = True
    mblnIsChanged = False
    gclsBase.BaseWorkSpace.CommitTrans
    If WanNeng Then
        gclsSys.SendMessage Me.hwnd, 71
    End If
    Exit Function
TheError:
    gclsBase.BaseWorkSpace.RollBacktrans
    SaveCard = False
End Function

Private Sub lstInput_GotFocus(Index As Integer)
    If txtInput.Visible = False Then Exit Sub
    SaveInput2Form
'    If DataValid1() = False Then Exit Sub
    
    txtInput.Visible = False
End Sub

Private Sub lstInput_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
    If Shift <> 0 Then Exit Sub
    If mblnExit Then Exit Sub
    Debug.Print KeyCode
    Dim lStart As Long
    Dim lLen As Long
    If lstInput(Index).ReferVisible Then Exit Sub
    lStart = lstInput(Index).SelStart
    lLen = Len(lstInput(Index).Text)
    If KeyCode = 39 Then
        If lStart = lLen Then
            If Index = 0 Then
                lstInput(1).SetFocus
            Else
            End If
        End If
    ElseIf KeyCode = 37 Then
        If lStart = 0 Then
            If Index = 1 Then
                lstInput(0).SetFocus
            Else
            End If
        End If
    ElseIf KeyCode = 40 Then
        If GrdCol.Row < GrdCol.Rows - 1 Then
            GrdCol.Row = GrdCol.Row + 1
        Else
            If GrdCol.TextMatrix(GrdCol.Row, 2) = "" Then
                cmdOk(0).SetFocus
                Exit Sub
            Else
                InsertARow
                GrdCol.Row = GrdCol.Rows - 1
            End If
        End If
        mlngRow = GrdCol.Row
        mlngCol = GrdCol.col
        EnterCell
    End If

End Sub


Private Sub mclsSubClass_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    If Msg = WM_PAINT Then
            '取Paint事件矩形区域
           Dim lngHdc As Long
           lngHdc = GetDC(GrdCol.hwnd)
           mclsSubClass.CallWndProc Msg, wParam, lParam
           DrawBLine lngHdc, GrdCol.ColPos(2) - Screen.TwipsPerPixelX, GrdCol.RowHeight(0), GrdCol.ColPos(2) - Screen.TwipsPerPixelX, GrdCol.Height, RGB(128, 128, 128)
           DrawBLine lngHdc, GrdCol.ColPos(3) - Screen.TwipsPerPixelX, GrdCol.RowHeight(0), GrdCol.ColPos(3) - Screen.TwipsPerPixelX, GrdCol.Height, RGB(128, 128, 128)
           DrawBLine lngHdc, GrdCol.ColPos(4) - Screen.TwipsPerPixelX, GrdCol.RowHeight(0), GrdCol.ColPos(4) - Screen.TwipsPerPixelX, GrdCol.Height, RGB(128, 128, 128)
'           DrawBLine lngHdc, grdCol.ColPos(4) + grdCol.ColWidth(4) + Screen.TwipsPerPixelX, grdCol.RowHeight(0), grdCol.ColPos(4) + grdCol.ColWidth(4) + Screen.TwipsPerPixelX, grdCol.Height, RGB(128, 128, 128)
           
           If GrdCol.Rows = 1 Then DrawBLine lngHdc, 0, GrdCol.RowHeight(0) - Screen.TwipsPerPixelY, GrdCol.width, GrdCol.RowHeight(0) - Screen.TwipsPerPixelY, RGB(0, 0, 0)
           
           ReleaseDC GrdCol.hwnd, lngHdc
    Else
        mclsSubClass.CallWndProc Msg, wParam, lParam
    End If
End Sub

Private Sub mnuDel_Click()
        If GrdCol.Rows > 2 Then
           If GrdCol.Row = GrdCol.Rows - 1 Then
                GrdCol.RemoveItem GrdCol.Row
                mblnIsChanged = True
           End If
        ElseIf GrdCol.Rows = 2 Then
            GrdCol.Rows = 1
            mblnIsChanged = True
        End If
        mlngRow = GrdCol.Row
        mlngCol = GrdCol.col
        lblNote(3).Caption = SumOtherVoucher()
        If GrdCol.Rows > 1 Then
            EnterCell
        Else
            GrdCol.col = 0
        End If
End Sub

Private Sub mnuNew_Click()
        With GrdCol
            If .Rows = 1 Then
                InsertARow
            ElseIf C2lng(.TextMatrix(.Rows - 1, 1)) <> 0 And C2Dbl(.TextMatrix(.Rows - 1, 3)) <> 0 Then
                InsertARow
            End If
            .Row = .Rows - 1
            .col = 1
            EnterCell
        End With
        mblnIsChanged = True
End Sub

Private Sub EnterCell(Optional ByVal DoValid As Boolean = True)
    Dim lngUnitID As Long
    If GrdCol.Row < 1 Then