在VB中如何将Access表中的内容保存到Excel保存界面
最新回答
灿烂星空
2024-04-27 08:25:31
Option Explicit
Private AccessFile As String
Private ExcelFile As String
Private ExcelApp As Excel.Application
Private Sub Command2_Click()
Dim aaa As Integer
Dim Conn As ADODB.Connection
Dim XlsSheet As Excel.Worksheet
Dim i As Long, j As Long, k As Long, TableCount As Long, RecordCount As Long
Dim l As Integer
Dim Sql As String, InsertSql As String, ValStr As String
Dim MaxWidth As Long, FieldLine As Long
Dim Rs As ADODB.Recordset, RsData As ADODB.Recordset
Dim Rg As Range
'使用commondialog控件得到两个文件名
CommonDialog1.Filter = "Access File(*.mdb)|*.mdb"
CommonDialog1.DialogTitle = "Open Access File"
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
AccessFile = CommonDialog1.FileName
CommonDialog1.Filter = "Excel File(*.xls)|*.xls"
CommonDialog1.DialogTitle = "Export to Excel File"
CommonDialog1.FileName = ""
CommonDialog1.ShowSave
If CommonDialog1.FileName = "" Then Exit Sub
ExcelFile = CommonDialog1.FileName
'执行期间，按钮不可用
Command1.Enabled = False
Command2.Enabled = False
'可能出现打开有异常的情况，所以这里要用 on error 处理一下
On Error GoTo ErrOpenXls
If Dir(ExcelFile) = "" Then '文件不存在
ExcelApp.Workbooks.Add ' 新建文件
ExcelApp.ActiveWorkbook.SaveAs ExcelFile '保存文件
Else
ExcelApp.Workbooks.Open ExcelFile '文件存在，直接打开
End If
'设置excelapp为不可见，这个对象其实就是excel窗口，它在操作过程中一直处于隐藏状态
On Error GoTo 0
'建立数据库链接
On Error GoTo ErrOpenMdb
Set Conn = CreateObject("ADODB.Connection")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & AccessFile
On Error GoTo 0
'adSchemaTables 是一张系统表，包含了MDB中所有的系统对象，当然也就包含了MDB中所有表的名称
Set Rs = Conn.OpenSchema(adSchemaTables)
Set RsData = CreateObject("ADODB.Recordset")
While Not Rs.EOF
'系统表中包含很多对象（表/窗体/查询等）
'这里我们只查找类型为“表格”（TABLE）的对象
If Rs("TABLE_TYPE").Value = "TABLE" Then
'一个正常的MDB中除了包含用户表以外，系统表也是TABLE类型
'系统表的表名的第一个字符是"~"，这不是我们需要的，所以要过滤
If Left(Rs("TABLE_NAME").Value, 1) <> "~" Then
TableCount = TableCount + 1
'统计一下有多少张用户表
End If
End If
Rs.MoveNext
Wend
Rs.MoveFirst
k = 0 '变量K用于显示进度，表示当前操作了多少张数据库里的表
While Not Rs.EOF
'找到类型为表格的系统对象
If Rs("TABLE_TYPE").Value = "TABLE" Then
'找到用户表
If Left(Rs("TABLE_NAME").Value, 1) <> "~" Then
l = 0 '此变量用于记录用户操作（YES/NO的选择）
k = k + 1
'显示进度
Label1.Caption = "Exporting(TableName:" & Rs("TABLE_NAME").Value & ") ... (" & k & "/" & TableCount & ")"
For i = 1 To ExcelApp.ActiveWorkbook.Worksheets.Count
'获得第i个表的对象
Set XlsSheet = ExcelApp.ActiveWorkbook.Sheets(i)
'查找当前的MDB里的当前操作到的表格的名字是否于XLS文件里的表名有重复
If Rs("TABLE_NAME").Value = XlsSheet.Name Then
'表名是重复的，提示是否覆盖
l = MsgBox("Same table name exist, overwrite it?", vbQuestion + vbYesNo + vbDefaultButton2, "Overrite")
If l = vbYes Then
XlsSheet.Range("1:65536").Delete
'用户确认覆盖，删除表格所有内容
End If
Exit For
End If
Next i
If l = 0 Then 'l=0说明是没有找到重复的表名
'新建一个sheet
Set XlsSheet = ExcelApp.ActiveWorkbook.Worksheets.Add
'名字与数据库里当前操作的表是一样的
XlsSheet.Name = Rs("TABLE_NAME")
End If
'此条SQL查询语句是获得当前表有多少条记录的查询
RsData.Open "Select count(*) from " & Rs("TABLE_NAME").Value, Conn, adOpenKeyset, adLockOptimistic '这里是什么？，adOpenKeyset是什么？adLockOptimistic是什么？麻烦把这种格式给我说一下
RecordCount = RsData(0) ' 记下记录总数
RsData.Close '操作完成，关闭对象
'如果表名有重复并且用户确认覆盖，或者没有重复，则进入下面的分支
If l = vbYes Or l = 0 Then
'读取所有记录
RsData.Open "Select * from " & Rs("TABLE_NAME").Value, Conn, adOpenKeyset, adLockOptimistic
'先获得记录的字段名
For i = 1 To RsData.Fields.Count
'把字段名保存在XLS表格的第一行
XlsSheet.Cells(1, i) = RsData.Fields(i - 1).Name
Set Rg = XlsSheet.Cells(1, i)
'给单元格加上边框
Rg.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic, vbBlack
Next i
i = 2 '实际MDB的数据保存与XLS表的第二行
While Not RsData.EOF
'复制所有记录到XLS
For j = 1 To Rs.Fields.Count
'令指定单元格等于指定数据库记录的值
XlsSheet.Cells(i, j) = RsData(j - 1).Value
Set Rg = XlsSheet.Cells(i, j)
'给XLS单元格加边框
Rg.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic, vbBlack '这里是什么？
Next j
'显示进度
Label1.Caption = "Exporting(TableName:" & Rs("TABLE_NAME").Value & ") ... (" & k & "/" & TableCount & ")"
Label1.Caption = Label1.Caption & vbCrLf & "Progress:" & Format((i - 1) / RecordCount, "0.00%")
i = i + 1 'i用于记录XLS的行号
If i Mod 5 = 0 Then '为了防止操作挂死，每隔5条记录就释放一下
DoEvents
End If
RsData.MoveNext '移动下一条MDB记录
Wend
RsData.Close '当前MDB表格操作完成
End If
End If
End If
Rs.MoveNext '这个RS是记录MDB的表名的，当前表操作完成，移动到下一条记录，操作下一个表
Wend
'全部完成，关闭所有对象
Rs.Close
Conn.Close
ExcelApp.ActiveWorkbook.Save
ExcelApp.ActiveWorkbook.Close
Set RsData = Nothing
Set Rs = Nothing
Set Conn = Nothing
'恢复按钮状态
Command1.Enabled = True
Command2.Enabled = True
Exit Sub
ErrOpenXls:
MsgBox "Open Excel File Failed", vbCritical, "Error"
Command1.Enabled = True
Command2.Enabled = True
Exit Sub
ErrOpenMdb:
MsgBox "Access File Connect Failed", vbCritical, "Error"
ExcelApp.ActiveWindow.Close
Command1.Enabled = True
Command2.Enabled = True
Exit Sub
End Sub
Private Sub Command1_Click()
Dim Conn As ADODB.Connection
Dim XlsSheet As Excel.Worksheet
Dim i As Long, j As Long, k As Long
Dim l As Integer
Dim Sql As String, InsertSql As String, ValStr As String
Dim MaxWidth As Long, FieldLine As Long
Dim Rs As ADODB.Recordset
'使用commondialog控件得到两个文件名
CommonDialog1.Filter = "Excel File(*.xls)|*.xls"
CommonDialog1.DialogTitle = "Open Excel File"
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
ExcelFile = CommonDialog1.FileName
CommonDialog1.Filter = "Access File(*.mdb)|*.mdb"
CommonDialog1.DialogTitle = "Export to Access File"
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
AccessFile = CommonDialog1.FileName
'操作期间，按钮不可用
Command1.Enabled = False
Command2.Enabled = False
'打开EXCEL文件，此处做处理，防止发生打开异常
On Error GoTo ErrOpenXls
ExcelApp.Workbooks.Open ExcelFile
On Error GoTo 0
'打开MDB文件，同上处理
On Error GoTo ErrOpenMdb
Set Conn = CreateObject("ADODB.Connection")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & AccessFile
On Error GoTo 0
'此条查询可以获得MDB里的所有对象名称（包括表格名/查询名/窗体名等）
Set Rs = Conn.OpenSchema(adSchemaTables)
'循环操作所有EXCEL表
For i = 1 To ExcelApp.ActiveWorkbook.Worksheets.Count
'取得当前要操作的sheet
Set XlsSheet = ExcelApp.ActiveWorkbook.Sheets(i)
'更新显示状态
Label1.Caption = "Exporting(SheetName:" & XlsSheet.Name & ") ... (" & i & "/" & ExcelApp.ActiveWorkbook.Worksheets.Count & ")"
Rs.MoveFirst '每次操作它，先要移动到第一个记录上
l = vbYes '同上一个sub，用于记录用户操作
Do While Not Rs.EOF
'检查系统表里的这个对象类型是否是表格
If Rs("TABLE_TYPE").Value = "TABLE" Then
'检查该表格名字是否与当前sheet重名
If Rs("TABLE_NAME").Value = XlsSheet.Name Then
'重名则提示是否覆盖
l = MsgBox("Same table name exist, overwrite it?", vbQuestion + vbYesNo + vbDefaultButton2, "Overrite")
If l = vbYes Then
'确认覆盖，直接删除该MDB表格
Conn.Execute "drop table " & XlsSheet.Name
End If
Exit Do
End If
End If
Rs.MoveNext
Loop
'用户确认覆盖，或者表格没有重名
If l = vbYes Then
'sql变量用于保存创建表格的sql语句
'语句格式为 create table 表格名 (字段1 类型1, 字段2 类型2, ...)
'例如：create table aaa(姓名 varchar(15), 数学 int)
'这里的半边括号是查询的前半个括号
Sql = "create table " & XlsSheet.Name & " ("
MaxWidth = 0 '此变量用于记录表格的数据区有多宽（最大列号）
For j = 1 To XlsSheet.Range("A65536").End(xlUp).Row '从1行到表格最后一个有数据的行
For k = 1 To XlsSheet.Range("IV" & j).End(xlToLeft).Column '从1列到表格最后有数据的列
'下面的判断：这个单元格是合并的、或者没有任何值，说明它不是一个有数据的单元格
'所以直接跳过它，看下一行
If XlsSheet.Cells(j, k).MergeCells = True Or XlsSheet.Cells(j, k) = "" Then
Exit For 'contain a merged cell, skip this line
End If
Next k
'如果上面的k的for循环完整的执行了一行没有提前跳出
'那么说明这一行包含一行完整的有效数据
'那么就认为这一行里包含的数据的列数就是XLS表格里的数据宽度
If k > XlsSheet.Range("IV" & j).End(xlToLeft).Column Then
'保存这个列数
MaxWidth = XlsSheet.Range("IV" & j).End(xlToLeft).Column
Exit For '找到了就退出
End If
Next j
'判断是否找到了有效数据，如果没有有效数据，跳过此sheet，因为xls里有些是空表
If MaxWidth > 0 Then
FieldLine = j '这里记录一下j，就是前面找到有效数据的行的行号，有效数据的第一行，被认为是字段名
'insertsql用于记录插入到MDB里的SQL的命令
InsertSql = "" '每次插入前，先设置成空串
'记录所有字段名
For j = 1 To MaxWidth '循环判断一下XLS里代表字段的这一行的数据格式
'如果是数值
If IsNumeric(XlsSheet.Cells(FieldLine + 1, j)) And Val(XlsSheet.Cells(FieldLine + 1, j)) < 2100000000 Then
'则对创建表格的SQL语句里加入一个："字段名 int,"
Sql = Sql & XlsSheet.Cells(FieldLine, j) & " long,"
Else
'不是数值，就认为是字符
'则对创建表格的SQL语句里加入一个："字段名 varchar(255),"
Sql = Sql & XlsSheet.Cells(FieldLine, j) & " varchar(255),"
End If
'insert语句的格式是:
'insert 表格名 (字段1, 字段2, ...) value (数据1, 数据2, ...)
'这里，用insertsql变量记录各个字段名的名字
InsertSql = InsertSql & XlsSheet.Cells(FieldLine, j) & ","
Next j
'根据前面的操作，这个语句最后现在多了一个逗号，要去掉
Sql = Left(Sql, Len(Sql) - 1)
'同上
InsertSql = Left(InsertSql, Len(InsertSql) - 1)
'看创建表格的SQL的格式：
'create table 表格名 (字段1 类型1, 字段2 类型2, ...)
'这里增加半边括号，就补全了整个SQL语句了
Sql = Sql & ")"
'执行该语句，创建表格
'如果不知道语句是什么，可以在这里加一个debug.print sql看看
Conn.Execute Sql 'create table
'表格创建完毕，开始插入数据
'从字段名开始加1行，认为是数据区，到表格的最大数据行
For j = FieldLine + 1 To XlsSheet.Range("A65536").End(xlUp).Row '这里是什么？
ValStr = "" '这个也是保存SQL的一部分，用于记录insert 语句里的values (数据1 ....)这部分
For k = 1 To MaxWidth '这里是什么？
'如果该字段是一个数值
If IsNumeric(XlsSheet.Cells(FieldLine + 1, k)) And Val(XlsSheet.Cells(FieldLine + 1, k)) < 2100000000 Then
'则插入时是insert 表名 (字段1) values(数值)
ValStr = ValStr & Val(XlsSheet.Cells(j, k)) & ","
Else
'如果不是数值，认为是字符串，则插入时是insert 表名 (字段1) values('值') 要多一个单引号
ValStr = ValStr & "'" & XlsSheet.Cells(j, k) & "',"
End If
'不断的循环，最终构造成了insert语句的后半部分
Next k
'同上面的，每次我们加入一个新的值的时候，是有逗号在结尾的，于是结尾多了一个逗号要去掉
ValStr = Left(ValStr, Len(ValStr) - 1)
'显示进度
Label1.Caption = "Exporting(SheetName:" & XlsSheet.Name & ") ... (" & i & "/" & ExcelApp.ActiveWorkbook.Worksheets.Count & ")"
Label1.Caption = Label1.Caption & vbCrLf & "Progress:" & Format(j / (XlsSheet.Range("A65536").End(xlUp).Row - FieldLine + 1), "0.00%")
'执行插入操作
'在这里，可以加一句debug.print "insert into " & XlsSheet.Name & " (" & InsertSql & ") values (" & ValStr & ")" 来看看效果
Conn.Execute "insert into " & XlsSheet.Name & " (" & InsertSql & ") values (" & ValStr & ")"
If j Mod 10 = 0 Then '插入MDB速度比较快，所以每10条记录释放一次操作
DoEvents
End If
Next j
Else
'没找到字段名，放弃这个表
MsgBox "Failed to get field name, skip this sheet", vbCritical, "Error"
End If
End If
Next i
'操作完毕，关闭所有对象
Rs.Close
Conn.Close
ExcelApp.ActiveWorkbook.Close
Set Rs = Nothing
Set Conn = Nothing
MsgBox "Finished!", vbExclamation, "Success"
Command1.Enabled = True
Command2.Enabled = True
Exit Sub
ErrOpenXls:
MsgBox "Open Excel File Failed", vbCritical, "Error"
Command1.Enabled = True
Command2.Enabled = True
Exit Sub
ErrOpenMdb:
MsgBox "Access File Connect Failed", vbCritical, "Error"
ExcelApp.ActiveWindow.Close
Command1.Enabled = True
Command2.Enabled = True
Exit Sub
End Sub
Private Sub Form_Load()
Set ExcelApp = CreateObject("Excel.Application") '创建EXCELAPP对象
ExcelApp.Visible = False '设置其为隐藏
Command1.Caption = "Excel To Access"
Command2.Caption = "Access to Excel"
Label1.Caption = "Excel to Access note: Access file must be exist firstly."
End Sub
Private Sub Form_Unload(Cancel As Integer)
'EXCELAPP这个对象一旦创建，即使程序退出也不销毁
'它其实就是一个excel的进程，可以在进程列表里看到
'所以，程序退出时，要执行这个来退出这个进程
ExcelApp.Quit
End Sub
热门标签
