Open docs + run macro + close + go to next

Microsoft Office 2007 small business wit...
August 26, 2010 at 21:51:45
Specs: Windows XP
Hello,
We are looking for a way to automate the following process : open docs, run macro, save under a new name and close files, then go to next as explained below :

We have a folder that contains a list of paired files. For example, history notes on different countries :

Algeria History Notes - E.doc
Algeria History Notes - F.doc
Argentina History Notes - E.doc
Argentina History Notes - F.doc
Australia History Notes - E.doc
Australia History Notes - F.doc
Belgium History Notes - E.doc
Belgium History Notes - F.doc

For reference purposes, we do open each pair (E-nglish and F-rench) one at a time, run a macro that creates a "bitext" where both English and French are side by side, then save it using the same name, only replacing E (or) F with Bi (e.g. Algeria History Notes - Bi.doc, etc).

Is there a way to automate the process (starting at the top of the folder) of opening the first pair, run the macro, save and close, then pick the second pair, open it, run the macro, save and close, then the third pair, etc... until we reach the end of the folder.

Thank you for your help.


See More: Open docs + run macro + close + go to next

Report •


#1
August 27, 2010 at 06:35:26
Hi,

I have written a macro that allows you to select all the English & French document pairs - it uses the standard windows File Open dialog box.

It does not immediately open the files.
It creates an array using the file names in pairs - and creates a third file name for the bilingual document.

It then opens the first document pair and creates the new document for the bilingual comparison.

It then calls a dummy subroutine - passing the names of the three opened documents to it.
You can put your existing macro into this subroutine - it will have access to the three document names.
When your macro is done, control passes back to this macro which saves and closes the three documents and opens the next group.
If you need the original 'E' & 'F' documents saved with different names, this can be added.

The file names selected by the user must be an even number of 'pairs' of E and F documents. The macro does not do any checking to see that document names match or that E or F appear in the document names. Make sure that the folder is displayed by name not by date modified etc. The selection must be made by selecting the first document name in the alphabetically sorted list, then the last name.
Checks could be added to ensure correct pairs. Code could be added to sort the file names and pair them up first. I didn't do this as I wasn't sure if this basic concept was going to work for you.

I have only tested this on the few file names you posted - so testing is limited - I created all the documents in one sub-folder with no other files in it, and just selected all of them.

Here is the macro:

Option Explicit

Sub DocPairs()
Dim strPairName As String
Dim lngFileCount As Long
Dim blnFound As Boolean
Dim strPathFile As String
Dim strFileArray() As String
Dim intArrayCount As Integer
Dim intFileType As Integer
Dim docBi As Document
Dim n As Integer


'Open the file dialog
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Show
   
    'resize array to match number of selected files /2
    'strFileArray(n,0) = english
    'strFileArray(n,1) = french
    'strFileArray(n,2) = bilingual
    If .SelectedItems.Count / 2 <> Int(.SelectedItems.Count / 2) Then
        'selected files not in pairs
        MsgBox "Must select pairs of files:" & vbCrLf _
                & "your selection  wasn't an even number"
        Exit Sub
    End If
    ReDim strFileArray((.SelectedItems.Count / 2) - 1, 2)
       
    'Copy all filenames into an array
    'File Picker returns files in alpha order, so pairs together,
    'except first file should be last !
    'no error checks here - so depends on correct files selected
    'and in correct order
    
    'set array counter & file type counter
    'leave first array element (0) empty
    intArrayCount = 1
    intFileType = 0
    For lngFileCount = 2 To .SelectedItems.Count - 1
        strFileArray(intArrayCount, intFileType) = .SelectedItems(lngFileCount)
        'increment file type counter
        intFileType = intFileType + 1
        'test if both file types handled
        If intFileType = 2 Then
            'save a bilingual file name
            strFileArray(intArrayCount, 2) = _
                    Replace(strFileArray(intArrayCount, 1), "F", "Bi")
            'reset file type counter
            intFileType = 0
            'increment array counter
            intArrayCount = intArrayCount + 1
        End If
    Next lngFileCount
    'no deal with last and first filenames
    strFileArray(0, 0) = .SelectedItems(.SelectedItems.Count)
    strFileArray(0, 1) = .SelectedItems(1)
    strFileArray(0, 2) = Replace(strFileArray(0, 1), "F", "Bi")
End With

'all filenames are ready
'open pairs, create bilingual document, save and close
For n = 0 To UBound(strFileArray, 1)
    'open pair
    Application.Documents.Open strFileArray(n, 0)
    Application.Documents.Open strFileArray(n, 1)
    'create new document (can use template here if required)
    Set docBi = Application.Documents.Add
    'save new document
    docBi.SaveAs strFileArray(n, 2)
    'call existing subroutine to procees document
    'all three document names are passed to the subroutine
    '* * * * * * * * * * * * * * *
    Call Compare(strFileArray(n, 0), strFileArray(n, 1), strFileArray(n, 2))
    '* * * * * * * * * * * * * * *
    'save and close the three documents
    'no warning message about overwriting existing files
    Application.DisplayAlerts = wdAlertsNone
    Documents(strFileArray(n, 0)).Close SaveChanges:=True
    Documents(strFileArray(n, 1)).Close SaveChanges:=True
    Documents(strFileArray(n, 2)).Close SaveChanges:=True
    Application.DisplayAlerts = wdAlertsAll
Next n
End Sub


Private Sub Compare(EFile As String, FFile As String, BiFile As String)
    'code to create bilingual document in here
    MsgBox "You have three documents:" & vbCrLf _
            & EFile & vbCrLf _
            & FFile & vbCrLf _
            & BiFile
End Sub

I haven't included any instructions on loading the macro, as you already have a macro.
The subroutine for your macro is called "Compare" and currently displays a message box showing the names of the three files passed to it each time.

If this is of use and you need some changes including code to check the file selection, please ask.

Regards

PS this replaces the save and close so that the E & F files are renamed (to "E2" and "F2")

    'save originals with different name
    Documents(strFileArray(n, 0)).SaveAs _
                FileName:=Replace(strFileArray(n, 0), "E", "E2")
    Documents(strFileArray(n, 1)).SaveAs _
                FileName:=Replace(strFileArray(n, 1), "F", "F2")
    Documents(Replace(strFileArray(n, 0), "E", "E2")).Close _
                SaveChanges:=False
    Documents(Replace(strFileArray(n, 1), "F", "F2")).Close _
                SaveChanges:=False
    Documents(strFileArray(n, 2)).Close SaveChanges:=True


Report •

#2
August 27, 2010 at 20:39:28
Hello,

Thank you very much for your help and macro.
I ran into this problem.
I installed the macro, create a folder and copied two file pairs (=4) into that folder. Let us call them

Algeria History Notes - E.doc
Algeria History Notes - F.doc
Argentina History Notes - E.doc
Argentina History Notes - F.doc

I ran the macro which did open the "Open files" window. I selected all four files. The process started but it got stuck at

docBi.SaveAs strFileArray(n, 2)

At that point, I did check the files that had been/remained opened in Word and I noticed three files:

Algeria History Notes - E.doc
Argentina History Notes - F.doc
Document1 (no suffix, no extension, nothing + the macro stops on this blank page).

I think this is all I could notice.

I need to ask you this also: how/where do I exactly insert the macro command called "MakeBiText" in the the Subroutine? Or do I simple need to rename "MakeBiText" "Compare" ? This must sound like a stupid question.

Thank you kindly,


Report •

#3
August 28, 2010 at 04:45:06
Hi,

The point at which the macro stopped was when it was trying to save a new document (the new Bi... document - Algeria History Notes - Bi.doc.

Add this line immediately before the docBi SaveAs ... line:

MsgBox strFileArray(n, 2)

This will show the path and filename that the macro was trying to use to save the new document.

I noticed in your reply that you said Let us call them when referring to the file names. I presume this means that the files are not named in the way you have posted. This could be the source of the problem. Can you let me know the actual name of one pair of files. (If you do not wish to post the actual names, you can send me a 'Private Message')

Regarding where to put your macro "MakeBiText"
1. It needs to be in the same Module as this macro
2. I don't know how your macro is given the document names to work with. As a result I provided a subroutine called "Compare" which has access to the three document names. The Compare subroutine starts like this:

Private Sub Compare(EFile As String, FFile As String, BiFile As String)
This provides the subroutine with direct access to the Path/filenames.
3. You have two choices:
3a. Take the code between the 'Sub' and 'End Sub' lines in MakeBiText and put it in the Compare sub, replacing the existing code, or
3b. Change the call to the macro by changing this line:
Call Compare(strFileArray(n, 0), strFileArray(n, 1), strFileArray(n, 2))

What you put between the parentheses depends on what the MakeBiText macro requires as parameters when it is called.
4. For further help on integrating your MakeBiText macro into this macro, I would need to know how MakeBiText gets the information on the documents it has to work on. For example does it pop-up an input box asking for a filename.

With more information on MakeBiText I should be able to advise further.
Also where have you saved this macro. Is it in "Normal" in a Module.

Regards


Report •

Related Solutions

#4
August 28, 2010 at 18:17:51
Hello,

No, there is no secret. Here is all the information.
I just stored in one folder two files pairs named for testing

Avis 10-36 EPMO Coconut Products - E.doc
Avis 10-36 EPMO Coconut Products - F.doc
Avis 10-37 Monitoring and Evaluation Officer HIV STI - E.doc
Avis 10-37 Monitoring and Evaluation Officer HIV STI - F.doc

You will notice I am no pro with macros. You will probably find them poorly built but they have served our purpose so far. Our secretariat needed something that could be usable to make bilingual text for checking purpose. Before inserting these texts into a huge memory, we need to make sure that there is a strict match between the English and the French. Many times we find editor's notes in English that are not in the French (e.g "Insert caption here") and this creates serious alignment problems between texts. This is for the context. Over time, the secretariat found other things that needed to be done like deleting all picture/graphics/objects. This is why I have a "multiple macro".

If you open two files Filename – E.doc and Filename – F and run the MakeBilingualText macro (FROM the Filename – E file), you will see what we get. It allows us to cross-check. The idea (and reason for the initial question) would be to prepare the bitext in a batch mode.

With the script below in the same module, it no longer opens the Select File window but returns a "Runtime Error : Sub or Function Not Defined" at Call Compare(strFileArray(n, 0), strFileArray(n, 1), strFileArray(n, 2)).

I put everything under a single module, and this is how it looks like.

Sub DocPairs()
Dim strPairName As String
Dim lngFileCount As Long
Dim blnFound As Boolean
Dim strPathFile As String
Dim strFileArray() As String
Dim intArrayCount As Integer
Dim intFileType As Integer
Dim docBi As Document
Dim n As Integer


'Open the file dialog
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Show

'resize array to match number of selected files /2
'strFileArray(n,0) = english
'strFileArray(n,1) = french
'strFileArray(n,2) = bilingual
If .SelectedItems.Count / 2 <> Int(.SelectedItems.Count / 2) Then
'selected files not in pairs
MsgBox "Must select pairs of files:" & vbCrLf _
& "your selection wasn't an even number"
Exit Sub
End If
ReDim strFileArray((.SelectedItems.Count / 2) - 1, 2)

'Copy all filenames into an array
'File Picker returns files in alpha order, so pairs together,
'except first file should be last !
'no error checks here - so depends on correct files selected
'and in correct order

'set array counter & file type counter
'leave first array element (0) empty
intArrayCount = 1
intFileType = 0
For lngFileCount = 2 To .SelectedItems.Count - 1
strFileArray(intArrayCount, intFileType) = .SelectedItems(lngFileCount)
'increment file type counter
intFileType = intFileType + 1
'test if both file types handled
If intFileType = 2 Then
'save a bilingual file name
strFileArray(intArrayCount, 2) = _
Replace(strFileArray(intArrayCount, 1), "F", "Bi")
'reset file type counter
intFileType = 0
'increment array counter
intArrayCount = intArrayCount + 1
End If
Next lngFileCount
'no deal with last and first filenames
strFileArray(0, 0) = .SelectedItems(.SelectedItems.Count)
strFileArray(0, 1) = .SelectedItems(1)
strFileArray(0, 2) = Replace(strFileArray(0, 1), "F", "Bi")
End With

'all filenames are ready
'open pairs, create bilingual document, save and close
For n = 0 To UBound(strFileArray, 1)
'open pair
Application.Documents.Open strFileArray(n, 0)
Application.Documents.Open strFileArray(n, 1)
'create new document (can use template here if required)
Set docBi = Application.Documents.Add
'save new document
docBi.SaveAs strFileArray(n, 2)
'call existing subroutine to procees document
'all three document names are passed to the subroutine
'* * * * * * * * * * * * * * *
Call Compare(strFileArray(n, 0), strFileArray(n, 1), strFileArray(n, 2))
'* * * * * * * * * * * * * * *
'save and close the three documents
'no warning message about overwriting existing files
Application.DisplayAlerts = wdAlertsNone
Documents(strFileArray(n, 0)).Close SaveChanges:=True
Documents(strFileArray(n, 1)).Close SaveChanges:=True
Documents(strFileArray(n, 2)).Close SaveChanges:=True
Application.DisplayAlerts = wdAlertsAll
Next n
End Sub
Sub MakeBilingualText()
'
' MakeBilingualText Macro
' Macro enregistrée le 18/08/2010 par Yves
'
Application.Run MacroName:="ConvTableText"
Application.Run MacroName:="Cleanupnew"
Application.Run MacroName:="Del_All_Objects"
Windows(2).Activate
Application.Run MacroName:="ConvTableText"
Application.Run MacroName:="Cleanupnew"
Application.Run MacroName:="Del_All_Objects"
Application.Run MacroName:="Macro20"
End Sub
Sub Del_All_Objects()
'
' Del_All_Objects Macro
'
'
ActiveDocument.Shapes.SelectAll
Selection.Delete
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^g"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub ConvTableText()
'
' ConvTableText Macro
' Macro enregistrée le 27/06/2006 par Yves
'
For Each aTable In ActiveDocument.Tables

aTable.ConvertToText wdSeparateByParagraphs, True

Next aTable
End Sub
Sub CleanupNew()
'
' CleanupNew Macro
' Macro enregistrée le 27/06/2006 par Yves
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^l"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^m"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^b"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.WholeStory
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.Font.Color = wdColorAutomatic
Selection.ParagraphFormat.Reset
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.WholeStory
Selection.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, _
NumRows:=48, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
.Style = "Grille du tableau"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
Selection.EscapeKey
Selection.Tables(1).Columns(1).SetWidth ColumnWidth:=210.95, RulerStyle:= _
wdAdjustNone
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
Selection.Font.Name = "Times New Roman"
Selection.Font.Size = 12
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.SelectColumn
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
End With
With Selection.ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.FirstLineIndent = CentimetersToPoints(0)
End With
Selection.MoveUp Unit:=wdLine, Count:=1
End Sub
Sub Macro20()
'
' Macro20 Macro
'
'
Selection.SelectColumn
Selection.Copy
Windows(1).Activate
Selection.SelectColumn
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Paste
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.Tables(1).Columns(1).SetWidth ColumnWidth:=225.15, RulerStyle:= _
wdAdjustNone
Selection.Tables(1).Columns(2).SetWidth ColumnWidth:=248.05, RulerStyle:= _
wdAdjustNone
End Sub

Thank you kindly,


Report •

#5
August 30, 2010 at 06:08:41
Hi,

I have had a look at the macros and how they are called.

The problem is that they do not work on named documents.
Some work on the document in the active window and some work on selections.

The following "Compare" sub can be used to call each of the existing macros, passing the document name to it:

Private Sub Compare(EFile As String, FFile As String, BiFile As String)
'Call existing macros and pass the English document to each one
 Call ConvTableText(EFile)
 Call CleanupNew(EFile)
 Call Del_All_Objects(EFile)
'Call existing macros and pass the French document to each one
 Call ConvTableText(FFile)
 Call CleanupNew(FFile)
 Call Del_All_Objects(FFile)
'This macro needs both documents
 Call Macro20(FFile, EFile)
End Sub

The two macros that use the 'ActiveDocument' can start like this:

Sub Del_All_Objects(convdoc As String)
' Del_All_Objects Macro
Documents(convdoc).Activate
ActiveDocument.Shapes.SelectAll
and
Sub ConvTableText(convdoc As String)
' ConvTableText Macro
Documents(convdoc).Activate
For Each aTable In ActiveDocument.Tables

The other two macros appear to work on selections and don't mention the ActiveDocument, and I don't know how the selections are made before they run.

You could try a similar approach for the Clean Up New macro:

Sub CleanupNew(convdoc As String)
' CleanupNew Macro
With Documents(convdoc)
... existing code ...
End With

The macro "Macro 20" is more difficult as it uses active window to move between documents - this is likely due to the macro having been created based on recording a macro.

The following may work:

Sub Macro20(convdocF As String, convdocE As String)
' Macro20 Macro
Documents(convdocF).Activate
Selection.SelectColumn
Selection.Copy
Documents(convdocE).Activate
Selection.SelectColumn
... remaining code

I also note that the macro I wrote was designed to create a new 'bilingual' document but there is nothing in your macros that creates or uses this new document. Is this something to be added later.

As I don't have any suitable documents to convert/modify, I can't test the suggestions I have made about running your macros. In a limited test, they were all called - and apart from the line that refers to a table style that I don't have (Grille du tableau).

Hope this is of some help.

Regards


Report •

#6
August 31, 2010 at 14:25:46
Hello Humar,

Many many thanks for your tips and explanations.
I was able to use the information you provided.
Thank you again for your time

Kind regards,


Report •

#7
August 31, 2010 at 16:46:21
Hi,

Glad to have been of help.

bonne journée

Humar


Report •

Ask Question