frmtl_backups.frm

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

        If lstTable.Selected(i) = True Then
             aryTable() = Split(m_aryItem(i), "|")
             aryName() = Split(m_aryName(i), "|")
            For j = 0 To UBound(aryTable())
                sTable = aryTable()(j)
                sName = aryName()(j)
                If IsNumeric(Right(aryTable()(j), 4)) Then
                    If lstTable.List(i) Like "*凭证*" Then
                        iFlag = 2   '有年份的凭证项目
                    Else
                        iFlag = 1   '有年份的项目
                    End If
                Else
                        iFlag = 3       '无年份的辅助项目
                End If
                
                If iFlag = 2 Then
                    For k = 1 To lstMonth.ListItems.Count
                        sStr = "Select * from " & sTable
                        If lstMonth.ListItems(k).Checked Then
                            sMonth = lstMonth.ListItems(k).text
                            iCount = iCount + 1
                            sWhere = " where kjqj=" & k
                            sStr = sStr & sWhere
                            If ExistRecord(sTable, sStr, glo.cnnMain, bErr) Then
                                If HeadExport(sStr, sFilePath & "\" & glo.sOperateYear & "年_" & k & "月份凭证.txt", _
                                    iFlag, sTable, glo.cnnMain, lstMonth.ListItems(k).text) Then
                                    Call DataExport(sTable & "_" & k, glo.cnnMain, sFilePath & "\" & glo.sOperateYear & "年_" & k & "月份凭证.txt", sStr, sMonth)
                                End If
                            ElseIf Not bErr Then
                                Call ReadErr(sTable, sMonth)
                            End If
                        End If
                    Next k
                    
                    If iCount = 0 Then
                        If ExistRecord(sTable, sStr, glo.cnnMain, bErr) Then
                            If HeadExport(sStr, sFilePath & "\" & glo.sOperateYear & "年全年凭证.txt", iFlag, sTable, glo.cnnMain, glo.sOperateYear & "全年凭证") Then
                                Call DataExport(sTable, glo.cnnMain, sFilePath & "\" & glo.sOperateYear & "年全年凭证.txt", sStr, "全部凭证")
                            End If
                        ElseIf Not bErr Then
                            Call ReadErr(sTable, "全年凭证")
                        End If
                    End If
              Else
                    sStr = "Select * from " & aryTable()(j)
                    If HeadExport(sStr, sFilePath & "\" & sName & ".txt", iFlag, sTable, glo.cnnMain) Then
                        If ExistRecord(sTable, sStr, glo.cnnMain, bErr) Then
                             Call DataExport(sTable, glo.cnnMain, sFilePath & "\" & sName & ".txt", sStr)
                        ElseIf Not bErr Then
                             Call ReadErr(sTable)
                        End If
                    End If
              End If
               
            Next j
        End If
    Next i
lblMsg.Caption = "提示:数据备份结束。"
cmdPrevious2.Enabled = True
cmdCancel2.Enabled = True
End If

End Sub
Private Sub ReadErr(ByVal sTable As String, Optional ByVal sMonth As String)
    lstResult.ListItems.Add , , sTable & "表中" & sMonth & "没有相应的记录数据！"
    lstResult.Refresh
End Sub
'数据头导出，参数sFilePath为文件绝对路径
Private Function HeadExport(ByVal sSQL As String, ByVal sFilePath As String, ByVal iFlag As Integer, _
    ByVal sTable As String, ByVal Conn As ADODB.Connection, Optional ByVal sMonth As String) As Boolean
     Dim iFileNum As Integer
     Dim rSt As ADODB.Recordset
     Dim sFieldsName As String
     Dim iCount As Integer, j As Integer
     HeadExport = False
     Set rSt = New ADODB.Recordset
        rSt.CursorLocation = adUseClient
        On Error GoTo HandleErr
        rSt.Open sSQL, Conn, adOpenStatic, adLockReadOnly
        sFieldsName = ""
        iCount = rSt.Fields.Count - 1
    
        For j = 0 To iCount
            sFieldsName = sFieldsName & rSt.Fields(j).Name & vbTab
        Next j
        
        sFieldsName = Trim$(sFieldsName)
        rSt.Close
    '打开文件
     iFileNum = FreeFile()
     Open sFilePath For Output As #iFileNum

     '写入注释行
     Print #iFileNum, "[Memo]        备份人：  " & vbTab & glo.sUserName & vbTab & "备份时间：" & vbTab & _
         Format(Date, "yyyy年mm月dd日") & Space(2) & Format(Time, "hh时mm分ss秒")
     If (iFlag = 1) Or (iFlag = 2) Then
        Print #iFileNum, "[Year]        备份年份：" & vbTab & glo.sOperateYear
     End If
     If iFlag = 2 Then
         Print #iFileNum, "[Month]       备份月份：" & vbTab & sMonth
     End If
     Print #iFileNum, "[Table]       备份表名：" & vbTab & sTable
     Print #iFileNum, "TF: " & sTable & "(" & sFieldsName & ")"
     Close #iFileNum
     HeadExport = True
     Exit Function
HandleErr:
        HeadExport = False
        lstResult.ListItems.Add , , sTable & "表备份失败！"
        lstResult.Refresh
        Close #iFileNum
        Exit Function
End Function
 '数据备份
 '参数sSql为备份的条件语句， Conn为连接字符串，sFile为传入的文件绝对路径
 Private Sub DataExport(ByVal sTable As String, ByVal Conn As Connection, _
    ByVal sFilePath As String, ByVal sSQL As String, Optional ByVal sMonth As String)
        Dim i, j As Integer
        Dim strResult As String
        Dim rSt As ADODB.Recordset
        Dim iFileNum As Integer
        
        Set rSt = New ADODB.Recordset
        On Error GoTo HandleErr
        
       '打开文件
        iFileNum = FreeFile()
        Open sFilePath For Append As #iFileNum
        With rSt
            .CursorLocation = adUseClient
            .Open sSQL, Conn, adOpenStatic, adLockReadOnly
            strResult = ""
            i = 0
            While Not .EOF
                For j = 0 To .Fields.Count - 1
                    If IsNull(.Fields(j).Value) Then
                        strResult = strResult & "NULL" & vbTab
                    Else
                        Select Case .Fields(j).Type
                            Case adCurrency, adDouble, adBigInt, adDecimal, adInteger, _
                                adNumeric, adSingle, adSmallInt, adTinyInt, adUnsignedBigInt, _
                                adUnsignedInt, adUnsignedSmallInt, adUnsignedTinyInt, adVarNumeric
                                strResult = strResult & Trim(CStr(.Fields(j).Value)) & vbTab
                            Case adDate, adDBDate, adDBFileTime, adDBTime, adDBTimeStamp
                                strResult = strResult & "to_date('" & _
                                Format(.Fields(j).Value, "yyyy-mm-dd") & "','yyyy-mm-dd')" & vbTab
                            Case Else
                                strResult = strResult & "'" & Trim(CStr(.Fields(j).Value)) & "'" & vbTab
                        End Select
                    End If
                Next j
                
            '将数据写入文本文件中
                Print #iFileNum, Space(22) & strResult
                strResult = ""
                i = i + 1
                .MoveNext
            Wend
            .Close
       End With
       If sMonth <> "" Then
            lstResult.ListItems.Add , , Mid(sTable, 1, Len(sTable) - 2) & "表" & sMonth & "备份成功！"
       Else
            lstResult.ListItems.Add , , sTable & "表备份成功！"
       End If
        lstResult.Refresh
        '关闭文件
        Close #iFileNum
        Exit Sub
HandleErr:
    If sMonth <> "" Then
        lstResult.ListItems.Add , , Mid(sTable, 1, Len(sTable) - 2) & "表备份失败！"
    Else
        lstResult.ListItems.Add , , sTable & "表备份失败！"
    End If
    lstResult.Refresh
    Close #iFileNum
    Exit Sub
End Sub




Private Sub cmdOK_KeyUp(KeyCode As Integer, Shift As Integer)
cmdOk.Enabled = False
End Sub


Private Sub cmdPrevious2_Click()
lstResult.ListItems.Clear
lstResult.Refresh
lblMsg.Caption = "提示:正在备份数据，请等候......"
lblMsg.Visible = False
cmdOk.Enabled = True
sTb.Tab = 0
End Sub

Private Sub form_load()
Dim ItmX As ListItem
Dim i As Integer
    lstResult.View = lvwList
    lstResult.ListItems.Clear
    lstResult.Refresh
    Call FillTable
    With lstMonth
        .View = lvwList
        Set ItmX = .ListItems.Add(, , "1月份凭证")
        Set ItmX = .ListItems.Add(, , "2月份凭证")
        Set ItmX = .ListItems.Add(, , "3月份凭证")
        Set ItmX = .ListItems.Add(, , "4月份凭证")
        Set ItmX = .ListItems.Add(, , "5月份凭证")
        Set ItmX = .ListItems.Add(, , "6月份凭证")
        Set ItmX = .ListItems.Add(, , "7月份凭证")
        Set ItmX = .ListItems.Add(, , "8月份凭证")
        Set ItmX = .ListItems.Add(, , "9月份凭证")
        Set ItmX = .ListItems.Add(, , "10月份凭证")
        Set ItmX = .ListItems.Add(, , "11月份凭证")
        Set ItmX = .ListItems.Add(, , "12月份凭证")
    End With
    lblMsg.Caption = "提示:正在备份数据，请等候......"
    lblMsg.Visible = False

    lblMonth.Caption = "选择" & glo.sOperateYear & "年凭证月份"
    
    With lblMemo
        .AutoSize = True
        .WordWrap = True
        .Caption = " 注意：1.当选择备份凭证数据时，最" & vbCrLf & _
            "          好按月份备份,以免数据过" & vbCrLf & _
            "          大，速度很慢" & vbCrLf & vbCrLf & _
            "        2.当选择银行对账单的同时也" & _
            vbCrLf & "          备份银行对账启用日期表" & vbCrLf & vbCrLf & _
            "        3.当选择客户档案表的同时也" & vbCrLf & _
            "          备份客户档案分类表" & _
            vbCrLf & vbCrLf & "        4.当选择供应商档案的同时也" & vbCrLf & _
            "          备份供应商分类表，供应商" & vbCrLf & "          显示设置表"
    End With
    sTb.Tab = 0
    lstMonth.Enabled = False
    cmdAll.Enabled = False
End Sub
Private Sub FillTable()
    With lstTable
        .Clear
        .AddItem glo.sOperateYear & "年会计科目表"
        m_aryItem(.NewIndex) = "tZW_Km" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "年会计科目表"
        
        .AddItem glo.sOperateYear & "年累计数据表"
        m_aryItem(.NewIndex) = "tZW_Balance" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "年累计数据表"
        
        .AddItem glo.sOperateYear & "年凭证数据表"
        m_aryItem(.NewIndex) = "tZW_Pzsj" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "年凭证数据表"
        
        .AddItem glo.sOperateYear & "年辅助核算表"
        m_aryItem(.NewIndex) = "tUSU_Fz" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "年辅助核算表"
         
       
        .AddItem glo.sOperateYear & "年支票登记表"
        m_aryItem(.NewIndex) = "tZW_Check" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "年支票登记表"
        
        .AddItem glo.sOperateYear & "年银行对账单"
        m_aryItem(.NewIndex) = "tZW_Yhdzd" & glo.sOperateYear & "|tZW_Yhdzqyrq"
        m_aryName(.NewIndex) = glo.sOperateYear & "年银行对账单|银行对账启用日期"
        
        .AddItem glo.sOperateYear & "客户档案表"
        m_aryItem(.NewIndex) = "tZW_Customer" & glo.sOperateYear & "|tZW_CustomerClass" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "客户档案表|" & glo.sOperateYear & "客户分类表"
         
        .AddItem glo.sOperateYear & "项目档案表"
        m_aryItem(.NewIndex) = "tZW_Item" & glo.sOperateYear & "|tZW_ItemClass" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "项目档案表|" & glo.sOperateYear & "项目分类表"
        
        .AddItem glo.sOperateYear & "供应商档案"
        m_aryItem(.NewIndex) = "tZW_Vendor" & glo.sOperateYear & "|tZW_VendorClass" & glo.sOperateYear & "|tZW_VendorShowSet" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "供应商档案|" & glo.sOperateYear & "供应商分类|" & glo.sOperateYear & "供应商设置"
        
        .AddItem glo.sOperateYear & "部门维护表"
        m_aryItem(.NewIndex) = "tUSU_Department" & glo.sOperateYear
        m_aryName(.NewIndex) = glo.sOperateYear & "部门维护表"
        
        .AddItem "摘要维护表"
        m_aryItem(.NewIndex) = "tZW_Zywh"
        m_aryName(.NewIndex) = "摘要维护表"
    End With
End Sub


Private Sub lstMonth_ItemCheck(ByVal Item As MSComctlLib.ListItem)
Dim sMonth As String
Dim lMonth As Long
Dim bError As Boolean
Dim bExist As Boolean

sMonth = Mid(Item, 1, 2)
lMonth = 0
If IsNumeric(sMonth) Then
    lMonth = CLng(sMonth)
Else
    lMonth = CLng(Mid(sMonth, 1, 1))
End If
bExist = PzsjExistRecord(lMonth, glo.cnnMain, bError)
If Not bExist Then
    Item.Checked = False
    If Not bError Then
        MsgBox "该月份没有凭证数据！", vbInformation, "提示"
    End If
    Exit Sub
End If
End Sub

Private Sub lstTable_Click()
Dim i As Integer
    
    If lstTable.Selected(2) = True Then
        lstMonth.Enabled = True
        cmdAll.Enabled = True
    Else
        lstMonth.Enabled = False
        For i = 1 To lstMonth.ListItems.Count
            lstMonth.ListItems(i).Checked = False
            cmdAll.Enabled = False
        Next i
    End If
End Sub
'判断条件记录是否存在，若存在则函数本身返回True
Private Function ExistRecord(ByVal sTable As String, _
    ByVal sSQL As String, ByVal sConn As ADODB.Connection, _
    ByRef bErr As Boolean) As Boolean
Dim rSt As ADODB.Recordset

On Error GoTo HandleErr
Set rSt = New ADODB.Recordset
bErr = False
With rSt
    .CursorLocation = adUseClient
    .Open sSQL, sConn, adOpenStatic, adLockReadOnly
    If Not .EOF And Not .BOF Then
        ExistRecord = True
    Else
        ExistRecord = False
    End If
    .Close
End With
Exit Function
HandleErr:
    bErr = True
    lstResult.ListItems.Add , , sTable & "表备份失败！"
    lstResult.Refresh
    Exit Function
End Function

'判断条件记录是否存在，若存在则函数本身返回True
Private Function PzsjExistRecord(ByVal lMonth As Long, ByVal sConn As ADODB.Connection, ByRef bErr As Boolean) As Boolean
Dim rSt As New ADODB.Recordset
Dim iCount As Integer
On Error GoTo HandleErr
bErr = False
With rSt
    .CursorLocation = adUseClient
    .Open "Select count(*) iCount from tZW_Pzsj" & glo.sOperateYear & " where kjqj=" & lMonth, sConn, adOpenStatic, adLockReadOnly
    If .Fields("iCount").Value > 0 Then
        PzsjExistRecord = True
    Else
        PzsjExistRecord = False
    End If
    .Close
End With
Exit Function
HandleErr:
    bErr = True
    MsgBox Err.Number & vbTab & Err.Description & vbTab & Err.Source, vbInformation, "提示"
    Exit Function
End Function