ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Change PDF properties (https://www.excelbanter.com/excel-programming/423109-change-pdf-properties.html)

Seanie

Change PDF properties
 
I am looking to chnage/add features to Ron De Bruins excellent e-mail
Excel via PDF format, as per below. How can I:- Add a security
password to prevent the e-mailed document from been altered and
printed?

Sub Mail_Area1()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim strbody As String
Dim FilenameStr As String
Dim TempWb As Workbook

Set Sourcewb = ActiveWorkbook

If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE"
_
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <
"" Then

Sourcewb.Sheets(Array("E-Mail1")).Copy
Set TempWb = ActiveWorkbook


FilenameStr = Application.DefaultFilePath & "\" & "Part of " &
Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm") & ".pdf"

ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FilenameStr, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

'Close the new workbook you create file without saving
TempWb.Close False


Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)


For Each cell In ThisWorkbook.Sheets("E-Mail1").Range("BV1:BV2")
strbody = strbody & cell.Value & vbNewLine
Next

For Each cell In ThisWorkbook.Sheets("E-Mail1") _
.Columns("BY").Cells.SpecialCells(xlCellTypeConsta nts)
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next
strto = Left(strto, Len(strto) - 1)


On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = strto
.Subject = ThisWorkbook.Sheets("E-Mail1").Range
("C2").Value
.Body = strbody
.Attachments.Add FilenameStr
.ReadReceiptRequested = True
.Importance = 1
.DeferredDeliveryTime = ThisWorkbook.Sheets("E-
Mail1").Range("CC1").Value
.SendUsingAccount = OutApp.Session.Accounts.Item(2)
.Send
End With
On Error GoTo 0


'Delete the file you send
Kill FilenameStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Else

MsgBox "PDF add-in Not Installed"
End If

End Sub

[email protected]

Change PDF properties
 
On Feb 1, 3:34*pm, Seanie wrote:
Anyone any ideas?

That's a great question. Also if you have the PDS/XPS add-in, you
should be able to use .SaveAs with a write password but it doesn't
work.



All times are GMT +1. The time now is 03:09 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com