rename of folder and/or filenames

[Robie]

Hi

I know Word better than other MS products and therefore I have put this request here.

I receive emails almost on daily basis to rename folder and/or filenames from a specific folder. Each email may contain 20 or more of these requests. This task was done manually before (when the emails where infrequent but now we get 2-5 emails a day) but it is getting ridiculous now and it would be nice if I can make the task automatic/semi-automatic. The emails look like this:

61.png

'Root' is a specific folder that I know the path of.

Is it possible to do this under VBA (or otherwise) where I can either rename the folders and/or change the filenames? This may not be possible but thought I would just ask.

Thanks.
Robie

[HansV]

Do you receive these emails in Outlook or in another mail client?

[Robie]

Do you receive these emails in Outlook or in another mail client?

Outlook Hans.

[HansV]

Oh, and could you attach a sample, as a .msg file (zipped), or a Word document, or a text file?

[Robie]

Oh, and could you attach a sample, as a .msg file (zipped), or a Word document, or a text file?

Word document attached.

email_content.docx

[HansV]

Thanks. I think it's possible to create a macro for this, but it might take a bit of time to develop it.

In the meanwhile, I will move this thread to the VB/VBA forum since the question is not specific to Word.

[Robie]

Thanks. I think it's possible to create a macro for this, but it might take a bit of time to develop it.

In the meanwhile, I will move this thread to the VB/VBA forum since the question is not specific to Word.

Thank you Hans. Even a semi-automatic option would be good.

[HansV]

You'll find a macro below, to be run from Word, after copying the text of an e-mail into a new Word document.

Important:

The version as posted will ask for confirmation for each action. Please inspect the command shown in the message boxes carefully and only click Yes if it is what you wanted.
If everything works smoothly, you can remove the If MsgBox ... Then and End If lines.

Code: Select all

Sub RenameRequest()
    Dim par As Paragraph
    Dim s As String
    Dim fiOld As String
    Dim fiNew As String
    Dim foOld As String
    Dim foNew As String
    Dim p1 As Long
    Dim p2 As Long
    Dim p3 As Long
    Dim p4 As Long
    Dim p5 As Long
    Dim p6 As Long
    Dim p7 As Long
    Dim p8 As Long
    For Each par In ActiveDocument.Paragraphs
        s = par.Range.Text
        Select Case True
            Case LCase(Left(s, Len("Folder change:"))) = LCase("Folder change:")
                p1 = Len("Folder change: please move the file ")
                p2 = InStr(p1 + 1, s, Chr(11))
                fiOld = Trim(Mid(s, p1 + 1, p2 - p1 - 2))
                p3 = InStr(p2 + 1, s, "from: ") + Len("from: ")
                p4 = InStr(p3, s, Chr(11))
                foOld = Trim(Mid(s, p3, p4 - p3)) & "\"
                p7 = InStr(p4 + 1, s, "to: ") + Len("to: ")
                p8 = InStr(p7, s, Chr(11))
                If p8 = 0 Then
                    p8 = InStr(p7, s, vbCr)
                End If
                foNew = Trim(Mid(s, p7, p8 - p7)) & "\"
                If MsgBox("Move file" & vbCrLf & vbCrLf & fiOld & vbCrLf & vbCrLf & "from" & vbCrLf & vbCrLf & foOld & vbCrLf & vbCrLf & "to" & vbCrLf & vbCrLf & foNew, vbQuestion + vbYesNo) = vbYes Then
                    Name foOld & fiOld As foOld & fiNew
                End If
            Case LCase(Left(s, Len("Folder rename:"))) = LCase("Folder rename:")
                p1 = InStr(1, s, "from: ") + Len("from: ")
                p2 = InStr(p1, s, Chr(11))
                foOld = Trim(Mid(s, p1, p2 - p1))
                p7 = InStr(p2 + 1, s, "to: ") + Len("to: ")
                p8 = InStr(p7, s, Chr(11))
                If p8 = 0 Then
                    p8 = InStr(p7, s, vbCr)
                End If
                foNew = Trim(Mid(s, p7, p8 - p7))
                If MsgBox("Rename folder" & vbCrLf & vbCrLf & foOld & vbCrLf & vbCrLf & "to" & vbCrLf & vbCrLf & foNew, vbQuestion + vbYesNo) = vbYes Then
                    Name foOld As foNew
                End If
            Case LCase(Left(s, Len("File rename:"))) = LCase("File rename:")
                p1 = Len("File rename: please rename the file in location ")
                p2 = InStr(p1 + 1, s, Chr(11))
                foOld = Trim(Mid(s, p1 + 1, p2 - p1 - 2)) & "\"
                p3 = InStr(p2 + 1, s, "from: ") + Len("from: ")
                p4 = InStr(p3, s, Chr(11))
                fiOld = Trim(Mid(s, p3, p4 - p3))
                p5 = InStr(p4 + 1, s, "to: ") + Len("to: ")
                p6 = InStr(p5, s, Chr(11))
                If p6 = 0 Then
                    p6 = InStr(p5, s, vbCr)
                End If
                fiNew = Trim(Mid(s, p5, p6 - p5))
                If MsgBox("Rename file" & vbCrLf & vbCrLf & fiOld & vbCrLf & vbCrLf & "from" & vbCrLf & vbCrLf & fiNew & vbCrLf & vbCrLf & "in folder" & vbCrLf & vbCrLf & foOld, vbQuestion + vbYesNo) = vbYes Then
                    Name foOld & fiOld As foOld & fiNew
                End If
            Case LCase(Left(s, Len("File rename and Folder change:"))) = LCase("File rename and Folder change:")
                p3 = InStr(1, s, "from: ") + Len("from: ")
                p4 = InStr(p3, s, Chr(11))
                fiOld = Trim(Mid(s, p3, p4 - p3))
                p5 = InStr(p4 + 1, s, "to: ") + Len("to: ")
                p6 = InStr(p5, s, Chr(11))
                fiNew = Trim(Mid(s, p5, p6 - p5))
                p1 = InStr(p6 + 2, s, "from: ") + Len("from: ")
                p2 = InStr(p1, s, Chr(11))
                foOld = Trim(Mid(s, p1, p2 - p1)) & "\"
                p7 = InStr(p2 + 1, s, "to: ") + Len("to: ")
                p8 = InStr(p7, s, Chr(11))
                If p8 = 0 Then
                    p8 = InStr(p7, s, vbCr)
                End If
                foNew = Trim(Mid(s, p7, p8 - p7)) & "\"
                If MsgBox("Move and rename file" & vbCrLf & vbCrLf & foOld & fiOld & vbCrLf & vbCrLf & "to" & vbCrLf & vbCrLf & foNew & fiNew, vbQuestion + vbYesNo) = vbYes Then
                    Name foOld & fiOld As foNew & fiNew
                End If
            Case Else
                ' Ignore this paragraph
        End Select
    Next par
End Sub

[Robie]

You'll find a macro below, to be run from Word, after copying the text of an e-mail into a new Word document.

Important:

The version as posted will ask for confirmation for each action. Please inspect the command shown in the message boxes carefully and only click Yes if it is what you wanted.
If everything works smoothly, you can remove the If MsgBox ... Then and End If lines.

Code: Select all

Sub RenameRequest()
    Dim par As Paragraph
    Dim s As String
    Dim fiOld As String
    Dim fiNew As String
    Dim foOld As String
    Dim foNew As String
    Dim p1 As Long
    Dim p2 As Long
    Dim p3 As Long
    Dim p4 As Long
    Dim p5 As Long
    Dim p6 As Long
    Dim p7 As Long
    Dim p8 As Long
    For Each par In ActiveDocument.Paragraphs
        s = par.Range.Text
        Select Case True
            Case LCase(Left(s, Len("Folder change:"))) = LCase("Folder change:")
                p1 = Len("Folder change: please move the file ")
                p2 = InStr(p1 + 1, s, Chr(11))
                fiOld = Trim(Mid(s, p1 + 1, p2 - p1 - 2))
                p3 = InStr(p2 + 1, s, "from: ") + Len("from: ")
                p4 = InStr(p3, s, Chr(11))
                foOld = Trim(Mid(s, p3, p4 - p3)) & "\"
                p7 = InStr(p4 + 1, s, "to: ") + Len("to: ")
                p8 = InStr(p7, s, Chr(11))
                If p8 = 0 Then
                    p8 = InStr(p7, s, vbCr)
                End If
                foNew = Trim(Mid(s, p7, p8 - p7)) & "\"
                If MsgBox("Move file" & vbCrLf & vbCrLf & fiOld & vbCrLf & vbCrLf & "from" & vbCrLf & vbCrLf & foOld & vbCrLf & vbCrLf & "to" & vbCrLf & vbCrLf & foNew, vbQuestion + vbYesNo) = vbYes Then
                    Name foOld & fiOld As foOld & fiNew
                End If
            Case LCase(Left(s, Len("Folder rename:"))) = LCase("Folder rename:")
                p1 = InStr(1, s, "from: ") + Len("from: ")
                p2 = InStr(p1, s, Chr(11))
                foOld = Trim(Mid(s, p1, p2 - p1))
                p7 = InStr(p2 + 1, s, "to: ") + Len("to: ")
                p8 = InStr(p7, s, Chr(11))
                If p8 = 0 Then
                    p8 = InStr(p7, s, vbCr)
                End If
                foNew = Trim(Mid(s, p7, p8 - p7))
                If MsgBox("Rename folder" & vbCrLf & vbCrLf & foOld & vbCrLf & vbCrLf & "to" & vbCrLf & vbCrLf & foNew, vbQuestion + vbYesNo) = vbYes Then
                    Name foOld As foNew
                End If
            Case LCase(Left(s, Len("File rename:"))) = LCase("File rename:")
                p1 = Len("File rename: please rename the file in location ")
                p2 = InStr(p1 + 1, s, Chr(11))
                foOld = Trim(Mid(s, p1 + 1, p2 - p1 - 2)) & "\"
                p3 = InStr(p2 + 1, s, "from: ") + Len("from: ")
                p4 = InStr(p3, s, Chr(11))
                fiOld = Trim(Mid(s, p3, p4 - p3))
                p5 = InStr(p4 + 1, s, "to: ") + Len("to: ")
                p6 = InStr(p5, s, Chr(11))
                If p6 = 0 Then
                    p6 = InStr(p5, s, vbCr)
                End If
                fiNew = Trim(Mid(s, p5, p6 - p5))
                If MsgBox("Rename file" & vbCrLf & vbCrLf & fiOld & vbCrLf & vbCrLf & "from" & vbCrLf & vbCrLf & fiNew & vbCrLf & vbCrLf & "in folder" & vbCrLf & vbCrLf & foOld, vbQuestion + vbYesNo) = vbYes Then
                    Name foOld & fiOld As foOld & fiNew
                End If
            Case LCase(Left(s, Len("File rename and Folder change:"))) = LCase("File rename and Folder change:")
                p3 = InStr(1, s, "from: ") + Len("from: ")
                p4 = InStr(p3, s, Chr(11))
                fiOld = Trim(Mid(s, p3, p4 - p3))
                p5 = InStr(p4 + 1, s, "to: ") + Len("to: ")
                p6 = InStr(p5, s, Chr(11))
                fiNew = Trim(Mid(s, p5, p6 - p5))
                p1 = InStr(p6 + 2, s, "from: ") + Len("from: ")
                p2 = InStr(p1, s, Chr(11))
                foOld = Trim(Mid(s, p1, p2 - p1)) & "\"
                p7 = InStr(p2 + 1, s, "to: ") + Len("to: ")
                p8 = InStr(p7, s, Chr(11))
                If p8 = 0 Then
                    p8 = InStr(p7, s, vbCr)
                End If
                foNew = Trim(Mid(s, p7, p8 - p7)) & "\"
                If MsgBox("Move and rename file" & vbCrLf & vbCrLf & foOld & fiOld & vbCrLf & vbCrLf & "to" & vbCrLf & vbCrLf & foNew & fiNew, vbQuestion + vbYesNo) = vbYes Then
                    Name foOld & fiOld As foNew & fiNew
                End If
            Case Else
                ' Ignore this paragraph
        End Select
    Next par
End Sub

Thank you so much Hans. It didn't take that long - I was expecting it to be days rather than minutes.