Opening pdf files through MS-Word - vba

I am trying to open a pdf file through MS Word, perform certain action such as evaluating calculations, printing the files, etc. and then proceed with closing the file. The error message I received is "Microsoft Excel is waiting for another application to complete an OLE action."
I have previously tried hyperlinkfollow and Shell MyPath & " " & MyFile, vbNormalFocus method, it doesn't work. I am still at the starting phase of opening the pdf files, please advice. Thanks!
Sub Extract_PDF_Data()
Dim mainData As String
Dim strFile As String
Dim Oldname As String
Dim Newname As String
Dim Folderpath As String
Dim s As String
Dim t As Excel.Range
Dim wd As New Word.Application
Dim mydoc As Word.Document
Folderpath = InputBox("Folder path: ")
Folderpath = Folderpath & "\"
strFile = Dir(Folderpath & "", vbNormal)
Do While Len(strFile) > 0
Oldname = Folderpath & strFile
Set wd = CreateObject("Word.Application")
Set mydoc = Word.Documents.Open(Filename:=Oldname, Format:="PDF Files",
ConfirmConversions:=False)
mainData = mydoc.Content.Text
mydoc.Close False
wd.Quit
strFile = Dir
Loop
End Sub

Don't us the New keyword in the line that declares the object variable. This will "block" the object variable - it causes the error when the code laters tries to instantiate it. This method can work in VB.NET but not in VBA.
Do it more like this:
Dim wd As Word.Application
Set wd = New Word.Application. 'Or use CreateObject

I think a combination of those three sources will lead to the answer:
How to open a pdf with Excel?
How to extract data from pdf using VBA?
How to open and print a pdf using VBA?
I think it will be something like this:
Sub Extract_PDF_Data()
Dim mainData As String
Dim strFile As String
Dim Oldname As String
Dim Newname As String
Dim Folderpath As String
Dim s As String
Dim t As Excel.Range
Dim Appshell As Variant
Dim ap As String
Dim Browsedir As Variant
Dim f As Variant
Dim KeyWord As String
' This is a suggestion, I use it because it is more convenient than copy-pasting folder paths
Dim FSO As Object
Set FSO = CreateObject("Scripting.Filesystemobject")
' Get Folder over user input
Set Appshell = CreateObject("Shell.Application")
Set Browsedir = Appshell.BrowseForFolder(0, "Select a Folder", &H1000, "E:\Xample\Path")
' check if not cancalled
If Not Browsedir Is Nothing Then
Folderpath = Browsedir.items().Item().Path
Else
GoTo Quit
End If
KeyWord = "The_Materialist_Example"
' go through all files in the folder
For Each f In FSO.GetFolder(Folderpath).Files
' if file is a pdf , open, check for keyword, decide if should be printed
If LCase(Right(f.Name, 3)) = "pdf" Then
' Here the methods suggest different answers.
' You can either use FollowHyperLink or use the Adobe Library to OPEN PDF
' I would write a function that checks the active pdf for the keyword : IsKeyFound
Debug.Print Folderpath & "\" & f.Name
Call PrintPDF(Folderpath & "\" & f.Name)
If IsKeyFound(f, KeyWord) Then
f.Print
End If
End If
Next f
Quit:
End Sub
Private Sub PrintPDF(strPDFFileName As String)
Dim sAdobeReader As String 'This is the full path to the Adobe Reader or Acrobat application on your computer
Dim RetVal As Variant
sAdobeReader = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
'Debug.Print sAdobeReader & "/P" & Chr(34) & strPDFFileName & Chr(34)
RetVal = Shell(sAdobeReader & " /P " & Chr(34) & strPDFFileName & Chr(34), 0)
End Sub
Private Function IsKeyFound(PDF As Variant, KeyWord As String) As Boolean
'Decide if file needs to be printed, insert your criteria and search algorithm here
End Function
I have not been able to figure out how to extract the keywords, you could however use a user input as a first approach and later move on to a automated scan of the pdf.
I hope this gets you further on the way to the solution.

Related

Through FSO VBA - Files are not moving, please go through my code, I don't understand why files are not moving. I am trying to execute it but msg box

Please go through my code, correct me where I am wrong, files are not moving from folder to folder.
Option Explicit
Sub MoveFiles()
Dim FSO As Object
Dim FromDir As String
Dim ToDir As String
Dim FExtension As String
Dim Fnames As String
FromDir = "C:\Users\B\Source Folder"
ToDir = "C:\Users\B\Destination Folder"
FExtension = "*.*"
Fnames = Dir(FromDir & FExtension)
If Len(Fnames) = 0 Then
MsgBox "No files or Files already moved" & FromDir
Exit Sub
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile Source:=FromDir & FExtension, Destination:=ToDir
End Sub
Problem
You are missing a \ at the end of your FromDir which will separate the path from your filenames.
For your info: & is not really combining path and filename, but just concatenating two strings, so it never adds the \ itself.
Correction possibility 1
You can add it to the definition of FromDir:
FromDir = "C:\Users\B\Source Folder\"
Correction possibility 2
Add it to these lines of code dynamically:
Fnames = Dir(FromDir & "\" & FExtension)
FSO.MoveFile Source:=FromDir & "\" & FExtension, Destination:=ToDir
Another remark
You should also separate FromDir from the error text, like this:
MsgBox "No files or Files already moved: " & FromDir

How to edit a .bat file with Excel VBA

I'm developing an Excel Add-in for .bat / .vbs files. The add-in has 2 options (1) create a new .bat / and .vbs file and (2) modify an existing .bat and .vbs file.
The "create" option is working great and does exactly what we need it to do.
I'm having issues with the "modify" piece. When the user selects "modify", and Excel form is displayed with a List Box. The user scrolls through the list and selects the one they need to modify. So far so go.
The next step is for the add-in to open (not run) both the .bat and .vbs file. I've been able to get the .bat file to execute; which in turns executes the .vbs file. But that is not what I need it to do.
If I was going to manually open the .bat or .vbs file. I would right click on the .bat or .vbs file and select "edit". The appropriate file opens in NotePad. I can then make any changes and save the file.
What I'm looking duplicate is the "right click and select edit steps" with VBA.
Any suggestions would be greatly appreicated. Thanks for your help in advance....
I am not familiar with Add-Ins, sorry if misleading. This does work in normal code:
Assume there is a userform frmTest7 with TextBox1, ListBox1 and CommandButton1 (to save changes). The userform code as follows.
Option Explicit
Private Sub CommandButton1_Click()
Dim fso As FileSystemObject
Dim oFile As TextStream
Dim FilePath As String
Dim strFile As String
FilePath = "C:\Users\" & Environ("UserName") & "\desktop\test_bat.bat"
Dim i As Long
For i = 0 To frmTest7.ListBox1.ListCount - 1
strFile = strFile & frmTest7.ListBox1.List(i) & vbCrLf
Next i
Set fso = New FileSystemObject
If fso.FileExists(FilePath) Then
'fso.DeleteFile (FilePath)
Set oFile = fso.CreateTextFile(FilePath, True)
oFile.WriteLine strFile
End If
If Not (oFile Is Nothing) Then oFile.Close
Set oFile = Nothing
Set fso = Nothing
End Sub
Private Sub ListBox1_Click()
frmTest7.TextBox1.Text = frmTest7.ListBox1.List(frmTest7.ListBox1.ListIndex)
End Sub
Private Sub TextBox1_AfterUpdate()
frmTest7.ListBox1.List(frmTest7.ListBox1.ListIndex) = frmTest7.TextBox1.Text
End Sub
Private Sub UserForm_Activate()
Dim fso As FileSystemObject
Dim oFile As TextStream
Dim FilePath As String
Dim strFile As String
FilePath = "C:\Users\" & Environ("UserName") & "\desktop\test_bat.bat"
Set fso = New FileSystemObject
Set oFile = fso.OpenTextFile(FilePath, ForReading)
strFile = oFile.ReadAll
oFile.Close
Dim arrStrFile() As String
strFile = Replace(strFile, vbCr, "")
arrStrFile = Split(strFile, Chr(10))
frmTest7.ListBox1.Clear
frmTest7.ListBox1.List = arrStrFile
Set oFile = Nothing
Set fso = Nothing
End Sub
I found a way to do this but not sure whether it works for you or not.
1. We cannot open .bat files but we can open .txt files so I converted the .bat file to .txt file and opening it using hyperlink.
In below example, Reminder is a .bat file and on clicking the Open button it converts the Reminder.bat to Reminder.txt and opens the file.
Sub RenameFileExtensionFromBatToTextAndOpen()
Dim fileName As String
Dim fileLocation As String
Dim originalExtension As String
Dim renamedExtenstion As String
fileLocation = "C:\Users\Nandan\Downloads\"
fileName = Sheets("Sheet1").Range("B5")
originalExtension = fileLocation & fileName & ".bat"
renamedExtenstion = fileLocation & fileName & ".txt"
Name originalExtension As renamedExtenstion
ActiveWorkbook.FollowHyperlink Address:=renamedExtenstion
End Sub
2. After changes saved, on clicking Done it will change the file format from Reminder.txt to Reminder.bat
Sub RenameFileExtensionFromTxtToBat()
Dim fileName As String
Dim fileLocation As String
Dim originalExtension As String
Dim renamedExtenstion As String
fileLocation = "C:\Users\Nandan\Downloads\"
fileName = Sheets("Sheet1").Range("B5")
originalExtension = fileLocation & fileName & ".bat"
renamedExtenstion = fileLocation & fileName & ".txt"
Name renamedExtenstion As originalExtension
End Sub
On opening file,
After clicking on Done,

VBA opening files which have a specific keyword in them

I have a folder which has a bunch of .xls files, of which only those which have the KEY Word " CITIES " are of interest to me. I need to open those files and collect some information and I am facing some issues.
Sub getTheExecSummary()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
myPath = "C:\Users\Morpheus\Documents\Projects\Files"
myExtension = "*.xls" 'How to add the keyword?'
myFile = Dir(myPath & myExtension)
Do While Len(myFile) > 0
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Debug.Print (myFile)
Debug.Print (wb.Name)
ActiveSheet.Range("A1").Value = wb.Name
'Get next file name
myFile = Dir
Loop
End Sub
I did write a few Debug.Print statements none of which seem to work. I want to for now print only those workbooks which have the keyword ' CITIES ' in their name.
I think that you want the Instr function.
If Instr(wb.Name, "CITIES") > 0 then .....
You might want to use "CITIES " or " CITIES " to exclude any unintentional uses of those letters, depending on how the filename is setup
Use the wildcard to identify the missing letters: *CITIES*.xls or *CITIES*.xls* if you're expecting xlsx, xlsm, etc.
Sub Test()
Dim colFiles As Collection
Dim vItem As Variant
Dim wrkBk As Workbook
Dim sPath As String
Set colFiles = New Collection
sPath = "C:\Users\Morpheus\Documents\Projects\Files\"
'you could use:
'sPath = Environ("UserProfile") & "\Documents\Projects\Files\"
EnumerateFiles sPath, "*CITIES*.xls", colFiles
For Each vItem In colFiles
Set wrkBk = Workbooks.Open(vItem)
wrkBk.Worksheets("Sheet1").Range("A1") = wrkBk.Name
Next vItem
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub

How to open a file in a Sharepoint site using VBA

I am trying to open a file with a file name which changes every week. This means that the date part on the file name is varying. Also, this file is the ONLY file inside the folder. But its file name is changing. I am using the code below but it was throwing the error, 'Run time 52: Bad file name & number'. I need your help.
Dim ThePath As String
Dim TheFile As String
ThePath = "https://ts.company.com/sites/folder1/folder2/folder3/folder4/"
TheFile = Dir(ThePath & "MANILA_ShiftRecord_*" & ".xlsx")
Workbooks.Open (ThePath & TheFile)
Thanks!
If it's only one file you can use this approach:
Dim sharepointFolder As String
Dim colDisks As Variant
Dim objWMIService As Object
Dim objDisk As Variant
Dim driveLetter As String
'Create FSO and network object
Set objNet = CreateObject("WScript.Network")
Set fs = CreateObject("Scripting.FileSystemObject")
'Get all used Drive-Letters
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\cimv2")
Set colDisks = objWMIService.ExecQuery("Select * from Win32_LogicalDisk")
'Loop through used Drive-Letters
For Each objDisk In colDisks
For i = 65 To 90
'If letter is in use exit loop and remember letter.
If i = Asc(objDisk.DeviceID) Then
j = i
Exit For
'letters which are not checked yet are possible only
ElseIf i > j Then
driveLetter = Chr(i) & ":"
Exit For
End If
Next i
'If a Drive-Letter is found exit the loop
If driveLetter <> "" Then
Exit For
End If
Next
'define path to SharePoint
sharepointFolder = "https://spFolder/Sector Reports/"
'Map the sharePoint folder to the free Drive-Letter
objNet.MapNetworkDrive driveLetter, sharepointFolder
'set the folder to the mapped SharePoint-Path
Set folder = fs.GetFolder(driveLetter)
Afterwards you can handle the folder with filesystemobject functions.

Excel to Sharepoint MapNetworkDrive error

Using Excel 2013, I'm trying to upload an excel file to sharepoint using the method below. I seem to be having an issue mapping my network drive, the error I get is "The specified device name is invalid" on the objNet.MapNetworkDrive "A: ", sFolder line.
Any help with the matter is appreciated- thanks in advance.
Sub nlsharepoint()
Dim sFolder As String
Dim sFileName As String
Dim locFolder
Dim objNet As Object
Dim FS As Object
sFolder = "\\company.sharepoint.com\sites\company\Documents\Morning%20Reports\"
sFileName = "New Line Tracker 2.xlsx"
locFolder = "C:\User\Desktop\NewLinesOutput.xlsx"
Set objNet = CreateObject("WScript.Network")
Set FS = CreateObject("Scripting.FileSystemObject")
objNet.MapNetworkDrive "A: ", sFolder
If FS.fileexists(locFolder) Then
FS.copyfile locFolder, sFolder
End If
objNet.RemoveNetworkDrive "A:"
Set objNet = Nothing
Set FS = Nothing
End Sub
I'm sure this is right, but it seems to simple so if not let me know and I'll delete.
I believe that you need to replace this line:
objNet.MapNetworkDrive "A: ", sFolder
with this:
objNet.MapNetworkDrive "A:", sFolder
There's a space after you specify the drive to map, and I don't believe that there should be.