This code uses the free Adobe PDF Services API to create a protected PDF. A protected PDF can have an 'Open password' required to open the PDF and/or a 'Permissions password' to allow printing, editing and content copying in the PDF document.
Follow these steps to use the Adobe PDF Services API:
The demonstration workbook contains a "Passwords" sheet, "Sheet1", "Sheet2", "Sheet3" and "Credentials". The code creates the "Credentials" sheet if it doesn't exist and prompts for the Client ID and Client Secret strings if they aren't defined.
modMain - Demonstration code which loops through the "Passwords" sheet and saves each specified sheet as a PDF and calls the Protect_PDF procedure to apply the Open Password and/or the Permissions Password to the PDF.
modProtectPDF - contains the Protect_PDF public procedure which follows the steps described at https://developer.adobe.com/document-services/docs/apis/#tag/Protect-PDF
Follow these steps to use the Adobe PDF Services API:
Create an Adobe Account at Adobe Account
Go to Adobe Developer Console - Loading... | Adobe Developer Console
Click APIs and Services
Under PDF Services API, click Create Project
Enter a Credential name
Tick the box 'Acrobat Services: PDF Services API'
Click Save Configured API
Click OAuth Server-to-Server
Copy the Client ID and Client Secret strings - these are required by the API and stored in the "Credentials" sheet in the demonstration workbook.
The demonstration workbook contains a "Passwords" sheet, "Sheet1", "Sheet2", "Sheet3" and "Credentials". The code creates the "Credentials" sheet if it doesn't exist and prompts for the Client ID and Client Secret strings if they aren't defined.
| Demo - Protect PDFs.xlsm | |||||
|---|---|---|---|---|---|
| A | B | C | |||
| 1 | Sheet Name | Open Password | Permissions Password | ||
| 2 | sheet1 | open1 | perm1 | ||
| 3 | Sheet2 | open2 | perm2 | ||
| 4 | Sheet3 | perm3 | |||
Passwords | |||||
modMain - Demonstration code which loops through the "Passwords" sheet and saves each specified sheet as a PDF and calls the Protect_PDF procedure to apply the Open Password and/or the Permissions Password to the PDF.
VBA Code:
Option Explicit
Public Sub Create_Protected_PDFs()
Dim PDFoutputFolder As String
Dim sheetNameCell As Range
Dim openPassword As String, permissionsPassword As String
Dim PDFsheet As Object
Dim PDFfullName As String
PDFoutputFolder = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
'In the "Passwords" sheet, loop through each sheet name in column A starting from A2, export the sheet as a PDF and protect the
'PDF with the 'Open password' in column B or/and the 'Permissions password' in column C.
'Either one or both of the 'Open password' and 'Permissions password' must be specified.
With ThisWorkbook.Worksheets("Passwords")
For Each sheetNameCell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
openPassword = .Cells(sheetNameCell.Row, "B").Value
permissionsPassword = .Cells(sheetNameCell.Row, "C").Value
Set PDFsheet = Nothing
On Error Resume Next
Set PDFsheet = ThisWorkbook.Sheets(sheetNameCell.Value)
On Error GoTo 0
If Not PDFsheet Is Nothing Then
PDFfullName = PDFoutputFolder & sheetNameCell.Value & ".pdf"
PDFsheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfullName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'Protect the PDF using the specified password(s). The original .pdf file is replaced by the protected .pdf file
Protect_PDF PDFfullName, PDFfullName, openPassword, permissionsPassword
End If
Next
End With
Application.ScreenUpdating = True
MsgBox "Protected PDFs created", vbInformation
End SubmodProtectPDF - contains the Protect_PDF public procedure which follows the steps described at https://developer.adobe.com/document-services/docs/apis/#tag/Protect-PDF
VBA Code:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
#End If
Private Type AdobeCredentialsType
client_id As String
client_secret As String
access_token As String
token_type As String
expires_in As Long
expiresAtDate As Date
End Type
Public Sub Protect_PDF(PDFinputFile As String, PDFoutputFile As String, documentOpenPassword As String, permissionsPassword As String, Optional permissions As String = "")
'Protects a PDF file using the steps described at https://developer.adobe.com/document-services/docs/apis/#tag/Protect-PDF
'Parameters
'
'PDFinputFile Full path of PDF file to be protected
'
'PDFoutputFile Full path of protected PDF file to be created. Can be same as PDFinputFile, in which case the original file is replaced
'
'documentOpenPassword Password to open the protected PDF. Also known as User password.
'
'permissionsPassword Password to secure the protected PDF with the specified permissions. Also known as Owner password.
'
'permissions Comma-separated list of permissions
' Permissions to allow printing, editing and content copying in the PDF document.
' Valid values: PRINT_LOW_QUALITY, PRINT_HIGH_QUALITY, EDIT_CONTENT, EDIT_FILL_AND_SIGN_FORM_FIELDS, EDIT_ANNOTATIONS,
' EDIT_DOCUMENT_ASSEMBLY, COPY_CONTENT
' By default, none of the specified actions are permitted.
' PRINT_HIGH_QUALITY permission includes PRINT_LOW_QUALITY permission.
' EDIT_CONTENT permission includes EDIT_DOCUMENT_ASSEMBLY and EDIT_FILL_AND_SIGN_FORM_FIELDS permissions.
' Permission values will only be used if permissionsPassword is not "".
Const baseURL As String = "https://pdf-services.adobe.io/"
Dim XMLhttpRequest As Object
Set XMLhttpRequest = CreateObject("MSXML2.XMLHTTP")
Dim credentials As AdobeCredentialsType
Dim postData As String
Dim uploadUri As String, locationUri As String, downloadUri As String
Dim assetID As String
Dim status As String
Dim PDFbytes() As Byte
Dim passwordProt As String
Dim permissionsList As String, perm As Variant
If documentOpenPassword = "" And permissionsPassword = "" Then
MsgBox "Protect_PDF procedure terminated because either one or both of the Document Open Password (User Password) and Permissions Password must be specified.", vbExclamation, "Protect PDF"
Exit Sub
End If
Load_Credentials credentials
If credentials.client_id = "" Or credentials.client_secret = "" Then
MsgBox "Protect_PDF procedure terminated because Client Id or/and Client Secret aren't defined.", vbExclamation, "Protect PDF"
Exit Sub
End If
'Get new access token if there isn't an access token or it expires within the next 5 minutes
If credentials.access_token = "" Or Now > DateAdd("n", -5, credentials.expiresAtDate) Then
'https://developer.adobe.com/document-services/docs/overview/pdf-services-api/gettingstarted/#step-1--getting-the-access-token
postData = "client_id=" & Enc(credentials.client_id) & "&client_secret=" & Enc(credentials.client_secret)
With XMLhttpRequest
Debug.Print Time; baseURL & "token"
.Open "POST", baseURL & "token", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send (postData)
Debug.Print .status, .statusText
'Debug.Print .responseText
If .status = 200 Then
credentials.access_token = GetJSONvalue(.responseText, "access_token")
credentials.token_type = GetJSONvalue(.responseText, "token_type")
credentials.expires_in = GetJSONvalue(.responseText, "expires_in")
credentials.expiresAtDate = DateAdd("s", credentials.expires_in, Now)
Save_Credentials credentials
Else
MsgBox "Protect_PDF procedure terminated because XMLhttp request for access_token returned status " & .status & " " & .statusText, vbExclamation, "Protect PDF"
Exit Sub
End If
End With
End If
'https://developer.adobe.com/document-services/docs/apis/#tag/Assets
'Request assetID and uploadUri in order to upload the PDF file
postData = "{""mediaType"": ""application/pdf""}"
With XMLhttpRequest
Debug.Print Time; baseURL & "assets"
.Open "POST", baseURL & "assets", False
.setRequestHeader "Authorization", "Bearer " & credentials.access_token
.setRequestHeader "X-API-Key", credentials.client_id
.setRequestHeader "Content-Type", "application/json"
.send (postData)
Debug.Print .status, .statusText
'Debug.Print .responseText
If .status = 200 Then
uploadUri = GetJSONvalue(.responseText, "uploadUri")
assetID = GetJSONvalue(.responseText, "assetID")
Else
MsgBox "Protect_PDF procedure terminated because XMLhttp request for file upload URI returned status " & .status & " " & .statusText, vbExclamation, "Protect PDF"
Exit Sub
End If
End With
'Read the PDF file into a byte array
PDFbytes = Load_File_Bytes(PDFinputFile)
'Upload the PDF file
With XMLhttpRequest
Debug.Print Time; uploadUri
.Open "PUT", uploadUri, False
.setRequestHeader "Content-Type", "application/pdf"
.send (PDFbytes)
Debug.Print .status, .statusText
If .status <> 200 Then
MsgBox "Protect_PDF procedure terminated because XMLhttp file upload returned status " & .status & " " & .statusText, vbExclamation, "Protect File"
Exit Sub
End If
End With
'Create the Json string for the Protect PDF job, specifying the assetID obtained above, the password(s) and permissions.
'On successful job submission you will get a status code of 201 and a response header location which will be used for polling.
passwordProt = ""
If permissionsPassword <> "" Then
passwordProt = " ""ownerPassword"": " & """" & permissionsPassword & """"
End If
If documentOpenPassword <> "" Then
If passwordProt <> "" Then passwordProt = passwordProt & "," & vbCrLf
passwordProt = passwordProt & " ""userPassword"": " & """" & documentOpenPassword & """"
End If
permissionsList = ""
For Each perm In Split(permissions, ",")
permissionsList = permissionsList & """" & perm & ""","
Next
If permissionsList <> "" Then permissionsList = Left(permissionsList, Len(permissionsList) - 1)
postData = "{" & vbCrLf & _
" ""assetID"": """ & assetID & """," & vbCrLf & _
" ""passwordProtection"": {" & vbCrLf & _
passwordProt & vbCrLf & _
" }," & vbCrLf & _
" ""encryptionAlgorithm"": ""AES_256""," & vbCrLf & _
" ""contentToEncrypt"": ""ALL_CONTENT"""
If permissionsPassword <> "" And permissionsList <> "" Then
postData = postData & "," & vbCrLf & _
" ""permissions"": [" & vbCrLf & _
permissionsList & vbCrLf & _
" ]"
End If
postData = postData & vbCrLf & _
"}"
'Debug.Print postData
With XMLhttpRequest
Debug.Print Time; baseURL & "operation/protectpdf"
.Open "POST", baseURL & "operation/protectpdf", False
.setRequestHeader "Authorization", "Bearer " & credentials.access_token
.setRequestHeader "X-API-Key", credentials.client_id
.setRequestHeader "Content-Type", "application/json"
.send (postData)
Debug.Print .status, .statusText
'Debug.Print .responseText
'Debug.Print .getAllResponseHeaders
If .status <> 201 Then
MsgBox "Protect_PDF procedure terminated because XMLhttp Protect PDF operation returned status " & .status & " " & .statusText, vbExclamation, "Protect File"
Exit Sub
End If
locationUri = Split(Split(.getAllResponseHeaders, "location: ")(1), vbCrLf)(0)
End With
'https://developer.adobe.com/document-services/docs/apis/#tag/Protect-PDF/operation/pdfoperations.protectpdf.jobstatus
'
'Poll the protect pdf operation for completion.
'
'On getting 200 response code from the poll API, you will receive a status field in the response body which can either
'be "in progress", "done" or "failed".
'If the status field is "in progress" you need to keep polling the location until it changes to "done" or "failed".
'If the status field is "done" the response body will also have a download pre-signed URI in the dowloadUri field, which will be used
'to download the asset directly from cloud provider by making the following API call
Do
With XMLhttpRequest
Debug.Print Time; locationUri
.Open "GET", locationUri, False
.setRequestHeader "Authorization", "Bearer " & credentials.access_token
.setRequestHeader "X-API-Key", credentials.client_id
.send
Debug.Print .status, .statusText
'Debug.Print .responseText
If .status <> 200 Then
MsgBox "Protect_PDF procedure terminated because XMLhttp job status request returned status " & .status & " " & .statusText, vbExclamation, "Protect PDF"
Exit Sub
End If
status = GetJSONvalue(.responseText, "status")
downloadUri = GetJSONvalue(.responseText, "downloadUri")
End With
Debug.Print Time; status
If status = "in progress" Then Sleep 500
Loop While status = "in progress"
If status = "done" Then
'Download the protected PDF and save it as the output PDF
DownloadFile downloadUri, PDFoutputFile
Else
MsgBox "Protect_PDF procedure terminated because XMLhttp Protect PDF operatation failed", vbExclamation, "Protect PDF"
Exit Sub
End If
'https://developer.adobe.com/document-services/docs/apis/#tag/Assets/operation/asset.delete
'Delete the PDF from Adobe cloud storage
With XMLhttpRequest
.Open "DELETE", baseURL & "assets/" & assetID, False
.setRequestHeader "Authorization", "Bearer " & credentials.access_token
.setRequestHeader "X-API-Key", credentials.client_id
.send
Debug.Print .status, .statusText
'Debug.Print .responseText
'Debug.Print .getAllResponseHeaders
If .status <> 204 Then
MsgBox "Protect_PDF procedure terminated because XMLhttp delete asset request returned status " & .status & " " & .statusText, vbExclamation, "Protect PDF"
Exit Sub
End If
End With
End Sub
Private Function GetJSONvalue(JSONstring As String, paramName As String) As String
'Extract a parameter value from a JSON string
Dim p1 As Long, p2 As Long
p1 = InStr(JSONstring, Chr(34) & paramName & Chr(34))
If p1 > 0 Then
p1 = p1 + Len(Chr(34) & paramName & Chr(34))
p1 = InStr(p1, JSONstring, ":") + 1
p2 = InStr(p1, JSONstring, ",")
If p2 = 0 Then p2 = InStr(p1, JSONstring, "]")
If p2 = 0 Then p2 = InStr(p1, JSONstring, "}")
GetJSONvalue = Mid(JSONstring, p1, p2 - p1)
GetJSONvalue = Replace(GetJSONvalue, Chr(34), "")
'Debug.Print paramName & " = " & GetJSONvalue
End If
End Function
Private Function Load_File_Bytes(PDFfile As String) As Byte()
'Read the PDF file bytes into a byte array
Dim fileNum As Integer
fileNum = FreeFile
Open PDFfile For Binary Access Read As fileNum
ReDim Load_File_Bytes(0 To LOF(fileNum) - 1)
Get fileNum, , Load_File_Bytes
Close fileNum
End Function
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim retVal As Long
retVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If retVal = 0 Then DownloadFile = True Else DownloadFile = False
End Function
Private Function Enc(s As String) As String
Enc = Application.WorksheetFunction.EncodeURL(s)
End Function
Private Sub Save_Credentials(credentials As AdobeCredentialsType)
'Write credentials to cells in the specified worksheet
With Credentials_Sheet
.Range("A1:B1").Value = Array("Client ID", credentials.client_id)
.Range("A2:B2").Value = Array("Client Secret", credentials.client_secret)
.Range("A3:B3").Value = Array("Access Token", credentials.access_token)
.Range("A5:B4").Value = Array("Token Type", credentials.token_type)
.Range("A5:B5").Value = Array("Expires In (secs)", credentials.expires_in)
.Range("A6:B6").Value = Array("Expiry Date", credentials.expiresAtDate)
.Columns("A").AutoFit
End With
End Sub
Private Sub Load_Credentials(ByRef credentials As AdobeCredentialsType)
'Read credentials from cells in the specified worksheet, or prompt for Client Id and Client Secret
With Credentials_Sheet
credentials.client_id = Get_client_id(.Range("B1").Value)
If credentials.client_id <> "" Then
credentials.client_secret = Get_client_secret(.Range("B2").Value)
End If
credentials.access_token = .Range("B3").Value
credentials.token_type = .Range("B4").Value
credentials.expires_in = .Range("B5").Value
credentials.expiresAtDate = .Range("B6").Value
End With
End Sub
Property Get Credentials_Sheet() As Worksheet
With ThisWorkbook
On Error Resume Next
Set Credentials_Sheet = .Worksheets("Credentials")
On Error GoTo 0
If Credentials_Sheet Is Nothing Then
Set Credentials_Sheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
Credentials_Sheet.Name = "Credentials"
End If
End With
End Property
Property Get Get_client_id(client_id As String) As String
If client_id = "" Then
Do
client_id = InputBox("Enter Client ID", "Adobe Credentials")
Loop While client_id = "" And StrPtr(client_id) <> 0
End If
Get_client_id = client_id
End Property
Property Get Get_client_secret(client_secret As String) As String
If client_secret = "" Then
Do
client_secret = InputBox("Enter Client Secret", "Adobe Credentials")
Loop While client_secret = "" And StrPtr(client_secret) <> 0
End If
Get_client_secret = client_secret
End Property
