【vba源码】导出Excel并给工作表设置密码

hi，大家好呀！

又到了一周一更新的日子了，这周我们来更新点啥呢？

话说，最近几次我们都更新了与excel相关的功能，那今天我就再来更新一篇处理excel的文章，那我们就来看看具体的功能！

01

准备导出的表/查询

在导出前，我们先要准备一个表，这次我们直接把之前用过的那张表T_Product，这张表我们在做导出时，添加合计行用过，如下图：

02

创建窗体

接着，我们来创建一个窗体，在窗体放上两个控件，一个文本框，一个按钮，如下图：

03

添加代码

接着，我们就可以来添加代码了：

Private Sub btnExport_Click()
On Error GoTo Err_ExportToExcel
Dim strName As String
Dim objExcel As Object
Dim objBook As Object
Dim objSheet As Object
Dim rst As Object
Dim objExcelQuery As Object
If IsNull(Me.txtPassWord) Then
MsgBox "请先输入密码！", vbCritical
Me.txtPassWord.SetFocus
Exit Sub
End If
strName = "产品.xlsx"
'使用文件对话框取得另存为的文件名
With Application.FileDialog(2) 'msoFileDialogSaveAs
.InitialFileName = strName
If .Show Then
strName = .SelectedItems(1)
If Not strName Like "*.xlsx" Then strName = strName & ".xlsx"
Else
strName = ""
End If
End With
If strName = "" Then Exit Sub
DoCmd.Hourglass True

Set objExcel = CreateObject("Excel.Application")
Set objBook = objExcel.Workbooks().Add()
Set objSheet = objBook.Worksheets("sheet1")

Set rst = CurrentDb.OpenRecordset("T_Product")
Set objExcelQuery = objSheet.QueryTables.Add(rst, objSheet.Range("A1"))
With objExcelQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
End With
objExcelQuery.Refresh
rst.Close

objBook.Sheets("sheet1").Protect Password:=Me.txtPassWord '保护sheet表

objBook.Worksheets("sheet1").SaveAs strName

If MsgBox("数据已导出，是否打开并查看？", vbQuestion + vbYesNo) = vbYes Then
objExcel.Visible = True
Else
objBook.Saved = True
objExcel.Quit
End If

Exit_ExportToExcel:
Set objExcel = Nothing
Set objBook = Nothing
Set objSheet = Nothing
Set rst = Nothing
DoCmd.Hourglass False
Exit Sub

Err_ExportToExcel:
If Err = 70 Then
MsgBox "无法删除文件 '" & strName & "'，可能该文件已被打开或没有权限。", vbCritical
Else
MsgBox Err.Source & " #" & Err & vbCrLf & vbCrLf & Err.Description, vbCritical
End If
Resume Exit_ExportToExcel
End Sub

04

运行测试

最后，就是运行测试了，我们来看一下效果。

在图中我们可以看到，导出后sheet1是有密码，如果直接修改是会有报错的，那说明我们成功了！

其实就是比我们导出的代码多了这一句，是不是非常的简单！

objBook.Sheets("sheet1").Protect Password:=Me.txtPassWord

好了，大家快去试一下吧！如果大家觉得我写的还行，不如给我一个小爱心吧，支持一下我！啵~~~