frmfi_zznew.frm

一个用VB写的财务软件源码

        Dim sOldID As String
        Dim dJS As Double
        'lijian**
        Dim lRow1 As Long
        Dim lRow2 As Long
        mfgDisplay.row = 0
        For iTmp = 0 To mfgDisplay.Cols - 1
            mfgDisplay.col = iTmp
            mfgDisplay.CellAlignment = 4
        Next
        mfgDisplay.col = 1
        mfgDisplay.row = Abs((mfgDisplay.row > 0))
        lRow2 = 1
        'end**
        sOldID = ""
        rstPzSet.CursorLocation = adUseClient
        rstPzSet.Open "select * from tzw_zzpzset" & glo.sOperateYear & " where cPzType='" & m_sPzType & "'  order by id,sijlhm", glo.cnnMain, adOpenStatic, adLockReadOnly
        While Not rstPzSet.EOF
             '------------------填充明细
             If sOldID <> Trim(rstPzSet.Fields("id").value) Then
                 lRow2 = lRow1
                 mfgDisplay.Rows = mfgDisplay.Rows + 1
                 mfgDisplay.row = mfgDisplay.Rows - 1
                 mfgDisplay.TextMatrix(mfgDisplay.row, MFG_COLID) = Trim(rstPzSet.Fields("id").value)
                 mfgDisplay.TextMatrix(mfgDisplay.row, MFG_COLSUMMARY) = Trim(rstPzSet.Fields("czzsm").value)
                 mfgDisplay.TextMatrix(mfgDisplay.row, MFG_COLLB) = Trim(rstPzSet.Fields("cpzlb").value)
                 If IsNull(rstPzSet.Fields("zzrq").value) Then
                 Else
                 mfgDisplay.TextMatrix(mfgDisplay.row, MFG_COLDATE) = Trim("" + rstPzSet.Fields("zzrq").value)
                 End If
                 sOldID = Trim(rstPzSet.Fields("id").value)           '上一个ＩＤ号
             End If
             rstPzSet.MoveNext
        Wend
End Sub

Private Function ChangeData(ByVal iCol As Long, ByVal iRow As Long) As Double      'ir    行
Dim result As Double
ChangeData = 0
result = cllZzNew.GetCellDouble(iCol, iRow, cllZzNew.GetCurSheet)
If cllZzNew.GetCellDataType(iCol, iRow, cllZzNew.GetCurSheet) = 2 Then
    CheckUserFormulaErr = ""
    ChangeData = result
Else
    CheckUserFormulaErr = "公式定义不正确"
End If
End Function


Private Sub Form_Resize()
mfgDisplay.Left = Me.ScaleLeft
mfgDisplay.Top = Me.ScaleTop + 680
mfgDisplay.Width = Me.ScaleWidth
mfgDisplay.Height = Me.ScaleHeight
End Sub

Private Sub frm_Unload()
Call MainDo("undoall")
End Sub

Private Sub mfgDisplay_DblClick()
If mfgDisplay.row < 1 Then Exit Sub
        mfgDisplay.TextMatrix(mfgDisplay.row, MFG_COLFLAG) = IIf(Trim(mfgDisplay.TextMatrix(mfgDisplay.row, MFG_COLFLAG)) = "√", "", "√")
End Sub

Private Sub mnuAllSelect_Click()
        Call MainDo("doall")
End Sub

Private Sub mnuHelp_Click()
        SendKeys "{f1}"
End Sub

Private Sub mnuQuit_Click()
        Unload Me
End Sub

Private Sub mnuUnAllselect_Click()
        Call MainDo("undoall")
End Sub

Private Sub mnuZd_Click()
        Call MainDo("zd")
End Sub

Private Sub tbrEdit_ButtonClick(ByVal Button As MSComctlLib.Button)
        Call MainDo(LCase(Button.Key))
End Sub

Private Sub MainDo(sMessage As String)
           Dim iRow As Integer
           Dim bSelected As Boolean
           Dim rSt As Recordset
        
            Select Case sMessage
            Case "doall"
                  Gsel ("√")
            Case "undoall"
                 Gsel ("")
                 
            Case "zd"
                 Dim sSQL As String
                 Dim rstPz As New Recordset
                 '判断是否有未记账凭证，如果有这提示不能进行期末调汇
                 sSQL = "select count(*)  from tzw_pzsj" & glo.sOperateYear & " where xgbz<>2  and kjqj>0 and kjqj< =" & Format(sKJRQ, "MM")
                 rstPz.CursorLocation = adUseClient
                 rstPz.Open sSQL, glo.cnnMain, adOpenKeyset, adLockOptimistic
                 If Not IsNull(rstPz.Fields(0).value) Then
                     If rstPz.Fields(0).value > 0 Then
                        MsgBox "含有未记账凭证，不能进行制单！", vbInformation
                        Exit Sub
                     End If
                 End If
                 
                 InitToVoucher
                 bSelected = False
                 For iRow = 1 To mfgDisplay.Rows - 1
                     If Trim(mfgDisplay.TextMatrix(iRow, MFG_COLFLAG)) = "√" Then
                         GetData mfgDisplay.TextMatrix(iRow, MFG_COLID)
                         If Abs(CheckSelect(Trim(mfgDisplay.TextMatrix(iRow, MFG_COLID)))) = 1 Then
                            bSelected = True
                            CellToVoucher
                         Else
                            mfgDisplay.TextMatrix(iRow, MFG_COLFLAG) = ""
                         End If
                         
                     End If
                 Next iRow
                 If bSelected = False Then
                    MsgBox "请至少选择一个有效制单的转账凭证序号!", vbExclamation, "提示"
                    Exit Sub
                 End If
                 For iRow = 1 To mfgDisplay.Rows - 1
                     If Trim(mfgDisplay.TextMatrix(iRow, MFG_COLFLAG)) = "√" Then
                         glo.cnnMain.Execute "update tzw_zzpzset" + glo.sOperateYear + " set zzrq='" + Format(GetPeriodTo(CInt(Format(Me.sKJRQ, "MM"))), "yyyy-MM-dd") + "' where id='" + mfgDisplay.TextMatrix(iRow, 0) + "' and cPzType='" & m_sPzType & "'"
                     End If
                 Next iRow
                 Set rSt = gloSys.cnnSYS.Execute("select toDate from tSys_period where PeriodId=" + Format(Me.sKJRQ, "mm") + " and year='" + Format(Me.sKJRQ, "yyyy") + "' and AccountID='" + glo.sAccountID + "'")
                 Set frm = New frmVoucher
                 With frm
                     If m_oTempVouchers.Voucher Is Nothing Then m_oTempVouchers.Voucher = New VoucherData.clsVoucher
                     If m_oTempVouchers.Count > 0 Then
                         m_oTempVouchers.Voucher.Copy m_oTempVouchers.Item(1)
                         m_oTempVouchers.Index = 1
                         .LoadObject = "AccountExtend.clsVoucherCollentionZz"
                         .AllowAddinObject = True
                         Load frm
                         .LoadingObjects = m_oTempVouchers
                         .HelpContextID = 5
                         .Show
                         .Reload m_oTempVouchers.Voucher, m_oTempVouchers.Voucher.sStatus
                         
                         .OnVoucherJeChange
                     End If
                 End With
            Case "help"
                 SendKeys "{f1}"
            Case "quit"
                 Unload Me
            End Select
End Sub


Private Function CheckSelect(sId As String) As Integer          '检查公式是否有错（False: 错，True :真） 1,完全正确；0，公式错误；-1，借贷不平；-2，凭证无分录
        Dim iR As Integer
        Dim bFirst As Boolean
        Dim dJf As Double
        Dim dDf As Double
        
        bFirst = True
        CheckSelect = 1
        For iR = 1 To cllZzNew.GetRows(0) - 1
            If cllZzNew.GetCellString(COL_ID, iR, 0) = sId Then
                bFirst = False
                If Trim(cllZzNew.GetCellString(COL_ERROR, iR, 0)) <> "" Then
                    CheckSelect = 0
                    MsgBox "凭证序号为：" & sId & "的凭证公式定义出错！", vbExclamation, "提示"
                    Exit Function
                End If
                If Left$(cllZzNew.GetCellString(COL_FX, iR, 0), 1) = "借" Then
                    dJf = dJf + Format(cllZzNew.GetCellDouble(COL_DEBITJE, iR, 0), "##0.00")
                Else
                    dDf = dDf + Format(cllZzNew.GetCellDouble(COL_CREDITJE, iR, 0), "##0.00")
                End If
             End If
        Next iR
'============================================2002.9.11 yao revise====================================================
        If bFirst = False Then
            If Not (dJf = 0 And dDf = 0) Then
                If Abs(dJf - dDf) > 0.001 Then
                    If MsgBox(sId & "凭证的借贷方金额不平衡，是否继续制单？", vbYesNo + vbQuestion, "") = vbYes Then
                        CheckSelect = -1
                    Else
                        CheckSelect = -3
                    End If
                    Exit Function      '当前序号已检查完毕
                End If
            Else
                MsgBox sId & "凭证无分录(或对应取值公式都为0)！ ", vbExclamation, "提示"
                CheckSelect = -2
                Exit Function      '当前序号已检查完毕
            End If
        End If
'================================================================================================================
End Function

Private Sub Gsel(sFlag As String)
   Dim i As Integer
   For i = 1 To mfgDisplay.Rows - 1
        mfgDisplay.TextMatrix(i, 5) = sFlag
   Next i
End Sub

Private Sub InitToVoucher()
Dim iGlo As New GlobalInterface.clsGlobal
Dim iGlosys As New GlobalInterface.clsGlobalSys
InitGloInface iGlo, iGlosys
m_oTempVouchers.Clear
m_oTempVouchers.iGlo = iGlo
m_oTempVouchers.iGlosys = iGlosys
End Sub
'填充凭证
Private Sub CellToVoucher()
Dim m_oTempVoucher As VoucherData.clsVoucher
Dim tempVoucherData As VoucherData.clsVoucherData
Dim tmpFz As YsyfFzOperate.ClsxmbmStruct
Dim i As Integer
Dim j As Integer
Dim sId As String

Dim sSubject As String
Dim sSummary As String
Dim sFx As String
Dim dJe As Double
dJe = 0
j = -1
Set m_oTempVoucher = New VoucherData.clsVoucher
With cllZzNew
    For i = 1 To cllZzNew.GetRows(0) - 1
        If cllZzNew.GetCellString(COL_ERROR, i, 0) = "" And Abs(CDbl(cllZzNew.GetCellDouble(COL_DEBITJE, i, 0) + cllZzNew.GetCellDouble(COL_CREDITJE, i, 0))) >= 0.01 Then
            If sSubject = "" And sSummary = "" And sFx = "" Then
                sSubject = Trim$(.GetCellString(COL_SUBJECT, i, 0))
                sSummary = Trim$(.GetCellString(COL_SUMMARY, i, 0))
                sFx = Trim$(.GetCellString(COL_FX, i, 0))
                
                Set tempVoucherData = New VoucherData.clsVoucherData
                m_oTempVoucher.DataSet.Add tempVoucherData
                tempVoucherData.Summary = Trim$(cllZzNew.GetCellString(COL_SUMMARY, i, 0))
                tempVoucherData.SubjectCode = Trim$(cllZzNew.GetCellString(COL_SUBJECT, i, 0))
                tempVoucherData.SubjectName = GetSubjectFullPath(glo.sAccountID, tempVoucherData.SubjectCode)
                tempVoucherData.Fx = cllZzNew.GetCellString(COL_FX, i, 0)
                tempVoucherData.zOccurDate = Format(GetPeriodTo(CInt(Format(Me.sKJRQ, "MM"))), "yyyy-MM-dd")
                tempVoucherData.Je = Format(cllZzNew.GetCellDouble(COL_DEBITJE, i, 0) + cllZzNew.GetCellDouble(COL_CREDITJE, i, 0), "0.00")
                j = 0
            End If
            If sSubject = Trim$(.GetCellString(COL_SUBJECT, i, 0)) And sSummary = Trim$(.GetCellString(COL_SUMMARY, i, 0)) And sFx = Trim$(.GetCellString(COL_FX, i, 0)) Then
                j = j + 1
            Else
                tempVoucherData.Je = dJe
                sSubject = Trim$(.GetCellString(COL_SUBJECT, i, 0))
                sSummary = Trim$(.GetCellString(COL_SUMMARY, i, 0))
                sFx = Trim$(.GetCellString(COL_FX, i, 0))
                dJe = 0
                j = 1
                Set tempVoucherData = New VoucherData.clsVoucherData
                m_oTempVoucher.DataSet.Add tempVoucherData
                tempVoucherData.Summary = cllZzNew.GetCellString(COL_SUMMARY, i, 0)
                tempVoucherData.SubjectCode = cllZzNew.GetCellString(COL_SUBJECT, i, 0)
                tempVoucherData.SubjectName = GetSubjectFullPath(glo.sAccountID, tempVoucherData.SubjectCode)
                tempVoucherData.Fx = cllZzNew.GetCellString(COL_FX, i, 0)
                tempVoucherData.zOccurDate = Format(GetPeriodTo(CInt(Format(Me.sKJRQ, "MM"))), "yyyy-MM-dd")
                tempVoucherData.Je = Format(cllZzNew.GetCellDouble(COL_DEBITJE, i, 0) + cllZzNew.GetCellDouble(COL_CREDITJE, i, 0), "0.00")
            End If
            If (.GetCellString(COL_ITEM, i, 0) <> "" Or .GetCellString(COL_DEPARTMENT, i, 0) <> "") Then
                Set tmpFz = New YsyfFzOperate.ClsxmbmStruct
                tmpFz.sXmdm = cllZzNew.GetCellString(COL_ITEM, i, 0)
                tmpFz.sXmmc = GetItemName(tmpFz.sXmdm)
                tmpFz.sBmdm = cllZzNew.GetCellString(COL_DEPARTMENT, i, 0)
                tmpFz.sBmmc = GetDepartmentName(tmpFz.sBmdm)
                tmpFz.sFx = cllZzNew.GetCellString(COL_FX, i, 0)
                tmpFz.dJe = Format(cllZzNew.GetCellDouble(COL_DEBITJE, i, 0) + cllZzNew.GetCellDouble(COL_CREDITJE, i, 0), "0.00")
                tmpFz.sKmdm = cllZzNew.GetCellString(COL_SUBJECT, i, 0)
                tmpFz.sKmmc = GetSubjectFullPath(glo.sAccountID, tmpFz.sKmdm)
                tmpFz.sXmid = 1
                tmpFz.sId = CStr(j)
                tmpFz.sPzrq = Format(GetPeriodTo(CInt(Format(Me.sKJRQ, "MM"))), "yyyy-MM-dd")
                tempVoucherData.m_FzCollection.CollectFz.Add tmpFz
            End If
            dJe = dJe + Format(cllZzNew.GetCellDouble(COL_DEBITJE, i, 0) + cllZzNew.GetCellDouble(COL_CREDITJE, i, 0), "0.00")
        End If
    Next
    If j > 0 Then
        tempVoucherData.Je = dJe
    End If
End With
If m_oTempVoucher.DataSet.getCount > 0 Then
    sId = cllZzNew.GetCellString(COL_ID, 1, 0)
    m_oTempVoucher.sVoucherType = GetVouchertypeFromMfg(sId)
    m_oTempVoucher.sVoucherDate = Format(GetPeriodTo(CInt(Format(Me.sKJRQ, "MM"))), "yyyy-MM-dd")
    m_oTempVoucher.sEnterprise = GetEnterName(glo.sAccountID) '单位
'    m_oTempVoucher.sVoucherDate = sKJRQ '日期
    m_oTempVoucher.sMasterMan = "" '主管
    m_oTempVoucher.sMasterManCode = ""
    m_oTempVoucher.sBillMan = glo.sUserName '制单人
    m_oTempVoucher.sBillManCode = glo.sUserID
    m_oTempVoucher.sCheckMan = "" '复合人
    m_oTempVoucher.sCheckManCode = ""
    m_oTempVoucher.iGlo = m_oTempVouchers.iGlo
    m_oTempVoucher.iGlosys = m_oTempVouchers.iGlosys
    m_oTempVoucher.sStatus = "新增"
    m_oTempVouchers.Add m_oTempVoucher
End If
End Sub

'获得凭证类别
Private Function GetVouchertypeFromMfg(ByVal sId As String) As String
Dim i As Integer
For i = 1 To mfgDisplay.Rows - 1
    If Trim$(sId) = Trim$(mfgDisplay.TextMatrix(i, MFG_COLID)) Then
        GetVouchertypeFromMfg = mfgDisplay.TextMatrix(i, MFG_COLLB)
        Exit For
    End If
Next
End Function