![]() |
|
|
|
#1
|
||||
|
||||
|
Hi All, I'm trying to create a Loop based code that matches the name of the file with images in a folder. If name matches then it will add a sheet and insert image in sheet. If it doesn't match then it should move on to next file in folder. I read a lot online and came up with the below but loop code not working. Code given below. Please note that I have never created a Word Macro - I work mainly on Excel Code:
'Links Used by Chirayu Walawalkar:
'http://stackoverflow.com/questions/11564857/how-do-i-get-the-current-filename-of-a-word-document-without-the-extension-or-f
'http://word.tips.net/T000819_Determining_if_a_File_Exists.html
'http://word.tips.net/T001437_Batch_Template_Changes.html
Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) > "")
End Function
'=====
Sub Case_Image()
'loop to work on all files
Dim strDocPath As String
Dim strCurDoc As String
Dim docCurDoc As Document
strDocPath = "C:\Cases\" '>>>>> change folder path if cases stored in different folder
strCurDoc = Dir$(strDocPath & "*.doc") '>>>>> check if doc or docx and change accordingly
Do While strCurDoc <> ""
Set docCurDoc = Documents.Open(strDocPath & strCurDoc)
'get my document name without .doc/.docx and other extensions
Dim doc As String
If InStrRev(ActiveDocument.Name, ".") <> 0 Then
doc = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)
Else
doc = ActiveDocument
End If
'check if my image exists and matches my document name
'if image found then add new page and copy image
If FileThere(ActiveDocument.Path & "\images\" & doc & ".jpg") Then '>>>>> relates to the function written above
Selection.InsertNewPage
Selection.InlineShapes.AddPicture FileName:= _
ActiveDocument.Path & "\images\" & doc & ".jpg", _
LinkToFile:=False, SaveWithDocument:=True
'if image not found then give me a message saying that
Else
'''''MsgBox "Image not found", vbInformation, ""
End If
docCurDoc.Save
docCurDoc.Close
' get next file name
strCurDoc = Dir$()
Loop
MsgBox "", vbInformation, "Folder consolidated"
End Sub
|
|
#2
|
||||
|
||||
|
Is this for Word or Excel? Word doesn't have sheets. You also seem to refer to a 'FileThere' function, but it doesn't appear in your code.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
#3
|
||||
|
||||
|
Hi macropod I'm referring to word and the Filethere function appears in the code above where its checking to see if the image exists with the same name as my filename
Code:
'check if my image exists and matches my document name 'if image found then add new page and copy image If FileThere...... |
|
#4
|
||||
|
||||
|
That's all very well, but VBA does not have a FileThere function.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
#5
|
||||
|
||||
|
Hi macropod,
I took the code for Filethere from following site: Code:
http://word.tips.net/T000819_Determining_if_a_File_Exists.html This part gets doc name: Code:
'get my document name without .doc/.docx and other extensions
Dim doc As String
If InStrRev(ActiveDocument.Name, ".") <> 0 Then
doc = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)
Else
doc = ActiveDocument
End If
Code:
'check if my image exists and matches my document name 'if image found then add new page and copy image If FileThere(ActiveDocument.Path & "\images\" & doc & ".jpg") Then '>>>>> relates to the function written above Selection.InsertNewPage Selection.InlineShapes.AddPicture FileName:= _ ActiveDocument.Path & "\images\" & doc & ".jpg", _ LinkToFile:=False, SaveWithDocument:=True |
|
#6
|
||||
|
||||
|
The basic problem with your code is that the Dir inside the loop wipes out the data for the outer Dir. Try:
Code:
Sub Case_Image()
Dim strFldr As String, strDocs As String, strImgs As String, strPath As String, StrImg As String
Dim wdDoc As Document, Rng As Range, i As Long
strPath = "C:\Cases\" '>>>>> change folder path if cases stored in different folder
strFldr = Dir(strPath & "*.doc", vbNormal) '>>>>> check if doc or docx and change accordingly
'Build document & image lists
While strFldr <> ""
strImgs = strImgs & vbCr & strPath & "\images\" & Left(strFldr, InStrRev(strFldr, ".")) & "jpg"
strDocs = strDocs & vbCr & strPath & strFldr
strFldr = Dir()
Wend
'Loop through the lists to match documents with images
For i = 1 To UBound(Split(strDocs, vbCr))
'If the document and its image are both found, add the image to the document
If (Dir(Split(strImgs, vbCr)(i), vbNormal) <> "") And (Dir(Split(strDocs, vbCr)(i), vbNormal) <> "") Then
Set wdDoc = Documents.Open(Split(strDocs, vbCr)(i), AddToRecentFiles:=False)
With wdDoc
.Range.Characters.First.InsertBreak wdPageBreak
Set Rng = .Range.Characters.First
Rng.Collapse wdCollapseStart
.InlineShapes.AddPicture FileName:=Split(strImgs, vbCr)(i), _
LinkToFile:=False, SaveWithDocument:=True, Range:=Rng
.Close True
End With
'If the image is missing, report it
ElseIf (Dir(Split(strImgs, vbCr)(i), vbNormal) <> "") Then
MsgBox Split(strImgs, vbCr)(i) & vbCr & "Not found", vbInformation
End If
Next
Set Rng = Nothing: Set wdDoc = Nothing
MsgBox "", vbInformation, "Folder consolidated"
End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
#7
|
||||
|
||||
|
Thanks macropod, works great... confusing because I hardly ever use DIM so will need to decode it.
I had another linked question instead of giving it a predefined folder path to run - is there a way to make it run from wherever it is opened. As in I open my first file and run the macro, it will auto pick the path from my first file and do it work and move onto next file? Is there also a way to tell it to give me a select folder option? Like when I run the macro it will ask me if I want to start from current file and folder or choose a different folder? |
|
#8
|
||||
|
||||
|
Quote:
Quote:
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
| Thread Tools | |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Thread Starter | Forum | Replies | Last Post |
batch file
|
romanticbiro | Office | 1 | 06-30-2014 06:04 PM |
| Batch adding Metadata to Docs | AndyTake2 | Word | 0 | 02-01-2013 10:18 AM |
Batch create Word documents
|
cdfj | Word VBA | 6 | 11-07-2012 01:03 PM |
Batch Edit Links
|
tosti | PowerPoint | 5 | 01-31-2012 12:51 PM |
Processing Time Intervals
|
pkrishna | Excel | 5 | 09-30-2011 06:24 AM |