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
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
Posting Permissions
Reply With Quote
