I have a dotx/docx document with many pictures and need to manipulate many of them in the same way. Therefore I have written a Python script which will perform the image manipulation on a jpg file.
All I need to do now is to write a VBA script which will save the currently selected picture as jpg file, call the Python script and replace the picture in the document. And then assign this macro to a keyboard shortcut.
My VBA code is currently:
Sub ManipulateImage()
Dim sel As Word.Selection
Dim shp As InlineShape
Set sel = Selection
If sel.Type = wdSelectionInlineShape Then
Set shp = sel.InlineShapes(1)
Debug.Print "**"
'Save as picture
End If
'Manipulate saved picture
Shell "mypythonscript.py imgfile"
'Replace picture
'sel.PasteSpecial?
End Sub
I currently can't figure out how to save the InlineShape object as jpg image using VBA. If I do it manually, I can simply right click the picture and select "Save as Picture".
You can use the following code for saving inline shapes in Word VBA:
Private Sub saveImage(shp As InlineShape, path As String)
Dim s As String
Dim i As Long
Dim j As Long
Dim r As Range
Set r = shp.Range.Duplicate
r.start = r.start - 1
r.End = r.End + 1
''shp.range.WordOpenXML does not always contain the binary data
''s = shp.Range.WordOpenXML
s = r.WordOpenXML
i = InStr(s, "<pkg:binaryData>") + 16
If i = 16 Then
MsgBox "No binary data found"
Exit Sub
End If
j = InStr(i, s, "</pkg:binaryData>")
s = Mid$(s, i, j - i)
Dim DecodeBase64() As Byte
Dim objXML As Object 'MSXML2.DOMDocument
Dim objNode As Object 'MSXML2.IXMLDOMElement
Set objXML = CreateObject("MSXML2.DOMDocument")
'create node with type of base 64 and decode
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.Text = s
DecodeBase64 = objNode.nodeTypedValue
Set objNode = Nothing
Set objXML = Nothing
Open path For Binary As #1
Put #1, 1, DecodeBase64
Close #1
End Sub
See Save InlineShape picture to file in Word VBA for more information.
Related
My Task
Split a Word document into multiple parts based on a delimiter while preserving the text format.
Where I am?
I tried a basic example with one document but without an array and it worked.
Option Explicit
Public Sub CopyWithFormat()
Dim docDestination As Word.Document
Dim docSource As Word.Document
Set docDestination = ActiveDocument
Set docSource = Documents.Add
docSource.Range.FormattedText = docDestination.Range.FormattedText
docSource.SaveAs "C:\Temp\" & "test.docx"
docSource.Close True
End Sub
Where do I stuck?
I put the whole document into an array and loop through it. Right not I get an error 424 - Object necessary on this line:
docDestination.Range.FormattedText = arrNotes(I).
I also tried these four variants without luck:
docDestination.Range.FormattedText = arrNotes(I).Range.FormattedText
docDestination.Range.FormattedText = arrNotes(I).FormattedText
docDestination.Range.FormattedText = arrNotes.Range.FormattedText(I)
docDestination.Range.FormattedText = arrNotes.FormattedText(I)
Could you please help and point me into the right direction on how to access the array properly?
My Code
Option Explicit
Sub SplitDocument(delim As String, strFilename As String)
Dim docSource As Word.Document
Dim docDestination As Word.Document
Dim I As Long
Dim X As Long
Dim Response As Integer
Dim arrNotes
Set docSource = ActiveDocument
arrNotes = Split(docSource.Range, delim)
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
X = X + 1
Set docDestination = Documents.Add
docDestination.Range.FormattedText = arrNotes(I) 'throws error 424
docDestination.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "0000")
docDestination.Close True
End If
Next I
End Sub
Sub test()
'delimiter & filename
SplitDocument "###", "Articles "
End Sub
Range.FormattedText returns a range object. The Split function, on the other hand, returns an array of strings which don't include formatting. Therefore your code should find the portion of the document you wish to copy and assign that part's FormattedText to a variable declared as Range. That variable could then be inserted into another document.
Private Sub CopyRange()
Dim Src As Range, Dest As Range
Dim Arr As Range
Set Src = Selection.Range
Set Arr = Src.FormattedText
Set Dest = ActiveDocument.Range(1, 1)
Dest.FormattedText = Arr
End Sub
The above code actually works. All you would need to do is to find a way to replace the Split function in your concept with a method that identifies ranges in the source document instead of strings.
I'm trying to use a loop to shorten the last part of my VBA code.
The current code I have is:
Sub InsertPics()
Dim WordApp as Object
Dim WordDoc as Object
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open("Testing.docx"
WordApp.Visible = True
Dim path() as Variant
Dim i as Long
Dim Pic as Variant
path = Application.Transpose(Sheets("Selection").Range("N10:N24").Value)
For i = LBound(ppath) To UBound(ppath)
path(i) = Sheets("Output").Range("Directory").Value & "\" & path(i) & ".jpg"
Next i
Set Pic1 = WordDoc.InlineShapes.AddPicture(path(1), False, True).ConvertToShape
Set Pic2 = WordDoc.InlineShapes.AddPicture(path(2), False, True).ConvertToShape
Set Pic3 = WordDoc.InlineShapes.AddPicture(path(3), False, True).ConvertToShape
End Sub
The Set Pic() part goes on for quite awhile so I'm looking for a way to do the same sub with a shorter code. Is there a way to loop this part?
Note: WordDoc refers to a specific word document, path() refers to a list of directory addresses that I've already defined.
You could use an array or a collection :
Sub test_volvader()
Dim i As Integer
Dim myCol As Collection
Set myCol = New Collection
For i = 1 To 3
myCol.Add WordDoc.InlineShapes.AddPicture(Path(1), False, True).ConvertToShape, i
Next i
For i = 1 To myCol.Count
YourOperationOnAPicture myCol.Item(i)
Next i
End Sub
You should put your pictures in a list too. See R3uK's collection proposal.
But if you don't need to keep a reference on your pictures, you can make it even simpler:
For i = 1 To 3
WordDoc.InlineShapes.AddPicture(path(i), False, True).ConvertToShape
Next
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.
All right, this is my second attempt at a code, and the second VBA macro project I've been assigned to work on. I've been working to learn VBA as my first coding language for the last week and a half, so I apologize for silly mistakes. That said, straight to business. Here's what I put together for a word document macro:
Sub MacroToUpdateWordDocs()
'the following code gets and sets a open file command bar for word documents
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Dim FinalrowName As String
Filter = "xlsx Files (*.xlsx),*.xlsx"
Caption = "Please Select A .xlsx File, " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption)
'check if value is blank if it is exit
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
FinalrowName = Finalrow + 1
If (Trim(SelectedFile) = "") Then
Exit Sub
Else
'setting up the inital word application object
Set auditmaster = CreateObject("excel.sheet")
'opening the document that is defined in the open file dialog
auditmaster.Application.Workbooks.Open (SelectedFile)
'ability to change wether it needs to burn cycles updating the UI
auditmaster.Visible = False
'declare excel sheet
Dim wdoc As Document
'set active sheet
Set wdoc = Application.ActiveDocument
Dim i As Integer
Dim u As Integer
Dim ColumnAOldAddy As String
Dim ColumnCNewAddy As String
u = 1
i = 1
'MsgBox (wordapp.ActiveDocument.Hyperlinks.Count)
'Sets up a loop to go through the Excel Audit file rows.
For i = 1 To auditmaster.ActiveSheet.Rows.Count
'Identifies ColumnAOldAddy and ColumnCNewAddy as columns A and C for each row i. Column A is the current hyperlink.address, C is the updated one.
ColumnAOldAddy = auditmaster.Cells(i, 1)
ColumnCNewAddy = auditmaster.Cells(i, 3)
'If C has a new hyperlink in it, then scan the hyperlinks in wdoc for a match to A, and replace it with C
If ColumnCNewAddy = Not Nothing Then
For u = 1 To doc.Hyperlinks.Count
'If the hyperlink matches.
If doc.Hyperlinks(u).Address = ColumnAOldAddy Then
'Change the links address.
doc.Hyperlinks(u).Address = ColumnCNewAddy
End If
'check the next hyperlink in wdoc
Next
End If
'makes sure the macro doesn't run on into infinity.
If i = Finalrow + 1 Then GoTo Donenow
'Cycles to the next row in the auditmaster workbook.
Next
Donenow:
'Now that we've gone through the auditmaster file, we close it.
auditmaster.ActiveSheet.Close SaveChanges:=wdDoNotSaveChanges
auditmaster.Quit SaveChanges:=wdDoNotSaveChanges
Set auditmaster = Nothing
End If
End Sub
So, this code is suppose to take a hyperlink audit file created by my first macro (The last bugs fixed and functioning wonderfully thanks to the Stack Overflow community!). The audit file has 3 columns and a row for each hyperlink it found in the target .docx: A = hyperlink address, B = Hyperlink displaytext, and C = the new Hyperlink address
When the code runs from the .docx file to be updated, it allows the user to choose the audit file. From there, it goes row by row to check if an updated hyperlink address has been written into the C column by the older audited address/display name, then searches the .docx file for the old hyperlink address and replaces it with the new hyperlink address. At that point, it finishes searching the document then moves on to the next row in the audit excel file.
My problem is that much of this code is copy/pasted out of code from an excel macro. I have been having a hell of a time figuring out how translate that code into something that identifies/references the word/excel documents appropriately. I'm hoping someone with more experience can take a peek at this macro and let me know where I've completely buggered up. It keeps giving me "Method or data member not found" errors all over the place currently, primarily concerning where I attempt to reference the audit excel file. I'm pretty sure that this is a relatively easy fix, but I don't have the vocabulary to figure out how to Google the answer!
Compiled OK, but not tested:
Sub MacroToUpdateWordDocs()
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Dim appXL As Object
Dim oWB As Object
Dim oSht As Object
Dim wdoc As Document
Dim ColumnAOldAddy As String
Dim ColumnCNewAddy As String
Dim i As Long
Dim h As Word.Hyperlink
Dim TheUser As String
Filter = "xlsx Files (*.xlsx),*.xlsx"
Caption = "Please Select A .xlsx File, " & TheUser
Set appXL = CreateObject("excel.application")
appXL.Visible = True
SelectedFile = appXL.GetOpenFilename(Filter, , Caption)
appXL.Visible = False
If Trim(SelectedFile) = "" Then
appXL.Quit
Exit Sub
Else
Set oWB = appXL.Workbooks.Open(SelectedFile)
Set oSht = oWB.worksheets(1)
Finalrow = oSht.Cells(oSht.Rows.Count, 1).End(-4162).Row '-4162=xlUp
End If
Set wdoc = Application.ActiveDocument
For i = 1 To Finalrow
ColumnAOldAddy = oSht.Cells(i, 1).Value
ColumnCNewAddy = oSht.Cells(i, 3).Value
If ColumnCNewAddy <> ColumnAOldAddy Then
For Each h In wdoc.Hyperlinks
If h.Address = ColumnAOldAddy Then
h.Address = ColumnCNewAddy
End If
Next h
End If
Next i
oWB.Close False
appXL.Quit
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