Option Explicit
Dim objShell, objFolder, objBrowFolder, objFSO, FileItem, SubFolder, ExcelFile, FilesCount, ExcelFiles(), UserSelect
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set objBrowFolder = objShell.BrowseForFolder(0, "Select folder for export PDF files to Excel", 0, "")
Set objFolder = objFSO.GetFolder(objBrowFolder.Self.Path)
If Err.Number = 0 Then
On Error GoTo 0
UserSelect = MsgBox("Export PDF files in " & objFolder & " to XLSX and open in Excel? (No - export only)", vbYesNoCancel, "Export PDF files")
If UserSelect = vbYes Or UserSelect = vbNo Then
FilesCount = 0
For Each FileItem In objFolder.Files
If LCase(objFSO.GetExtensionName(FileItem.Name)) = "pdf" Then
ExcelFile = SavePDFAsOtherFormat(FileItem, "xlsx")
If ExcelFile <> "" Then
FilesCount = FilesCount + 1
ReDim Preserve ExcelFiles(FilesCount)
ExcelFiles(FilesCount) = ExcelFile
End If
End If
Next
If UserSelect = vbYes And FilesCount > 0 Then
Dim objExcel, excelWorkBook, excelSheet, i
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Or objExcel Is Nothing Then Set objExcel = WScript.CreateObject("Excel.Application")
If objExcel Is Object Then
On Error GoTo 0
objExcel.Visible = False
For i = 1 To FilesCount
Set excelWorkBook = objExcel.WorkBooks.Open(ExcelFiles(i))
Set excelSheet = excelWorkBook.Worksheets(1)
'Any code with opened Excel sheet here
Next
objExcel.Visible = True
Dim objWScript: Set objWScript = CreateObject("WScript.Shell")
Dim objLocator: Set objLocator = CreateObject("WbemScripting.SWbemLocator")
Dim objServices: Set objServices = objLocator.ConnectServer()
Dim objProcess, objProps: Set objProps = objServices.ExecQuery("select * from Win32_Process where name = 'excel.exe'")
For Each objProcess in objProps
objWScript.AppActivate objProcess.ProcessId
Next
End If
Else
MsgBox FilesCount & " files exported.", vbOKOnly, "Export complite"
End If
End If
End If
Function SavePDFAsOtherFormat(PDFPath, FileExtension)
Dim objAcroApp, objAcroAVDoc, objAcroPDDoc, objJSO, boResult, ExportFormat, NewFilePath
NewFilePath = ""
On Error Resume Next
Set objAcroApp = CreateObject("AcroExch.App")
Set objAcroAVDoc = CreateObject("AcroExch.AVDoc")
boResult = objAcroAVDoc.Open(PDFPath, "")
Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
Set objJSO = objAcroPDDoc.GetJSObject
Select Case LCase(FileExtension)
Case "eps": ExportFormat = "com.adobe.acrobat.eps"
Case "html", "htm": ExportFormat = "com.adobe.acrobat.html"
Case "jpeg", "jpg", "jpe": ExportFormat = "com.adobe.acrobat.jpeg"
Case "jpf", "jpx", "jp2", "j2k", "j2c", "jpc": ExportFormat = "com.adobe.acrobat.jp2k"
Case "docx": ExportFormat = "com.adobe.acrobat.docx"
Case "doc": ExportFormat = "com.adobe.acrobat.doc"
Case "png": ExportFormat = "com.adobe.acrobat.png"
Case "ps": ExportFormat = "com.adobe.acrobat.ps"
Case "rft": ExportFormat = "com.adobe.acrobat.rft"
Case "xlsx": ExportFormat = "com.adobe.acrobat.xlsx"
Case "xls": ExportFormat = "com.adobe.acrobat.spreadsheet"
Case "txt": ExportFormat = "com.adobe.acrobat.accesstext"
Case "tiff", "tif": ExportFormat = "com.adobe.acrobat.tiff"
Case "xml": ExportFormat = "com.adobe.acrobat.xml-1-00"
Case Else: ExportFormat = ""
End Select
If ExportFormat <> "" And Err.Number = 0 Then
On Error GoTo 0
If LCase(FileExtension) <> "xls" Then
NewFilePath = Left(PDFPath, Len(PDFPath) - 3) & LCase(FileExtension)
Else
NewFilePath = Left(PDFPath, Len(PDFPath) - 3) & "xml"
End If
boResult = objJSO.SaveAs(NewFilePath, ExportFormat)
End If
boResult = objAcroAVDoc.Close(True)
boResult = objAcroApp.Exit
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
SavePDFAsOtherFormat = NewFilePath
End Function |
