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