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
Related
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.
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
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!
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
I'm trying to open a PPTX from a specific folder using a Function within a Sub. The function's purpose is to choose the file that the rest of the macro's code will perform it on (essentially to make it the ActivePresentation) The problem is that when I call the function PickDir() to get the file's path and open it, the macro stops running. So, I just get an open presentation and not performing the action I want it to do.
The problem occurs about 5 lines after all the variables are Dim'd.
Sub ExtractImagesFromPres()
On Error GoTo ErrorExtract
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim ImgCtr As Integer
Dim SldCtr As Integer
Dim ShapeNameArray() As String
Dim oPP As Object
Dim SrcDir As String
Dim SrcFile As String
'File naming variables
Dim PPLongLanguageCode As String
Dim PPShortLanguageCode As String
Dim FNShort As String
Dim FNLong As String
Dim PPLanguageParts1() As String
Dim PPLanguageParts2() As String
Dim FNLanguageParts() As String
SrcDir = PickDir() 'call the PickDir() function to choose a directory to work from
If SrcDir = "" Then Exit Sub
SrcFile = SrcDir & "\" & Dir(SrcDir + "\*.pptx") 'complete directory path of ppt to be split
Set oPP = CreateObject("Powerpoint.Application") 'open ppt containing slides with images/text to be exported
ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
ImgCtr = 0 'Image and Slide counter for error messages
SldCtr = 1
ReDim ShapeNameArray(1 To 1) As String 'initialize ShapeNameArray to avoid null array errors
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes 'loop each shape within each slide
If oShpSource.Type <> msoPlaceholder Then 'if shape is not filename placeholder then add it's name to ShapeNameArray
ShapeNameArray(UBound(ShapeNameArray)) = oShpSource.Name
ReDim Preserve ShapeNameArray(1 To UBound(ShapeNameArray) + 1) As String 'need to add one to array for new shape name
ElseIf oShpSource.Type = msoPlaceholder Then 'is shape is filename placeholder then check to see if not empty
If oShpSource.TextFrame.TextRange.Length = 0 Then
MsgBox "The filename is missing on Slide:" & SldCtr & vbNewLine & _
"Please enter the correct filname and re-run this macro"
Exit Sub
End If
PPLanguageParts1 = Split(ActivePresentation.Name, ".") 'extract language code from PowerPoint filename
PPLongLanguageCode = PPLanguageParts1(LBound(PPLanguageParts1))
PPLanguageParts2 = Split(PPLongLanguageCode, "_")
PPShortLanguageCode = PPLanguageParts2(UBound(PPLanguageParts2))
FNLanguageParts = Split(oShpSource.TextFrame.TextRange.Text, "_") 'insert PowerPoint filename language code into image filename language code
FNShort = FNLanguageParts(LBound(FNLanguageParts))
FNLong = FNShort & "_" & PPShortLanguageCode
oShpSource.TextFrame.TextRange.Text = FNLong
End If
Next oShpSource
ReDim Preserve ShapeNameArray(1 To UBound(ShapeNameArray) - 1) As String 'ShapeNameArray has one too many elements, so subtract one
Call oSldSource.Shapes.Range(ShapeNameArray).Export(FNLong & ".jpg", ppShapeFormatJPG) 'export images with proper filenames
ReDim ShapeNameArray(1 To 1) As String
ImgCtr = ImgCtr + 1
SldCtr = SldCtr + 1
Next oSldSource
If ImgCtr = 0 Then 'error message if no images
MsgBox "There were no images found in this presentation", _
vbInformation, "Image extraction failed."
End If
Exit Sub
ErrorExtract:
If Err.Number <> 0 Then 'error message log
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
End If
End Sub
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = ""
Set FD = Application.FileDialog(msoFileDialogFolderPicker) 'initialize default MS directory picker
With FD
.Title = "Pick the folder where your files are located" 'title for directory picker dialog box
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
Are you running this from within powerpoint? If yes, you don't need to create another Application object: you can just open the ppt directly. And you can use the return value from Open() to get a reference to the presentation (rather than using "activePresentation")
Dim ppt as Presentation
Set ppt = Application.Presentations.Open(SrcFile, False, False, True)
'do stuff with ppt
This line is probably giving you some trouble:
ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
I don't know how to activate a window in PPT but at the very least you'll need to use the following:
Set ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
As for activating the presentation, you may need to access the windows collection, or something similar? A suggestion, hopefully to get you thinking.
application.Presentations(1).Windows(1).Activate
Finally, you may actually not need to activate the presentation, if you have no other presentations open, the one you're opening will quite likely be the active one by default, if you open it visible. I suspect this is the case, given that you are creating the powerpoint application object. If this is correct then you simply need to do the following:
oPP.Presentations.Open(SrcFile, False, False, True)
debug.print oPP.ActivePresentation.Name
Edit: I'd also recommend setting a reference to the powerpoint object library and declaring oPP as follows:
Dim oPP as Powerpoint.Application
Then when creating an instance of the application:
Set oPP = New Powerpoint.Application
If you don't want to have to worry about which presentation is active, you can do:
Dim oPres as Presentation
Set oPres = oPP.Presentations.Open(SrcFile, False, False, True)
Then in the rest of the code, use oPres instead of ActivePresentation