loop through folder of PDF files - excel

I'd like to loop through a folder of PDF files and insert file into the appropriate text box of a word document.
I couldn't find much online about it, but I tried to model my code on looping through a folder of excel files... I haven't attempted to get it to insert the PDFs but am trying to tackle this problem first. BTW I have Adobe Reader and not Adobe Professional, if that helps.
I debugged the code and the error is on Set fromPDF = AcroExch.PDDoc.Open(sPath & sFile)...
Any help would be appreciated.
Sub UseTextBox()
Dim reportDoc As Object
Dim str As String
Dim tag As String
Dim pdfName As String
Set reportDoc = ActiveDocument
MsgBox reportDoc
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'match PDF to figure and insert
Set SelectFolder = Application.FileDialog(msoFileDialogFolderPicker)
With SelectFolder
.Title = "Select Directory"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo ResetSettings
sPath = .SelectedItems(1) & "\"
End With
sFile = Dir(sPath & "*pdf")
Do While sFile <> ""
Set fromPDF = AcroExch.PDDoc.Open(sPath & sFile)
pdfName = sFile
For Each objShape In reportDoc.Shapes
If objShape.Type = msoTextBox Then
str = objShape.TextFrame.TextRange.Text
If InStr(str, "(") > 0 Then
tag = BetweenParentheses(objShape.TextFrame.TextRange)
MsgBox tag
End If
End If
Next objShape
sFile = Dir
Loop
ResetSettings:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
End Sub

Where are you creating the AcroExch object? I think that might be your issue.
You may need something like:
Set MyObject = CreateObject("AcroExch.PDDoc")

Related

How to search for latest file in folder and if not found then open dialog box with restrictions?

The goal is to combine two functions or make them compatible with each other. There is errors when it comes to the part when the path of the chosen file is not refer to in the same manner as the path of the found file within the loop if available in the folder.
I get an error. See "HERE IS WHERE I GET THE ERROR" at
Dim closedBook As Workbook: Set closedBook = Workbooks.Open(sFilePath)
'main code that run is doing something like search for file within folder,
'loop and get the latest file and generates a path and name for next
'function which is to copy a sheet from the found file over to the main
'workbook and so.
'What I'm trying to to is to build a failsafe, lets say file is not pushed
'or placed whin this predestinated folder, then instead of doing nothing,
'dialog box opens up and files gets chosen instead.
Option Explicit
Sub ImportAndFormatData()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Const sFolderPath As String = "C:\Temp\"
'Search for newest file
Dim sFileName As String: sFileName = Dir(sFolderPath & "_pr11*.xlsx")
If Len(sFileName) = 0 Then Call OpenDialogBox
Dim cuDate As Date, sFileDate As Date, cuPath As String, sFilePath As String
Do Until Len(sFileName) = 0
cuPath = sFolderPath & sFileName
cuDate = FileDateTime(cuPath)
'Debug.Print "Current: " & cuDate & " " & cuPath ' print current
If cuDate > sFileDate Then
sFileDate = cuDate
sFilePath = cuPath
End If
sFileName = Dir
Loop
'Debug.Print "Result: " & sFileDate & " " & sFilePath ' print result
'Open newest file - HERE IS WHERE I GET THE ERROR
Dim closedBook As Workbook: Set closedBook = Workbooks.Open(sFilePath)
closedBook.Sheets("Analyse").Copy After:=ThisWorkbook.Sheets("PR11_P3")
closedBook.Close SaveChanges:=False
'code dose not end here but that part don't need to be included here since
'its just formatting
End Sub
In OpenDialogBox, I'm tying to enforce a specific title (only this file/report is correct source for the entire code or rather rest of the code).
See "GIVES ERROR DOSENT WORK" at
.Filters.Add "Excel filer", "_pr11*.xlsx?", 1
Sub OpenDialogBox()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Title = "Välj valfri PR11"
.Filters.Add "Excel filer", "_pr11*.xlsx?", 1 'GIVES ERROR DOSENT WORK
.AllowMultiSelect = False
If .Show = True Then
Debug.Print .SelectedItems(1)
Debug.Print Dir(.SelectedItems(1))
End If
End With
End Sub
This combines both the Dir() and FileDialog approaches:
Sub ImportAndFormatData()
Dim fSelected As String, wb As Workbook
fSelected = InputFile()
If Len(fSelected) > 0 Then
Set wb = Workbooks.Open(fSelected)
wb.Sheets("Analyse").Copy After:=ThisWorkbook.Sheets("PR11_P3")
wb.Close False
End If
End Sub
Function InputFile() As String
Const SRC_FOLDER As String = "C:\Temp\"
Dim f, fSelected As String, latestDate As Date, fdt
f = Dir(SRC_FOLDER & "*_pr11*.xlsx") 'first check the configured folder for a match
If Len(f) > 0 Then
'found matching file at specified path: loop for the newest file
Do While Len(f) > 0
fdt = FileDateTime(SRC_FOLDER & f)
If fdt > latestDate Then
fSelected = SRC_FOLDER & f
latestDate = fdt
End If
f = Dir()
Loop
InputFile = fSelected
Else
'no match at specified path - allow user selection
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Title = "Välj valfri PR11"
.Filters.Add "Excel filer", "*.xlsx" 'filter only allows extension: no filename wildcards...
.AllowMultiSelect = False
If .Show Then InputFile = .SelectedItems(1)
End With
End If
End Function

Converting multiple xlsl files to xls (97-2003 Worksheet) extension without changing the names

I am trying to loop through all the 'xlsx' files in a folder and convert them to 'xls' ( Excel 97-2003 Worksheet) format. I use the following codes but then the output files are still saved as 'xlsx' instead of 'xls'. I am a beginner and looking to learn more from others. Thanks for your help!
Sub Convert()
Dim strPath As String
Dim strFile As String
Dim strfilenew As String
Dim xWbk As Workbook
Dim xSFD, xRFD As FileDialog
Dim xSPath As String
Dim xRPath As String
Set xSFD = Application.FileDialog(msoFileDialogFolderPicker)
With xSFD
.Title = "Please select the folder contains the xls files:"
.InitialFileName = "C:\"
End With
If xSFD.Show <> -1 Then Exit Sub
xSPath = xSFD.SelectedItems.Item(1)
Set xRFD = Application.FileDialog(msoFileDialogFolderPicker)
With xRFD
.Title = "Please select a folder for outputting the new files:"
.InitialFileName = "C:\"
End With
If xRFD.Show <> -1 Then Exit Sub
xRPath = xRFD.SelectedItems.Item(1) & "\"
strPath = xSPath & "\"
strFile = Dir(strPath & "*.xlsx")
strfilenew = Dir(strPath & "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While strFile <> ""
If Right(strFile, 4) = "xlsx" Then
Set xWbk = Workbooks.Open(Filename:=strPath & strfilenew)
xWbk.SaveAs Filename:=xRPath & strfilenew, _
FileFormat:=xlExcel18
xWbk.Close SaveChanges:=True
End If
strFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There was a bit of a mix-up in your file naming, basically as evidenced by the several double-declarations that I removed. The really big mistake was here, Set xWbk = Workbooks.Open(Filename:=strPath & strfilenew) where you tried to open the old workbook by the new name. I think the confusion started here "Please select the folder contains the xls files:". Of course, this is the folder with the XLSX files. The recommended antidote is to use "meaningful" variable names but you chose to speak in riddles (like xSFD) which makes coding more difficult.
However, the code below is largely yours, and it does work.
Sub Convert()
' 230
Dim Spath As String ' path to read from (XLSX files)
Dim Rpath As String ' path to write to (XLS files)
Dim strFile As String ' loop variable: current file name
Dim Wbk As Workbook ' loop object: current workbook(strFile)
Dim Sp() As String ' split array of strFile
Dim strFileNew As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the folder contains the XLSX files:"
.InitialFileName = "C:\"
If .Show <> -1 Then Exit Sub
Spath = .SelectedItems.Item(1) & "\"
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder for outputting the new files:"
.InitialFileName = "C:\"
If .Show <> -1 Then Exit Sub
Rpath = .SelectedItems.Item(1) & "\"
End With
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
strFile = Dir(Spath & "*.xlsx")
Do While strFile <> ""
If Right(strFile, 4) = "xlsx" Then
Sp = Split(strFile, ".")
Sp(UBound(Sp)) = "xls"
strFileNew = Join(Sp, ".")
Set Wbk = Workbooks.Open(Filename:=Spath & strFile)
Wbk.SaveAs Filename:=Rpath & strFileNew, FileFormat:=xlExcel8
Wbk.Close SaveChanges:=True
End If
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Observe that the new file name is created by splitting the old name on periods, changing the last element, and reassembling the modified array.

Bad file name or number vba

my code keeps getting a bad file name or number error and I can't figure out what the issue is, any help would be appreciated! I'm trying to store the filepath based on user selection as a variable which I can reference later in a vlookup. Below is my code, I can't figure out what's wrong but I used the pasted code in another macro which compiled fine.
sub edits
dim xpath and xfile as string
xPath = NewPath 'Newpath function executes
xfile = Dir$(xPath & "*.xlsm*", vbNormal) 'error here
Set SourceBook = Workbooks.Open(xPath & xfile)
End Sub
Function NewPath() As String
With Application.FileDialog(msoFileDialogOpen)
.ButtonName = "Choose a file"
.Title = "Previous File"
.AllowMultiSelect = False
If .Show Then xPath = .SelectedItems(1) & "\"
End With
End Function
Below is the code I've used which has compiled, it has the user select a folder instead of a file
sub something
dim xpath and xfile as string
xPath = NewPath
If Not strPath = vbNullString Then
xfile = Dir$(xPath & "*.xlsm", vbNormal)
Do While Not xfile = vbNullString
'some code
Set SourceBook = Workbooks.Open(xPath & xfile)
SourceBook.Close False
xfile = Dir$()
Loop
End If
End Sub
Function NewPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.ButtonName = "Choose a folder"
.Title = "Folder Picker"
.AllowMultiSelect = False
If .Show Then NewPath = .SelectedItems(1) & "\"
End With
End Function

Preserving powerpoint/excel property data after converting to pptx/xlsx

I have vba code to convert a ppt to pptx file, but how do I preserve the file properties (author/created date, modified date, etc)? Here is the vba code that converts the, in this case .ppt file, to a pptx file.
Sub BatchSave()
' Opens each PPT in the target folder and saves as PowerPoint 2007/2010 (.pptx) format
Dim sFolder As String
Dim sPresentationName As String
Dim oPresentation As Presentation
Dim bidpList As Collection
' Select the folder:
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
sFolder = fDialog.SelectedItems.Item(1)
If Right(sFolder, 1) <> "\" Then sFolder = sFolder + "\"
End With
' Make sure the folder name has a trailing backslash
If Right$(sFolder, 1) <> "\" Then
sFolder = sFolder & "\"
End If
' Are there PPT files there?
If Len(Dir$(sFolder & "*.PPT")) = 0 Then
MsgBox "Bad folder name or no PPT files in folder."
Exit Sub
End If
' Open and save the presentations
sPresentationName = Dir$(sFolder & "*.PPT")
While sPresentationName <> ""
Set oPresentation = Presentations.Open(sFolder & sPresentationName, , ,
False)
Call oPresentation.SaveAs(sFolder & sPresentationName & "x")
oPresentation.Close
Wend
MsgBox "DONE"
End Sub
Declaring object variables for your two presentations will simplify the code a bit, and then you can do something along these lines:
Dim oPres As Presentation
Dim oCopyPres As Presentation
Dim x As Long
Set oPres = ActivePresentation
ActivePresentation.SaveCopyAs "c:\temp\test.pptx"
Set oCopyPres = Presentations.Open("c:\temp\test.pptx")
On Error Resume Next
For x = 1 To oPres.BuiltInDocumentProperties.Count
oCopyPres.BuiltInDocumentProperties(x).Name = oPres.BuiltInDocumentProperties(x).Name
oCopyPres.BuiltInDocumentProperties(x).Value = oPres.BuiltInDocumentProperties(x).Value
Next
You'll want to modify this to set WithWindow false and to use variables as file names, but you're already doing that in the code you have. It should be simple enough to fold in a modified version of the code above.

vba excel: open files (known filename) from multiple folders

I'm trying to figure out how to import text files (always named tracks.txt) from different folders into one workbook with separate worksheets named after the folder.
basically it should work like this:
select main folder
select multiple sub-folders (which contain the tracks.txt)
or
search in all sub-folders starting with the string (user input)
import tracks.txt in new worksheet
replace worksheetname with subfoldername
would this be possible?
'//-----------------------------------------------------------------------------------------\\
'||code was made with the great help of bsalv and especially snb from www.worksheet.nl ||
'||adjusted and supplemented for original question by myself martijndg (www.worksheet.nl) ||
'\\-----------------------------------------------------------------------------------------//
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select folder with subfolder (containing tracks.txt) NO SPACES IN FILEPATH!!!"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1) + "\" 'laatste slash toegevoegd aan adres
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub importtracks()
Dim subfolder, serie As String
c00 = GetFolder("C:\")
serie = InputBox(Prompt:="partial foldername of serie", _
Title:="find folders of 1 serie", Default:="track##.")
If serie = "track##." Or serie = vbNullString Then
Exit Sub
End If
Workbooks.Add
For Each it In Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir " & c00 & "tracks.txt /b /s").stdout.readall, vbCrLf), ":")
sn = Split(CreateObject("scripting.filesystemobject").opentextfile(it).readall, vbCrLf)
With Sheets
subfolder = Replace(Replace(CreateObject("scripting.filesystemobject").GetParentFolderName(it), "" & c00 & "", ""), "\", "")
End With
If InStr(1, subfolder, serie, vbTextCompare) Then
With Sheets.Add
.Move after:=Sheets(Sheets.Count)
.name = subfolder
.Cells(1).Resize(UBound(sn) + 1) = WorksheetFunction.Transpose(sn)
.Columns(1).TextToColumns , xlDelimited, semicolon:=True
End With
End If
Next
If Sheets.Count = 3 And Sheets(Sheets.Count).name = "Sheet3" Then
MsgBox "no subfolder contained the string '" & serie & "' or your choosen filepath contained spaces"
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Exit Sub
End If
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
Application.DisplayAlerts = True
End Sub

Resources