Use VBS to copy from Notepad to Word - pdf

I'm trying to create a script to convert PDF to plain text, then copy the plain text into Word. (We do a lot of reformatting corrupt documents from scratch where I work.) I have a script that's working perfectly except for one thing: when pasting into Word, it doesn't paste the whole file. With longer files, I'm only getting part of the text.
'string to hold file path
Dim strDMM
strDMM = "[path]"
'make this directory if it doesn't exits
On Error Resume Next
MkDir strDMM
On Error GoTo 0
'get the file name to process
Dim TheFile
TheFile = InputBox("What is the file name?" & chr(13) & chr(13) & "(Example: [name].pdf)", "Name of File")
'declare some acrobat variables
Dim AcroXApp
Dim AcroXAVDoc
Dim AcroXPDDoc
'open acrobat
Set AcroXApp = CreateObject("AcroExch.App")
AcroXApp.Hide
'open the document we want
Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
AcroXAVDoc.Open "[path to desktop]" & TheFile, "Acrobat" 'users are instructed to save to the Desktop for ease of access here
'make sure the acrobat window is active
AcroXAVDoc.BringToFront
'I don't know what this does. I copied it from code online.
Set AcroXPDDoc = AcroXAVDoc.GetPDDoc
'activate JavaScript commands w/Acrobat
Dim jsObj
Set jsObj = AcroXPDDoc.GetJSObject
'save the file as plain text
jsObj.SaveAs strDMM & "pdf-plain-text.txt", "com.adobe.acrobat.plain-text"
'close the file and exit acrobat
AcroXAVDoc.Close False
AcroXApp.Hide
AcroXApp.Exit
'declare constants for manipulating the text files
Const ForReading = 1
Const ForWriting = 2
'Create a File System Object
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
'read file and get text
dim objFile
set objFile=objFSO.OpenTextFile( strDMM & TheFile, ForReading)
Dim strText
strText=objFile.ReadAll
'Create a Word Object
Dim objWord
set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
End With
'Add method used to create a blank document
Dim objDoc
Set objDoc=objWord.Documents.Add()
'create a shorter variable to pass commands to Word
Dim objSelection
set objSelection=objWord.Selection
'type the read text into Word; this is the part that's failing
objSelection.TypeText strText
objFile.Close
I've tried multiple files with the same result. The funny thing is, it pastes the same material from file A each time, but when copying from file B, it pastes a different amount of material. In other words, if A gives me 8 pages of 60 on the first run, I get those same 8 pages each time. File B might give me 14 pages of 60, then it gives me the same 14 pages each time. This only changes if I delete material from the .txt file. If I delete several paragraphs from A, then run the script, I might get 12 pages. Then I get those same 12 every time. But there's no pattern (that I can discern) to predict where it cuts off.
I can't find any EOF characters, and when I read from notepad and write to notepad, the whole thing is copied perfectly. The problem is somewhere in the transfer to Word.
Is there something I'm missing? Is there a limit to the size of a string that Word can write with TypeText? (I would think that if that were the case, I wouldn't get documents of varying length, right? Shouldn't they all stop at n characters if that's the limit?)
I've read about additional libraries that let VBS work with the clipboard, but I'm a total noob and don't know if that's a more elegant solution or how to make it work. I'm also not sure that on my work computer I have the necessary access to install those libraries.
Any help is appreciated!

There is no need to read a file into Word, you can insert a text file from disk
Dim objWord
'Dim objDoc
Set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
'Add method used to create a blank document
.Documents.Add
.Selection.InsertFile FileNameAndPath
End With

The basic problem, which you hinted at, is that the String data type is limited to 65,400 characters. With an unknown file length, it is better to read in one line at a time and write it to Word. There is a good discussion of something similar here. The following code should help you get where you wan to go:
'read file and get text
dim objFile
set objFile=objFSO.OpenTextFile( strDMM & TheFile, ForReading)
'Don't do this!
'Dim strText
'strText=objFile.ReadAll
'Create a Word Object
Dim objWord
set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
End With
'Add method used to create a blank document
Dim objDoc
Set objDoc=objWord.Documents.Add()
'create a shorter variable to pass commands to Word
Dim objSelection
set objSelection=objWord.Selection
'Read one line at a time from the text file and
'type that line into Word until the end of the file is reached
Dim strLine
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
objSelection.TypeText strLine
Loop
objFile.Close
Hope that helps!

Related

Extracting images from Word document using VBA

I need to loop over some word documents, and extract images from a word document and save them in a separate folder.
I've tried the method of saving them as an HTML document, but it is not a good fit for my requirement.
Now, I'm looping through the images using inlineshapes object and then copy-pasting them on a publisher document and then saving them as an image. However, I'm facing a Runtime Automation error when I'm running the script.
For using the Publisher runtime library I've tried both early and late binding but I'm facing the error on both of them.
Can anyone please let me know what is the problem? Also, if anyone can explain why I'm facing this error, that'd be great. As per my understanding, it is due to memory allocation, but I'm not sure.
Here is the code block that I've been working on (fp, dp are folder paths, while filename is the word document name. I'm calling this sub in another sub that is looping over all the files in a folder):
Sub test(ByVal fp As String, ByVal dp As String, ByVal filename As String)
Dim doc As Document
Dim pubdoc As New Publisher.Document
Dim shp As InlineShape
'Application.Screenupdating = False
'Dim pubdoc As Object
'Set pubdoc = CreateObject("Publisher.Document")
Set doc = Documents.Open(fp)
With doc
i = .InlineShapes.Count
Debug.Print i
End With
For j = 1 To i
Set shp = doc.InlineShapes(j)
shp.Select
Selection.CopyAsPicture
pubdoc.Pages(1).Shapes.Paste
pubdoc.Pages(1).Shapes(1).SaveAsPicture (dp & Application.PathSeparator & j & ".jpg")
pubdoc.Pages(1).Shapes(1).Delete
Next
doc.Close (wdDoNotSaveChanges)
pubdoc.Close
'Application.Screenupdating = True
End Sub
Apart from this, if anyone has any suggestions to make this faster, I'm all ears. Thanks in advance!
Just add .zip to the end of the file name, expand the file and look in the word/media folder. All the files will be there, no programming necessary.
Extracting the pictures from a Filtered HTML document that was created from your original source document would be faster. However, you said that was not a good fit for you needs so ... here is example code that will locate pictures in your source document and paste them into a second document.
The speed problem of this type of code is caused by the CopyPicture working from a Selection command, so I recommend using a range instead. Of course the For/Next loop that is required is slower no matter what.
Sub CopyPasteAsPicture()
Dim doc As Word.Document, iShp As Word.InlineShape, shp As Word.Shape
Dim i As Integer, nDoc As Word.Document, rng As Word.Range
Set doc = ActiveDocument
If doc.Shapes.Count > 0 Then
For i = 1 To doc.Shapes.Count
Set shp = doc.Shapes(i)
If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then
'if you want only pictures extracted then you have
'to specify the type
shp.ConvertToInlineShape
'if you want all extracted pictures to be in the sequence
'they appear in the document then you have to convert
'floating shapes to inline shapes
End If
Next
End If
If doc.Content.InlineShapes.Count > 0 Then
Set nDoc = Word.Documents.Add
Set rng = nDoc.Content
For i = 1 To doc.Content.InlineShapes.Count
doc.Content.InlineShapes(i).Range.CopyAsPicture
rng.Paste
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
rng.Paragraphs.Add
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
Next
End If
End Sub
If you want to place all shapes (floating or inline) into a folder as image files, then the best way is to save the source document as a filtered HTML document. Here is the command:
htmDoc.SaveAs2 FileName:=LGPWorking & strFileName, AddToRecentFiles:=False, FileFormat:=Word.WdSaveFormat.wdFormatFilteredHTML
In the above the active document is assigned to the variable htmDoc. I am giving this new document a specific name and location. The output from this is not only the HTML file but also a directory by the same name with an appended "_Files" label. In the "x_Files" directory are all the image files.
If you only want selective images pulled from your original source document, or if you want images pulled from multiple source documents ... then you need to use the above code that I shared for placing only the images you want from one or more source document into a new Word document and then save that new document as an Filtered HTML.
When your routine is done, you can Kill the HTML document and only leave the Files directory.
I had to change a few things around, but this will allow to save a single image on a word document and go through a couple of cycles before it turns into a jpg on the other side, without any white space
filename = ActiveDocument.FullName
saveLocaton = "z:\temp\"
FolderName = "test"
On Error Resume Next
Kill "z:\temp\test_files\*" 'Delete all files
RmDir "z:\temp\test_files" 'Delete folder
ActiveDocument.SaveAs2 filename:="z:\temp\test.html", FileFormat:=wdFormatHTML
ActiveDocument.Close
Kill saveLocaton & FolderName & ".html"
Kill saveLocaton & FolderName & "_files\*.xml"
Kill saveLocaton & FolderName & "_files\*.html"
Kill saveLocaton & FolderName & "_files\*.thmx"
Name saveLocaton & FolderName & "_files\image00" & 1 & ".png" As saveLocaton & FolderName & "_files\" & test2 & "_00" & x & ".jpg"
Word.Application.Visible = True
Word.Application.Activate

Memory leak in a Word VBA macro

I have a macro for converting multiple Word documents to HTML format:
Sub macro1()
Dim objCC As ContentControl
Dim dataline As String
Dim doc As Document
Open "D:\Data\find1" For Input As #1
While Not eof(1)
Line Input #1, dataline
Debug.Print dataline
Set doc = Documents.Open(dataline)
Do While doc.ContentControls.Count > 0
For Each objCC In doc.ContentControls
objCC.Delete False
Next
Loop
doc.SaveAs ActiveDocument.Path + "/" + ActiveDocument.Name + ".html", wdFormatHTML
doc.Close
Wend
Close #1
End Sub
The list of documents is in the file find1. I have about 20000 documents, but after converting of about 1000 files the memory is full, and the system hangs. Is there a way to avoid it?
As I have mentioned in comments, this memory leak is to do with how Office opens/closes files - if you open and then close a file, even without changing or saving it, some data is left in memory and cannot be dumped without closing the Application.
I suspect (but cannot confirm) that it originates from some sort of "feature" to make reopening files slightly faster.
Now - as I said earlier - you can free that memory by closing the Application, so, that is what we'll do! If we Late-Bind Word to a different Office Application (Excel / Powerpoint / Outlook), we can then close and reopen it mid-macro
Sub macro1()
Dim objCC As Object 'Late Binding, must be Object
Dim dataline As String
Dim doc As Object 'Late Binding, must be Object
Dim lineCounter AS Long: lineCounter = 0 'So that we can keep track of files!
Dim MSWord AS Object 'Late Binding, must be Object
Set MSWord = CreateObject("Word.Application") 'Create an instance of Word
'MSWord.Visible=True 'OPTIONAL LINE! Makes Word visible, default is False
Open "D:\Data\find1" For Input As #1
While Not eof(1)
Line Input #1, dataline
Debug.Print dataline
Set doc = MSWord.Documents.Open(dataline) 'Open with the correct Application
Do While doc.ContentControls.Count > 0
For Each objCC In doc.ContentControls
objCC.Delete False
Next objCC
Loop
doc.SaveAs MSWord.ActiveDocument.Path + "/" + MSWord.ActiveDocument.Name + ".html", wdFormatHTML
doc.Close
lineCounter = lineCounter +1 'Count processed documents
If (lineCounter mod 100) = 0 Then 'Every 100 documents - adjust as necessary
'We need to destroy any objects associated with Word to close it safely
Set objCC = Nothing
Set doc = Nothing
MSWord.Quit 'Close Word, to free the junk memory
DoEvents 'Check in with Windows - we haven't crashed, honest!
Set MSWord = CreateObject("Word.Application") 'Create a new instance of Word
'MSWord.Visible=True 'OPTIONAL LINE! Makes Word visible, default is False
End If
Wend
Close #1
Set objCC = Nothing
Set doc = Nothing
MSWord.Quit 'Close Word, for the final time
End Sub
Maybe You should try to work with FilesystemObject, e.g.
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(fileSpec, ForReading)
strContents = objFile.ReadAll
' and so on
objFile.Close

How to parse a .doc file using a word VBA

I am stuck with this word VBA and in need of some assistance.I have 160 word documents in a folder and each .doc contains atleast one phrase like 'IO:' I want to copy all the file names that starts after 'IO:' and stop copying when the cursor finds Report Output:. Here is one sample input:
`Step Name: Step 3 – GP00BMDR
Step Description:: GENISYS main batch driver which processes external transactions and internal transactions, updates masters, generates transaction records to the accounting subsystem and produces print files.
File Specification:
Input: 1. GPFTRNW – PHGP.GPFTRNW.TRN.STD.KSDS
2. GPFSCIM – PHGP.GPFSCIM.SCI.KSDS
3. GPFSCSM – PHGP.GPFSCSM.SCS.KSDS
IO: 1. GPFPDGT – PHGP.GPFPDGT.PDG.TRN.KSDS
2. GPFRTXT – PHGP.GPFRTXT.RTX.KSDS
Report Output: Nil`
So I want to copy the .doc name and the file names after IO: and stops when the cursor reaches Report Output: . Here is my script:
Sub Ftp_Step_Details()
'this macro checks for FTP in respective steps and copy and writes in a cell along with the corresponding JCL
Dim wordApplication As Word.Application
Dim wordDocument As Word.Document
Dim flag As String
Dim Folder As String, J As String, FLD As Object
Dim Objfile As Object
Dim objfso As Object
Dim intRow As String
Dim contents As String
flag = True
Dim intResult As Integer
Dim strPath As String
'the dialog is displayed to the user
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has cancled the dialog
If intResult <> 0 Then
'dispaly message box
strPath = Application.FileDialog( _
msoFileDialogFolderPicker).SelectedItems(1)
End If
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\FILE-LIST\File-List.xlsx")
objExcel.Visible = True
objExcel.Workbooks.Add
objExcel.Cells(1, 1).Value = "Jcl Name"
objExcel.Cells(1, 2).Value = "File Names"
'Folder = "D:\TEST-IO" 'JCL source goes here
Set objfso = CreateObject("Scripting.FileSystemObject")
Set wordApplication = CreateObject("Word.Application")
intRow = 2
'Opening the file in READ mode
Set FLD = objfso.GetFolder(strPath)
For Each file In FLD.Files
Set Objfile = wordApplication.Documents.Open(file)
Do While Not Objfile.AtEndOfStream
contents = Objfile.ReadLine
If contents Like "*IO:" Then
flag = True
End If
If contents Like "*Report Output:*" Then
flag = False
End If
If flag = True Then
objExcel.Cells(intRow, 1).Value = file.Name
objExcel.Cells(intRow, 2).Value = contents3
intRow = intRow + 1
End If
Loop
Next
Objfile.Close
MsgBox "THANK YOU"
End Sub
Now whie testing the code i am getting TYPE MISMATCH in the step Set Objfile = wordApplication.Documents.Open(file) why is that?
Another doubt I have does Readline function works in word VBA as well?
Now whie testing the code i am getting TYPE MISMATCH in the step Set Objfile = wordApplication.Documents.Open(file) why is that?
Because File is type Scripting.File which is an Object, and the Documents.Open method expects a string.
You could try:
Documents.Open(file.Path)
Another doubt I have does Readline function works in word VBA as well?
No, I don't think so.

VBA - Automated PowerPoint won't open .pptx file that is being used by another User

I am creating a script that copies slides from various other .pptx files into a Master PowerPoint, but if one of the files is opened by another User at the same time the macro executes I receive an 80004005 error. My script is as follows:
Public Sub Update()
Dim PPTApp As Object
Dim PPT As Object
Dim MasterPPT As Presentation
Dim Total As Integer
Dim FSO As New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim File As Scripting.File
Set MasterPPT = Presentations("Combined Staff Agenda Template.pptm")
Total = MasterPPT.Slides.Count
Set PPTApp = CreateObject("PowerPoint.Application")
' Sets the first ComboBox destination folder
Set Folder = FSO.GetFolder("O:\org\acle\Common\PE_SHARE\Technical Staff Meeting Agendas\Individual Slides\" & Order_UserForm.comboFirst.Value)
For Each SubFolder In Folder.SubFolders
For Each File In SubFolder.Files
' Copies and pastes all slides for each file
Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
PPT.Slides.Range.Copy
MasterPPT.Slides.Paste (Total)
PPT.Close
Total = MasterPPT.Slides.Count
Next File
Next SubFolder
The For Each loop is repeated twice for two more folders, and then the sub routine ends. The folder system is organized as follows: Parent Directory ("Technical Staff Meeting Agendas") > "Individual Slides" > Three (3) Department Folders > Individual User Folders with a .pptx file in each. Any workaround for accessing the File.Path if it is already opened?
Completely untested, but let's try something like this (assuming you're getting an error on Presentations.Open. I added an error-handling block around this method call, and based on the documentation (here) it looks like the .Open method's Untitled argument is equivalent to creating a copy of the file.
If that doesn't work, let me know. I can revise to explicitly create and open a copy of the file and open that, instead.
UPDATE Since the Untitled property didn't work, let's try explicitly creating a copy of the file. I did not include any "cleanup" code to remove the copied versions.
Public Sub Update()
Dim PPTApp As Object
Dim PPT As Object
Dim MasterPPT As Presentation
Dim Total As Integer
Dim FSO As New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim File As Scripting.File
Set MasterPPT = Presentations("Combined Staff Agenda Template.pptm")
Total = MasterPPT.Slides.Count
Set PPTApp = CreateObject("PowerPoint.Application")
' Sets the first ComboBox destination folder
Set Folder = FSO.GetFolder("O:\org\acle\Common\PE_SHARE\Technical Staff Meeting Agendas\Individual Slides\" & Order_UserForm.comboFirst.Value)
For Each SubFolder In Folder.SubFolders
For Each File In SubFolder.Files
' Copies and pastes all slides for each file
On Error GoTo FileInUseError
Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
On Error GoTo 0
PPT.Slides.Range.Copy
MasterPPT.Slides.Paste (Total)
PPT.Close
Total = MasterPPT.Slides.Count
Next File
Next SubFolder
'## It's important to put this before your error-handling block:
Exit Sub
'## Error handling:
Err.Clear
'## First attempt, did not work as expected
'Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, Untitled:=msoTrue, WithWindow:=msoFalse)
'## Second attempt. You will need to add some logic to remove these files or do it manually.
Dim copyPath as String
copyPath = Replace(File.Path, File.Name, "Copy of " & File.Name)
FSO.CopyFile File.Path, copyPath, True
Set PPT = PPTApp.Presentations.Open(copyPath)
Resume Next
End Sub
Update 2
Other things you could try (not likely to work, but you should try them anyways):
I notice that this code is executing from within PowerPoint, so one thing that doesn't make sense is the: Set PPTApp = CreateObject("PowerPoint.Application"). You're already running an instance of PPT, and only one instance of PPT runs (unlike Excel which can have multiple instances). So get rid of that line entirely.
'Set PPTApp = CreateObject("PowerPoint.Application")
Then also you can get rid of the variable PPTApp. I notice you use a combination of early- and late-binding for your PowerPoint Object Variables. That doesn't really make sense and while I wouldn't expect that to cause any errors, you never know.
'Dim PPTApp as Object 'PowerPoint.Application '## This is unnecessary!!
Dim PPT as Presentation
Dim MasterPPT as Presentation
If all else fails, open the new file WithWindow=msoTrue and step through the code line by line using F8...
UPDATE 3
While I am not able to test a file that is locked/in-use by another user, I was able to test what happens if I have a file that is in use by myself. I use the following code and identify that the Files iteration will eventually encounter the lock/tmp version of the file, beginning with "~" tilde character. These are ordinarily hidden files, but FSO is picking them up in the iteration anyways.
Aside from that, I encounter similar errors if the file is not a valid PPT filetype (PPT, PPTX, PPTM, XML, etc.). I used the following code which prints a log of errors in the Immediate window (and informs you with MsgBox prompt) if there are errors.
Sub Test()
Dim MasterPPT As Presentation
Dim PPT As Presentation
Dim Total As Integer
Dim FSO As Object
Dim Folder As Object
Dim SubFolder As Object
Dim File As Object
Dim errMsg$
Dim copyPath$
Set MasterPPT = ActivePresentation '## Modify as needed.
Total = MasterPPT.Slides.Count
Set FSO = CreateObject("Scripting.FileSystemObject")
' Sets the first ComboBox destination folder // MODIFY AS NEEDED
Set Folder = FSO.GetFolder("C:\Users\david_zemens\Desktop\CHARTING STANDARDS")
For Each SubFolder In Folder.SubFolders
For Each File In SubFolder.Files
' Copies and pastes all slides for each file
On Error GoTo FileInUseError:
' Make sure it's a PPT file:
If File.Type Like "Microsoft PowerPoint*" Then
10:
Set PPT = Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
20:
PPT.Slides.Range.Copy
30:
MasterPPT.Slides.Paste (Total)
PPT.Close
End If
On Error GoTo 0
Total = MasterPPT.Slides.Count
NextFile:
Next File
Next SubFolder
'## It's important to put this before your error-handling block:
Set FSO = Nothing
Set Folder = Nothing
Set SubFolder = Nothing
Set File = Nothing
Exit Sub
FileInUseError:
'## Error handling:
'## Display information about the error
errMsg = "Error No.: " & Err.Number & vbCrLf
errMsg = errMsg & "Description: " & Err.Description & vbCrLf
errMsg = errMsg & "At line #: " & Erl & vbCrLf
errMsg = errMsg & "File.Name: " & File.Name
Debug.Print errMsg & vbCrLf
MsgBox errMsg, vbInformation, "Error!"
Err.Clear
Resume NextFile
End Sub

VBScript - How do I get these workbooks to talk?

I posted earlier about getting my VBScript to wait until a process had finished before continuing (further info: VBScript - How to make program wait until process has finished?.
I was given an adequate answer after some discussion. However, it seems that I am now going in a new direction with the code as the solution presented another problem that I am hoping you may be able to help me with.
Basically I have some code which I have provided below. It takes in 4 arguments, one of which is a PATH to a folder containing many files which I want to use along with the other three in my VBA macro.
If WScript.Arguments.Count = 4 Then
' process input argument
Set args = WScript.Arguments
arg1 = args.Item(0)
arg2 = args.Item(1)
arg3 = args.Item(2)
arg4 = args.Item(3)
' Create a WshShell instance
Dim WShell
Set WShell = CreateObject("WScript.Shell")
' Create an Excel instance
Dim x1
Set x1 = CreateObject("Excel.Application")
' Disable Excel UI elements
x1.DisplayAlerts = False
x1.AskToUpdateLinks = False
'x1.AlertBeforeOverwriting = False
x1.FeatureInstall = msoFeatureInstallNone
' Open the Workbooks specified on the command-line
Dim x1WB
Dim x2WB
Dim x3WB
Dim x4WB
Dim strWB1
Dim strWB2
Dim strWB3
Dim strWB4
Dim FSO
Dim FLD
Dim FIL
Dim strFolder
strWB1 = arg1
Set x1WB = x1.Workbooks.Open(strWB1)
' Show the workbook/Excel program interface. Comment out for silent running.
x1WB.Application.Visible = True
strWB2 = arg2
Set x2WB = x1.Workbooks.Open(strWB2)
' Show the workbook/Excel program interface. Comment out for silent running.
x2WB.Application.Visible = True
strWB3 = arg3
Set x3WB = x1.Workbooks.Open(strWB3)
' Show the workbook/Excel program interface. Comment out for silent running.
x3WB.Application.Visible = True
'To hold the string of the PATH to the multiple files
strFolder = arg4
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get a reference to the folder I want to search
set FLD = FSO.GetFolder(strFolder)
Dim strMyMacro
strMyMacro = "my_excel_sheet_with_vba_module.xlsm!Sheet1.my_vba_macro"
'loop through the folder and get the file names
For Each Fil In FLD.Files
WshShell.run """C:\Program Files\Microsoft Office\Office14\EXCEL.exe"" " & Fil, 1, true
x1.Run strMyMacro
'~~> Problem - How do I get the macro to run before opening the above file but run after it has opened (due to setting the bWaitOnReturn to true)
'~~> Problem - How do I get the file on current iteration to close after the macro has completed?
'~~> Problem - If this is not the issue, can you identify it?
Next
x1WB.close
x2WB.close
x3WB.close
'x4WB.close
' Clean up and shut down
Set x1WB = Nothing
Set x2WB = Nothing
Set x3WB = Nothing
Set x4WB = Nothing
Set FSO = Nothing
Set FLD = Nothing
x1.Quit
Set x1 = Nothing
Set WshShell = Nothing
WScript.Quit 0
Else
WScript.Quit 1
End If
The script works like this:
4 arguments are passed to the script. The 3rd argument is a .xlsm file which contains my VBA macro. The last argument is a PATH to a folder containing multiple files.
It then opens up the first three Excel files.
Then I run a loop to iterate through the files Fil in the folder that was specified as the 4th argument. AFAIK this has to be done via a WScript.shell using the .run method so that the rest of the script will hang until the Excel file it is processing finishes before closing it and opening up the next file in the folder.
After opening up file Fil, I then run the macro (albeit at this moment in time unsuccessfully).
I was tempted to simply open up all of the Excel files using the WScript.shell object however AFAIK I would not be able to run the macro this way.
Hopefully I have been able to define my aims of this piece of VBScript though if I haven't let me know and I shall clarify. Can you help?
Thanks,
QF.
Something along these lines might work for you (in Excel). A few things I'm not clear on though:
Where is your existing VBA macro - I'm guessing it's in one of the 3 files you're opening?
What types of files are in the folder you're looping through? I guessed Excel.
How is the vbscript being run? It looks like you're shelling out from your HTA, but why not include it directly in the HTA? That would save you from having to shell out and pass arguments...
Option Explicit
Dim wb1 As Workbook, wb2 As Workbook
Sub ProcessFolder(path1, path2, sFolder)
Dim wb As Workbook
Dim s
Set wb1 = Workbooks.Open(path1)
Set wb2 = Workbooks.Open(path2)
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
s = Dir(sFolder & "*.xls*", vbNormal)
Do While Len(s) > 0
Set wb = Workbooks.Open(sFolder & s)
ProcessFile wb
wb.Close False
s = Dir()
Loop
wb1.Close False
wb2.Close False
End Sub
Sub YourExistingMacro(wb As Workbook)
'do stuff with wb and presumably the other 3 open files...
End Sub