I have code that allows the users to enter the data (name, address, company name, city, state )which works perfectly, and when users hit submit, it populates it to the word document.
Next, if possible, I am trying to also have a save as pop up appear as soon as submit is clicked but do not know what to do next. I've tried multiple examples, but all of them give me a compile error expected end sub
I need help!!
Here is my working code:
Private Sub CommandButton1_Click()
Dim firstnamelastname As Range
Set firstnamelastname = ActiveDocument.Bookmarks("firstnamelastname").Range
firstnamelastname.Text = Me.TextBox1.Value
Dim Companyname As Range
Set Companyname = ActiveDocument.Bookmarks("Companyname").Range
Companyname.Text = Me.TextBox2
Dim Address As Range
Set Address = ActiveDocument.Bookmarks("address").Range
Address.Text = Me.TextBox3
Dim citystatezip As Range
Set citystatezip = ActiveDocument.Bookmarks("Citystatezip").Range
citystatezip.Text = Me.TextBox4
Me.Repaint
userform1.hide
but when I add anything for saving, it doesn't work.
I am also okay with removing the userform1.hide code and adding another button for save; then userform.hide so that they can continue to write the document.
There is no need to use Windows API.
The Application.Dialogs property returns a Dialogs collection that represents all the built-in dialog boxes in Word. To get an object from the collection you need to pass an instance of the WdWordDialog enumeration. For example, the following code shows the SaveAs dialog with predefined values:
dim strFullPath as string
dim strRootPath as string
dim strFileName as string
strRootPath = "C:\Users\Eugene\Documents\"
strFileName = "FileName.docx"
strFullPath = strRootPath & strFileName
With appWrd.Dialogs(wdDialogFileSaveAs)
.Name = strFullPath
.Format = Word.WdSaveFormat.wdFormatXMLDocument
.Show
End With
The following code shows a Save As dialog with the preset filter. If it is not canceled it returns the full path to which the file is saved.
This code works with 32-bit Office. For 64-bit Office, the declarations must be changed.
Place the following declarations before any Subs or Functions:
'Declarations for GetSaveAsFile
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (ByRef pOpenfilename As OPENFILENAME) As Long
Private Const OFN_EXPLORER As Long = &H80000
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
This function shows the dialog and returns the full path:
Public Function GetSaveAsFile(Optional ByVal HWnd As Long = 0, Optional ByVal strPath As String, _
Optional ByVal arrFilters As Variant, Optional ByRef lngFilterIndex As Long = -1, Optional ByVal strTitle As String = "") As String
'00-01s Prompts for a file name using a SaveAs dialog
'Returns full path; returns "" if canceled
'Saves to default location if no path specified
'"All Files" if no filters specified; no filter if arrFilters = ""
'lngFilterIndex: 0-based index for selected filter (in and out); -1 if canceled
'strTitle = "": "Save as" localized
On Error GoTo ErrHand
Dim typOFName As OPENFILENAME
Const lngMAX_FILE As Long = 500 'buffer size
Dim strFile As String 'file name
Dim strFilters As String 'filters string
Dim i As Long
strFile = Mid$(strPath, InStrRev(strPath, "\") + 1) 'crop preset file name/pattern from path
If IsMissing(arrFilters) Or IsEmpty(arrFilters) Then 'default: All files (*.*)
strFilters = "All files (*.*)" & vbNullChar & "*.*" & vbNullChar & vbNullChar
ElseIf VarType(arrFilters) = vbString Then 'no filter
Else 'compose filter string
For i = 0 To UBound(arrFilters, 1)
strFilters = strFilters & arrFilters(i, 0) & " (*." & arrFilters(i, 1) & ")" & vbNullChar & "*." & arrFilters(i, 1) & vbNullChar
Next i
End If
strFilters = strFilters & vbNullChar 'append second vbNullChar
'prepare structure
With typOFName
.lStructSize = Len(typOFName)
.hwndOwner = HWnd 'parent window
.lpstrFilter = strFilters 'file filters
.nFilterIndex = lngFilterIndex + 1 'preset filter index
.lpstrFile = strFile & Space$(lngMAX_FILE - Len(strFile) - 2) 'create buffer and preset file name
.nMaxFile = lngMAX_FILE 'maximum length of a returned file
.lpstrInitialDir = strPath 'initial path
.lpstrTitle = strTitle 'dialog title
.flags = OFN_EXPLORER 'show explorer style dialog
.lpstrDefExt = "" 'enables default extension according to selected filter
If GetSaveFileName(typOFName) Then 'call dialog
GetSaveAsFile = Left$(.lpstrFile, InStr(1, .lpstrFile, vbNullChar) - 1) 'cut before NullChar
lngFilterIndex = .nFilterIndex - 1 'read filter index
Else
lngFilterIndex = -1
End If
End With
Exit Function
ErrHand: 'your error handler
End Function
Explanations to the parameters:
'HWnd: window handle of the window calling this function, e.g. your Word window; ActiveWindow.HWnd. Or you can pass 0.
'strPath: Opens the Save As dialog with this path
'arrFilter: 0-based 2-dimensioned array with one or several filter names and file extensions; or "" for All files .
'lngFilterIndex: 0 or higher if you pass an array with more than one filter definitions.
'strTitle: Your own title if you like a special one
You call the function to save a document as docx like this:
'Example to call the function:
Sub SaveDoc()
Dim arrFilters As Variant '0-based 2-dim. array with filter types and extensions
Dim strFullPath As String 'resulting full path from dialog
Dim lngFormat As Word.WdSaveFormat 'format to save document
ReDim arrFilters(0 To 0, 0 To 1) 'prepare array for 1 filter
arrFilters(0, 0) = "Word Document" 'filter file type
arrFilters(0, 1) = "docx" 'filter extension
lngFormat = wdFormatXMLDocument 'docx format (change if you prefer another format)
strFullPath = GetSaveAsFile(HWnd:=ActiveWindow.HWnd, strPath:=ActiveDocument.Path & "\", _
arrFilters:=arrFilters, lngFilterIndex:=0, strTitle:="")
If Len(strFullPath) > 0 Then 'skip if dialog canceled
ActiveDocument.SaveAs2 strFullPath, lngFormat 'save active document (see reference of SaveAs2 for more parameters)
End If
End Sub
I'm trying to fix the macro, shown below.
It is intended to convert embed images to linked (via IncludePicture). However, in it's current state, images are added at the bottom of the document. Obviously, it's far from being perfect. Instead, macro should replace embed images with the linked ones, one by one, like shown here:
How to fix it?
Also, note: Macro should be launched from another file. So, you need two documents: one with macro and one with images. It's not good, but it's how it works currently.
Code:
Sub MakeDocMediaLinked()
Application.ScreenUpdating = False
Dim StrOutFold As String, Obj_App As Object, Doc As Document, Rng As Range
Dim StrDocFile As String, StrZipFile As String, StrMediaFile As String
With Application.Dialogs(wdDialogFileOpen)
If .Show = -1 Then
.Update
Set Doc = ActiveDocument
End If
End With
If Doc Is Nothing Then Exit Sub
With Doc
' ID the document to process
StrDocFile = .FullName
StrOutFold = Split(StrDocFile, ".")(0) & "_Media"
.Close SaveChanges:=False
End With
' Test for existing output folder, create it if it doesn't already exist
If Dir(StrOutFold, vbDirectory) = "" Then MkDir StrOutFold
' In case the output folder is not empty. Also, in case the file has no media
On Error Resume Next
' Delete any files in the output folder
Kill StrOutFold & "\*.*"
' Create a Shell App for accessing the zip archives
Set Obj_App = CreateObject("Shell.Application")
' Define the zip name
StrZipFile = Split(StrDocFile, ".")(0) & ".zip"
' Create the zip file, by simply copying to a new file with a zip extension
FileCopy StrDocFile, StrZipFile
' Extract the zip archive's media files to the temporary folder
Obj_App.NameSpace(StrOutFold & "\").CopyHere Obj_App.NameSpace(StrZipFile & "\word\media\").Items
' Delete the zip file - the loop takes care of timing issues
Do While Dir(StrZipFile) <> ""
Kill StrZipFile
Loop
' Restore error trapping
On Error GoTo 0
' Get the temporary folder's file listing
StrMediaFile = Dir(StrOutFold & "\*.*", vbNormal)
Documents.Open FileName:=StrDocFile
With ActiveDocument
' Process the temporary folder's files
While StrMediaFile <> ""
.Range.InsertAfter vbCr
Set Rng = .Paragraphs.Last.Range
.Fields.Add Range:=Rng, Type:=wdFieldEmpty, PreserveFormatting:=False, _
Text:="INCLUDEPICTURE """ & Replace(StrOutFold & "\" & StrMediaFile, "\", "\\") & """ \d"
' Get the next media file
StrMediaFile = Dir()
Wend
.Fields.Update
End With
Application.ScreenUpdating = True
End Sub
You could also parse the XML returned by Document.Content.XML to extract all the images. Then update each source with the path of the external image and write back the XML with Document.Content.InsertXML.
Writing the XML back automatically adds a linked field which seem to be one of your requirement.
It's faster that working with the clipboard and it doesn't alter the style of the shape. Though, you might need to tweak the code to handle specific cases.
Private Declare PtrSafe Function CryptStringToBinaryW Lib "Crypt32" (ByVal pszString As LongPtr, ByVal cchString As Long, ByVal dwFlags As Long, ByRef pbBinary As Byte, ByRef cbBinary As Long, ByVal pdwSkip As LongPtr, ByVal pdwFlags As LongPtr) As Boolean
Public Sub Example()
SaveAslinkedImages ActiveDocument, "c:\temp\myfile-no-img.docx"
End Sub
Public Sub SaveAslinkedImages(Doc As Document, fname As String)
Dim objXml As Object, binData As Object, binName$, nodes, node
Dim imgPath$, docDir$, imgDir$, i&, data() As Byte
Set objXml = VBA.CreateObject("Msxml2.DOMDocument.6.0")
objXml.Async = False
objXml.validateOnparse = False
' parse xml document '
objXml.LoadXML Doc.Content.XML
' add namespaces for SelectNodes '
objXml.setProperty "SelectionNamespaces", _
objXml.DocumentElement.getAttributeNode("xmlns:w").XML & " " & _
objXml.DocumentElement.getAttributeNode("xmlns:v").XML
' create the media folder '
docDir = Left(fname, InStrRev(fname, "\") - 1)
imgDir = Left(fname, InStrRev(fname, ".") - 1) & "_media"
MakeDir imgDir
' iterate each image data '
For Each binData In objXml.SelectNodes("//w:binData")
binName = binData.getAttribute("w:name")
' get all the nodes referencing the image data '
Set nodes = objXml.SelectNodes("//v:imagedata[#src='" & binName & "']")
If nodes.Length Then ' if any '
' build image path '
imgPath = imgDir & "\" & Mid(binName, InStrRev(binName, "/") + 1)
' save base64 data to file '
DecodeBase64 binData.Text, data
SaveBytesAs data, imgPath
' remove the data '
binData.ParentNode.RemoveChild binData
' for each image '
For Each node In nodes
' set id '
node.ParentNode.setAttribute "id", node.ParentNode.getAttribute("o:spid")
' remove o namespace '
node.ParentNode.Removeattribute "o:spid"
node.Removeattribute "o:title"
' set external image source '
node.setAttribute "src", imgPath
Next
End If
Next
' write back the xml and save the document '
Doc.Content.InsertXML objXml.XML
Doc.SaveAs2 fname
End Sub
Public Sub SaveBytesAs(data() As Byte, path As String)
Open path For Binary Access Write As #5
Put #5, 1, data
Close #5
End Sub
Public Sub MakeDir(path As String)
If Len(Dir(path, vbDirectory)) Then Exit Sub
MakeDir Left(path, InStrRev(path, "\") - 1)
MkDir path
End Sub
Public Function DecodeBase64(str As String, out() As Byte) As Boolean
Dim size As Long
size = ((Len(str) + 3) \ 4) * 3
ReDim out(0 To size - 1) As Byte
DecodeBase64 = CryptStringToBinaryW(StrPtr(str), Len(str), 1, out(0), size, 0, 0)
If size - 1 < UBound(out) Then ReDim Preserve out(0 To size - 1)
End Function
This is where your code is going astray:-
With ActiveDocument
.Range.InsertAfter vbCr
Set Rng = .Paragraphs.Last.Range
You are inserting a carriage return at the end of the document (which actually inserts a new blank paragraph) and then add a field in that paragraph. Obviously, you want the field somewhere else.
Meanwhile, if you wish to delete the links you should let your code do that. I haven't been able to figure out whether your code makes an attempt in that direction but presume that it extracts the picture's path from the link. So, the link should be located and deleted after giving up its path, and the field inserted in its place.
Here's my attempt. I did make an assumption that the shapes in the document would be a Inline Shape. I mocked this up on my computer with inline shapes.
Important Prerequistes
I'm using early binding of the Scripting.FileSystemObject and the Scripting.Dictionary. In order for this to function with no other changes to the code, please add a reference to the Microsoft Scripting Runtime.
How it works
The code iterates through each shape in the document chosen and saves each shape to a local folder. Once each shape is saved the shape is then deleted. From here the filename (key) and the range (value) of the InlineShape is saved into a dictionary. After this process has been done for each shape, the field with the INCLUDEPICTURE details are added by iterating through the dictionary to get the values needed.
Code
Option Explicit
Sub SOExample()
On Error GoTo Errhand:
Application.ScreenUpdating = False
Dim FileName As String
Dim doc As Document
Dim rng As Range ' Used to keep track of where the shape was before being deleted
Dim shp As Word.InlineShape 'I think you want to iterate inline shapes which generally are pictures
Dim i As Long ' Counter
Dim fso As FileSystemObject ' used for File Operations/etc
Dim tmpPics As String: tmpPics = GetDesktop & "Temp Pics" 'default folder on the desktop for temp storage
Dim picData() As Byte ' To hold picture information
Dim pos As Variant
Dim fileNumb As Long
'This section was untouched
With Application.Dialogs(wdDialogFileOpen)
If .Show = -1 Then
.Update
Set doc = ActiveDocument
End If
End With
'Make sure we have an object to work with
If doc Is Nothing Then Exit Sub
'Get a reference to FSO
Set fso = New FileSystemObject
'Delete files or create folder where needed
If fso.FolderExists(tmpPics) Then
fso.DeleteFile (tmpPics & "\*"), True
Else
fso.CreateFolder tmpPics
End If
'Create a dictionary to store the file name and range
'We need to do one pass through each image and save them, then delete the sheet
'As we go we are going to add the filename into our dictionary as the key, and -
'add the range of the remove image as the value. We use that range later to add the INCLUDEPICTURE portion
Dim mydict As New Scripting.Dictionary: Set mydict = New Scripting.Dictionary
'iterate each inlineShape...you may need to alter this as I'm unsure if this is the only type needed
'To be extracted. Sections of code grabbed from:
'https://stackoverflow.com/questions/6512392/how-to-save-word-shapes-to-image-using-vba
For Each shp In doc.InlineShapes
fileNumb = FreeFile
i = i + 1
'Build a temporary file name for our temp folder
FileName = tmpPics & "\Image " & CStr(i) & ".emf"
'Write the file as an EMF file
Open FileName For Binary Access Write As fileNumb
picData = shp.Range.EnhMetaFileBits
pos = 1
Put fileNumb, pos, picData
Close fileNumb
Set rng = shp.Range
'Add the details to our dictionary for iteration later
'I'm not adding the text here as, at least for me, adding this field adds another shape
'On the next iteration, it was trying to apply the same steps...creating what I'm assuming is an inifinite loop
If Not mydict.Exists(FileName) Then mydict.Add FileName, rng
shp.Delete
Set rng = Nothing
Next
Dim var As Variant
'Go through our dictionary, and add the fields into our document
For Each var In mydict.Keys
doc.Fields.Add Range:=mydict(var), _
Text:="INCLUDEPICTURE """ & Replace(var, "\", "\\") & """ \d"
Next
CleanExit:
Application.ScreenUpdating = True
Exit Sub
Errhand:
Debug.Print Err.Number, Err.Description
Select Case Err.Number
'Add error handler here
End Select
Resume CleanExit
End Sub
'A small helper function to get a path to the desktop
Private Function GetDesktop() As String
Dim oWSHShell As Object: Set oWSHShell = CreateObject("WScript.Shell")
GetDesktop = oWSHShell.SpecialFolders("Desktop") & "\"
Set oWSHShell = Nothing
End Function
One way would be to copy the image to the clipboard with Selection.Copy and to save it as a PNG from there. Then replace the image with an external link with Document.InlineShapes.AddPicture.
To handle the duplicated images, hash each image and keep track of the computed code.
I would also rescale the shape before an after to keep the original resolution.
Public Sub Example()
SaveAsExternImages ActiveDocument, "c:\temp\myfile-no-img.docx"
End Sub
Public Sub SaveAsExternImages(doc As Document, fname As String)
Dim sh As InlineShape, rg As Range, docDir, imgDir, imgPath, imgHash
Dim hDib, scaleW, scaleH, i As Long
Dim imgPaths As New Collection
Dim imgs As New Collection
' create the media folder and set the relative directory '
docDir = Left(fname, InStrRev(fname, "\") - 1)
imgDir = Left(fname, InStrRev(fname, ".") - 1) & "_media"
MakeDir imgDir
' clean clipboard '
Call OpenClipboard: Call EmptyClipboard: Call CloseClipboard
' select images '
For Each sh In doc.InlineShapes
Select Case sh.Type
Case wdInlineShapeLinkedPicture, wdInlineShapePicture
imgs.Add sh
End Select
Next
' handle each image '
For Each sh In imgs
' store/reset the scale '
scaleW = sh.ScaleWidth
scaleH = sh.ScaleHeight
sh.ScaleWidth = 100
sh.ScaleHeight = 100
' copy shape to the clipboard '
sh.Select
doc.Application.Selection.Copy
' get clipboard as DIB (device independent bitmap) '
If OpenClipboard() Then Else Err.Raise 9, , "OpenClipboard failed"
hDib = GetClipboardData(8) ' 8 = CF_DIB = BITMAPINFO '
If hDib Then Else Err.Raise 9, , "GetClipboardData failed"
' get image hash code from DIB (CRC32) '
imgHash = GetDIBHashCode(hDib)
' save as PNG if hash not already present in the collection '
If TryGetValue(imgPaths, imgHash, imgPath) = False Then
i = i + 1
imgPath = SaveDIBtoPNG(hDib, imgDir & "\image" & i & ".png")
imgPath = Mid(imgPath, Len(docDir) + 2) ' make relative '
imgPaths.Add imgPath, CStr(imgHash)
End If
' dispose clipboard '
Call EmptyClipboard
Call CloseClipboard
' replace the shape with a linked picture and restore the scale '
Set rg = sh.Range
sh.Delete
doc.Application.ChangeFileOpenDirectory docDir ' set relative folder '
Set sh = doc.InlineShapes.AddPicture(imgPath, True, False, rg)
sh.ScaleWidth = scaleW
sh.ScaleHeight = scaleH
Next
doc.SaveAs2 fname
End Sub
Related functions/procedures:
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As LongPtr, pclsid As Byte) As Long
Private Declare PtrSafe Function RtlComputeCrc32 Lib "ntdll" (ByVal start As Long, ByRef data As Any, ByVal Size As Long) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Boolean
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" (Optional ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, cfg As Any, ByVal hook As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromGdiDib Lib "gdiplus" (ByVal hdr As LongPtr, ByVal data As LongPtr, img As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal img As LongPtr, ByVal path As LongPtr, riid As Byte, ByVal cfg As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal img As LongPtr) As Long
Private Function GetDIBHashCode(hDib) As Long
Dim pDib As LongPtr, bmSize As Long, sz As Long
pDib = GlobalLock(hDib)
If pDib Then Else Err.Raise 9, , "GlobalLock failed"
GetDIBHashCode = RtlComputeCrc32(0, ByVal pDib, GlobalSize(hDib))
GlobalUnlock hDib
End Function
Private Function SaveDIBtoPNG(hDib, filePath As String) As String
Dim cfg(0 To 7) As Long, clsid(0 To 15) As Byte, pDib As LongPtr, hGdi As LongPtr, hImg As LongPtr
CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), clsid(0) ' PNG encoder '
cfg(0) = 1& ' GdiplusVersion '
pDib = GlobalLock(hDib) ' lock BITMAPINFOHEADER + image bytes '
If pDib Then Else Err.Raise 9, , "GlobalLock failed"
If GdiplusStartup(hGdi, cfg(0), 0) Then Err.Raise 9, , "GdiplusStartup failed"
If GdipCreateBitmapFromGdiDib(pDib, pDib + 40, hImg) Then Err.Raise 9, , "GdipCreateBitmapFromGdiDib failed"
If GdipSaveImageToFile(hImg, StrPtr(filePath), clsid(0), 0) Then Err.Raise 9, , "GdipSaveImageToFile failed"
If GdipDisposeImage(hImg) Then Err.Raise 9, , "GdipDisposeImage failed"
If GdiplusShutdown(hGdi) Then Err.Raise 9, , "GdiplusShutdown failed"
GlobalUnlock hDib
SaveDIBtoPNG = filePath
End Function
Private Function TryGetValue(obj As Collection, Key, outValue) As Boolean
On Error Resume Next
outValue = obj.Item(CStr(Key))
TryGetValue = Err.Number = 0
End Function
Private Sub MakeDir(path)
If Len(Dir(path, vbDirectory)) = False Then
MkDir path
ElseIf Len(Dir(path & "\")) Then
Kill path & "\*"
End If
End Sub
By locating each image and put the link in its position this code will acheive what you want. Note that the original file will be overwritten if you save the modified document. See my comments in the code for more info.
Code now works for duplicates as well
Option Explicit
Const IMAGEBASENAME = "image"
Const IMAGEEXTENSION = ".jpeg" 'Images in .zip file are all .jpg
Sub MakeDocMediaLinked()
Dim StrOutFold As String
Dim Obj_App As Object
Dim Doc As Document
Dim Rng As Range
Dim StrDocFile As String
Dim StrZipFile As String
Dim StrMediaFile As String
Dim objShape As InlineShape
Dim imgNum As Integer
Dim imgCount As Integer
Dim imgName As String
Dim imgNames As New Collection
Dim i As Integer
Dim doDir As Boolean
Application.ScreenUpdating = False
With Application.Dialogs(wdDialogFileOpen)
If .Show = -1 Then
.Update
Set Doc = ActiveDocument
End If
End With
If Doc Is Nothing Then Exit Sub
With Doc
StrDocFile = .FullName ' ID the document to process
StrOutFold = Split(StrDocFile, ".")(0) & "_Media"
.Close SaveChanges:=False
End With
If Dir(StrOutFold, vbDirectory) = "" Then MkDir StrOutFold ' Test for existing output folder, create it if it doesn't already exist
'*
'* Delete any files in the output folder. On Error Resume Next not used
'*
If Dir(StrOutFold & "\*.*", vbNormal) <> "" Then Kill StrOutFold & "\*.*"
' Create a Shell App for accessing the zip archives
Set Obj_App = CreateObject("Shell.Application")
' Define the zip name
StrZipFile = Split(StrDocFile, ".")(0) & ".zip"
' Create the zip file, by simply copying to a new file with a zip extension
FileCopy StrDocFile, StrZipFile
' Extract the zip archive's media files to the temporary folder
Obj_App.NameSpace(StrOutFold & "\").CopyHere Obj_App.NameSpace(StrZipFile & "\word\media\").Items
Do While Dir(StrZipFile) <> "" ' Delete the zip file - the loop takes care of timing issues
Kill StrZipFile
Loop
StrMediaFile = Dir(StrOutFold & "\*.*", vbNormal) ' Get the temporary folder's file listing
Documents.Open FileName:=StrDocFile
With ActiveDocument
imgCount = .InlineShapes.Count
For imgNum = 1 To imgCount
'*
'* Get the (next) image
'*
Set objShape = .InlineShapes(imgNum)
'*
'* Get the original full path of the image
'*
imgName = objShape.AlternativeText
'*
'* Look for possible duplicate
'*
'* Add the ordinal number as the item and the path as the key to avoid duplicates
'* If we get an error here then the image is a duplicate of a previous one
'* The ordinal number in imgNames identifies the image to use in the _Media folder
'*
i = imgNames.Count 'Current count
doDir = True ' Assume no duplicate
On Error Resume Next
imgNames.Add imgNum, imgName
On Error GoTo 0 'Always reset error handling after Resume
If i = imgNames.Count Then 'Duplicate found, build the duplicate's file name
StrMediaFile = IMAGEBASENAME & imgNames(imgName) & IMAGEEXTENSION
doDir = False 'Do not read a new file
End If
'*
'* Get the range where we want the link to appear
'*
Set Rng = objShape.Range
'*
'* Delete the image from the document
'*
objShape.Delete
'*
'* Replace the image with a link to a saved disk image in the *_Media folder
'*
.Fields.Add Range:=Rng, Type:=wdFieldEmpty, PreserveFormatting:=False, _
Text:="INCLUDEPICTURE """ & Replace(StrOutFold & "\" & StrMediaFile, "\", "\\") & """ \d"
If doDir Then StrMediaFile = Dir() ' Get the next media file since we had no duplicate this time
Next imgNum
.Fields.Update
End With
Set imgNames = Nothing
Application.ScreenUpdating = True
End Sub
John, yet another attempt. Runs fine with your test document and my docs as well.
Made the code 2 pass.
I found that sometimes original .jpg files will be saved as .jpeg files in the .zip file
Also sometimes .png files will be saved in .zip file as .jpeg.
I did not put any effort on finding out why. Instead I modified my code to cope with this fact.
Here is the result which will handle any number of duplicates.
'********************************************************************
'* Replace original images with links to locally extracted images
'* Ver. 1.02 2017-10-04 peakpeak
'*
Option Explicit
Const IMAGEBASENAME = "image"
Const JPEG = "jpeg"
Const JPG = "jpg"
Sub MakeDocMediaLinked()
Dim Doc As Document
Dim Rng As Range
Dim StrOutFold As String
Dim StrDocFile As String
Dim StrZipFile As String
Dim imgName As String
Dim StrMediaFile As String
Dim imgNum As Integer
Dim imgCount As Integer
Dim i As Integer
Dim ordinalNum As Integer
Dim imgOrdinals As New Collection
Dim objShape As InlineShape
Dim Obj_App As Object
Application.ScreenUpdating = False
With Application.Dialogs(wdDialogFileOpen)
If .Show = -1 Then
.Update
Set Doc = ActiveDocument
End If
End With
If Doc Is Nothing Then Exit Sub
With Doc
StrDocFile = .FullName ' ID the document to process
StrOutFold = Split(StrDocFile, ".")(0) & "_Media"
.Close SaveChanges:=False
End With
If Dir(StrOutFold, vbDirectory) = "" Then MkDir StrOutFold ' Test for existing output folder, create it if it doesn't already exist
'*
'* Delete any files in the output folder. On Error Resume Next not used
'*
If Dir(StrOutFold & "\*.*", vbNormal) <> "" Then Kill StrOutFold & "\*.*"
' Create a Shell App for accessing the zip archives
Set Obj_App = CreateObject("Shell.Application")
' Define the zip name
StrZipFile = Split(StrDocFile, ".")(0) & ".zip"
' Create the zip file, by simply copying to a new file with a zip extension
FileCopy StrDocFile, StrZipFile
' Extract the zip archive's media files to the temporary folder
Obj_App.NameSpace(StrOutFold & "\").CopyHere Obj_App.NameSpace(StrZipFile & "\word\media\").Items
Do While Dir(StrZipFile) <> "" ' Delete the zip file - the loop takes care of timing issues
Kill StrZipFile
Loop
StrMediaFile = Dir(StrOutFold & "\*.*", vbNormal) ' Get the temporary folder's file listing
Documents.Open FileName:=StrDocFile
With ActiveDocument
imgCount = .InlineShapes.Count
'*
'* Pass 1, collect ordinal numbers for all unique images
'*
ordinalNum = 1
For imgNum = 1 To imgCount
Set objShape = .InlineShapes(imgNum)
imgName = objShape.AlternativeText 'Contains the full path to the original inserted image
i = imgOrdinals.Count 'Current count of image ordinals
On Error Resume Next
imgOrdinals.Add ordinalNum, imgName 'Error if duplicate
On Error GoTo 0 'Always reset error handling after Resume
If i <> imgOrdinals.Count Then ordinalNum = ordinalNum + 1 'Ordinal added
Next imgNum
'*
'* Pass 2, replace images with links
'*
For imgNum = 1 To imgCount
'*
'* Get the (next) image
'*
Set objShape = .InlineShapes(imgNum)
'*
'* Get the original full path of the image
'*
imgName = objShape.AlternativeText 'Contains the full path to the original inserted image
'*
'* Original extension and extension in the .zip file might differ due to internal algorithms in Word
'* Get the image file name in *_Media folder based on its ordinal number and regardless of original extension
'*
StrMediaFile = Dir(StrOutFold & "\" & IMAGEBASENAME & imgOrdinals(imgName) & ".*", vbNormal)
'*
'* Get the range where we want the link to appear
'*
Set Rng = objShape.Range
'*
'* Delete the image from the document
'*
objShape.Delete
'*
'* Replace the image with a link to a saved disk image in the *_Media folder
'*
.Fields.Add Range:=Rng, Type:=wdFieldEmpty, PreserveFormatting:=False, _
Text:="INCLUDEPICTURE """ & Replace(StrOutFold & "\" & StrMediaFile, "\", "\\") & """ \d"
Next imgNum
.Fields.Update
End With
Set imgOrdinals = Nothing
Application.ScreenUpdating = True
End Sub
New solution
Method
For each InlineShape (working in reverse), if it's a wdInlineShapePicture
Copy it to a temporary document
Save the temporary document as .docx
Copy the temporary document as a .zip file
Extract the contents of the *.zip/word/media folder to a temporary folder
Move and rename the only file in that folder to the destination folder
Delete the shape
Create a field that links to the newly processed file, where the shape used to be
Code
Option Explicit
Sub Example()
MakeDocMediaLinked ActiveDocument
End Sub
Sub MakeDocMediaLinked(ByRef Doc As Document)
' iterate through each image
Dim i As Long
Dim shapeCollection As InlineShapes
Dim tempDoc As Document
Dim fso As New FileSystemObject ' early binding; add a reference to Microsoft Scripting Runtime (scrrun.dll)
Dim oShell As New Shell32.Shell ' early binding; add a reference to Microsoft Shell Controls and Automation (shell32.dll)
Dim currentMediaFileNameSource As String
Dim currentMediaFileNameNew As String
Dim shp As InlineShape
Dim rngToRemove As Range, rngToInsertInto As Range
Const tempDocFilePathDoc As String = "C:\test\temp.docx"
Const tempDocFilePathZip As String = "C:\test\temp.zip"
Const tempMediaFolderPath As String = "C:\test\temp\"
Const destMediaFolderPath As String = "C:\test\images\"
MakePath tempMediaFolderPath ' make the temporary folder in which to store an image, if it doesn't already exist
MakePath destMediaFolderPath ' make the images folder in which to store the images, if it doesn't already exist
Set tempDoc = Application.Documents.Add(Visible:=False) ' create the temp doc, hide it
tempDoc.SaveAs2 FileName:=tempDocFilePathDoc ' save the temp doc
Set shapeCollection = Doc.InlineShapes
For i = shapeCollection.Count To 1 Step -1 ' working backwards through the collection
Set shp = shapeCollection(i)
If shp.Type = wdInlineShapePicture Then
tempDoc.Range.Delete ' clear the temp doc
tempDoc.Range.FormattedText = shp.Range.FormattedText ' copy the image into the temp doc
tempDoc.Save ' save the temp doc
fso.CopyFile tempDocFilePathDoc, tempDocFilePathZip ' copy the temp doc and rename to a temp zip file (will overwrite existing zip)
oShell.NameSpace(tempMediaFolderPath).CopyHere oShell.NameSpace(tempDocFilePathZip & "\word\media\").Items ' copy the one media file to a destination
currentMediaFileNameSource = Dir(tempMediaFolderPath) ' get the name of the media file
currentMediaFileNameNew = "media-" & i & Mid(currentMediaFileNameSource, InStrRev(currentMediaFileNameSource, ".")) ' names the files media-4.jpeg, media-3.png, etc.
fso.CopyFile tempMediaFolderPath & currentMediaFileNameSource, destMediaFolderPath & currentMediaFileNameNew ' copy and rename the file into the destination folder
fso.DeleteFile tempMediaFolderPath & currentMediaFileNameSource, True ' delete the temporary file
Set rngToRemove = shp.Range ' set the range that we will be removing, i.e. the shape range
Set rngToInsertInto = shp.Range ' set the range that we will be inserting the field into, i.e. the start of the shape range (1)
rngToInsertInto.Collapse wdCollapseStart ' set the range that we will be inserting the field into, i.e. the start of the shape range (2)
rngToRemove.Delete ' remove the shape
Doc.Fields.Add Range:=rngToInsertInto, Type:=wdFieldEmpty, PreserveFormatting:=False, _
Text:="INCLUDEPICTURE """ & Replace(destMediaFolderPath & currentMediaFileNameNew, "\", "\\") & """ \d" ' 4. add the field, we refer to destMediaFolderPath & currentMediaFileNameNew in the field definition
End If
Next i
tempDoc.Close SaveChanges:=False ' close the temp doc
fso.DeleteFile tempDocFilePathZip, True ' delete the temporary zip
fso.DeleteFile tempDocFilePathDoc, True ' delete the temporary doc
fso.DeleteFolder Left(tempMediaFolderPath, Len(tempMediaFolderPath) - 1), True ' delete the temporary folder
Set fso = Nothing
Set oShell = Nothing
End Sub
Sub MakePath(ByVal tempPath As String)
Dim fso As New FileSystemObject
Dim path() As String
Dim path2() As String
Dim i As Long
Do While Right(tempPath, 1) = "\" ' remove any ending slashes
tempPath = Left(tempPath, Len(tempPath) - 1)
Loop
path = Split(tempPath, "\")
ReDim path2(LBound(path) To UBound(path))
i = LBound(path)
path2(i) = path(i)
If Not fso.FolderExists(path2(i) & "\") Then Exit Sub ' if the drive doesn't even exist, then exit
For i = LBound(path) + 1 To UBound(path)
path2(i) = path2(i - 1) & "\" & CleanPath(path(i))
If Not fso.FolderExists(path2(i) & "\") Then fso.CreateFolder path2(i)
Next i
Set fso = Nothing
End Sub
Function CleanPath(ByVal tempPath As String)
Dim i As Long
Dim invalidChars As Variant
invalidChars = Array("/", ":", "*", "?", """", "<", ">", "|")
For i = LBound(invalidChars) To UBound(invalidChars)
tempPath = Replace(tempPath, invalidChars(i), " ")
Next i
CleanPath = tempPath
End Function
After
images folder
document (showing fields)
I've been looking around for a VBA script that will open a folder, open a .xlsx file, run my code, close the .xlsx file, and go to the next folder (not subfolder). I just can't figure it out. My folder structure is as follows:
C:\Files\[hundreds of folders]\name.xlsx
Each folder has a .xlsx file in it and I need to run my code on all of these files (about 1000 folders each with 1 file).
Any and all help would be greatly appreciated! Thanks!
This uses a list "mfList" that gets created based on the criteria that it begins with "C:\Files\" and has exactly one sub folder after that point. All such folders "qualify" to be recorded in the list. Once you have the list, you can go through each of the paths, and for every .xlsx file in that path, run your code. I took one of my programs and manipulated it, so I haven't actually tested it, but hopefully this gives you the idea, and points you in the right direction. (And again these are functions, you'd have to create the subroutine that calls them, of course, with appropriate variables)
Function MapFolders(fPath As String, Optional ByRef mfList As Collection, Optional NotTopLevel As Boolean)
Dim i As Long, Temp As String, nList As New Collection, mfVariant As Variant
On Error Resume Next: i = mfList.Count: On Error GoTo 0: If i = 0 Then Set mfList = nList
If Left(fPath, 9) = "C:\Files\" And InStr(Right(fPath, Len(fPath) - 9), "\") = InStrRev(Right(fPath, Len(fPath) - 9), "\") And Not InStr(Right(fPath, Len(fPath) - 9), "\") = 0 Then mfList.Add fPath
i = 1: Temp = SubFolder(fPath, i)
While Len(Temp) > 0
MapFolders Temp, mfList, True
i = i + 1: Temp = SubFolder(fPath, i)
Wend
If (Not mfList.Count = 0) And (Not NotTopLevel) Then Set mfVariant = Nothing: Set mfList = nList
Set nList = Nothing
End Function
Function SubFolder(fPath As String, i As Long) As String
Dim FSO As New FileSystemObject, FSOFolder As Object, FSOSubFolder As Object, FCount As Integer, j As Long
SubFolder = "": On Error Resume Next: Set FSOFolder = FSO.GetFolder(fPath): On Error GoTo 0
If FSOFolder Is Nothing Then Exit Function
On Error Resume Next: FCount = FSOFolder.SubFolders.Count: On Error GoTo 0
If i <= FCount Then
For Each FSOSubFolder In FSOFolder.SubFolders
j = j + 1: If j = i Then Exit For
Next FSOSubFolder
SubFolder = FSOSubFolder.Path & "\"
End If
Set FSO = Nothing: Set FSOFolder = Nothing
End Function
Hope this helps. You can extrapolate accordingly.
Sub Openfile()
Dim MyFolder As String
Dim MyFile As String
'The code below opens up the specified folder.
'Replace the pathway with your own.
'Keep the explorer.exe string.
Call Shell("explorer.exe" & " " & "C:\Users\mvanover\Desktop\Test", vbNormalFocus)
'The code below opens up every excel file with .xlsx extension in the MyFolder path.
MyFolder = "C:\Users\mvanover\Desktop\Test"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
End Sub
Update:
You could also input all the folder names in cells located in your macro-enabled workbook and set those values to the an object in your macro. You can then add that object to the end of your string located in the shell function. An example is shown below:
Call Shell("explorer.exe" & " " & "C:\Users\mvanover\Desktop\Test\" & FolderName, vbNormalFocus)
You could then set up an easy loop that would go through each folder name and open them accordingly. Your code inside that loop would consist of opening all/one excel workbook(s), running the code you'd like to run, and closing the each folder. The code for closing the folders as well is shown below:
Call Shell("explorer.exe" & " " & "C:\Users\mvanover\Desktop\Test\" & FolderName, vbNormalFocus)
DoEvents
Hwnd = apiFindWindow("CabinetWClass", vbNullString)
Dim retval As Long
If (Hwnd) Then
retval = apiPostMessage(Hwnd, CLOSE_WIN, 0, ByVal 0&)
End If
Add the code shown below before your sub statement as well or the closing folder code won't work:
Private Const CLOSE_WIN = &H10
Dim Hwnd As Long
Private Declare Function apiFindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassname As String, _
ByVal lpWindowName As String) _
As Long
Private Declare Function apiPostMessage _
Lib "user32" Alias "PostMessageA" _
(ByVal Hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
Sorry about all this new code. It's actually a lot harder to close a folder compared to opening it. When I was debugging through the closing code with F8 it works.
I have a barcode reader and bunch of books. For each of the books, I want to list the book name and the author in an Excel spreadsheet.
My view is that some VBA code connecting to an Amazon web service would make this easier.
My questions is - hasn't anyone done this before? Could you point me to the best example.
I thought it was an easy one googling, but turned out more difficult than I expected.
In fact, I was unable to find a VBA ISBN based program to get book data from the web, so decided to do one.
Here is a VBA macro using the services from xisbn.worldcat.org. Examples here.. The services are free and don't need authentication.
To be able to run it you should check at Tools-> References (in the VBE window) the "Microsoft xml 6.0" library.
This macro takes the ISBN (10 digits) from the current cell and fills the following two columns with the author and title. You should be able to loop through a full column easily.
The code has been tested (well, a bit) but there is no error checking in there.
Sub xmlbook()
Dim xmlDoc As DOMDocument60
Dim xWords As IXMLDOMNode
Dim xType As IXMLDOMNode
Dim xword As IXMLDOMNodeList
Dim xWordChild As IXMLDOMNode
Dim oAttributes As IXMLDOMNamedNodeMap
Dim oTitle As IXMLDOMNode
Dim oAuthor As IXMLDOMNode
Set xmlDoc = New DOMDocument60
Set xWords = New DOMDocument60
xmlDoc.async = False
xmlDoc.validateOnParse = False
r = CStr(ActiveCell.Value)
xmlDoc.Load ("http://xisbn.worldcat.org/webservices/xid/isbn/" _
+ r + "?method=getMetadata&format=xml&fl=author,title")
Set xWords = xmlDoc
For Each xType In xWords.ChildNodes
Set xword = xType.ChildNodes
For Each xWordChild In xword
Set oAttributes = xWordChild.Attributes
On Error Resume Next
Set oTitle = oAttributes.getNamedItem("title")
Set oAuthor = oAttributes.getNamedItem("author")
On Error GoTo 0
Next xWordChild
Next xType
ActiveCell.Offset(0, 1).Value = oTitle.Text
ActiveCell.Offset(0, 2).Value = oAuthor.Text
End Sub
I did not go through Amazon because of their new "straightforward" authentication protocol ...
This is has been enormously helpful for me!
I have updated the macro to allow it to cycle through a column of ISBN numbers until it reaches an empty cell.
It also search for publisher, year and edition.
I have added some basic error checking if certain fields are not available.
Sub ISBN()
Do
Dim xmlDoc As DOMDocument60
Dim xWords As IXMLDOMNode
Dim xType As IXMLDOMNode
Dim xword As IXMLDOMNodeList
Dim xWordChild As IXMLDOMNode
Dim oAttributes As IXMLDOMNamedNodeMap
Dim oTitle As IXMLDOMNode
Dim oAuthor As IXMLDOMNode
Set xmlDoc = New DOMDocument60
Set xWords = New DOMDocument60
xmlDoc.async = False
xmlDoc.validateOnParse = False
r = CStr(ActiveCell.Value)
xmlDoc.Load ("http://xisbn.worldcat.org/webservices/xid/isbn/" _
+ r + "?method=getMetadata&format=xml&fl=author,title,year,publisher,ed")
Set xWords = xmlDoc
For Each xType In xWords.ChildNodes
Set xword = xType.ChildNodes
For Each xWordChild In xword
Set oAttributes = xWordChild.Attributes
On Error Resume Next
Set oTitle = oAttributes.getNamedItem("title")
Set oAuthor = oAttributes.getNamedItem("author")
Set oPublisher = oAttributes.getNamedItem("publisher")
Set oEd = oAttributes.getNamedItem("ed")
Set oYear = oAttributes.getNamedItem("year")
On Error GoTo 0
Next xWordChild
Next xType
On Error Resume Next
ActiveCell.Offset(0, 1).Value = oTitle.Text
On Error Resume Next
ActiveCell.Offset(0, 2).Value = oAuthor.Text
On Error Resume Next
ActiveCell.Offset(0, 3).Value = oPublisher.Text
On Error Resume Next
ActiveCell.Offset(0, 4).Value = oYear.Text
On Error Resume Next
ActiveCell.Offset(0, 5).Value = oEd.Text
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell.Value)
End Sub
I just found this thread as I was attempting to do the same thing. Unfortunately I'm on a MAC, so these answers don't help. With a bit of research I was able to do get it to work in MAC Excel with this module:
Option Explicit
' execShell() function courtesy of Robert Knight via StackOverflow
' http://stackoverflow.com/questions/6136798/vba-shell-function-in-office- 2011-for-mac
Private Declare Function popen Lib "libc.dylib" (ByVal command As String, ByVal mode As String) As Long
Private Declare Function pclose Lib "libc.dylib" (ByVal file As Long) As Long
Private Declare Function fread Lib "libc.dylib" (ByVal outStr As String, ByVal size As Long, ByVal items As Long, ByVal stream As Long) As Long
Private Declare Function feof Lib "libc.dylib" (ByVal file As Long) As Long
Function execShell(command As String, Optional ByRef exitCode As Long) As String
Dim file As Long
file = popen(command, "r")
If file = 0 Then
Exit Function
End If
While feof(file) = 0
Dim chunk As String
Dim read As Long
chunk = Space(50)
read = fread(chunk, 1, Len(chunk) - 1, file)
If read > 0 Then
chunk = Left$(chunk, read)
execShell = execShell & chunk
End If
Wend
exitCode = pclose(file)
End Function
Function HTTPGet(sUrl As String) As String
Dim sCmd As String
Dim sResult As String
Dim lExitCode As Long
Dim sQuery As String
sQuery = "method=getMetadata&format=xml&fl=*"
sCmd = "curl --get -d """ & sQuery & """" & " " & sUrl
sCmd = "curl --get -d """ & sQuery & """" & " " & sUrl
sResult = execShell(sCmd, lExitCode)
' ToDo check lExitCode
HTTPGet = sResult
End Function
Function getISBNData(isbn As String) As String
Dim sUrl As String
sUrl = "http://xisbn.worldcat.org/webservices/xid/isbn/" & isbn
getISBNData = HTTPGet(sUrl)
End Function
Function getAttributeForISBN(isbn As String, info As String) As String
Dim data As String
Dim start As Integer
Dim finish As Integer
data = getISBNData(isbn)
start = InStr(data, info) + Len(info) + 2
finish = InStr(start, data, """")
getAttributeForISBN = Mid(data, start, finish - start)
End Function
This is not all my original work, I pasted it together from another site, then did my own work. Now you can do things like:
getAttributeForISBN("1568812019","title")
This will return the title of that book. Of course you can apply this formula to all of the ISBNs in column A to look up multiple titles, or authors, or whatever.
Hopefully this helps someone else out there!
If the barcode is the ISBN, which seems likely, perhaps you can use: amazon.com/Advanced-Search-Books/b?ie=UTF8&node=241582011