listmodule.bas

金算盘软件代码

    Dim lngResult As Long
    Dim strShow() As String
    Dim strTemp As String
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim intFileNum As Integer

    strPath = GetFilePath(StrFileName)
    strTemp = "文件名=CustomerType.dat" & Chr(0) & "字段数=3"
    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) & "导出日期=" & Format(Date, "yyyy-mm-dd")
    lngResult = WritePrivateProfileSection("单位类别", strTemp, StrFileName)
    strSql = "SELECT * FROM CustomerType" & strWhere & " ORDER BY strCustomerTypeCode"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql)
    With recTemp
        If Dir(strPath & "CustomerType.Dat") <> "" Then
            Kill strPath & "CustomerType.Dat"
        End If
        intFileNum = FreeFile
        Open strPath & "CustomerType.Dat" For Binary As #intFileNum
        Do While Not .EOF
            strTemp = !strCustomerTypeCode & Chr(9) & !strCustomerTypeName _
                & Chr(9) & IIf(!blnIsInActive, "1", "0") & Chr(13) & Chr(10)
            Put #intFileNum, , strTemp
            .MoveNext
        Loop
        Close #intFileNum
    End With
End Sub

Private Sub ExportCustomer(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 = "文件名=Customer.dat" & Chr(0) & "字段数=23"
    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,2"
    strTemp = strTemp & Chr(0) & "字段5=付款条件,5,2"
    strTemp = strTemp & Chr(0) & "字段6=信用额度,6,1"
    strTemp = strTemp & Chr(0) & "字段7=折扣率,7,1"
    strTemp = strTemp & Chr(0) & "字段8=员工,8,2"
    strTemp = strTemp & Chr(0) & "字段9=地区,9,2"
    strTemp = strTemp & Chr(0) & "字段10=联系人,10,2"
    strTemp = strTemp & Chr(0) & "字段11=职务,11,2"
    strTemp = strTemp & Chr(0) & "字段12=电话(O),12,2"
    strTemp = strTemp & Chr(0) & "字段13=电话(H),13,2"
    strTemp = strTemp & Chr(0) & "字段14=传真,14,2"
    strTemp = strTemp & Chr(0) & "字段15=电子邮件,15,2"
    strTemp = strTemp & Chr(0) & "字段16=税号,16,2"
    strTemp = strTemp & Chr(0) & "字段17=地址,17,2"
    strTemp = strTemp & Chr(0) & "字段18=邮编,18,2"
    strTemp = strTemp & Chr(0) & "字段19=备注,19,2"
    strTemp = strTemp & Chr(0) & "字段20=应收科目,20,2"
    strTemp = strTemp & Chr(0) & "字段21=应付科目,21,2"
    strTemp = strTemp & Chr(0) & "字段22=应收折扣科目,22,2"
    strTemp = strTemp & Chr(0) & "字段23=应付折扣科目,23,2"
    strTemp = strTemp & Chr(0) & "导出日期=" & Format(Date, "yyyy-mm-dd")
    lngResult = WritePrivateProfileSection("单位", strTemp, StrFileName)
    strSql = "SELECT Customer.*,CustomerType.strCustomerTypeCode,Term.strTermCode" _
        & ",Area.strAreaCode,Title.strTitleName,Account.strAccountCode AS 应收科目" _
        & ",A1.strAccountCode AS 应付科目,A2.strAccountCode AS 应收折扣科目" _
        & ",A3.strAccountCode AS 应付折扣科目 FROM Customer,CustomerType,Term,Area,Title,Account" _
        & ",Account A1,Account A2,Account A3 WHERE Customer.lngCustomerTypeID=CustomerType.lngCustomerTypeID " _
        & " AND Customer.lngTermID=Term.lngTermID(+) AND Customer.lngAreaID=Area.lngAreaID(+) AND" _
        & " Customer.lngTitleID=Title.lngTitleID(+) AND Customer.lngARAccountID=Account.lngAccountID(+) " _
        & " AND Customer.lngAPAccountID=A1.lngAccountID(+) AND Customer.lngARDiscountAccountID=A2.lngAccountID(+) " _
        & " AND Customer.lngAPDiscountAccountID=A3.lngAccountID(+)" & strWhere
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql)
    With recTemp
        If Dir(strPath & "Customer.Dat") <> "" Then
            Kill strPath & "Customer.Dat"
        End If
        intFileNum = FreeFile
        Open strPath & "Customer.Dat" For Binary As #intFileNum
        Do While Not .EOF
            strTemp = !strCustomerCode & Chr(9) & !strCustomerName & Chr(9) & !strCategory _
                & Chr(9) & !strCustomerTypeCode & Chr(9) & !strTermCode & Chr(9) & !dblCreditLimit _
                & Chr(9) & !dblDiscountRate & Chr(9) & !lngEmployeeID & Chr(9) & !strAreaCode _
                & Chr(9) & !strContactName & Chr(9) & !strTitleName _
                & Chr(9) & !strOfficePhoneNumber & Chr(9) & !strHomePhoneNumber _
                & Chr(9) & !strFaxNumber & Chr(9) & !strEMail _
                & Chr(9) & !strTaxNO & Chr(9) & !strBillToAddress _
                & Chr(9) & !strBillToPostalCode & Chr(9) & !strNotes & Chr(9) & !应收科目 _
                & Chr(9) & !应付科目 & Chr(9) & !应收折扣科目 _
                & Chr(9) & !应付折扣科目 & Chr(13) & Chr(10)
            Put #intFileNum, , strTemp
            .MoveNext
        Loop
        Close #intFileNum
    End With
End Sub

Private Sub ExportDepartment(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 = "文件名=Department.dat" & Chr(0) & "字段数=6"
    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,3"
    strTemp = strTemp & Chr(0) & "字段6=备注,6,2"
    strTemp = strTemp & Chr(0) & "导出日期=" & Format(Date, "yyyy-mm-dd")
    lngResult = WritePrivateProfileSection("部门", strTemp, StrFileName)
    strSql = "SELECT * FROM Department" & strWhere & " ORDER BY strDepartmentCode"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql)
    With recTemp
        If Dir(strPath & "Department.Dat") <> "" Then
            Kill strPath & "Department.Dat"
        End If
        intFileNum = FreeFile
        Open strPath & "Department.Dat" For Binary As #intFileNum
        Do While Not .EOF
            strTemp = !strDepartmentCode & Chr(9) & !strDepartmentName & Chr(9) & !strFullName _
                & Chr(9) & !intLevel & Chr(9) & IIf(!blnIsDetail, "1", "0") _
                & Chr(9) & !strNotes & Chr(13) & Chr(10)
            Put #intFileNum, , strTemp
            .MoveNext
        Loop
        Close #intFileNum
    End With
End Sub
'引出自定义项目
Private Sub ExportDefine(ByVal StrFileName As String, strWhere As String, ByVal Index As Integer)
    Dim strPath As String
    Dim lngResult As Long
    Dim strTemp As String
    Dim strSql As String
    Dim strDefineName As String
    Dim recTemp As rdoResultset
    Dim intFileNum As Integer

    strPath = GetFilePath(StrFileName)
    strDefineName = "Custom" & Index & ".Dat"
    strTemp = "文件名=" & strDefineName & Chr(0) & "字段数=4"
    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) & "导出日期=" & Format(Date, "yyyy-mm-dd")
    lngResult = WritePrivateProfileSection("自定义项目" & Index, strTemp, StrFileName)
    strSql = "SELECT * FROM Custom" & Index & strWhere & " ORDER BY strCustomCode"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql)
    With recTemp
        If Dir(strPath & strDefineName) <> "" Then
            Kill strPath & strDefineName
        End If
        intFileNum = FreeFile
        Open strPath & strDefineName For Binary As #intFileNum
        Do While Not .EOF
            strTemp = !strCustomCode & Chr(9) & !strCustomName & Chr(9) _
                & IIf(!blnIsInActive, "1", "0") & Chr(9) & !strNotes & Chr(13) & Chr(10)
            Put #intFileNum, , strTemp
            .MoveNext
        Loop
        Close #intFileNum
    End With
End Sub

Private Sub ExportEmployeeType(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 = "文件名=EmployeeType.dat" & Chr(0) & "字段数=3"
    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) & "导出日期=" & Format(Date, "yyyy-mm-dd")
    lngResult = WritePrivateProfileSection("职员类别", strTemp, StrFileName)
    strSql = "SELECT * FROM EmployeeType" & strWhere & " ORDER BY strEmployeeTypeCode"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql)
    With recTemp
        If Dir(strPath & "EmployeeType.Dat") <> "" Then
            Kill strPath & "EmployeeType.Dat"
        End If
        intFileNum = FreeFile
        Open strPath & "EmployeeType.Dat" For Binary As #intFileNum
        Do While Not .EOF
            strTemp = !strEmployeeTypeCode & Chr(9) & !strEmployeeTypeName _
                & Chr(9) & !strNotes & Chr(13) & Chr(10)
            Put #intFileNum, , strTemp
            .MoveNext
        Loop
        Close #intFileNum
    End With
End Sub

Private Sub ExportEmployee(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 = "文件名=Employee.dat" & 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,2"
    strTemp = strTemp & Chr(0) & "字段5=部门代码,5,2"
    strTemp = strTemp & Chr(0) & "字段6=文化程度,6,2"
    strTemp = strTemp & Chr(0) & "字段7=征收个人所得税标志,7,3"
    strTemp = strTemp & Chr(0) & "字段8=个人所得税类别,8,2"
    strTemp = strTemp & Chr(0) & "字段9=银行代发工资标志,9,2"
    strTemp = strTemp & Chr(0) & "字段10=代发银行,10,2"
    strTemp = strTemp & Chr(0) & "字段11=银行代发帐号,11,2"
    strTemp = strTemp & Chr(0) & "字段12=入职日期,12,2"
    strTemp = strTemp & Chr(0) & "字段13=离职日期,13,2"
    strTemp = strTemp & Chr(0) & "字段14=职务代码,14,2"
    strTemp = strTemp & Chr(0) & "字段15=地址,15,2"
    strTemp = strTemp & Chr(0) & "字段16=邮编,16,2"
    strTemp = strTemp & Chr(0) & "字段17=电话(O),17,2"
    strTemp = strTemp & Chr(0) & "字段18=电话(H),18,2"
    strTemp = strTemp & Chr(0) & "字段19=出生日期,19,2"
    strTemp = strTemp & Chr(0) & "字段20=备注,20,2"
    strTemp = strTemp & Chr(0) & "字段21=身份证号码,21,2"
    strTemp = strTemp & Chr(0) & "导出日期=" & Format(Date, "yyyy-mm-dd")
    lngResult = WritePrivateProfileSection("职员", strTemp, StrFileName)
    strSql = "SELECT Employee.*,EmployeeType.strEmployeeTypeCode,Department.strDepartmentCode" _
        & ",Education.strEducationName,Title.strTitleName,PersonTaxType.strPersonTaxTypeName" _
        & ",Bank.strBankName FROM Employee,EmployeeType,Department,Education,Title,PersonTaxType,Bank " _
        & "WHERE Employee.lngEmployeeTypeID=EmployeeType.lngEmployeeTypeID AND" _
        & " Employee.lngDepartmentID=Department.lngDepartmentID AND" _
        & " Employee.lngEducationID=Education.lngEducationID(+) AND" _
        & " Employee.lngTitleID=Title.lngTitleID(+) AND" _
        & " Employee.lngPersonTaxTypeID=PersonTaxType.lngPersonTaxTypeID(+) AND" _
        & " Employee.lngBankID=Bank.lngBankID(+)" & strWhere
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql)
    With recTemp
        If Dir(strPath & "Employee.Dat") <> "" Then
            Kill strPath & "Employee.Dat"
        End If
        intFileNum = FreeFile
        Open strPath & "Employee.Dat" For Binary As #intFileNum
        Do While Not .EOF
            strTemp = !strEmployeeCode & Chr(9) & !strEmployeeName _
                & Chr(9) & IIf(!blnIsMale, "1", "0") & Chr(9) & !strEmployeeTypeCode _
                & Chr(9) & !strDepartmentCode & Chr(9) & !strEducationName _
                & Chr(9) & IIf(!blnIsPersonTax, "1", "0") & Chr(9) & !strPersonTaxTypeName _
                & Chr(9) & IIf(!blnIsBank, "1", "0") & Chr(9) & !strbankname _
                & Chr(9) & !strBankCode & Chr(9) & !strIndate _
                & Chr(9) & !strOutdate & Chr(9) & !strTitleName _
                & Chr(9) & !strAddress & Chr(9) & !strPostalCode _