VBA to Copy Text String from PDF - vba

I've started using the following code to identify a text string in a PDF. It works great, however, I'm wondering if there is a way to copy the entire row from the PDF into excel once the text has been found? I'm not very familiar with using VBA code to pull from PDFs so I'm kind of stuck at the moment. Any help is appreciated!!
Sub AcrobatFindText2()
'variables
Dim Resp 'For message box responses
Dim gPDFPath As String
Dim sText As String 'String to search for
Dim sStr As String 'Message string
Dim foundText As Integer 'Holds return value from "FindText" method
'hard coding for a PDF to open, it can be changed when needed.
gPDFPath = "C:\Users\Me\Documents\test.pdf"
'Initialize Acrobat by creating App object
Set gApp = CreateObject("AcroExch.App", "")
gApp.Hide
'Set AVDoc object
Set gAvDoc = CreateObject("AcroExch.AVDoc")
' open the PDF
If gAvDoc.Open(gPDFPath, "") Then
sText = "Designation"
'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
Resp = 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
gApp.Show
gAvDoc.BringToFront
End Sub

Related

VBA Word - delete certain pages - error 5904 - cannot edit Range

I want to delete certain pages from a Word doc.
To do this I used the code from
https://www.extendoffice.com/documents/word/5503-word-delete-multiple-pages.html
Sub DeletePagesInDoc()
Dim xRange As Range
Dim xPage As String
Dim xDoc As Document
Dim xArr
Dim I, xSplitCount As Long
Application.ScreenUpdating = False
Set xDoc = ActiveDocument
xPage = InputBox("Enter the page numbers of pages to be deleted: " & vbNewLine & _
"use comma to separate numbers", "KuTools for Word", "")
xArr = Split(xPage, ",")
xPageCount = UBound(xArr)
For I = xPageCount To 0 Step -1
Selection.GoTo wdGoToPage, wdGoToAbsolute, xArr(I)
xDoc.Bookmarks("\Page").Range.Delete
Next
Application.ScreenUpdating = True
End Sub
However, I receive the following error message:
Run-time error '5904':
Cannot edit Range.
This line produces the error:
xDoc.Bookmarks("\Page").Range.delete
I am sure I entered the pagenumbers correctly (separated by commas, and without spaces)
EDIT: mysteriously, the error solved itsself and no longer appears now! Thanks for the replies.

Error: -2147188160 Slides.Item: Integer out of range.2 is not in in index's valid range of 1 to 1 VBA power point error

I'm trying to extract few specific slide numbers from each ppt and trying to paste them into a single ppt using VBA.But Im facing this error.Im quite new to VBA ,so it would be of great help how to proceed further.
Tried with the suggestions given in the link https://support.microsoft.com/en-us/help/285472/run-time-error-2147188160-on-activewindow-or-activepresentation-call-i#:~:text=This%20behavior%20is%20caused%20by,code%20will%20cause%20this%20error.
But it is not working
Thanks in Advance
My code is as follows:
Sub sample()
Dim objPresentation As Presentation
On Error GoTo ErrorHandler
Dim sListFileName As String
Dim sListFilePath As String
Dim iListFileNum As Integer
Dim sBuf As String
' EDIT THESE AS NEEDED
' name of file containing files to be inserted
sListFileName = "LIST2.TXT"
' backslash terminated path to folder containing list file:
sListFilePath = "path"
' Do we have a file open already?
If Not Presentations.Count > 0 Then
Exit Sub
End If
' If LIST.TXT file doesn't exist, create it
If Len(Dir$(sListFilePath & sListFileName)) = 0 Then
iListFileNum = FreeFile()
Open sListFilePath & sListFileName For Output As iListFileNum
' get file names
sBuf = Dir$(sListFilePath & "*.PPT")
While Not sBuf = ""
Print #iListFileNum, sBuf
sBuf = Dir$
Wend
Close #iListFileNum
End If
iListFileNum = FreeFile()
Open sListFilePath & sListFileName For Input As iListFileNum
' Process the list
While Not EOF(iListFileNum)
' Get a line from the list file
Line Input #iListFileNum, sBuf
' Verify that the file named on the line exists
If Dir$(sBuf) <> "" Then
Dim SlideArray As Variant
'Set variable to Active Presentation
Set OldPPT = ActivePresentation
'Create a brand new PowerPoint presentation
If PowerPoint.Application.Version >= 9 Then
'window must be visible
PowerPoint.Application.Visible = msoTrue
End If
Set NewPPT = Presentations.Add
InSlides = InputBox("List the slide numbers separated by commas:", "Slides", 2)
SlideArray = Split(InSlides, ",")
For x = 0 To UBound(SlideArray)
sld = CInt(SlideArray(x))
'Set variable to a specific slide
Set Old_sld = OldPPT.Slides(sld)
'Copy Old Slide
y = Old_sld.SlideIndex
Old_sld.Copy
'Paste Slide in new PowerPoint
NewPPT.Slides.Paste
Set New_sld = Application.ActiveWindow.View.Slide
'Bring over slides design
New_sld.Design = Old_sld.Design
'Bring over slides custom color formatting
New_sld.ColorScheme = Old_sld.ColorScheme
'Bring over whether or not slide follows Master Slide Layout (True/False)
New_sld.FollowMasterBackground = Old_sld.FollowMasterBackground
Next x
End If
Wend
Close #iListFileNum
MsgBox "DONE!"
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub

In Excel-Word Interop, how do I use the File Object after using the Name function to rename it?

Overall objective: create an Excel-based file converter that interops with Word, changing several built-in document properties, header/footer text & pics, watermark, and file name. The new attributes/text/file paths are found in cells. After changing all these attributes, et al, the file is to be copied as a regular .docx to a new Output folder and also exported as a PDF to a separate PDF Output folder. Optionally the files in the input folder will be deleted after the other steps are completed.
Specific problem: After I rename any of the files using the Name function, the File Object (I'm using File Scripting Object) loses its reference to the old file (since it's renamed), but does not pick up on the new, renamed file. After renaming the file, I would like to make a copy of it into the word document output folder; then, with the original, I would export it to the PDF output folder. Finally, I would either delete it or leave it alone, depending on an optional boolean.
I have attempted to re-assign the File Object with the new file, but this doesn't seem to be possible, and nothing else in its properties or methods makes sense to use.
Sub ChangeProperties()
Dim wordApp As Word.Application
Dim wordDoc() As Word.Document
Dim fso As New FileSystemObject
Dim fo(3) As Folder
Dim f As file
Dim cvSht As Worksheet
Dim fileSht As Worksheet
Dim progShp As Shape
Dim fileRng(0 To 13) As Range
Dim optRng As Range
Dim i As Long
Dim n As Long
Dim count As Long
Set wordApp = Word.Application
' Dashboard sheet
Set cvSht = Sheets("Convert")
' Sheet where user types new attributes or views old attributes
Set fileSht = Sheets("FileAttributes")
' Folder objects
Set fo(1) = fso.GetFolder(cvSht.Range("F3").Value)
Set fo(2) = fso.GetFolder(cvSht.Range("F5").Value)
Set fo(3) = fso.GetFolder(cvSht.Range("F7").Value)
ChDir (fo(1) & Application.PathSeparator)
Set optRng = cvSht.Range("H13")
' Just some user-defined true/false input cells
optERR = optRng
optMSG = optRng.Offset(1, 0)
optPDF = optRng.Offset(2, 0)
optDOC = optRng.Offset(3, 0)
optRMV = optRng.Offset(4, 0)
' Run some pre-execution checks to prevent catastrophic failure
If fo(1).Files.count > 20 Then
MsgBox "Too many files in folder. Please only 20 files at a time.", vbOKOnly, "Error!"
Exit Sub
End If
For i = 0 To 13
Set fileRng(i) = fileSht.Range("D27").Offset(0, i)
Next
n = 1
If InStr(1, fileRng(0).Offset(n - 1, 0), "doc") = 0 Then
MsgBox "New file names must end with a proper extension, i.e. - .docx", vbCritical, "Terminating Process!"
Exit Sub
End If
For Each f In fo(1).Files
For i = 0 To fo(1).Files.count
If fileRng(0).Value = f.Name Then
MsgBox "New file names must be different from the existing file names! Aborting...", vbCritical, "Terminating Process!"
Exit Sub
End If
Next
Next
For Each f In fo(1).Files
If optERR = False Then On Error Resume Next
If Left(f.Name, 1) = "~" Then GoTo Nxt
Set wordDoc(n) = wordApp.Documents.Open(f.Path)
' -------- Clipped out middle parts for clarity ---------
If fileRng(0).Offset(n - 1, 0) <> "" Then
End If
On Error GoTo 0
wordDoc(n).Save
Application.Wait Now + 0.00003
Application.StatusBar = "Processing..." & n & "/" & fo(1).Files.count
If optPDF Then
If Right(f, 1) = "x" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".docx", ".pdf"), wdExportFormatPDF
ElseIf Right(f, 1) = "c" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".doc", ".pdf"), wdExportFormatPDF
ElseIf Right(f, 1) = "m" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".docm", ".pdf"), wdExportFormatPDF
End If
End If
wordDoc(n).Close
**Name f.Name As fileRng(0).Offset(n - 1, 0).Value** ' Causes the next lines to fail
**Set f = fileRng(0).Offset(n - 1, 0).Value** ' Attempt to reassign fails
**If optDOC Then f.Copy (fo(3) & "/")** ' This would fail too
If optRMV Then f.Delete
Nxt:
On Error GoTo 0
n = n + 1
Next
End Sub

VBA for Outlook not parsing email correctly

I am writing a VBA for outlook that will go through emails in my specific folder and go through the email's body and parse a specific line and then save it to an excel file. So far I am not getting any errors and when I run it, it saves an Excel file, but its only prints out an "email" string that I echo within the program, it's not parsed.
So I am having a bit of a problem parsing the proper information from the emails in the outlook folder. In matter of fact, I'm not sure if it's even parsing anything at all.
For iCtr = 1 To OutlookNameSpace.Folders.Item(1).Folders.Count
' handle case sensitivity as I can't type worth a crap
If LCase(OutlookNameSpace.Folders.Item(1).Folders(iCtr).Name) = LCase(strTargetFolder) Then
'found our target :)
Set outlookFolder = OutlookNameSpace.Folders.Item(1).Folders(iCtr)
Exit For ' found it so lets move on
End If
Next
'set up a header for the data dump, this is for CSV
strEmailContents = "Email" & vbCrLf
'likely should have some error handling here, in case we have found no target folder
'Set myFolderItem = outlookFolder.Items
' I have commenteted out some items to illustrate the call to Sue'strEmailContents Function
If Not outlookFolder Is Nothing Then
For Each outlookMessage In outlookFolder.Items
If TypeOf outlookMessage Is MailItem Then
strMsgBody = outlookMessage.Body ' assign message body to a Var
' then use Sue Moshers code to look for stuff in the body
' all of the following stuff in the quotes "" is specific to your needs
strEmailContents = strEmailContents & ParseTextLinePair(strMsgBody, "E-mail: ")
strEmailContents = strEmailContents & "," & ParseTextLinePair(strMsgBody, "")
'add the email message time stamp, just cause i want it
'debug message comment it out for production
'WScript.echo strEmailContents
End If
Next
End If
Here is my function to parse the lines:
Function ParseTextLinePair(strSource, strLabel)
' Sue Moshers code
'commented out type declaration for VBS usgage take out fer VB usage
Dim intLocLabel 'As Integer
Dim intLocCRLF 'As Integer
Dim intLenLabel 'As Integer
Dim strText 'As String
' locate the label in the source text
intLocLabel = InStr(strSource, strLabel)
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText) ' this i like
End Function
Here is an example of an email I am trying to parse; i have put it in code format so it is easier to read.
Vendor: 22***********
Your company may be interested in the following advertisement(s).
To learn more about the advertisements below, please visit the
******** Vendor Bid System (VBS) at
http://www.****************.com. For specific
questions about the solicitation, each advertisement includes
contact information for the agency representative who issued it.
to view additional information on the advertisement(s) listed
below.
____________________________________________________________
Agency: ***************************************
Agency Ads: http://www.*************.com
Advertisement Number: ******BLACKEDOUT INFO***********
Advertisement Type: Informational Notice
Title: Centralized Customer Service System (CCSS) - Notice of Public Meeting
Advertisement Status: New
Agency Contact: Sheree *****
E-mail: blah#aol.com
Telephone: (000)-000-0000
Thank you in advanced!!
EDIT
Alright sir, give this a shot. Make sure you designate your folder and searchtext at the top. A message box will popup once the email has been extracted.
Sub ParseContents()
Dim strTargetFolder : strTargetFolder = "Inbox"
Dim SearchText: SearchText = "Email: "
Dim NS As outlook.NameSpace
Dim oFld As outlook.Folder
Set NS = Application.GetNamespace("MAPI")
For ifld = 1 To NS.Folders.Count
For ictr = 1 To NS.Folders.Item(ifld).Folders.Count
' handle case sensitivity as I can't type worth a crap
If LCase(NS.Folders.Item(ifld).Folders(ictr).Name) = LCase(strTargetFolder) Then
'found our target :)
Set oFld = NS.Folders.Item(ifld).Folders(ictr)
Exit For ' found it so lets move on
End If
Next
Next
'set up a header for the data dump, this is for CSV
strEmailContents = "Email" & vbCrLf
Dim EscapeLoops: EscapeLoops = False
'likely should have some error handling here, in case we have found no target folder
'Set myFolderItem = outlookFolder.Items
' I have commenteted out some items to illustrate the call to Sue'strEmailContents Function
If Not oFld Is Nothing Then
For Each outlookMessage In oFld.Items
If TypeOf outlookMessage Is MailItem Then
If InStr(outlookMessage.Body, SearchText) Then
strMsgBody = outlookMessage.Body ' assign message body to a Var
' then use Sue Moshers code to look for stuff in the body
' all of the following stuff in the quotes "" is specific to your needs
Dim splitter, parsemail: splitter = Split(strMsgBody, vbCrLf)
For Each splt In splitter
If InStr(splt, SearchText) Then
parsemail = splt
EscapeLoops = True
Exit For
End If
Next
strEmailContents = strEmailContents & "Date/Time: " & outlookMessage.CreationTime & vbCrLf
strEmailContents = strEmailContents & ParseTextLinePair(parsemail, SearchText)
MsgBox strEmailContents
If EscapeLoops Then Exit For
End If
End If
Next
End If
End Sub
Function ParseTextLinePair(strSource, strLabel)
Dim Rturn
If InStr(strSource, vbCrLf) Then
Rturn = Mid(strSource, InStr(strSource, strLabel) + Len(strLabel), InStr(strSource, vbCrLf) - InStr(strSource, strLabel) + Len(strLabel)):
Else
Rturn = Mid(strSource, InStr(strSource, strLabel) + Len(strLabel))
End If
ParseTextLinePair = Trim(Rturn)
End Function

Open PowerPoint from directory and resume macro

I'm trying to open a PPTX from a specific folder using a Function within a Sub. The function's purpose is to choose the file that the rest of the macro's code will perform it on (essentially to make it the ActivePresentation) The problem is that when I call the function PickDir() to get the file's path and open it, the macro stops running. So, I just get an open presentation and not performing the action I want it to do.
The problem occurs about 5 lines after all the variables are Dim'd.
Sub ExtractImagesFromPres()
On Error GoTo ErrorExtract
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim ImgCtr As Integer
Dim SldCtr As Integer
Dim ShapeNameArray() As String
Dim oPP As Object
Dim SrcDir As String
Dim SrcFile As String
'File naming variables
Dim PPLongLanguageCode As String
Dim PPShortLanguageCode As String
Dim FNShort As String
Dim FNLong As String
Dim PPLanguageParts1() As String
Dim PPLanguageParts2() As String
Dim FNLanguageParts() As String
SrcDir = PickDir() 'call the PickDir() function to choose a directory to work from
If SrcDir = "" Then Exit Sub
SrcFile = SrcDir & "\" & Dir(SrcDir + "\*.pptx") 'complete directory path of ppt to be split
Set oPP = CreateObject("Powerpoint.Application") 'open ppt containing slides with images/text to be exported
ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
ImgCtr = 0 'Image and Slide counter for error messages
SldCtr = 1
ReDim ShapeNameArray(1 To 1) As String 'initialize ShapeNameArray to avoid null array errors
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes 'loop each shape within each slide
If oShpSource.Type <> msoPlaceholder Then 'if shape is not filename placeholder then add it's name to ShapeNameArray
ShapeNameArray(UBound(ShapeNameArray)) = oShpSource.Name
ReDim Preserve ShapeNameArray(1 To UBound(ShapeNameArray) + 1) As String 'need to add one to array for new shape name
ElseIf oShpSource.Type = msoPlaceholder Then 'is shape is filename placeholder then check to see if not empty
If oShpSource.TextFrame.TextRange.Length = 0 Then
MsgBox "The filename is missing on Slide:" & SldCtr & vbNewLine & _
"Please enter the correct filname and re-run this macro"
Exit Sub
End If
PPLanguageParts1 = Split(ActivePresentation.Name, ".") 'extract language code from PowerPoint filename
PPLongLanguageCode = PPLanguageParts1(LBound(PPLanguageParts1))
PPLanguageParts2 = Split(PPLongLanguageCode, "_")
PPShortLanguageCode = PPLanguageParts2(UBound(PPLanguageParts2))
FNLanguageParts = Split(oShpSource.TextFrame.TextRange.Text, "_") 'insert PowerPoint filename language code into image filename language code
FNShort = FNLanguageParts(LBound(FNLanguageParts))
FNLong = FNShort & "_" & PPShortLanguageCode
oShpSource.TextFrame.TextRange.Text = FNLong
End If
Next oShpSource
ReDim Preserve ShapeNameArray(1 To UBound(ShapeNameArray) - 1) As String 'ShapeNameArray has one too many elements, so subtract one
Call oSldSource.Shapes.Range(ShapeNameArray).Export(FNLong & ".jpg", ppShapeFormatJPG) 'export images with proper filenames
ReDim ShapeNameArray(1 To 1) As String
ImgCtr = ImgCtr + 1
SldCtr = SldCtr + 1
Next oSldSource
If ImgCtr = 0 Then 'error message if no images
MsgBox "There were no images found in this presentation", _
vbInformation, "Image extraction failed."
End If
Exit Sub
ErrorExtract:
If Err.Number <> 0 Then 'error message log
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
End If
End Sub
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = ""
Set FD = Application.FileDialog(msoFileDialogFolderPicker) 'initialize default MS directory picker
With FD
.Title = "Pick the folder where your files are located" 'title for directory picker dialog box
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
Are you running this from within powerpoint? If yes, you don't need to create another Application object: you can just open the ppt directly. And you can use the return value from Open() to get a reference to the presentation (rather than using "activePresentation")
Dim ppt as Presentation
Set ppt = Application.Presentations.Open(SrcFile, False, False, True)
'do stuff with ppt
This line is probably giving you some trouble:
ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
I don't know how to activate a window in PPT but at the very least you'll need to use the following:
Set ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
As for activating the presentation, you may need to access the windows collection, or something similar? A suggestion, hopefully to get you thinking.
application.Presentations(1).Windows(1).Activate
Finally, you may actually not need to activate the presentation, if you have no other presentations open, the one you're opening will quite likely be the active one by default, if you open it visible. I suspect this is the case, given that you are creating the powerpoint application object. If this is correct then you simply need to do the following:
oPP.Presentations.Open(SrcFile, False, False, True)
debug.print oPP.ActivePresentation.Name
Edit: I'd also recommend setting a reference to the powerpoint object library and declaring oPP as follows:
Dim oPP as Powerpoint.Application
Then when creating an instance of the application:
Set oPP = New Powerpoint.Application
If you don't want to have to worry about which presentation is active, you can do:
Dim oPres as Presentation
Set oPres = oPP.Presentations.Open(SrcFile, False, False, True)
Then in the rest of the code, use oPres instead of ActivePresentation