listmodule.bas

金算盘软件代码

Attribute VB_Name = "ListModule"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  列表及卡片部分公用代码
'  作者：黄涛
'  日期：1998.02.21
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
'Option Compare Text


' 编码列表窗口位置

Public Const ListFormTop = 50
Public Const ListFormLeft = 50
Public Const ListFormRight = 50
Public Const ListFormBottom = 50
Public Const ListUpAreaHeight = 500
Public Const ssTabUpAreaHeight = 600
Public Const ListDownAreaHeight = 500
Public Const ListFormMinWidth = 5500
Public Const ListFormMinHeight = 3400
Public Const ListGridTop = 150
Public Const ListGridLeft = 150
Public Const ListGridRight = 150
Public Const ListGridBottom = 150

' 编码列表窗口栏目背景颜色
Public Const clrFixedbkclr = &H808080
Public Const clrSelectedbkclr = &HC0C0C0
Public strError As String

' 编码卡片窗口位置
Public Const CardFormButtonCheckBox = 200
Public Const MAX_PATH = 260

Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type

Public mblnAccountInit As Boolean
Public mblnCustomerInit As Boolean
Public mblnItemInit As Boolean
Private marrAccount() As String
Private marrcustomer() As String
Private marrItem() As String

Declare Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'WXY Define 销货清单
Public Type DataBookTemplate
    lngTemplateID As Long   '对应的销售发票模板ID
    strDatBook As String    '销货清单“名称，单据类型ID”字符串
End Type
Public DataBook() As DataBookTemplate '销售发票对应的销货清单模板ID

Private Sub InitArray(ByVal strSql As String, arrX() As String)
    Dim l As Long, recX As rdoResultset
    
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recX.EOF Then
        recX.MoveNext
        recX.MoveFirst
        ReDim arrX(1 To recX.RowCount, 1 To 2)
        For l = 1 To recX.RowCount
            arrX(l, 1) = recX(0)
            arrX(l, 2) = recX(1)
            recX.MoveNext
        Next l
    End If
    recX.Close
End Sub

Public Function InitTitle(strTitleName() As String, blnisUser() As Boolean) As Boolean
    Dim strSql As String
    Dim k As Integer
    Dim recTemplete As rdoResultset
    
    strSql = "SELECT * From Setting Where lngModuleID=8 Order By strkey"
    Set recTemplete = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    For k = 0 To 5
        strTitleName(k) = recTemplete!strSetting
        recTemplete.MoveNext
        blnisUser(k) = CBool(recTemplete!strSetting)
        recTemplete.MoveNext
        If strTitleName(k) <> "" Then
            InitTitle = True
        End If
    Next
End Function

'判断余额表中明细记录除本期已记帐期初外其余字段值是否为零
Public Function IsCashBank(lngAccountID As Long) As Boolean
    Dim strSql As String
    Dim recTemp As rdoResultset
    
    strSql = "SELECT Decode(lngAccountNatureID,1,1,2,1,0) As IsCashBank" _
        & " FROM Account WHERE lngAccountID=" & lngAccountID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.RowCount > 0 Then
        IsCashBank = recTemp!IsCashBank
    End If
End Function

Private Sub ExportAccount(ByVal StrFileName As String, strWhere As String)
    Dim strPath As String
    Dim lngResult As Long
    Dim strTemp As String
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim intFileNum As Integer
    
    strPath = GetFilePath(StrFileName)
'    strPath = Left(StrFileName, Len(StrFileName) - Len(strPath) - 1)
        strTemp = "文件名=Account.dat" & Chr(0) & "科目级数=0" _
            & Chr(0) & "科目结构=0" & Chr(0) & "字段数=21"
        strTemp = strTemp & Chr(0) & "字段1=科目代码,1,2"
        strTemp = strTemp & Chr(0) & "字段2=科目名称,2,2"
        strTemp = strTemp & Chr(0) & "字段3=科目类别,3,2"
        strTemp = strTemp & Chr(0) & "字段4=科目级次,4,1"
        strTemp = strTemp & Chr(0) & "字段5=借贷方向,5,1"
        strTemp = strTemp & Chr(0) & "字段6=数量单位,6,2"
        strTemp = strTemp & Chr(0) & "字段7=币别,7,2"
        strTemp = strTemp & Chr(0) & "字段8=科目全称,8,2"
        strTemp = strTemp & Chr(0) & "字段9=末级标志,9,3"
        strTemp = strTemp & Chr(0) & "字段10=科目性质,10,1"
        strTemp = strTemp & Chr(0) & "字段11=多币种核算标志,11,3"
        strTemp = strTemp & Chr(0) & "字段12=数量核算标志,12,3"
        strTemp = strTemp & Chr(0) & "字段13=单位核算标志,13,3"
        strTemp = strTemp & Chr(0) & "字段14=部门核算标志,14,3"
        strTemp = strTemp & Chr(0) & "字段15=员工核算标志,15,3"
        strTemp = strTemp & Chr(0) & "字段16=统计核算标志1,16,3"
        strTemp = strTemp & Chr(0) & "字段17=统计核算标志2,17,3"
        strTemp = strTemp & Chr(0) & "字段18=停用标志,18,3"
        strTemp = strTemp & Chr(0) & "字段19=现金流量标志,19,3"
        strTemp = strTemp & Chr(0) & "字段20=期末调汇标志,20,3"
        strTemp = strTemp & Chr(0) & "字段21=计算科目利息标志,21,3"
        strTemp = strTemp & Chr(0) & "导出日期=" & Format(Date, "yyyy-mm-dd")
        lngResult = WritePrivateProfileSection("科目", strTemp, StrFileName)
        strSql = "SELECT Account.*,AccountType.strAccountTypeName FROM Account,AccountType" _
            & " WHERE Account.lngAccountTypeID=AccountType.lngAccountTypeID " & strWhere _
            & " ORDER BY strAccountCode"
        Set recTemp = gclsBase.BaseDB.OpenResultset(strSql)
        With recTemp
            If Dir(strPath & "Account.Dat") <> "" Then
                Kill strPath & "Account.Dat"
            End If
            If Dir(strPath & "AccountCurrency.Dat") <> "" Then
                Kill strPath & "AccountCurrency.Dat"
            End If
            intFileNum = FreeFile
            Open strPath & "Account.Dat" For Binary As #intFileNum
            Do While Not .EOF
                strTemp = !strAccountCode & Chr(9) & !strAccountName & Chr(9) & !strAccountTypeName _
                    & Chr(9) & !intLevel & Chr(9) & !intDirection & Chr(9) & !strQuantityUnit _
                    & Chr(9) & IIf(!blnIsAllCurrency, "*", "") & Chr(9) & !strFullName _
                    & Chr(9) & IIf(!blnIsDetail, "1", "0") & Chr(9) & !lngAccountNatureID _
                    & Chr(9) & IIf(!blnIsMultCurrency, "1", "0") & Chr(9) & IIf(!blnIsQuantity, "1", "0") _
                    & Chr(9) & IIf(!blnIsCustomer, "1", "0") & Chr(9) & IIf(!blnIsDepartment, "1", "0") _
                    & Chr(9) & IIf(!blnIsEmployee, "1", "0") & Chr(9) & IIf(!blnIsClass1, "1", "0") _
                    & Chr(9) & IIf(!blnIsClass2, "1", "0") & Chr(9) & IIf(!blnIsInActive, "1", "0") _
                    & Chr(9) & IIf(!blnIsCash, "1", "0") & Chr(9) & IIf(!blnIsCalcExchange, "1", "0") _
                    & Chr(9) & IIf(!blnIsCalcInterest, "1", "0") & Chr(13) & Chr(10)
                Put #intFileNum, , strTemp
                If !blnIsAllCurrency Or !blnIsMultCurrency Then
                    ExportAccountCurrency strPath, !blnIsAllCurrency, !lngAccountID, !strAccountCode
                End If
                .MoveNext
            Loop
            Close #intFileNum
        End With
End Sub

Private Sub ExportAccountCurrency(ByVal strPath As String, ByVal blnAllCur As Boolean, _
    ByVal lngAcnID As Long, ByVal strCode As String)
    Dim intFileNum As Integer
    Dim recAC As rdoResultset
    Dim strSql As String
    Dim strTemp As String
    Dim strIDStr As String
    
    If blnAllCur Then
        strSql = "SELECT lngCurrencyID FROM Currencys ORDER BY lngCurrencyID"
    Else
        strSql = "SELECT lngCurrencyID FROM AccountCurrency WHERE lngAccountID=" _
            & lngAcnID & "  ORDER BY lngCurrencyID"
    End If
    Set recAC = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recAC.EOF
        strIDStr = strIDStr & recAC!lngCurrencyID & " "
        recAC.MoveNext
    Loop
    recAC.Close
    If strIDStr <> "" Then
        strTemp = strCode & "=" & RTrim(strIDStr) & Chr(9)
        intFileNum = FreeFile
        Open strPath & "AccountCurrency.Dat" For Binary As #intFileNum
        If LOF(intFileNum) Then
            Seek #intFileNum, LOF(intFileNum) + 1
        End If
        Put #intFileNum, , strTemp
        Close #intFileNum
    End If
End Sub

Private Sub ExportCurrency(ByVal StrFileName As String, strWhere As String)
    Dim strPath As String
    Dim lngResult As Long
    Dim strTemp As String
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim intFileNum As Integer

    strPath = GetFilePath(StrFileName)
    strTemp = "文件名=Cy.dat" & Chr(0) & "字段数=7"
    strTemp = strTemp & Chr(0) & "字段1=货币代码,1,2"
    strTemp = strTemp & Chr(0) & "字段2=货币名称,2,2"
    strTemp = strTemp & Chr(0) & "字段3=是否本位币,3,3"
    strTemp = strTemp & Chr(0) & "字段4=折算方式,4,2"
    strTemp = strTemp & Chr(0) & "字段5=货币小数位数,5,1"
    strTemp = strTemp & Chr(0) & "字段6=汇率小数位数,6,1"
    strTemp = strTemp & Chr(0) & "字段7=日期匹配方式,7,1"
    strTemp = strTemp & Chr(0) & "导出日期=" & Format(Date, "yyyy-mm-dd")
    lngResult = WritePrivateProfileSection("货币", strTemp, StrFileName)
    strSql = "Select * From Currencys " & strWhere
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql)
    With recTemp
        If Dir(strPath & "Cy.Dat") <> "" Then
            Kill strPath & "Cy.Dat"
        End If
        intFileNum = FreeFile
        Open strPath & "Cy.Dat" For Binary As #intFileNum
        Do While Not .EOF
            strTemp = !strCurrencyCode & Chr(9) & !strCurrencyName _
                & Chr(9) & IIf(!lngCurrencyID = 1, "1", "0") _
                & Chr(9) & IIf(!blnIsIndirect, "1", "0") _
                & Chr(9) & !bytCurrencydec _
                & Chr(9) & !bytRateDec _
                & Chr(9) & !bytMatchmethod _
                & Chr(13) & Chr(10)
            Put #intFileNum, , strTemp
            .MoveNext
        Loop
        Close #intFileNum
    End With
End Sub

Private Sub ExportCustomerType(ByVal StrFileName As String, strWhere As String)
    Dim strPath As String