I have an application in Microsoft Access 2007 which generates PDF files via OutputTo ... acFormatPDF. It works fine, but now, someone has manipulated a generated PDF and I now will add a protection for the PDF's to my program code. How can I do that because the OutputTo seems to have no options for doing that? The only protection I need is for changing the document. All other protections (copy, print, ...) have no relevance.
I found a method for applying protection to PDFs using AcroJS and the list of instantiateable COM classes found here. I use "CreateObject" to perform late binding of the Acrobat objects, but if you have Acrobat installed, you can add a reference in your project by going into the VBA IDE and clicking Tools ---> References... and checking the box next to "Adobe Acrobat x.x Type Library" (where x.x is your version of Acrobat). If you don't see that available, look for "acrobat.tlb" in Program Files and add it via the Browse...
Public Sub ProtectPDF(strFilePath As String, strPolicyName As String)
On Error GoTo ErrHandler
Dim oPDDoc As Object
Dim oJso As Object
Dim oSec As Object
Dim arrPolicies As Variant
Dim PolicyIndex As Integer
Dim i As Integer
Dim success As Boolean
Const PDSaveFull = 1
Set oPDDoc = CreateObject("AcroExch.PDDoc")
If oPDDoc.Open(strFilePath) Then
Set jso = oPDDoc.GetJSObject
Set sec = jso.security
apols = sec.getSecurityPolicies()
PolicyIndex = -1
For i = 0 To UBound(arrPolicies)
If arrPolicies(i).Name = strPolicyName Then
PolicyIndex = i
End If
Next
If Not PolicyIndex = -1 Then
jso.encryptUsingPolicy (arrPolicies(PolicyIndex))
Else
Err.Raise vbObjectError + 1, "ProtectPDF", "Could not find Policy named: """ & strPolicyName & """"
End If
success = oPDDoc.Save(PDSaveFull, strFilePath)
oPDDoc.Close
Else
Err.Raise vbObjectError + 2, "ProtectPDF", "Failed to open " & strFilePath
End If
Exit Sub
ErrHandler:
'Handle any Adobe errors here...
End Sub
Related
This question already has answers here:
MailItem.GetInspector.WordEditor in Office 2016 generates Application-defined or object defined error
(4 answers)
Closed 3 months ago.
i have a strange problem, vba return me the error vba runtime error -1802485755(94904005) and i searched on internet and i found nothing, so i am tring to ask here if someone can help me
here is the code
Private Sub CommandButton3_Click()
Dim str As New Classe1
Dim ricerca As String
Dim dmi As outlook.MailItem
Dim UTCdate As Date, UTCdate2 As Date
Dim out As outlook.Application
Dim DATA1 As Date
Dim DATA2 As Date
Dim errorN As Long
On Error GoTo FormatoErrato:
DATA1 = DateAdd("h", 1, Res.DataStart.Value)
DATA2 = DateAdd("h", 23, Res.DataEnd.Value)
On Error GoTo 0
Set out = New outlook.Application
Set dmi = out.CreateItem(olMailItem)
UTCdate = dmi.PropertyAccessor.LocalTimeToUTC(DATA1)
UTCdate2 = dmi.PropertyAccessor.LocalTimeToUTC(DATA2)
ricerca = "#SQL=""urn:schemas:httpmail:subject"" LIKE '%sometext%'" & _
" AND ""urn:schemas:httpmail:datereceived"" <= '" & UTCdate2 & "'" & _
" AND ""urn:schemas:httpmail:datereceived"" >= '" & UTCdate & "'"
str.prova (ricerca)
FormatoErrato:
errorN = Err.Number
If errorN = 13 Then
MsgBox "invalid format", vbCritical
End If
End Sub
this code (in a class module) is on a userform button where you set two dates and then the following code search the emails that strike the requirments
Sub prova(val As String)
Res.Mezzi.Clear
Dim fol As outlook.Folder
Dim arr, arr2
Dim ricerca As String, txt As String
Dim n As Long, s As Long, tot As Long, l As Long
Dim mi As outlook.MailItem
Dim i As Object
Dim doc As Word.Document
Set fol = 'outlook folder path'
s = 0
n = 1
ReDim Preserve arr2(0 To s)
For Each i In fol.Items.Restrict(val)
If i.Class = olMail Then
Set mi = i
Set doc = mi.GetInspector.WordEditor
If doc.Tables.Count > 0 Then
For tot = 1 To doc.Tables.Count
arr2(s) = Application.WorksheetFunction.Clean(doc.Tables(tot).Cell(2, 2).Range.Text)
s = s + 1
ReDim Preserve arr2(0 To s)
Next tot
End If
End If
Next i
For s = 0 To UBound(arr2)
If IsEmpty(arr2(s)) = False And arr2(s) <> "" Then
Res.Mezzi.AddItem arr2(s)
End If
Next s
End Sub
the email that i'm looking for has a table, one or more in it so i used getinspector.wordeditor to check if the table exist and then take the data that i need from it.
the sub works fine if the difference between the dates is just few days if i put a week give that error
coudl you help me to solve the problem or work around it?
thanks in advance
I didn't find any information which Office version is installed on the system. So, if you have a pretty old version of MS Office installed the following case makes sense - the WordEditor property is only valid if the IsWordMail method returns True and the EditorType property is olEditorWord.
The most-likely possible reason for such errors at runtime is security settings when dealing with the Outlook object model. The message body is a protected property in the Outlook object model which can generate errors when Outlook is automated from an external application. You can find the list of protected properties described on the Protected Properties and Methods page.
So, the Object Model Guard warns users and prompts users for confirmation when untrusted applications attempt to use the object model to obtain email address information, store data outside of Outlook, execute certain actions, and send email messages. If, for any reason, the warning is not appropriate or can't be displayed, the Outlook object model may generate errors when accessing protected properties.
In your scenario you can:
Use a low-level API which doesn't trigger security issues in the Outlook object model - Extended MAPI or any other third-party wrapper around that API.
Create a COM add-in which has access to the trusted Application object and which doesn't trigger security issues.
Install any AV with the latest updates.
Use group policy settings to setup security settings to not trigger security issues.
after many trials i think i solved
to avoid to raise the error i should close the inspector.
in this way:
If i.Class = olMail Then
Set mi = i
Set insp = mi.GetInspector
Set doc = insp.WordEditor
If doc.Tables.Count > 0 Then
For tot = 1 To doc.Tables.Count
arr2(s) = Application.WorksheetFunction.Clean(doc.Tables(tot).Cell(2, 2).Range.Text)
s = s + 1
ReDim Preserve arr2(0 To s)
Next tot
End If
End If
insp.Close olSave
now all seems to work fine even with range of 10 days of emails
I have an Excel application which collects information via a form based interface. This is used to;
Fill values in the workbook
A procedure opens a Word document (template essentially) and names the file according to rules, based
on some of the input data. (Okay to this point)
The idea then, is to transfer collected information (from the Excel app driving this process) to
the same Word document opened and named.
Specifically, I intend to populate a number of uniquely named ActiveX textboxes with document.
*** This is where I fail miserably.
I have enabled the "Microsoft Word 16.0 Object Library" under references in the MSExcel VBA environment.
Given that I know the name/title of the content control (ActiveX textbox is a 'content control' isn't it?). The code below is a simplified example, if it works for the example I should be able to sort out the broader document:
Sub trial()
Dim Word As Word.Application
Dim wdDoc As Word.Document
On error resume next
Set Word = New Word.Application
Set wdDoc = Word.Documents.Open("G:\CAPS Management Tool\Customer.docm")
Word.Application.Visible = True
Dim cc As Object
Set cc = ActiveDocument.SelectContentControlsByTitle(txt_PersonName) 'txt_PersonName is the control name
cc.Range.Text = "SUCCESS" 'Run-time error 438
'Object does not support property or method
Set cc = ActiveDocument.SelectContentControlsByTitle(txt_Address) 'txt_Address is the control name
cc.Range.Text = "SUCCESS" 'Run-time error 438
'Object does not support property or method
End Sub
Anybody able to assist? There are a lot of text boxes in the Word document I wish to plug in to.
Thanks in advance.
OK, so I kept digging (I don't like accepting defeat) and found that my entire premise was wrong! ActiveX controls in Word are considered "InlineShapes" not "ContentControls". But the results I was reading in the internet searches had me confused (didn't claim to be the sharpest tool in the shed).
Once I realised this, some more digging provided the answer (see below).
So, first to list the 3 controls in my document (and their index) with the following Sub
Sub ListActiveXControls()
Dim i As Integer
i = 1
Do Until i > ActiveDocument.InlineShapes.Count
Debug.Print ActiveDocument.InlineShapes(i).OLEFormat.Object.Name & " Control Index = " & i
i = i + 1
Loop
End Sub
Now moving to EXCEL, I used the following:
Sub trial()
Dim Word As Word.Application
Dim wdDoc As Word.Document
Set Word = New Word.Application
Set wdDoc = Word.Documents.Open("G:\CAPS Management Tool\Customer.docm")
Word.Application.Visible = True
debug.print "ActiveDocument Name is : " & ActiveDocument.Name
' Result = Nothing
' Allowing the code to continue without the pause caused the operation to fail
Application.Wait (Now + TimeValue("0:00:10")) ' See text below, would not work without pause
wdDoc.Activate
' Begin set ActiveX control values. In this instance,
' The first line corresponds to 'Textbox1'
ActiveDocument.InlineShapes(1).OLEFormat.Object.Text = "Success"
' The second line corresponds to 'Textbox2'
ActiveDocument.InlineShapes(2).OLEFormat.Object.Text = "Success"
' The third line corresponds to 'ChkBox1'
ActiveDocument.InlineShapes(3).OLEFormat.Object.Value = True
End Sub
For some reason, without the 'Wait' command, the operation fails. Stepping through, if there is no pause, the ActiveDocument seems to be null, no idea why. It occurs with a document with 2 ActiveX controls or 165 ActiveX controls and the wait required seems to
be 10 secs on my PC. Incidentally, setting almost 150 control values was only seconds, once the wait period was completed.
If anyone knows why the 'Wait' is seemingly required, I'd be interested to know!
Here are a few tips to help you work this out.
Don't use On Error Resume Next unless you really need it. And then when you do use it, re-enable error catching with On Error Goto 0 as quickly as possible. Otherwise you'll miss many errors in your code and it will be hard to tell what's happening.
Don't use the name Word as a variable name. It is reserved for the Word.Application and will only confuse the compiler (and you).
The control titles are text strings, so you must enclose them in double-quotes.
I've thrown in a bonus Sub that gives you a quick method to either open a new Word application instance or attach to an existing application instance. You'll find that (especially during debugging) there will be dozens of Word exe's opened and running.
The example code below also breaks the assignment of your "SUCCESS" value to the control into a separate Sub. It's in this short Sub that using On Error Resume Next is appropriate -- and isolated from the rest of the logic -- limiting its scope.
Option Explicit
Sub trial()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Set wdApp = AttachToMSWordApplication
Set wdDoc = wdApp.Documents.Open("C:\Temp\Customer.docm")
wdApp.Application.Visible = True
TextToControl wdDoc, "txt_PersonName", "SUCCESS"
TextToControl wdDoc, "txt_Address", "SUCCESS"
End Sub
Private Sub TextToControl(ByRef doc As Word.Document, _
ByVal title As String, _
ByVal value As String)
Dim cc As ContentControl
On Error Resume Next
Set cc = doc.SelectContentControlsByTitle(title).Item(1)
If Not cc Is Nothing Then
cc.Range.Text = value
Else
Debug.Print "ERROR: could not find control titled '" & title & "'"
'--- you could also raise an error here to be handled by the caller
End If
End Sub
Public Function AttachToMSWordApplication() As Word.Application
'--- finds an existing and running instance of MS Word, or starts
' the application if one is not already running
Dim msApp As Word.Application
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Word.Application")
End If
Set AttachToMSWordApplication = msApp
End Function
I have pulled code from a different source to try and search for a specific string in a PDF file. (source of code) https://acrobatusers.com/forum/general-acrobat-topics/search-text-pdf-vba-only-adobe-reader-installed/ . I tried this source because I do not have Adobe Professional, and due to the state of my company, requests like this will take atleast one month to process - and may still be denied. So I have to try and make this work without Adobe Professional.
As of now, when I try to run/test this code, it returns an error
"Compile error: User-defined type not defined"
and it highlights the Dim gAvDoc As Acrobat.AcroAVDoc portion of the code. Which suggests to me that I am missing something in the reference. I've tried selecting seemingly related references with no success.
Can anyone let me know if the missing reference is the issue? If so, what reference do I need to select to get the code to work. These are the references I currently have checked:
'Visual Basic For Applications';
'Microsoft Excel 14.0 Object Library';
'OLE Automation';
'Microsoft Office 14.0 Object Library';
'Adobe Acrobat Browser Control Type Library 1.0';
'Adobe Reader File Preview Type Library';
'Attachmate_Reflection_Objects';
'Attachmate_Reflection_Objects_Emulation_IbmHosts';
'Attachmate_Reflection_Objects_Emulation_OpenSystems';
'Attachmate_Reflection_Objects_Framework';
'Acrobat Access 3.0 Type Library'; 'AcroBrokerLib';
'Active DS Type Library';
'Microsoft ActiveX Data Objects 2.0 Library';
'Microsoft ActiveX Data Objects (Multi-dimensional) 6.0 Library'
I'm also running Windows 10 with Microsoft Excel 2010
Option Explicit
Sub SearchPDF_forString()
Dim gAvDoc As Acrobat.AcroAVDoc 'Robby change, "Acrobat.AcroAVDoc" to "Object"
Dim gPDFPath As String
Dim foundText As Integer 'Holds return value from "FindText" method
Dim Rsp 'For message box responses
Dim sText As String 'Robby Addition
Dim sStr As String 'Robby Addition
Dim resp As String 'Robby Addition
gPDFPath = "\\DTCHYB-MNMH001\C_WBGCTS_Users\U658984\My Documents\QC_random\DuplicateFormProject_ForKevin\1099DALL_1.pdf"
'set AVDoc object for searching
Set gAvDoc = CreateObject("AcroExch.AVDoc")
If gAvDoc.Open(gPDFPath, "") Then
sText = "041-3600122117"
'FindText params: StringToSearchFor, caseSensitive (1 or 0), WholeWords (1 or 0), ResetSearchToBeginOfDocument (1 or 0)
foundText = gAvDoc.FindText(sText, 1, 0, 1) 'Returns -1 if found, 0 otherwise
Else
' if failed, show error message
Rsp = MsgBox("Cannot open" & gPDFPath, vbOKOnly)
End If
If foundText = -1 Then
'compose a message
sStr = "Found " & sText
resp = MsgBox(sStr, vbOKOnly)
Else
' if failed, show error message
resp = MsgBox("Cannot find" & sText, vbOKOnly)
End If
End Sub
I'm trying to search an MS Word doc for embedded Excel files and save them to a different location.
1) I want to record the page number and or section name (based on header style) the embedded file was located in the Word Doc. How can I extract this info?
2) Is there anyway to get the original filename of the embedded Excel file?
Here is the code I'm using to search for embedded files. Originally
Working off the code first presented here: Extract Embeded Excel Workseet Data
Sub TestMacro2()
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Dim lNumShapes As Long
Dim lShapeCnt As Long
Dim xlApp As Object
Dim wrdActDoc As Document
Dim iRow As Integer
Dim iCol As Integer
Set wrdActDoc = ActiveDocument
For lShapeCnt = 1 To wrdActDoc.InlineShapes.Count
If wrdActDoc.InlineShapes(lShapeCnt).Type = wdInlineShapeEmbeddedOLEObject Then
If wrdActDoc.InlineShapes(lShapeCnt).OLEFormat.ProgID = "Excel.Sheet.8" Then
wrdActDoc.InlineShapes(lShapeCnt).OLEFormat.Edit
Set xlApp = GetObject(, "Excel.Application")
cpath = "location of interest"
xlApp.Workbooks(1).SaveAs cpath & " " & lShapeCnt
xlApp.Workbooks(1).Close
xlApp.Quit
Set xlApp = Nothing
End If
End If
Next lShapeCnt
End Sub
Note: Your code would be more efficient (and easier to read) if you assign an object that's re-used to a variable:
Dim ils as Word.InlineShape
Set ils = wrdActDoc.InlineShapes(lShapeCnt)
(1) The Range.Information method can return the page number. Something like:
Dim pageNumber as Long
pageNumber = ils.Range.Information(wdwdActiveEndPageNumber)
The other option is not as straight forward... I expect you really mean Heading style, not Header style. There is a built-in bookmark that will get the Heading preceding the current selection. That would be something like:
Dim secName as String
ils.Range.Select
secName = ActiveDocument.Bookmarks("\HeadingLevel").Range.Text
(2) If the file is not linked then your chances are slim. There's nothing VBA can get at directly, that's certain. Possibly, something might be stored in the WordOpenXML. You can check that by downloading the Open XML SDK Productivity Tool, opening such a document in it and inspecting that part of the Open XML. If it's in there then you can get at it in VBA using ils.Range.WordOpenXML to get the Open XML for the InlineShape, then parse that.
I have to know how can i link the excel database of Instrument loop Diagram in AutoCad format. I have AutoCad Template for a loop typical and Excel Database in which i have 100 Loops information for particular typical.I have AutoCad 2006,2007 and 2011 with me. please suggest idea for linking and generating he AutoCAD Drawings automatically.
The easiest way would be to learn a bit of AutoLisp, which is really worth learning if you're into generating drawings or automating your processes within AutoCAD.
Here's a great website for learning AutoLisp:
http://www.afralisp.net/index.php
AutoDesk's Lisp forum is also a great source of help.
As for extracting the data from Excel, here is a library which really facilitates access from AutoLisp:
http://download.cnet.com/KozMos-VLXLS/3000-2077_4-94214.html
'General rule: excel and acad have to be same like both 64bit or both 32 bit !!!
' You will need to add a reference to the AutoCAD
' Type Library to run this example book. Use the "Tools -
' References" menu. If you prefere you can switch to late
' binding by changeing the AutoCAD types to generic objects
Public Sub Excel_drives_acadPolyline_import_POINTs()
Dim objApp As AcadApplication
Dim objDoc As AcadDocument
Dim objEnt As AcadEntity
Dim varPnt As Variant
Dim strPrmpt As String
Dim intVCnt As Integer
Dim varCords As Variant
Dim varVert As Variant
Dim varCord As Variant
Dim varNext As Variant
Dim intCrdCnt As Integer
On Error GoTo Err_Control
Set objApp = AINTERFACE.Iapp
Set objDoc = objApp.activedocument
AppActivate objApp.CAPTION
objDoc.Utility.GetEntity objEnt, varPnt
If TypeOf objEnt Is AcadLWPolyline Then
AppActivate ThisDrawing.applicaTION.CAPTION
varCords = objEnt.COORDINATES
For Each varVert In varCords
intVCnt = intVCnt + 1
Next
For intCrdCnt = 0 To intVCnt / 2 - 1
varCord = objEnt.COORDINATE(intCrdCnt)
Excel.applicaTION.Cells(intCrdCnt + 1, 1).value = varCord(0)
Excel.applicaTION.Cells(intCrdCnt + 1, 2).value = varCord(1)
Next intCrdCnt
Else
MsgBox "Selected entity was not a LWPolyline"
End If
Exit_Here:
If Not objApp Is Nothing Then
Set objApp = Nothing
Set objDoc = Nothing
End If
Exit Sub
Err_Control:
'debug.print err.DESCRIPTION
Resume Exit_Here
End Sub
'----------------------------------------------------------------
' You will need to add a reference to the Excel
' Type Library to run this.In case of excel excel.exe is the library !
Sub acad-drives_excel()
Dim xAP As Excel.applicaTION
Dim xWB As Excel.Workbook
Dim xWS As Excel.WorkSheet
Set xAP = Excel.applicaTION
Set xWB = xAP.Workbooks.Open(SLOPEDIR.PROJECT & "\A2K2_VBA\IUnknown.xls")
Set xWS = xWB.Worksheets("Sheet1")
MsgBox "Excel says: """ & Cells(1, 1) & """"
Dim A2K As AcadApplication
Dim A2Kdwg As AcadDocument
Set A2K = AINTERFACE.Iapp
Set A2Kdwg = A2K.applicaTION.documents.Add
MsgBox A2K.NAME & " version " & A2K.version & _
" is running."
Dim HEIGHT As Double
Dim p(0 To 2) As Double
Dim TxtObj As ACADTEXT
Dim TxtStr As String
HEIGHT = 1
p(0) = 1: p(1) = 1: p(2) = 0
TxtStr = Cells(1, 1)
Set TxtObj = A2Kdwg.modelspace.AddText(TxtStr, _
p, HEIGHT)
A2Kdwg.SaveAs SLOPEDIR.PROJECT & "\A2K2_VBA\IUnknown.dwg"
A2K.documents.Close
A2K.Quit
Set A2K = Nothing
xAP.Workbooks.Close
xAP.Quit
Set xAP = Nothing
End Sub
Whatever way you choose now you can draw into the autocad drawing by using VBA.
There is another way for non programmers.
AUTOCAD SCRIPT
in fact you can create a excel table which creates this things and then you can export them to a text file. For simple task a solution but crap if you hase more complex things to do.
And last but not least you can create dynamic blocks and use vba to insert them and set the values of their parameters according to your excel sheet. But this would explode this tiny post