office 有內建的另存pdf功能，word 可存加密的pdf
而excel雖然有加密選項，可是不能選
想存加密的excel pdf，就要裝acrobat，使用列印功能來存檔
或用其它pdf編輯軟體，把未加密的pdf加上密碼
但這樣沒辦一氣呵成，有點麻煩
照慣例先google，找不到相關範例
所以寫一個使用開源函式庫的範例，讓大家參考
範例功能：
可替pdf加上128-bit RC4密碼，不需要另外裝acrobat(或其它編輯軟體)
只需要幾行程式碼就可簡單加上密碼
前置作業
一、至少要有 .net framework 4.0 (或以上)
二、把附件中的ProtectPDF.dll，放到c:\windows\ (或您喜歡的位置)
三、登錄程式庫，使用系統管理員權限執行命令提示字元(cmd)
這裡要注意一下32、64位元，不要選錯目錄
32位元 excel(需先關閉excel)
進入目錄 C:\Windows\Microsoft.NET\Framework\v4???????
執行
RegAsm.exe c:\windows\ProtectPDF.dll /tlb: ProtectPDF32.tlb /codebase
64位元 excel(需先關閉excel)
進入目錄 C:\Windows\Microsoft.NET\Framework64\v4??????
執行
RegAsm.exe c:\windows\ProtectPDF.dll /tlb: ProtectPDF64.tlb /codebase
(如果想移除程式庫註冊，先關閉excel，最後加上unregister，像這樣 ... /codebase /unregister )
四、打開excel，進入visual basic
=>工具=>設定引用項目=>瀏覽=>選 ProtectPDF32.tlb 或 ProtectPDF64.tlb
五、把程式碼放到模組裡
'===========================
'範例執行效果
'把目前的活頁薄在桌面上存一個沒密碼的pdf
'使用程式庫加上唯讀、可讀寫密碼，另存一個加密pdf
'使用複製程式碼方式自建檔案的，請把＜＞全形，改成半形字
Sub Savepdf()
Dim Report As String, target As String, ReadOnlyPassWord As String, EditPassWord As String, SetPassWord As Object
Set SetPassWord = CreateObject("ProtectPDF.GoPDF")
'設定檔名、目錄、密碼
target = Environ("USERPROFILE") & "\Desktop\"
filename1 = target & "nopassword.pdf"
filename2 = target & "password.pdf"
ReadOnlyPassWord = "123"
EditPassWord = "456"
'另存新檔pdf格式
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filename1, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'加入密碼保護
Report = SetPassWord.protectpdfstandard(ReadOnlyPassWord, EditPassWord, filename1, filename2)
'Debug.Print Report
Set SetPassWord = Nothing
End Sub
'===============================
這個副程式，可以很容易的改自動化，想處理大量檔案也沒問題(像員工薪資表之類的)
之後，就看您們要如何使用、改寫了
附加壓縮檔: 201706/mobile01-a715ac672b3ed9fcd4a15138090eed9a.zip
'==2017/7/9 不想讓文章浮上來，反正也沒人看
，偷偷增加一個範例 =='===內有vlookup 搜尋array+錯誤處理方式====
'===2017/7/16 小小修改一下autopdf副程式 ===
'程式功能，使用A欄的資料(不用排序)，分類後，新增工作表，再分別另存pdf(加密)
Sub autopdf()
Dim i As Integer, Password_Data As Variant, AllCriteria, Criteriadata, report, checkname As String, target1 As String, target2 As String, target3 As String
target1 = "c:\excel\" '暫存目錄1
target2 = "c:\excel\password\" '暫存目錄2
target3 = "c:\excel\nopassword\" '暫存目錄3
Call delsheet
Call deltemp(target1, target2, target3)
Application.ScreenUpdating = False
With Sheets("sheet1")
.Select
.Range("a:a").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set AllCriteria = .Range(.Cells(2, "a"), .Cells(2, "a").End(xlDown)).SpecialCells(xlCellTypeVisible)
Password_Data = Sheets("密碼表").Range("a2:c" & Sheets("密碼表").Range("a1").CurrentRegion.Rows.Count)
For Each Criteriadata In AllCriteria
report = Application.VLookup(Criteriadata, Password_Data, 1, False)
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "_" & Criteriadata & "_"
.Range("a:a").AutoFilter Field:=1, Criteria1:=Criteriadata
.UsedRange.Copy Sheets("_" & Criteriadata & "_").Cells(1, 1)
If TypeName(report) = "Error" Then
checkname = checkname & vbNewLine & Criteriadata
readonlypassword = ""
editpassword = ""
Else
readonlypassword = Application.VLookup(Criteriadata, Password_Data, 2, False)
editpassword = Application.VLookup(Criteriadata, Password_Data, 3, False)
End If
'Debug.Print criteriadata & "_" & ReadOnlyPassWord & "_" & EditPassWord
Call Savepdf(target2, target3, Criteriadata, readonlypassword, editpassword)
Next
.AutoFilterMode = False
End With
'call delsheet
Worksheets(1).Select
Application.ScreenUpdating = True
If checkname ＜＞ "" Then
MsgBox "以下資料不在密碼表內，不會加入密碼保護" & checkname, vbOKOnly, "資料比對錯誤"
End If
Shell "explorer.exe" & " " & target1, vbNormalFocus
End Sub
Sub Savepdf(target2 As String, target3 As String, filename, readonlypassword, editpassword)
Dim report As String, SetPassWord As Object
Set SetPassWord = CreateObject("ProtectPDF.GoPDF")
'另存新檔pdf格式
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=target3 & filename, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'加入密碼保護
report = SetPassWord.protectpdfstandard(readonlypassword, editpassword, target3 & filename & ".pdf", target2 & filename & ".pdf")
Set SetPassWord = Nothing
End Sub
Sub delsheet()
Application.DisplayAlerts = False
Dim delsheet() As Variant, Protect() As Variant
ReDim delsheet(1 To Worksheets.Count)
Protect = Array("Sheet1", "我要留著", "不能刪的", "密碼表")
'可自訂不想刪的工作表名稱
For i = 1 To Worksheets.Count
If Join(Filter(Protect, Worksheets(i).Name)) = "" Then
j = j + 1
delsheet(j) = Worksheets(i).Name
End If
Next
If j = "" Then Exit Sub
ReDim Preserve delsheet(1 To j)
Worksheets(delsheet).Delete
Worksheets(1).Select
Application.DisplayAlerts = True
End Sub
Sub deltemp(target1 As String, target2 As String, target3 As String)
If Dir(target1, vbDirectory) = "" Then MkDir target1
If Dir(target2, vbDirectory) = "" Then MkDir target2
If Dir(target3, vbDirectory) = "" Then MkDir target3
'注意，暫存目錄下的檔案(含子目錄)，會在無任何提示下刪除
If Dir(target1 & "*.*") ＜＞ "" Then Kill target1 & "*.*"
If Dir(target2 & "*.*") ＜＞ "" Then Kill target2 & "*.*"
If Dir(target3 & "*.*") ＜＞ "" Then Kill target3 & "*.*"
End Sub
'=============================================================
這是(64位元 excel 範例)，如果要用32位元的 excel ，請重新設定32位元的引用項目
附加壓縮檔: 201707/mobile01-a822b9e8c4c84d5206deb1b8f8465fa0.zip
