VB6数据导出到Excel文件，一种设计界面查询条件的方法，一种简单加密方法（改写）

引用：Microsoft Excel 11.0 Object Library

'// 一种设计界面查询条件的方法
'// 查询统计界面 获取需要的SQL查询语句
Private Function GetSearchSQL() As String
    On Error GoTo ErrHandle
   
    Dim strSql               As String
    Dim strLicense           As String
    Dim strStartTime         As String
    Dim strEndTime           As String
    Dim strRoad              As String
    Dim strLicenseColor      As String
    Dim lngCarSpeed          As Long
    Dim blnOtherChecked      As Boolean
  
    strSql = "select * from VehiclePass"
    strStartTime = Format$(DTPSearchStartTime.Value, "yyyy-MM-dd HH:mm:ss")
    strEndTime = Format$(DTPSearchEndTime.Value, "yyyy-MM-dd HH:mm:ss")
  
    If (chkStartTime.Value = Checked) And (chkEndTime.Value = Checked) Then
        If strStartTime > strEndTime Then
            GetSearchSQL = "TimeError"
            Exit Function
        End If
    End If
 
    blnOtherChecked = False
 
    If chkLicense.Value = Checked Then            '// 如果选中 模糊查询牌照号
        If blnOtherChecked Then
            strSql = strSql & " and "
        Else
            strSql = strSql & " where "
        End If
        strLicense = Trim(txtSearchLicense)
        strSql = strSql & "License like " & "'%" & strLicense & "%'"
        blnOtherChecked = True
    End If
   
    If chkStartTime.Value = Checked Then         '// 如果选中 查询时间大于起点
        If blnOtherChecked Then
            strSql = strSql & " and "
        Else
            strSql = strSql & " where "
        End If
        strSql = strSql & "PassTime >=" & "#" & strStartTime & "#"
        blnOtherChecked = True
    End If
   
    If chkEndTime.Value = Checked Then           '// 如果选中 查询时间小于终点
        If blnOtherChecked Then
            strSql = strSql & " and "
        Else
            strSql = strSql & " where "
        End If
        strSql = strSql & "PassTime <=" & "#" & strEndTime & "#"
        blnOtherChecked = True
    End If
    
    If chkRoad.Value = Checked Then              '// 如果选中 道号等于选择道号 精确查询
        If blnOtherChecked Then
            strSql = strSql & " and "
        Else
            strSql = strSql & " where "
        End If
        strRoad = Trim(cboSearchRoad.Text)
        strSql = strSql & "DriveWay = " & "'" & strRoad & "'"
        blnOtherChecked = True
    End If
       
    If chkLicenseColor.Value = Checked Then      '// 如果选中 车牌颜色等于查询颜色 精确查询
        If blnOtherChecked Then
            strSql = strSql & " and "
        Else
            strSql = strSql & " where "
        End If
        strLicenseColor = Trim(cboSearchLicenseColor.ListIndex)
        strSql = strSql & "License_Color = " & "'" & strLicenseColor & "'"
        blnOtherChecked = True
    End If
   
    If chkSpeed.Value = Checked Then             '// 如果选中 查询速度等于符合要求的速度 精确查询
        If blnOtherChecked Then
            strSql = strSql & " and "
        Else
            strSql = strSql & " where "
        End If
        lngCarSpeed = CLng(txtSearchSpeed)
        If Trim(cboSearchSpeedCondition) = "大于" Then
            strSql = strSql & "Speed > " & lngCarSpeed
        ElseIf Trim(cboSearchSpeedCondition) = "等于" Then
            strSql = strSql & "Speed = " & lngCarSpeed
        Else
            strSql = strSql & "Speed < " & lngCarSpeed
        End If
        blnOtherChecked = True
    End If
    
    GetSearchSQL = strSql & " order by PassTime"
    Exit Function
ErrHandle:
    GetSearchSQL = "Error"
End Function

'放在公共模块中的函数，用于记录日志：
Public Const MAX_PATH = 260             '// WIN32_FIND_DATA中的文件名最长限制值
Public Const INVALID_HANDLE_VALUE = -1  '// FindFirstFile发生错误时的返回值

'// WIN32_FIND_DATA中使用的文件时间
Public Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

'// FindFirstFile、FindNextFile中使用的参数类型，返回文件参数
Public 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

'// CreateDirectory中使用的结构
Public Type SECURITY_ATTRIBUTES
        nLength              As Long
        lpSecurityDescriptor As Long
        bInheritHandle       As Long
End Type

'// 创建一个新目录
'// 非零表示成功，零表示失败。会设置GetLastError
Public Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" ( _
                        ByVal lpNewDirectory As String, _
                        ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES _
                        ) As Long

'// 根据文件名查找文件
'// 执行成功，返回一个搜索句柄。如果出错，返回一个INVALID_HANDLE_VALUE常数，一旦不再需要，应该用FindClose函数关闭这个句柄
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
                        ByVal lpFileName As String, _
                        ByRef lpFindFileData As WIN32_FIND_DATA _
                        ) As Long
                       
'// 关闭由FindFirstFile函数创建的一个搜索句柄
'// 非零表示成功，零表示失败。会设置GetLastError
Public Declare Function FindClose Lib "kernel32" ( _
                        ByVal hFindFile As Long _
                        ) As Long
                       
'// 删除指定文件
'// 非零表示成功，零表示失败。会设置GetLastError
Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" ( _
                        ByVal lpFileName As String _
                        ) As Long
                       
****************************************************************
' 作用：记录系统运行时可捕获错误 系统事件 跟踪关键的操作
'
' 假设：文件系统可操作
'
' 关联：在错误捕获发生错误底时候主界面显示信息
'
' 参数: szPosition     事件或错误发生在程序中的位置
'       szDescription  对事件或错误的描述
'       nEventSign     事件及错误的标记序号(图标序号)
'       blnSeparate   是否写入新的分割标记
'
' 返回值：无
'
' 版本号：CE1.3
'
' 更新日期：2004-08-31
'****************************************************************
Public Sub WriteToLog(ByVal szPosition As String, _
                      ByVal szDescription As String, _
                      ByVal nEventSign As Long, _
                      Optional ByVal blnSeparate As Boolean = False)

    On Error GoTo ErrHandle
   
    Dim szLogFileName        As String
    Dim iFileNumber          As Integer
    Dim szCurrentTime        As String
    Dim lpWin32FileData      As WIN32_FIND_DATA
    Dim nFindFileHandle      As Long
   
    szCurrentTime = Format$(Date$, "yyyy-MM-dd") & Space(1) & Format$(Time$, "HH:mm:ss")
   
    szLogFileName = App.Path & "/vics_Export.log"
    iFileNumber = FreeFile
   
    nFindFileHandle = FindFirstFile(szLogFileName, lpWin32FileData)
    Call FindClose(nFindFileHandle)
   
    If INVALID_HANDLE_VALUE = nFindFileHandle Then  '// 如果系统日志文件不存在则创建
        Open szLogFileName For Output As #iFileNumber
            If blnSeparate Then
                Print #iFileNumber, ""
            End If
            Print #iFileNumber, szCurrentTime & "|" & szPosition & "|" & szDescription & "|" & nEventSign
        Close #iFileNumber
    Else                                            '// 如果系统日志文件存在则追加
        If lpWin32FileData.nFileSizeLow > 51120 Then
            DoEvents
            DeleteFile szLogFileName
            DoEvents
            Open szLogFileName For Output As #iFileNumber
                If blnSeparate Then
                    Print #iFileNumber, ""
                End If
                Print #iFileNumber, szCurrentTime & "|" & szPosition & "|" & szDescription & "|" & nEventSign
            Close #iFileNumber
        Else
            Open szLogFileName For Append As #iFileNumber
                If blnSeparate Then
                    Print #iFileNumber, ""
                End If
                Print #iFileNumber, szCurrentTime & "|" & szPosition & "|" & szDescription & "|" & nEventSign
            Close #iFileNumber
        End If
    End If
   
    Exit Sub
ErrHandle:
    Close #iFileNumber
End Sub

Attribute VB_Name = "mdlExcelReport"
'//*******************************************************************************
'//    工程名称：
'//    模块名称：mdlExcelReport.bas
'//    模块功能：导出到Excel表格的实现
'//    原始版本：否
'//    引用文件：
'//
'//    版本        作者            日期            描述
'//    1.00                        2005.04.15     创建
'//
'//*******************************************************************************
Option Explicit

Private mnHeaderLine          As Long    '//标题头行数
Private mstrHeaderInfo(20)    As String  '//标题头信息
Private mnStartRow            As Long    '//表格的其实坐标 行
Private mnStartColumn         As Long    '//表格的其实坐标 列
Private mnColumnNumber        As Long    '//表格列数
Private mstrColumnHeader(20)  As String  '//表格信息
Private mnColumnHeaderLen(20) As Long    '//表格每列的宽度
Private mnRecordNumber        As Long    '//共有记录的条数

'/*================================================================
' *
' * 函 数 名：GetInfoFromLine
' *
' * 参    数：ByVal szLineInfo As String   一整行信息
' *
' * 功能描述: 从一整行信息中提取出预定义位置的参数信息
' *
' * 返 回 值：成功返回 提取出来的参数（字符串形式）；失败返回 空字符串
' *
' * 异常处理：异常跳出函数处理，返回特殊值空字符串
' *
' * 作    者：Shi.Mingjie 2003/07/14
' *
' ================================================================*/
Private Function GetParameterInfoInOneLine(ByVal strOneLineInfo As String) As String
    Dim strTmp    As String
    Dim strResult As String
    Dim lngStrLen As Long, I As Long
   
    strOneLineInfo = Trim(strOneLineInfo)
    lngStrLen = Len(strOneLineInfo)
    If lngStrLen <= 0 Then
        GetParameterInfoInOneLine = ""
        Exit Function
    End If
   
    strTmp = "="
    I = InStr(1, strOneLineInfo, strTmp, vbTextCompare)
   
    If (I > 0) Then
        strResult = Right$(strOneLineInfo, lngStrLen - I)
    Else
        GetParameterInfoInOneLine = ""
        Exit Function
    End If
   
    GetParameterInfoInOneLine = strResult
End Function

Public Function Encrypt(ByVal vpassw As String) As String
    Dim x As Long, I As Long
    Dim tmpvpassw As String, ascvpassw As String
    x = 10
    For I = 1 To Len(vpassw)
        tmpvpassw = Mid(vpassw, I, 1)
        ascvpassw = Asc(tmpvpassw)
        tmpvpassw = ascvpassw Xor x
        Encrypt = Encrypt & Chr(tmpvpassw)
    Next
End Function

Private Function LoadPrintSettingFromFile() As Boolean
    On Error GoTo ErrHandle
   
    Dim szConfigFile     As String
    Dim iFileNumber      As Integer
    Dim iCycleTimes      As Integer
    Dim szReadInfo(20)   As String
    Dim i                As Long
   
    szConfigFile = App.Path & "/vicsExport.ini"
    iFileNumber = FreeFile
    If Dir(szConfigFile) <> "" Then
        Open szConfigFile For Input Lock Write As #iFileNumber
            iCycleTimes = 0
            Do Until EOF(iFileNumber)
                Line Input #iFileNumber, szReadInfo(iCycleTimes)
                If iCycleTimes < 19 Then
                    iCycleTimes = iCycleTimes + 1
                Else
                    Exit Do
                End If
            Loop
        Close #iFileNumber
        If iCycleTimes >= mnHeaderLine + 1 Then
            For i = 1 To mnHeaderLine
                mstrHeaderInfo(i) = Trim(GetInfoFromLine(szReadInfo(i)))
            Next i
        ElseIf iCycleTimes >= 2 Then
            For i = 1 To (iCycleTimes - 1)
                mstrHeaderInfo(i) = Trim(GetInfoFromLine(szReadInfo(i)))
            Next i
        End If
    Else
        LoadPrintSettingFromFile = False
        Call WriteToLog("Main->LoadPrintSettingFromFile", "配置文件不存在!", 4)
    End If
   
    LoadPrintSettingFromFile = True
    Exit Function
ErrHandle:
    LoadPrintSettingFromFile = False
    Close #iFileNumber
    Call WriteToLog("Main->LoadPrintSettingFromFile", " 异常: " & Err.Number & " " & Err.Description, 4)
End Function

Public Function SetExcelSource(ByVal nVehiclePassNumber As Long) As Long
    On Error GoTo ErrHandle
   
    Dim strStartTime As String
    Dim strStopTime  As String
   
    grsVehiclePass.MoveFirst
    strStartTime = Format$(grsVehiclePass("PassTime"), "yyyy-MM-dd HH:mm:ss")  '// 起始统计时间
    grsVehiclePass.MoveLast
    strStopTime = Format$(grsVehiclePass("PassTime"), "yyyy-MM-dd HH:mm:ss")   '// 终止统计时间
   
    mnHeaderLine = 5
    mstrHeaderInfo(1) = "主题"
    mstrHeaderInfo(2) = "地点"
    mstrHeaderInfo(3) = "时间：" & strStartTime & " 至 " & strStopTime
    mstrHeaderInfo(4) = "其它信息"
    mstrHeaderInfo(5) = ""
   
    mnStartRow = 6
    mnStartColumn = 1
   
    mnColumnNumber = 7
    mstrColumnHeader(1) = "序号"
    mstrColumnHeader(2) = "通行时间"
    mstrColumnHeader(3) = "车道"
    mstrColumnHeader(4) = "号码"
    mstrColumnHeader(5) = "颜色"
    mstrColumnHeader(6) = "特写图片"
    mstrColumnHeader(7) = "全景图片"
'''    mstrColumnHeader(8) = "标志"
'''    mstrColumnHeader(9) = "近景图片地址"
'''    mstrColumnHeader(10) = "远景图片地址"

    '// 一次导出的数据不允许超过20000条
    If (nVehiclePassNumber > 0) And (nVehiclePassNumber < 20001) Then
        mnRecordNumber = nVehiclePassNumber
    Else
        mnRecordNumber = 0
    End If
   
    SetExcelSource = 1
    Exit Function
ErrHandle:
    SetExcelSource = 0
End Function

Public Sub DataFormatToExcel(ByVal strExcelFileName As String, _
                             ByVal blnPrintPreview As Boolean)
    On Error GoTo ErrHandle
   
    Dim xlsApp        As Excel.Application
    Dim xlsBook       As Excel.Workbook
    Dim xlsSheet      As Excel.Worksheet
   
    Dim i             As Long
    Dim j             As Long
    Dim strFileName   As String
    Dim strCellUnit   As String
    Dim strTmp        As String
   
    Set xlsApp = CreateObject("Excel.Application")                    '// 创建Excel对象

    Set xlsBook = xlsApp.Workbooks.Add(App.Path & "/filetemplet.xls") '// 打开Excel工作薄模板文件

    xlsApp.Visible = False                                            '// 设置Excel对象可见（或不可见）

    Set xlsSheet = xlsBook.Worksheets(1)
   
    For i = 1 To mnHeaderLine
        xlsSheet.Cells(i, 1) = mstrHeaderInfo(i)
    Next i
   
    For i = 1 To mnColumnNumber
        xlsSheet.Cells(mnStartRow, i) = mstrColumnHeader(i)
    Next i
   
    grsVehiclePass.MoveFirst '// 开始时记录集位置移至最前面
    
    For i = (mnStartRow + 1) To (mnStartRow + mnRecordNumber)
        Select Case grsVehiclePass("License_Color")
        Case "0"
            strTmp = "白 "
        Case "1"
            strTmp = "黄 "
        Case "2"
            strTmp = "蓝 "
        Case "3"
            strTmp = "黑 "
        Case Else
            strTmp = "无"
        End Select
       
        xlsSheet.Cells(i, 1) = (i - mnStartRow)             '// 第1列
        xlsSheet.Cells(i, 2) = Format$(grsVehiclePass("PassTime"), "yyyy-MM-dd HH:mm:ss")  '// 第2列
        xlsSheet.Cells(i, 3) = grsVehiclePass("DriveWay")   '// 第3列
        xlsSheet.Cells(i, 4) = grsVehiclePass("License")    '// 第4列
        xlsSheet.Cells(i, 5) = strTmp                       '// 第5列
       
        strCellUnit = "F" & i                               '// 第6列
        With xlsSheet
            .Hyperlinks.Add Anchor:=.Range(strCellUnit), _
                Address:=Trim(grsVehiclePass("Image_Special")), _
                ScreenTip:="本机路径：" & Trim(grsVehiclePass("Image_Special")), _
                TextToDisplay:="近景图片"
        End With
       
        strCellUnit = "G" & i                               '// 第7列
        With xlsSheet
            .Hyperlinks.Add Anchor:=.Range(strCellUnit), _
                Address:=Trim(grsVehiclePass("Image_All")), _
                ScreenTip:="本机路径：" & Trim(grsVehiclePass("Image_All")), _
                TextToDisplay:="远景图片"
        End With
         
        frmManage.pgbExport.Value = i - mnStartRow
       
        grsVehiclePass.MoveNext
    Next i
   
    grsVehiclePass.MoveFirst '// 结束时记录集位置移至最前面,恢复初始设置
   
    xlsBook.SaveAs strExcelFileName
  
    If blnPrintPreview Then
        xlsApp.Visible = True
        xlsBook.PrintPreview
    End If

    Set xlsSheet = Nothing
   
    xlsBook.Close False
    Set xlsBook = Nothing
   
    xlsApp.Quit              '// 结束Excel对象
    Set xlsApp = Nothing     '// 释放xlApp对象
   
    If blnPrintPreview Then
        If MsgBox("是否保存预览报表？", vbYesNo + vbQuestion + vbDefaultButton2, "保存选项") <> vbYes Then
            Kill (strExcelFileName)
        Else
            Call MsgBox("报表已经被保存。 存放在：" & strExcelFileName, vbInformation, "保存提示")
        End If
    Else
        Call MsgBox("报表已经被保存。 存放在：" & strExcelFileName, vbInformation, "保存提示")
    End If
   
    Exit Sub
ErrHandle:
    Call MsgBox("信息导入Excel发生意外错误！" & vbCrLf & _
                "ErrNumber：" & Err.Number & vbCrLf & _
                "Description：" & Err.Description, vbCritical, "警告！")
End Sub

'''Public Function DeleteExcelSource() As Long
'''    On Error GoTo ErrHandle
'''
'''    If mrsRecordset.State <> 0 Then
'''        mrsRecordset.Close
'''    End If
'''    Set mrsRecordset = Nothing
'''
'''    DeleteExcelSource = 1
'''    Exit Function
'''ErrHandle:
'''    DeleteExcelSource = 0
'''End Function