frmtransferloss.frm

金算盘软件代码

    
ErrHandle:
    errNo = Errors.ErrorsDeal(True, Me)
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg hWnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
    End Select
End Sub

Private Sub cmdStep_Click(Index As Integer)
    Dim blnUnload As Boolean
    Dim strMsg As String
    
    blnUnload = False
    
    Select Case Index
    Case 0  '取消
        blnUnload = True
    Case 1  '上一步
        If stabWizard.Tab > 0 Then
            stabWizard.Tab = stabWizard.Tab - 1
        End If
    Case 2  '下一步
        If stabWizard.Tab < mintStepNum Then
            stabWizard.Tab = stabWizard.Tab + 1
        End If
    Case 3: '完成
        If ValidStep(mintStepNum) Then
            cmdStep(3).Enabled = False
            Execute
            blnUnload = True
        End If
    End Select
    
    If blnUnload Then
       Unload Me
    End If
End Sub

'重设按扭显示属性
Private Sub RefreshCmd()
    Dim lngCnt As Long
    
    Select Case stabWizard.Tab
    Case 0
        cmdStep(1).Enabled = False
        cmdStep(2).Enabled = True
    Case mintStepNum
        cmdStep(1).Enabled = True
        cmdStep(2).Enabled = False
    Case Else
        cmdStep(1).Enabled = True
        cmdStep(2).Enabled = True
    End Select
    
    '是否每步都合法
    For lngCnt = 0 To mintStepNum
        If Not mblnValid(lngCnt) Then
            Exit For
        End If
    Next lngCnt
    cmdStep(3).Enabled = (lngCnt > mintStepNum)
    
    '若是最后一步，把完成按扭变为有效
    If Not cmdStep(3).Enabled Then
        If stabWizard.Tab = mintStepNum Then
            cmdStep(3).Enabled = True
        End If
    End If
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  向导步骤初始化
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'第一步：结转损益科目初始
Private Function InitRate()
    Dim dtmEndDate As Date, lngCnt As Long
    Dim intYear As Integer, intPeriod As Integer
    Dim strSQL As String, recCurrency As rdoresultset, recRate As rdoresultset
    Dim lngNaturalID As Long, strFormat As String
    Dim recTmp As rdoresultset
    
    If fraWizard(0).Tag <> "已设置" Then
        fraWizard(0).Tag = "已设置"
        
        intYear = gclsBase.FYearOfDate(gclsBase.BaseDate)
        intPeriod = gclsBase.PeriodOfDate(gclsBase.BaseDate)
        '本位币
        lngNaturalID = gclsBase.NaturalCurId
        
        gclsBase.DateOfPeriod intYear, intPeriod, , dtmEndDate
        
        strSQL = "SELECT lngCurrencyID AS ID,  " _
                & "strCurrencyCode || ' ' || strCurrencyName AS 币种, " _
                & "0 AS 汇率, bytRateDec as RateDec, " _
                & "blnIsIndirect as IsIndirect "
        strSQL = strSQL & " FROM Currencys WHERE blnIsInActive=0 AND lngCurrencyID<>" & lngNaturalID
        
        Set datRate.Resultset = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    
        Set mclsRateGrid = New Grid
        Set mclsRateGrid.Grid = msgRate
        mclsRateGrid.ColOfs = 1
        mclsRateGrid.SetupStyle
        msgRate.ColWidth(0) = 0
        msgRate.ColWidth(1) = 3000
        msgRate.ColWidth(2) = 1600
        msgRate.ColWidth(3) = 0
        msgRate.ColWidth(4) = 0
        msgRate.ColAlignment(2) = 6
        mclsRateGrid.SetEditText "汇率", "#0.00000", , , txtRate
    
        '装入期末汇率
        strSQL = "SELECT Currencys.lngCurrencyID AS ID,dblRate " _
            & "FROM Currencys,Rate " _
            & "WHERE Currencys.lngCurrencyID=Rate.lngCurrencyID " _
            & "AND Rate.strDate<='" & Format(dtmEndDate, "YYYY-MM-DD") & "'" _
            & "ORDER BY Currencys.lngCurrencyID,Rate.strDate DESC"
        Set recRate = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
        With msgRate
            For lngCnt = 1 To .Rows - 1
                If .TextMatrix(lngCnt, 3) > 0 Then
                    strFormat = "0." & String(.TextMatrix(lngCnt, 3), "0")
                Else
                    strFormat = "0"
                End If
                strSQL = "SELECT Currencys.lngCurrencyID AS ID,dblRate " _
                    & " FROM Currencys,Rate " _
                    & " WHERE Currencys.lngCurrencyID=Rate.lngCurrencyID " _
                    & " AND Rate.strDate<='" & Format(dtmEndDate, "YYYY-MM-DD") & "'" _
                    & " AND Currencys.lngCurrencyID=" & .TextMatrix(lngCnt, 0) _
                    & " ORDER BY Currencys.lngCurrencyID,Rate.strDate DESC"
                Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
                If Not recTmp.EOF Then
                    .TextMatrix(lngCnt, 2) = Format(recTmp!dblRate, strFormat)
                Else
                    .TextMatrix(lngCnt, 2) = Format(0, strFormat)
                End If
                mclsRateGrid.FormatCell lngCnt, 2
            Next lngCnt
        End With
    End If

    fraWizard(3).Tag = ""

End Function

'第二步：损益科目初始
Private Function InitAccount()
    Dim lngID As Long
    
    If fraWizard(1).Tag <> "已设置" Then
        fraWizard(1).Tag = "已设置"
        '科目参照
        RefreshAccount
        lngID = GetSet(1, "特殊科目", "汇兑损益", 0)
        If lngID > 0 Then
            lstxtAccount.SeekId lngID
        End If
    End If
    
    fraWizard(3).Tag = ""
End Function

'第三步：凭证选项初始
Private Function InitOption()
    Dim lngID As Long
    If fraWizard(2).Tag <> "已设置" Then
        
        fraWizard(2).Tag = "已设置"

        '凭证模板参照
        RefreshTemplate
        lngID = CLng(GetSet(1, "汇兑损益", "凭证摸板", 0))
        If lngID > 0 Then lstxtTemplate.SeekId lngID
    
        '凭证类型参照
        RefreshVoucherType
        lngID = CLng(GetSet(1, "汇兑损益", "凭证类型", 0))
        If lngID > 0 Then lstxtType.SeekId lngID
    End If
End Function

'第四步：凭证预缆初始
Private Function InitResult()
    Dim lngCnt As Long, lngCntDetail As Long, lngCntOrder As Long
    Dim strResult As String, strDetail As String, strAmount As String
    Dim strSQL As String
    Dim recAccount As rdoresultset
    Dim lngLen As Long, lngSpace As Long
    Dim errNo As Long
    Dim lngDetailCnt As Long
    
    On Error GoTo ErrHandle
    
    If fraWizard(3).Tag <> "已设置" Then
        
        fraWizard(3).Tag = "已设置"
        
        '摘要参照
        If Trim$(lstxtRemark.Text) = "" Then
            strResult = "汇兑损益"
        Else
            strResult = lstxtRemark.Text
        End If
        RefreshRemark
        lstxtRemark.Text = strResult
        
        '生成凭证
        GenTransLossVoucher
        If Not VoucherData(0).Used Then Exit Function
        
        strResult = ""
        lngLen = 48
        For lngCnt = 0 To UBound(VoucherData)
            With VoucherData(lngCnt)
                lngDetailCnt = UBound(.Detail)
                If lngDetailCnt > 100 Then
                    strResult = "本凭证有" & UBound(.Detail) + 1 & "笔分录,下面是前20条分录：" & Chr(13) & Chr(10) & Chr(13) & Chr(10)
                    lngDetailCnt = 19
                End If
                For lngCntOrder = 0 To lngDetailCnt
                    If .Detail(UBound(.Detail)).Direction = adCredit Then
                        lngCntDetail = lngCntOrder
                    Else
                        If lngCntOrder = 0 Then
                            lngCntDetail = UBound(.Detail)
                        Else
                            lngCntDetail = lngCntOrder - 1
                        End If
                    End If
                    If .Detail(lngCntDetail).Direction = adDebit Then
                        strDetail = "借："
                    Else
                        strDetail = "贷："
                    End If
                    strSQL = "SELECT strAccountCode,strAccountName FROM Account " _
                        & "WHERE lngAccountID=" & .Detail(lngCntDetail).AccountID
                    Set recAccount = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
                    If Not recAccount.EOF Then
                        strDetail = strDetail & recAccount!strAccountCode & " " _
                            & Trim(recAccount!strAccountName)
                            If .Detail(lngCntDetail).CustomerID > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & CustomerName(.Detail(lngCntDetail).CustomerID)
                            End If
                            If .Detail(lngCntDetail).DepartmentID > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & DepartmentName(.Detail(lngCntDetail).DepartmentID)
                            End If
                            If .Detail(lngCntDetail).EmployeeID > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & EmployeeName(.Detail(lngCntDetail).EmployeeID)
                            End If
'                            If .Detail(lngCntDetail).JobID > 0 Then
'                                strDetail = strDetail & "/" & JobName(.Detail(lngCntDetail).JobID)
'                            End If
                            If .Detail(lngCntDetail).ClassID1 > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & Class1Name(.Detail(lngCntDetail).ClassID1)
                            End If
                            If .Detail(lngCntDetail).ClassID2 > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & Class2Name(.Detail(lngCntDetail).ClassID2)
                            End If
                            If .Detail(lngCntDetail).CurrencyID > 0 Then
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                                strDetail = Space(4) & "— " & CurrencyName(.Detail(lngCntDetail).CurrencyID)
                            End If
                    End If
                    lngSpace = lngLen - StrLen(strDetail) - 14
                    If lngSpace < 0 Then lngSpace = 0
                    strDetail = strDetail & Space(lngSpace)
                    strAmount = Format(.Detail(lngCntDetail).Amount, "#0.00")
                    lngSpace = 14 - StrLen(strAmount)
                    If lngSpace < 0 Then lngSpace = 0
                    strDetail = strDetail & Space(lngSpace) & strAmount
                    strResult = strResult & strDetail & Chr(13) & Chr(10)
                Next lngCntOrder
            End With
            strResult = strResult & "────────────────────────" & Chr(13) & Chr(10)
        Next lngCnt
        txtResult.Text = strResult
    End If
    Exit Function
    
ErrHandle:
    errNo = Errors.ErrorsDeal(True, Me)
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg hWnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
    End Select
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  向导步骤合法检查
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'第一步，期末汇率
Private Function ValidRate(Msg As String) As Boolean
    Dim lngRow As Long
    
    ValidRate = True
    With msgRate
        For lngRow = .FixedRows To .Rows - 1
            If IsNumeric(.TextMatrix(lngRow, 2)) Then
                If .TextMatrix(lngRow, 2) = 0 Then
                    ValidRate = False
                    Msg = .TextMatrix(lngRow, 1) & "未输入期末汇率！"
                    Exit For
                End If
                If .TextMatrix(lngRow, 2) < 0 Then
                    ValidRate = False
                    Msg = .TextMatrix(lngRow, 1) & "期末汇率必须大于0.00！"
                    Exit For
                End If
            Else
                ValidRate = False
                Msg = .TextMatrix(lngRow, 1) & "未输入期末汇率！"
                Exit For
            End If
        Next lngRow
        If ValidRate Then
            If .Rows = .FixedRows Then
                ValidRate = False
                Msg = "没有币种可调整汇率！"
            End If
        End If
    End With
End Function

'第二步，损益科目
Private Function ValidAccount(Msg As String) As Boolean
    Dim strSQL As String
    Dim recAccount As rdoresultset
    Dim strCode As String, strText As String
    On Error Resume Next
    ValidAccount = True
    
    strText = lstxtAccount.Text
    If InStr(strText, vbTab) > 0 Then
        strCode = Left(strText, InStr(strText, vbTab) - 1)