Macro to replace Image, Numbers in Table and in multiple protected word document

[balaji3081]

Hi All,

I am struggling at this, I have received 200 word documents for which I need to make set changes on all, Below are th changes requested -

NOTE : All Word Documents are password protected, and after the changed are made need to be saved as current month -

1 - Logo to be replaced.
2- In a already existing table need to replace numbers,
3 - In the given table need to insert a row and add comments to the row.
4- Update Header and footer with present Month & Year.

Please help.

[gmayor]

See my comments to the equally vague duplicate of this question at http://www.msofficeforums.com/word-vba/30531-macro-replace-image-numbers-table-multiple-protected.html

[balaji3081]

Apologies not being clear on my request, I have provided the details below, Hope this helps to understand my request better.


Is the password the same for all the documents? And what does "be saved as current month" mean?
"The password is same for all the documents", the old files are named as "xxxxxx-04/15", which needs to be changed to "xxxxxx-03/16"

1. Where and how is the logo inserted? - "there is a old company logo on the document needs to be replaced with the new logo".
2. Replace which numbers with what? - To be replaced with numbers again.
3. Insert a row where and in which cell add the comments? - "there are 3 tables with vendor name and fees and description, In one of the tables I need to add a new vendor details by adding a new row"
4. What is in the headers and footers that needs to be 'updated' - "Header and Footer has the version date as 04/2015, needs to be updated to 03/2016"

[balaji3081]

Hi Gmayor,

Attaching he sample file and the set of instructions.


I am not able to log in into the other forum.

Hence adding files here , please have a look at them and let me know if it provides the required details.


Thanks.

[balaji3081]

Any quick suggestions will be very helpful.

Regards

[gmayor]

You would have had a quicker response had you posted the information when I originally asked for it, instead of posting the same question, without the information, in an assortment of forums. As I explained this is not a simple process even with the document sample, and impossible without it. Forum contributors provide this assistance in their own time. It is not a help desk!

It was my birthday yesterday and I had more intesting things to do. However the following function, used in conjunction with

http://www.gmayor.com/document_batch_processes.htm (http://www.gmayor.com/document_batch_processes.htm)
will do what you asked when run as a custom process. It will provide a report to indicate any documents that don't match the criteria.


Option Explicit
Function DocEdit(oDoc As Document) As Boolean
'Use in conjunction with http://www.gmayor.com/document_batch_processes.htm
Dim oShape As Shape
Dim oRng As Range
Dim oStory As Range
Dim oTable As Table
Dim oCell As Range
Dim oRow As Row
Dim sName As String
Dim sPath As String
Dim dTop As Long, dLeft As Long, dWidth As Long, dHeight As Long

On Error GoTo err_Handler

If Not oDoc.Shapes.Count = 1 Then GoTo err_Handler
If Not oDoc.Tables.Count = 6 Then GoTo err_Handler

'Change picture
With oDoc.Shapes(1)
dTop = .Top
dLeft = .Left
dWidth = .Width
dHeight = .Height
.Delete
End With
Set oRng = oDoc.Range(0, 0)
Set oShape = oDoc.Shapes.AddPicture(Filename:="C:\Path\Forums\NewLogo.png", _
LinkToFile:=False, _
SaveWithDocument:=True, Anchor:=oRng)
With oShape
.Top = dTop
.Left = dLeft
.Width = dWidth
.Height = dHeight
.WrapFormat.Type = wdWrapSquare
End With

'Modify Table 1
Set oTable = oDoc.Tables(1)
Set oCell = oTable.Columns(3).Cells(2).Range
oCell.End = oCell.End - 1
oCell.Text = Replace(oCell.Text, "120", "128")

'Modify Table 2
Set oTable = oDoc.Tables(2)
Set oCell = oTable.Columns(2).Cells(4).Range
oCell.End = oCell.End - 1
oCell.Text = Replace(oCell.Text, "195", "175")

Set oCell = oTable.Columns(3).Cells(4).Range
oCell.End = oCell.End - 1
oCell.Text = Replace(oCell.Text, "195", "175")

'Modify Table 3
Set oTable = oDoc.Tables(3)
Set oCell = oTable.Columns(1).Cells(1).Range
oCell.End = oCell.End - 1
oCell.Text = Replace(oCell.Text, "tt", "t")

'Modify Table 4
Set oTable = oDoc.Tables(4)
Set oCell = oTable.Columns(1).Cells(1).Range
oCell.End = oCell.End - 1
oCell.Text = Replace(oCell.Text, "tt", "t")

Set oCell = oTable.Columns(2).Cells(7).Range
oCell.End = oCell.End - 1
oCell.Text = Replace(oCell.Text, "9", "87")

Set oRow = oTable.Rows.Add(BeforeRow:=oTable.Rows(7))
Set oCell = oRow.Cells(1).Range
oCell.End = oCell.End - 1
oCell.Text = "Project RAG"
Set oCell = oRow.Cells(2).Range
oCell.End = oCell.End - 1
oCell.Text = "0.07%"
Set oCell = oRow.Cells(3).Range
oCell.End = oCell.End - 1
oCell.Text = "Xxx"

'Change version dates
For Each oStory In oDoc.StoryRanges
With oStory.Find
Do While .Execute(FindText:="Version date [0-9]{2}\/[0-9]{4}", _
MatchWildcards:=True, _
Wrap:=wdFindStop)
oStory.Text = "Version date " & Format(Date, "mm/yyyy")
oStory.Collapse 0
Loop
End With
Next oStory
'Revise document name
sPath = oDoc.Path & Chr(92)
sName = Left(oDoc.Name, InStr(1, oDoc.Name, Chr(46)) - 1)
sName = Left(sName, Len(sName) - 6)
sName = sName & Format(Date, "mm-yyyy") & ".docx"

sName = sPath & FileNameUnique(sPath, sName, "docx")

'Save Document with new name
oDoc.SaveAs2 Filename:=sName, AddToRecentFiles:=False
DocEdit = True
lbl_Exit:
Set oShape = Nothing
Set oRng = Nothing
Set oStory = Nothing
Set oCell = Nothing
Set oRow = Nothing
Exit Function
err_Handler:
DocEdit = False
GoTo lbl_Exit
End Function

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor
'Requires the use of the FileExists function
'strPath is the path in which the file is to be saved
'strFilename is the filename to check
'strextension is the extension of the filename to check
Dim lngF As Long
Dim lngName As Long
strExtension = Replace(strExtension, Chr(46), "")
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
'If the filename exists, add or increment a number to the filename
'and keep checking until a unique name is found
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
'Reassemble the filename
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strFullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[balaji3081]

Thanks Gmayor for your help, I agree it would have been easier had I given the sample files in the first go, Also agree this is not a help desk.

Unfortunately I am not allowed to download the add in you mentioned on my office system, Is there any other method/code for getting the result.

Regards.