showalterinfo.bas

金算盘软件代码

Attribute VB_Name = "ShowAlterInfo"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   显示固资变动信息模块
'   作者:肖宇
'   日期:1998-07-05
'
'   功能:
'       1.提供关联固资变动资料的接口
'       2.提供关联固资卡片资料的接口
'       3.提供取币种汇率方法
'       4.提供删除多币种、多科目和多部门
'         录入窗体的相关内容集合的方法
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

'卡片查阅
Public Sub DispFixedCard(ByVal lngCardID As Long)
    frmScanFixCard.EditCard lngCardID
End Sub

'显示变动信息
Public Sub DispCardInfo(ByVal lngAlterID As Long)
    DispAlterInfo lngAlterID
End Sub
Public Sub DispAlterInfo(ByVal lngAlterID As Long)
    Dim strSql As String
    Dim recFixedAlter As rdoResultset
    Dim lngCardID As Long
    Dim bytAlterType As Integer
    Dim blnInit As Boolean
    
    strSql = "SELECT strDate,lngFixedCardID,bytAlterType FROM FixedAlter WHERE lngFixedAlterID=" & lngAlterID
    Set recFixedAlter = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recFixedAlter.EOF Then
        lngCardID = recFixedAlter!lngFixedCardID
        bytAlterType = recFixedAlter!bytAlterType
        blnInit = (CDate(recFixedAlter!strDate) < CDate(gclsBase.BeginDate))
    Else
        lngAlterID = 0
    End If
    recFixedAlter.Close
    Set recFixedAlter = Nothing
    
    If lngAlterID > 0 Then
        Select Case bytAlterType
        Case 1 ' 增加
            frmFixedAdd.EditCard lngAlterID, lngCardID, True, blnInit
        Case 2 ' 减少
            frmFixedDec.EditCard lngAlterID, lngCardID, True
        Case 3 ' 其他变动
            frmFixedOtherAlter.EditCard lngAlterID, lngCardID, True
        End Select
    End If
End Sub

Public Function FixedMethodName(lngFixedMethodID As Long) As String
    Dim strSql As String
    Dim recMethod As rdoResultset
    
    strSql = "SELECT * FROM FixedMethod WHERE lngFixedMethodID=" & lngFixedMethodID
    Set recMethod = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recMethod.EOF Then
        FixedMethodName = recMethod!strFixedMethodName
    End If
    recMethod.Close
    Set recMethod = Nothing
End Function

Public Function UseStatus(strCode As String) As String
    Select Case strCode
    Case "1": UseStatus = "使用中"
    Case "2": UseStatus = "未使用"
    Case "3": UseStatus = "不需用"
    Case "4": UseStatus = "租出"
    Case Else
        UseStatus = ""
    End Select
End Function

Public Function UseStatusCode(strName As String) As String
    Select Case strName
    Case "使用中": UseStatusCode = "1"
    Case "未使用": UseStatusCode = "2"
    Case "不需用": UseStatusCode = "3"
    Case "租出": UseStatusCode = "4"
    Case Else
        UseStatusCode = ""
    End Select
End Function

Public Function DeprectionMethod(strCode As String) As String
    Select Case strCode
    Case "1": DeprectionMethod = "不计提折旧"
    Case "2": DeprectionMethod = "平均年限法"
    Case "3": DeprectionMethod = "工作量法"
    Case "4": DeprectionMethod = "双倍余额递减法"
    Case "5": DeprectionMethod = "年数总和法"
    Case "6": DeprectionMethod = "分类折旧法"
    Case Else
        DeprectionMethod = "1"
    End Select
End Function

Public Function DeprectionMethodCode(strName As String) As String
    Select Case strName
    Case "不计提折旧": DeprectionMethodCode = "1"
    Case "平均年限法": DeprectionMethodCode = "2"
    Case "工作量法": DeprectionMethodCode = "3"
    Case "双倍余额递减法": DeprectionMethodCode = "4"
    Case "年数总和法": DeprectionMethodCode = "5"
    Case "分类折旧法": DeprectionMethodCode = "6"
    Case Else
        DeprectionMethodCode = "1"
    End Select
End Function

'判断凭证是否已被删除
Public Function VoucherExist(ByVal lngVoucherID As Long) As Boolean
    Dim strSql As String
    Dim recVoucher As rdoResultset
    
    VoucherExist = False
    If lngVoucherID > 0 Then
        strSql = "SELECT * FROM Voucher WHERE lngVoucherID=" & lngVoucherID & " AND blnIsVoid = 0 "
        Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recVoucher.EOF Then
            VoucherExist = True
        End If
        recVoucher.Close
        Set recVoucher = Nothing
    End If
End Function
'取消折旧
Public Function UndoDeprection() As Boolean
    Dim strSql As String
    Dim recVoucher As rdoResultset
    Dim clsVoucher As clsVoucherMethod
    Dim lngVoucherID As Long
    
    strSql = "SELECT lngVoucherID FROM Voucher WHERE lngVoucherSourceID=" & vsFixedDeprection _
        & " AND intYear=" & gclsBase.AccountYear & " AND bytPeriod=" & gclsBase.Period _
        & " AND blnIsVoid = 0 "
    Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recVoucher.EOF Then
        lngVoucherID = recVoucher!lngVoucherID
    End If
    recVoucher.Close
    Set recVoucher = Nothing
    If lngVoucherID > 0 Then
        If ShowMsg(frmMain.hwnd, "本期已提折旧，是否取消折旧?", vbQuestion + vbYesNo + vbDefaultButton2, "计提折旧") = vbYes Then
            Set clsVoucher = New clsVoucherMethod
            If Not clsVoucher.DeleteVoucher(lngVoucherID, True) Then
                ShowMsg frmMain.hwnd, "取消折旧失败!", vbCritical + vbOKOnly, "计提折旧"
            Else
                ShowMsg frmMain.hwnd, "本期已经取消折旧!", vbInformation + vbOKOnly, "计提折旧"
            End If
            Set clsVoucher = Nothing
        End If
    Else
        ShowMsg frmMain.hwnd, "本期以后期间已提折旧!", vbCritical + vbOKOnly, "计提折旧"
    End If
End Function
'检查期间是否计提折旧
Public Function PeriodDepection(intYear As Integer, intPeriod As Integer, Optional intDiffPeriod As Integer = 0, Optional blnTrade As Boolean = True) As Boolean
    Dim strSql As String
    Dim recVoucher As rdoResultset
    Dim lngPeriod As Long
    Dim intNumPeriod As Integer
    Dim strTrade As String
    
    '若是行政事业版
    strTrade = GetAccountSystem()
    If strTrade = "3" Then
        PeriodDepection = blnTrade
    End If
    
    intNumPeriod = PeriodsOfYear()
    If intDiffPeriod <> 0 Then
        lngPeriod = CLng(intYear) * intNumPeriod + intPeriod + intDiffPeriod - 1
        lngPeriod = (lngPeriod \ intNumPeriod) * 100 + (lngPeriod Mod intNumPeriod + 1)
    Else
        lngPeriod = CLng(intYear) * 100 + intPeriod
    End If
    PeriodDepection = False
    strSql = "SELECT * FROM Voucher WHERE lngVoucherSourceID=" & vsFixedDeprection _
        & " AND (intYear)*100+bytPeriod>=" & lngPeriod _
        & " AND ( blnIsVoid = 0 )"
    Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recVoucher.EOF Then
        PeriodDepection = True
    End If
    recVoucher.Close
    Set recVoucher = Nothing
End Function

'变动记录是否生成凭证
Public Function AlterExistVoucher(lngFixedAlterID As Long) As Boolean
    Dim strSql As String
    Dim recFixedAlter As rdoResultset
    
    AlterExistVoucher = False
    strSql = "SELECT * FROM FixedAlter WHERE lngFixedAlterID=" & lngFixedAlterID
    Set recFixedAlter = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recFixedAlter.EOF Then
        If recFixedAlter!lngVoucherID > 0 Then
            AlterExistVoucher = VoucherExist(recFixedAlter!lngVoucherID)
        End If
    End If
    recFixedAlter.Close
    Set recFixedAlter = Nothing
End Function

Public Function GetVoucherNo(ByVal lngVoucherID As Long) As String
    Dim strSql As String
    Dim recVoucher As rdoResultset
    
    strSql = "SELECT VoucherType.strVoucherTypCode,lngVoucherNo FROM Voucher " _
        & ", VoucherType WHERE Voucher.lngVoucherTypeID=VoucherType.lngVoucherTypeID " _
        & "AND lngVoucherID=" & lngVoucherID
    Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recVoucher.EOF Then
        GetVoucherNo = recVoucher!strVoucherTypCode & "-" & Format(recVoucher!lngVoucherNO, "0000")
    Else
        GetVoucherNo = ""
    End If
    recVoucher.Close
    Set recVoucher = Nothing
End Function

'每年会计期间数
Public Function PeriodsOfYear() As Integer
    Dim strSql As String
    Dim recPeriod As rdoResultset
    strSql = "SELECT bytPeriodNO AS intYearPreiod FROM AccountYear ORDER BY intYear ASC "
    Set recPeriod = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recPeriod.EOF Then
        PeriodsOfYear = recPeriod!intYearPreiod
    Else
        PeriodsOfYear = 12
    End If
End Function

'某个固定资产是否提过折旧
Public Function FixedDeprection(ByVal lngCardID As Long, ByVal intYear As Integer, ByVal bytPeriod As Integer) As Boolean
    Dim strSql As String
    Dim recBalance As rdoResultset
    
    strSql = "SELECT * FROM FixedBalance WHERE lngFixedCardID=" & lngCardID _
        & " AND intYear * 100 + bytPeriod >= " & CLng(intYear) * 100 + bytPeriod _
        & " AND dblDeprection>0"
    Set recBalance = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recBalance.EOF Then
        FixedDeprection = True
    Else
        FixedDeprection = False
    End If
    recBalance.Close
    Set recBalance = Nothing
End Function

'某期固定资产是否录入工作量
Public Function BeenInputWork(ByVal intYear As Integer, ByVal bytPeriod As Integer) As Boolean
    Dim strSql As String
    Dim strQFixedMax As String