【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

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