Amendment in the macro

[Jagdev]

Hi Experts

I already have a macro which pick the Reference number from the body of the worddoc and rename it. The link for your reference - http://www.msofficeforums.com/word-vba/23610-how-rename-word-doc-name-mentioned-body-2.html and macro is attached with the thread as well.

The word files are in tabular form and the number is in right section and with the number can I get the name which is in the left side of it. In short is it possible to rename the doc with reference number and the name as well.

Regards,
JD

[Jagdev]

Hi

please find the sample doc file as well. I have manually created it to create the replica of the original document. The name of the sample file should be - "Asia-Pacific_DUTM033_000012TTY.docx"

The latter half is achievable with the macro, but the first half is something I am looking for.

Regards,
JD

[Jagdev]

Hi Experts

Any view on the above thread please.

Regards,
JD

[gmayor]

Your original document was locked and meaningless. Your second doc used content controls so you can read those to get the construction you require. You will also require a function to remove any illegal filename characters e.g.



Sub Macro1()
Dim oCC As ContentControl
Dim strName As String
Dim strRef1 As String
Dim strRef2 As String
Dim strFilename As String
For Each oCC In ActiveDocument.ContentControls
Select Case oCC.Title
Case "TreatyStatement/Name": strName = oCC.Range.Text
Case "TreatyStatement/OurReference1": strRef1 = oCC.Range.Text
Case "TreatyStatement/OurReference2": strRef2 = oCC.Range.Text
End Select
Next oCC
strFilename = strName & Chr(95) & strRef1 & Chr(95) & strRef2 & ".docx"
MsgBox CleanFileName(strFilename, "docx")
lbl_Exit:
Exit Sub
End Sub

Private Function CleanFileName(strFilename As String, strExtension As String) As String
Dim vfName As Variant
Dim lng_Name As Long
If InStr(1, strFilename, Chr(92)) > 0 Then
vfName = Split(strFilename, Chr(92))
CleanFileName = vfName(UBound(vfName))
vfName = Split(CleanFileName, Chr(46))
Else
vfName = Split(strFilename, Chr(46))
End If
CleanFileName = vfName(0)
If UBound(vfName) > 1 Then
For lng_Name = 1 To UBound(vfName) - 1
CleanFileName = CleanFileName & Chr(46) & vfName(lng_Name)
Next lng_Name
End If
vfName = Split(CleanFileName, Chr(11))
CleanFileName = vfName(0)
vfName = Split(CleanFileName, Chr(13))
CleanFileName = vfName(0) & Chr(46) & strExtension
CleanFileName = Replace(CleanFileName, Chr(34), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(42), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(47), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(58), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(60), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(62), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(63), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(92), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(124), Chr(95))
lbl_Exit:
Exit Function
End Function

[Jagdev]

Hi Graham

I am really very very sorry for adding password on the module. It just really went off from my head.

I removed the password and attached it with the thread. Please have a look on it.

Regards,
JD

[Jagdev]

Hi Graham,

The word "TreatyStatement/" is not compulsory be available in the word docs. The sample file I uploaded is manually created to help you understand how the docs look alike. The attached macro is working fine to rename the doc files with reference number, but one more requirement arises in which we have to rename the file with both name and number. If I considered the above sample example as my doc file which needs to be renamed, its name would be - Asia-Pacific_DUTM033_000012TTY.docx
Please let me know if anything is unclear.
Regards,
JD

[gmayor]

I don't think that access to your code helps here. The macro I just posted will derive the filename from a document that matches your second document, by reading the content controls (it has to get the name from somewhere), so if the document may be formatted differently you would have to create a function that gets the filename from what you have. For a macro like this to work there has to be some consistency between the documents for the macro to be able to access the required parts.

[Jagdev]

The things that are consistency in all the statements are listed on the left end side of the document.
Please quote our reference in any enquiry to Accounts Department

Account Number

Your Reference

Our Reference

Advice Date

The name is opposite to Account Number – Is it possible to pull whatever is there on the right end side of the account number and merge it with the Our reference as a naming convention of the document.

[gmayor]

What are to the right of these items are content controls. It is they that need to be addressed, by title (or unique part of a title)
Otherwise you have made things difficult by the use of nested tables and merged cells. I wouldn't want to go there.

[Jagdev]

The right end side consist of name of the company first at the first line and then its address on the rest of lines. One thing is sure that on the right end side is name of the company at the first line. I just random check few document and find that few contains "reatyStatement/" if I am not wrong this means content control as per your macro code and few are without it.

Regards,
JD

[Jagdev]

I am even fine if we can pull a word or two from the name instead of entire name.

[Jagdev]

Hi Graham
Just asking for my info the macro which I have posted in which the main source of renaming convention is:
“With .Tables(1).Cell(2, 2).Tables(1).Cell(3, 2).Range
strNewNm = .ContentControls(1).Range.Text _
& "_" & .ContentControls(2).Range.Text
End With”
I believe it means the Tables(1) and 2nd row and 2nd cell which will take the macro to our reference number, but isn’t the right end data is part of this table, I tried to change the range Tables(1).Cell(2,1).Tables(1).Cell(3,2).Range it throws error that error 5941 – the requested member of the collection doesn’t exist. I tired many permutation and combination, but encountered same error msg.
Regards,
JD

[Jagdev]

Hi Graham
I think that, I understood your point of content controls on the right end side. The macro which you have posted above run will when we have to rename TreatyStatement/Name with other controls as well in the table.
We have 2 types of Statements one is TreatyStatement which works fine with you macro and other one is Closing Instruction. Where they have hide the content control and can we unlock the content control and I believe its control names will be different. That is not the issue we can create a copy of the macro and run these statements with few modifications on it.
Regards,
JD

[Jagdev]

Hi Graham
Could you please help me with few modifications in you macro code? The code should pick doc files from a folder location and rename them and save them in a particular folder. Currently it is just popping up the name at the end of the code.



Sub Macro1()
Dim oCC As ContentControl
Dim strName As String
Dim strRef1 As String
Dim strRef2 As String
Dim strFilename As String
For Each oCC In ActiveDocument.ContentControls
Select Case oCC.Title
Case "TreatyStatement/Name": strName = oCC.Range.Text
Case "TreatyStatement/OurReference1": strRef1 = oCC.Range.Text
Case "TreatyStatement/OurReference2": strRef2 = oCC.Range.Text
End Select
Next oCC
strFilename = strName & Chr(95) & strRef1 & Chr(95) & strRef2 & ".docx"
MsgBox CleanFileName(strFilename, "docx")
lbl_Exit:
Exit Sub
End Sub

Private Function CleanFileName(strFilename As String, strExtension As String) As String
Dim vfName As Variant
Dim lng_Name As Long
If InStr(1, strFilename, Chr(92)) > 0 Then
vfName = Split(strFilename, Chr(92))
CleanFileName = vfName(UBound(vfName))
vfName = Split(CleanFileName, Chr(46))
Else
vfName = Split(strFilename, Chr(46))
End If
CleanFileName = vfName(0)
If UBound(vfName) > 1 Then
For lng_Name = 1 To UBound(vfName) - 1
CleanFileName = CleanFileName & Chr(46) & vfName(lng_Name)
Next lng_Name
End If
vfName = Split(CleanFileName, Chr(11))
CleanFileName = vfName(0)
vfName = Split(CleanFileName, Chr(13))
CleanFileName = vfName(0) & Chr(46) & strExtension
CleanFileName = Replace(CleanFileName, Chr(34), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(42), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(47), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(58), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(60), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(62), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(63), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(92), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(124), Chr(95))
lbl_Exit:
Exit Function
End Function

[gmayor]

You don't need two macros you just need case statements to reflect what you see e.g.


Case "TreatyStatement/Name", "Closing/Name" : strName = oCC.Range.Text

As for the rest, I thought you already had a macro that would loop through and save the documents? All you need to do is add the code into the loop and instead of a message box, save the file with the name.

[Jagdev]

Hi Graham

Thanks for your help. I almost fixed all the issue, but stuck with closing statement. The doc files are password protected is there any code with unprotect the doc file?

Regards,
JD

[gmayor]

What closing statement? I am not sure what you mean. Both Open and SaveAs have options to include passwords. These are well covered in the VBA Help.

[Jagdev]

Hi Graham
I have 4 different types of doc files which need to be renamed. I somehow managed to find their content controls and they are in the code below. Can we do something to reduce it? Currently what I am thinking is to create 4 different folders and links them to each code and run it, but is there any other way to deal with it.


Sub RenameDocuments()
Application.ScreenUpdating = False
Dim strFldr As String, strDocNm As String, strFile As String, strNewNm As String, wdDoc As Document
Dim FSO As Object, objFile As Object
strDocNm = ActiveDocument.FullName
strFldr = GetFolder
If strFldr = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
strFldr = strFldr & "\"
strFile = Dir(strFldr & "*.doc", vbNormal)
While strFile <> ""
If strFldr & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFldr & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
strNewNm = .SelectContentControlsByTitle("TreatyStatement/Name")(1).Range.Text _
& "_" & .SelectContentControlsByTitle("TreatyStatement/OurReference1")(1).Range.Text _
& "_" & .SelectContentControlsByTitle("TreatyStatement/OurReference2")(1).Range.Text _
'& "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
strNewNm = strNewNm & "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
.Close SaveChanges:=False
End With
If FSO.FileExists(strFldr & strNewNm) Then
ActiveDocument.Range.InsertAfter "Unable to create:" & Chr(11) & strFldr & strNewNm & Chr(11) & "File Exists" & vbCr
Else
Set objFile = FSO.GetFile(strFldr & strFile)
objFile.Name = strNewNm
End If
End If
strFile = Dir()
Wend
Set wdDoc = Nothing: Set objFile = Nothing: Set FSO = Nothing
Application.ScreenUpdating = True
End Sub
Sub RenameDocuments_ClmNOS()
Application.ScreenUpdating = False
Dim strFldr As String, strDocNm As String, strFile As String, strNewNm As String, wdDoc As Document
Dim FSO As Object, objFile As Object
strDocNm = ActiveDocument.FullName
strFldr = GetFolder
If strFldr = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
strFldr = strFldr & "\"
strFile = Dir(strFldr & "*.doc", vbNormal)
While strFile <> ""
If strFldr & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFldr & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
strNewNm = .SelectContentControlsByTitle("CN/Ccy1/CurrencyDets/CurrencyDet/InsuredName")(1).Range.Text _
& "_" & .SelectContentControlsByTitle("ClaimNotification/Ccy1/CurrencyDetails/CurrencyDetail/ClaimRef")(1).Range.Text _
& "_" & .SelectContentControlsByTitle("ClaimNotification/Ccy1/CurrencyDetails/CurrencyDetail/Policyref")(1).Range.Text _
' & "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
strNewNm = strNewNm & "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
.Close SaveChanges:=False
End With
If FSO.FileExists(strFldr & strNewNm) Then
ActiveDocument.Range.InsertAfter "Unable to create:" & Chr(11) & strFldr & strNewNm & Chr(11) & "File Exists" & vbCr
Else
Set objFile = FSO.GetFile(strFldr & strFile)
objFile.Name = strNewNm
End If
End If
strFile = Dir()
Wend
Set wdDoc = Nothing: Set objFile = Nothing: Set FSO = Nothing
Application.ScreenUpdating = True
End Sub
Sub RenameDocuments_ClmStm()
Application.ScreenUpdating = False
Dim strFldr As String, strDocNm As String, strFile As String, strNewNm As String, wdDoc As Document
Dim FSO As Object, objFile As Object
strDocNm = ActiveDocument.FullName
strFldr = GetFolder
If strFldr = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
strFldr = strFldr & "\"
strFile = Dir(strFldr & "*.doc", vbNormal)
While strFile <> ""
If strFldr & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFldr & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
strNewNm = .SelectContentControlsByTitle("ClaimMovementUWInfo/Underwriter")(1).Range.Text _
& "_" & .SelectContentControlsByTitle("ClaimMovementUWInfo/PolicyRef")(1).Range.Text _
& "_" & .SelectContentControlsByTitle("ClaimMovementUWInfo/ClaimRef")(1).Range.Text _
' & "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
strNewNm = strNewNm & "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
.Close SaveChanges:=False
End With
If FSO.FileExists(strFldr & strNewNm) Then
ActiveDocument.Range.InsertAfter "Unable to create:" & Chr(11) & strFldr & strNewNm & Chr(11) & "File Exists" & vbCr
Else
Set objFile = FSO.GetFile(strFldr & strFile)
objFile.Name = strNewNm
End If
End If
strFile = Dir()
Wend
Set wdDoc = Nothing: Set objFile = Nothing: Set FSO = Nothing
Application.ScreenUpdating = True
End Sub
Sub RenameDocuments_Closing()
Application.ScreenUpdating = False
Dim strFldr As String, strDocNm As String, strFile As String, strNewNm As String, wdDoc As Document
Dim FSO As Object, objFile As Object
strDocNm = ActiveDocument.FullName
strFldr = GetFolder
If strFldr = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
strFldr = strFldr & "\"
strFile = Dir(strFldr & "*.doc", vbNormal)
While strFile <> ""
If strFldr & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFldr & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
strNewNm = .SelectContentControlsByTitle("DC/Name")(1).Range.Text _
& "_" & .SelectContentControlsByTitle("DC/PolicyRef")(1).Range.Text _
& "_" & .SelectContentControlsByTitle("DC/TransRef")(1).Range.Text _
'& "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
strNewNm = strNewNm & "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
.Close SaveChanges:=False
End With
If FSO.FileExists(strFldr & strNewNm) Then
ActiveDocument.Range.InsertAfter "Unable to create:" & Chr(11) & strFldr & strNewNm & Chr(11) & "File Exists" & vbCr
Else
Set objFile = FSO.GetFile(strFldr & strFile)
objFile.Name = strNewNm
End If
End If
strFile = Dir()
Wend
Set wdDoc = Nothing: Set objFile = Nothing: Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

[Jagdev]

Hi Graham,

Thanks for all your support. One last thing is it possible in the above code that after renaming the doc file gets convert to pdf.

Regards
JD

[gmayor]

Not without re-opening the file, but there's nothing to stop you saving as PDF with the new name before you close the file.

[Jagdev]

Hi Graham

Thanks for all your support and help.

Regards,
JD