Macro to check the existence of a word docx file and create a new word file with specific content.

staicumihai · #1 11-09-2016, 10:06 PM

Hi guys!

I have this macro:

Code:

Sub Rename_Folder()
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim i As Integer
Dim strPath As String
Dim strSubFolderPath As String
Dim strSubFolderNewName As String
Dim fisword As String
Dim FOLDER As String
Dim primit As String
Dim cinci As String
Dim cinci1 As String
Dim raport As String
Dim BAAR As String
Dim nr As String
Dim marca As String
Dim data As String
Dim anexa1 As String
Dim anexa5 As String
Dim AUDATEX As String
Dim nr1 As String
Dim marca1 As String
Dim anexa4 As String
Const strDrive As String = "D:\MIHAI\DOSARE\BAAR\"
raport = Trim(ActiveDocument.BuiltInDocumentProperties("Title").Value)
BAAR = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32)
nr = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "")
marca = ActiveDocument.BuiltInDocumentProperties("Comments").Value
nr1 = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "-")
marca1 = marca & ", " & nr1
data = ActiveDocument.BuiltInDocumentProperties("Content status").Value
cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32), 6)
cinci1 = Replace(cinci, " ", "")
primit = "BAAR-Dosarxxx" & "_" & cinci1 & "-" & data & " Mihai"
fisword = "R" & raport & "_" & BAAR & nr & " " & marca
FOLDER = "BAAR-Dosarxxx" & raport & "_" & cinci1 & " " & nr & " " & marca & "-" & data & " Mihai FIN"
anexa1 = "Anexa4_R" & raport & "_" & "DevizAudatex " & nr
anexa5 = "Anexa5_R" & raport & "_" & "Evaluare auto " & nr
Selection.Font.Bold = True
anexa4 = "Anexa4"
Selection.Font.Bold = False
strPath = "D:\MIHAI\DOSARE\BAAR"
strSubFolderNewName = strDrive & FOLDER
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strPath)
For Each oSubFolder In oFolder.SubFolders
  If Not oSubFolder.Name Like "MICHAEL_*" Then 'Optional
    strSubFolderPath = oSubFolder.Path
    Name strSubFolderPath As strSubFolderNewName
    Exit For
  End If 'Optional
Next oSubFolder
lbl_Exit:
Set oFSO = Nothing
Set oFolder = Nothing
Set oSubFolder = Nothing
FileCopy strDrive & "RP.vcp", strDrive & FOLDER & "\RP.vcp"
Exit Sub
End Sub

In the path strDrive & FOLDER is only one file named Mail AU or Mail CT or Mail EN
What I need to do is next:

If the file Mail AU.docx is in strDrive & FOLDER then create a new docx file named AU.docx in the path strDrive that contains the following text:

"Raport de verif pt. dosar BAAR (where BAAR is the string I defined)

In atentia d-lui Adrian Uta,

Urmare a verificarii dosarului BAAR auto pagubit marca marca (where marca is the string I defined) va transmitem atasat raportul de verificare.

Rog confirmati primirea.

Cu stima,
Mihai STAICU"

If the file Mail CT.docx is in strDrive & FOLDER then create a new docx file named CT.docx in the path strDrive that contains the following text:

"
Raport de verif pt. dosar BAAR (where BAAR is the string I defined)

In atentia d-lui Cristi Turcu,

Urmare a verificarii dosarului BAAR auto pagubit marca marca (where marca is the string I defined) va transmitem atasat raportul de verificare.

Rog confirmati primirea.

Cu stima,
Mihai STAICU
"

If the file Mail EN.docx is in strDrive & FOLDER then create a new docx file named EN.docx in the path strDrive that contains the following text:

"
Raport de verif pt. dosar BAAR (where BAAR is the string I defined)

In atentia d-lui Emilia Negoita,

Urmare a verificarii dosarului BAAR auto pagubit marca marca (where marca is the string I defined) va transmitem atasat raportul de verificare.

Rog confirmati primirea.

Cu stima,
Mihai STAICU
"

Anyone has any ideas ? Thank you so much.

gmayor · #2 11-10-2016, 02:36 AM

Perhaps the following, though together with your other macro it should give you enough information to modify it to your needs.

Code:

Option Explicit

Sub Macro1()
Const strpath As String = "C:\Path\"
Const BAAR As String = "BAAR"
Const MARCA As String = "marca"
Dim strName As String
Dim strMessage As String
Dim fso As Object
Dim oDoc As Document

    strMessage = "Raport de verif pt. dosar " & BAAR & vbCr & _
                 "In atentia d-lui " & strName & "," & vbCr & _
                 "Urmare a verificarii dosarului " & BAAR & " auto pagubit marca " & MARCA & _
                 "va transmitem atasat raportul de verificare." & vbCr & _
                 "Rog confirmati primirea." & vbCr & _
                 "Cu stima," & vbCr & vbCr & _
                 "Mihai STAICU"

    Set fso = CreateObject("Scripting.FileSystemObject")
    Select Case True
        Case fso.FileExists(strpath & "Mail AU.docx")
            Set oDoc = Documents.Add(Template:=strpath & "Mail AU.docx")
            strName = "Adrian Uta"
            oDoc.Range.Text = strMessage
            oDoc.SaveAs2 FileName:=strpath & "AU.docx", addtorecentfiles:=False

        Case fso.FileExists(strpath & "Mail EN.docx")
            Set oDoc = Documents.Add(Template:=strpath & "Mail EN.docx")
            strName = "Emilia Negoita"
            oDoc.Range.Text = strMessage
            oDoc.SaveAs2 FileName:=strpath & "EN.docx", addtorecentfiles:=False
    End Select
lbl_Exit:
    Set fso = Nothing
    Set oDoc = Nothing
    Exit Sub
End Sub

staicumihai · #3 11-10-2016, 04:04 AM

Thanks for your reply!
This is the macro I have now based on your macros:

Code:

Option Explicit
Sub Rename_Folder()
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim i As Integer
Dim strpath As String
Dim strSubFolderPath As String
Dim strSubFolderNewName As String
Dim fisword As String
Dim FOLDER As String
Dim primit As String
Dim cinci As String
Dim cinci1 As String
Dim raport As String
Dim BAAR As String
Dim nr As String
Dim MARCA As String
Dim data As String
Dim anexa1 As String
Dim anexa5 As String
Dim AUDATEX As String
Dim nr1 As String
Dim marca1 As String
Dim anexa4 As String
Dim strName As String
Dim fso As Object
Dim oDoc As Document
Dim strName1 As String
Dim strmessage As String

Const strDrive As String = "D:\MIHAI\DOSARE\BAAR\"

raport = Trim(ActiveDocument.BuiltInDocumentProperties("Title").Value)
BAAR = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32)
nr = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "")
MARCA = ActiveDocument.BuiltInDocumentProperties("Comments").Value
nr1 = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "-")
marca1 = MARCA & ", " & nr1
data = ActiveDocument.BuiltInDocumentProperties("Content status").Value
cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32), 6)
cinci1 = Replace(cinci, " ", "")
primit = "BAAR-Dosarxxx" & "_" & cinci1 & "-" & data & " Mihai"
fisword = "R" & raport & "_" & BAAR & nr & " " & MARCA
FOLDER = "BAAR-Dosarxxx" & raport & "_" & cinci1 & " " & nr & " " & MARCA & "-" & data & " Mihai FIN"
anexa1 = "Anexa4_R" & raport & "_" & "DevizAudatex " & nr
anexa5 = "Anexa5_R" & raport & "_" & "Evaluare auto " & nr

Selection.Font.Bold = True
anexa4 = "Anexa4"
Selection.Font.Bold = False
  
    strpath = "D:\MIHAI\DOSARE\BAAR"
    strSubFolderNewName = strDrive & FOLDER
   Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(strpath)
    For Each oSubFolder In oFolder.SubFolders
        If Not oSubFolder.Name Like "MICHAEL_*" Then 'Optional
            strSubFolderPath = oSubFolder.Path
            Name strSubFolderPath As strSubFolderNewName
                      Exit For
        End If 'Optional
    Next oSubFolder
Set oFSO = Nothing
Set oFolder = Nothing
Set oSubFolder = Nothing

FileCopy strDrive & "RP.vcp", strDrive & FOLDER & "\RP.vcp"
                       
strmessage = "Raport de verif pt. dosar " & BAAR & vbCr & _
                 "In atentia " & strName1 & " " & strName & "," & vbCr & _
                 "Urmare a verificarii dosarului " & BAAR & " auto pagubit marca " & MARCA & _
                 "va transmitem atasat raportul de verificare." & vbCr & _
                 "Rog confirmati primirea." & vbCr & _
                 "Cu stima," & vbCr & vbCr & _
                 "Mihai STAICU"
                 
Const STRPAT As String = strSubFolderNewName

    Set fso = CreateObject("Scripting.FileSystemObject")
    Select Case True
        Case fso.FileExists(STRPAT & "Mail AU.docx")
            Set oDoc = Documents.Add(Template:=STRPAT & "Mail AU.docx")
            strName = "Adrian Uta"
            strName1 = "d-lui"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=STRPAT & "AU.docx", addtorecentfiles:=False

        Case fso.FileExists(STRPAT & "Mail CT.docx")
            Set oDoc = Documents.Add(Template:=STRPAT & "Mail EN.docx")
            strName = "Cristi Turcu"
            strName1 = "d-lui"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=STRPAT & "CT.docx", addtorecentfiles:=False
         
        Case fso.FileExists(STRPAT & "Mail EN.docx")
            Set oDoc = Documents.Add(Template:=STRPAT & "Mail EN.docx")
            strName = "Emilia Negoita"
            strName1 = "d-nei"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=STRPAT & "EN.docx", addtorecentfiles:=False
                            
            
    End Select
lbl_Exit:
    Set fso = Nothing
    Set oDoc = Nothing
    Exit Sub
End Sub

The problem is at the red line of the code. The only way it will work is if I use a constant but I need the path to be strSubFolderNewName (because here is the initial docx file Mail AU.docx, Mail CT.docx or Mail EN.docx). Somehow I need to turn strSubFolderNewName into a constant that I can use.

So how can I assign that to a constant ?

gmayor · #4 11-10-2016, 04:46 AM

You can't have variables in a constant. Declare the variable as a string and then define the string that is strSubFolderNewName

macropod · #5 11-10-2016, 03:29 PM

staicumihai: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had. I have already added the code tags & reconstructed the formatting for your first post. Please fix your last post.

staicumihai · #6 11-10-2016, 09:32 PM

Thanks Macropod!

staicumihai · #7 11-13-2016, 09:57 PM

Thanks a lot Gmayor!

How do I define the string strSubFolderNewName ?

gmayor · #8 11-14-2016, 12:08 AM

Code:

Dim strSubFolderNewName as String
strSubFolderNewName = "Whatever you want it to be"

staicumihai · #9 11-14-2016, 01:47 AM

That's the thing

"Whatever I want it to be" needs to be strSubFolderNewName which is strDrive & Folder (the renamed folder)

strSubFolderNewName varies, as it contains data from within the document.

gmayor · #10 11-14-2016, 02:42 AM

Code:

strSubFolderNewName = strDrive & strfolder

It's not rocket science.

staicumihai · #11 11-14-2016, 03:24 AM

Code:

Option Explicit
Sub Rename_Folder()
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim i As Integer
Dim strpath As String
Dim strSubFolderPath As String
Dim strSubFolderNewName As String
Dim fisword As String
Dim FOLDER As String
Dim primit As String
Dim cinci As String
Dim cinci1 As String
Dim raport As String
Dim BAAR As String
Dim nr As String
Dim MARCA As String
Dim data As String
Dim anexa1 As String
Dim anexa5 As String
Dim AUDATEX As String
Dim nr1 As String
Dim marca1 As String
Dim anexa4 As String
Dim strName As String
Dim fso As Object
Dim oDoc As Document
Dim strName1 As String
Dim strmessage As String
Dim strpat As String


Const strDrive As String = "D:\MIHAI\DOSARE\BAAR\"

raport = Trim(ActiveDocument.BuiltInDocumentProperties("Title").Value)
BAAR = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32)
nr = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "")
MARCA = ActiveDocument.BuiltInDocumentProperties("Comments").Value
nr1 = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "-")
marca1 = MARCA & ", " & nr1
data = ActiveDocument.BuiltInDocumentProperties("Content status").Value
cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32), 6)
cinci1 = Replace(cinci, " ", "")
primit = "BAAR-Dosarxxx" & "_" & cinci1 & "-" & data & " Mihai"
fisword = "R" & raport & "_" & BAAR & nr & " " & MARCA
FOLDER = "BAAR-Dosarxxx" & raport & "_" & cinci1 & " " & nr & " " & MARCA & "-" & data & " Mihai FIN"
anexa1 = "Anexa4_R" & raport & "_" & "DevizAudatex " & nr
anexa5 = "Anexa5_R" & raport & "_" & "Evaluare auto " & nr

Selection.Font.Bold = True
anexa4 = "Anexa4"
Selection.Font.Bold = False
  
    strpath = "D:\MIHAI\DOSARE\BAAR"
    strSubFolderNewName = strDrive & FOLDER
   Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(strpath)
    For Each oSubFolder In oFolder.SubFolders
        If Not oSubFolder.Name Like "MICHAEL_*" Then 'Optional
            strSubFolderPath = oSubFolder.Path
            Name strSubFolderPath As strSubFolderNewName
                      Exit For
        End If 'Optional
    Next oSubFolder
Set oFSO = Nothing
Set oFolder = Nothing
Set oSubFolder = Nothing

FileCopy strDrive & "RP.vcp", strDrive & FOLDER & "\RP.vcp"
                       
strmessage = "Raport de verif pt. dosar " & BAAR & vbCr & _
                 "In atentia " & strName1 & " " & strName & "," & vbCr & _
                 "Urmare a verificarii dosarului " & BAAR & " auto pagubit marca " & MARCA & _
                 "va transmitem atasat raportul de verificare." & vbCr & _
                 "Rog confirmati primirea." & vbCr & _
                 "Cu stima," & vbCr & vbCr & _
                 "Mihai STAICU"
                 
 strpat = strSubFolderNewName
 
  MsgBox strpat
    Set fso = CreateObject("Scripting.FileSystemObject")
            Select Case True
      Case fso.FileExists(strpat & "Mail AU.docx")
         Set oDoc = Documents.Add(Template:=strpat & "Mail AU.docx")
       strName = "Adrian Uta"
            strName1 = "d-lui"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=strpat & "AU.docx", addtorecentfiles:=False

        Case fso.FileExists(strpat & "Mail CT.docx")
           Set oDoc = Documents.Add(Template:=strpat & "Mail EN.docx")
            strName = "Cristi Turcu"
            strName1 = "d-lui"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=strpat & "CT.docx", addtorecentfiles:=False
        
        Case fso.FileExists(strpat & "Mail EN.docx")
            Set oDoc = Documents.Add(Template:=strpat & "Mail EN.docx")
            strName = "Emilia Negoita"
            strName1 = "d-nei"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=strpat & "EN.docx", addtorecentfiles:=False
                             
            
    End Select
lbl_Exit:
    Set fso = Nothing
    Set oDoc = Nothing
    Exit Sub
End Sub

I did that. It doesn't work. It renames the folder but it doesn't create the new word docx file. It doesn't give any errors whatsoever.

gmayor · #12 11-14-2016, 05:32 AM

Without the documents this cannot be tested, but a few observations are warranted.

Why have you created another variable for strSubFolderNewName?

Code:

strpat = strSubFolderNewName

Use the strSubFolderNewName name you have already defined.

Your FileExists statements are never true because strSubFolderName doesn't end in a folder separator character, so the documents cannot be created. Thus the lines e.g.

Code:

Case fso.FileExists(strpat & "Mail AU.docx")
            Set oDoc = Documents.Add(Template:=strpat & "Mail AU.docx")
            'etc

should probably be

Code:

Case fso.FileExists(strSubFolderNewName & "\" & "Mail AU.docx")
            Set oDoc = Documents.Add(Template:=strSubFolderNewName & "\" & "Mail AU.docx")
            'etc

You have declared and defined some variables 'anexa#' but not used them?
You have created CreateObject("Scripting.FileSystemObject") twice as fso and oFSO. You only need to create it once and use the same object twice.

staicumihai · #13 11-14-2016, 09:47 PM

It works!

Code:

Option Explicit
Sub Rename_Folder()
Dim oFolder As Object
Dim oSubFolder As Object
Dim fso As Object

Dim oDoc As Document

Dim i As Integer

Dim strName As String
Dim strName1 As String
Dim strmessage As String
Dim strpath As String
Dim strSubFolderPath As String
Dim strSubFolderNewName As String
Dim fisword As String
Dim FOLDER As String
Dim primit As String
Dim cinci As String
Dim cinci1 As String
Dim raport As String
Dim BAAR As String
Dim nr As String
Dim nr1 As String
Dim MARCA As String
Dim marca1 As String
Dim data As String
Dim anexa1 As String
Dim anexa4 As String
Dim anexa5 As String
Dim AUDATEX As String

Const strDrive As String = "D:\MIHAI\DOSARE\BAAR\"

raport = Trim(ActiveDocument.BuiltInDocumentProperties("Title").Value)
BAAR = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32)
nr = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "")
MARCA = ActiveDocument.BuiltInDocumentProperties("Comments").Value
nr1 = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "-")
marca1 = MARCA & ", " & nr1
data = ActiveDocument.BuiltInDocumentProperties("Content status").Value
cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32), 6)
cinci1 = Replace(cinci, " ", "")
primit = "BAAR-Dosarxxx" & "_" & cinci1 & "-" & data & " Mihai"
fisword = "R" & raport & "_" & BAAR & nr & " " & MARCA
FOLDER = "BAAR-Dosarxxx" & raport & "_" & cinci1 & " " & nr & " " & MARCA & "-" & data & " Mihai FIN"
anexa1 = "Anexa4_R" & raport & "_" & "DevizAudatex " & nr
anexa5 = "Anexa5_R" & raport & "_" & "Evaluare auto " & nr

Selection.Font.Bold = True
anexa4 = "Anexa4"
Selection.Font.Bold = False
  
strpath = "D:\MIHAI\DOSARE\BAAR"
strSubFolderNewName = strDrive & FOLDER
    
Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(strpath)
    For Each oSubFolder In oFolder.SubFolders
        If Not oSubFolder.Name Like "MICHAEL_*" Then 'Optional
            strSubFolderPath = oSubFolder.Path
            Name strSubFolderPath As strSubFolderNewName
                      Exit For
        End If 'Optional
    Next oSubFolder
Set fso = Nothing
Set oFolder = Nothing
Set oSubFolder = Nothing

FileCopy strDrive & "RP.vcp", strDrive & FOLDER & "\RP.vcp"
                       
strmessage = "Raport de verif pt. dosar " & BAAR & vbCr & _
             "In atentia " & strName1 & " " & strName & "," & vbCr & _
             "Urmare a verificarii dosarului " & BAAR & " auto pagubit marca " & MARCA & " " & _
             "va transmitem atasat raportul de verificare." & vbCr & _
             "Rog confirmati primirea." & vbCr & _
             "Cu stima," & vbCr & _
             "Mihai STAICU"

Set fso = CreateObject("Scripting.FileSystemObject")
Select Case True
   Case fso.FileExists(strSubFolderNewName & "\" & "Mail AU.docx")
            Set oDoc = Documents.Add(Template:=strSubFolderNewName & "\" & "Mail AU.docx")
            strName = "Adrian Uta"
            strName1 = "d-lui"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=strSubFolderNewName & "\" & "AU.docx", addtorecentfiles:=False
   Case fso.FileExists(strSubFolderNewName & "\" & "Mail CT.docx")
            Set oDoc = Documents.Add(Template:=strSubFolderNewName & "\" & "Mail CT.docx")
            strName = "Cristi Turcu"
            strName1 = "d-lui"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=strSubFolderNewName & "\" & "CT.docx", addtorecentfiles:=False
  Case fso.FileExists(strSubFolderNewName & "\" & "Mail EN.docx")
            Set oDoc = Documents.Add(Template:=strSubFolderNewName & "\" & "Mail EN.docx")
            strName = "Emilia Negoita"
            strName1 = "d-nei"
            oDoc.Range.Text = strmessage
            oDoc.SaveAs2 FileName:=strSubFolderNewName & "\" & "EN.docx", addtorecentfiles:=False
         
    End Select
lbl_Exit:
    Set fso = Nothing
    Set oDoc = Nothing
    Exit Sub
End Sub

Thanks so much Gmayor!

I have 3 more questions:
How to put in the word file the strings strName and strName1 ?
And how can I format the text with no spacing lines ?
How to not open the word file after it is created ?

gmayor · #14 11-14-2016, 11:11 PM

I showed you how to put the name in the string in the first macro I posted.
The line breaks in strMessage are the vbCr commands in the string. Remove the ones you don't want.

staicumihai · #15 11-15-2016, 01:42 AM

Thanks man, I combined the two macros that you helped me with and got it to work.

Code:

Option Explicit
Sub BAAR()

Dim oFolder As Object
Dim oSubFolder As Object
Dim fso As Object
Dim oDoc As Document

Dim fisword As String
Dim FOLDER As String

Dim cinci As String
Dim cinci1 As String
Dim raport As String
Dim BAAR As String
Dim baar1 As String

Dim nr As String
Dim nr1 As String
Dim MARCA As String
Dim marca1 As String
Dim data As String
Dim anexa1 As String
Dim anexa5 As String
Dim AUDATEX As String

Dim strSubFolderPath As String
Dim strsubfoldernewname As String
Dim strmessageAU As String
Dim strmessageCT As String
Dim strmessageEN As String

Const strDrive As String = "D:\MIHAI\DOSARE\BAAR\"

raport = Trim(ActiveDocument.BuiltInDocumentProperties("Title").Value)
BAAR = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32)
baar1 = ActiveDocument.BuiltInDocumentProperties("keywords").Value
nr = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "")
MARCA = ActiveDocument.BuiltInDocumentProperties("Comments").Value
nr1 = Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), Chr(150), "-")
marca1 = MARCA & ", " & nr1
data = ActiveDocument.BuiltInDocumentProperties("Content status").Value

If Len(baar1) = 20 Then
cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32), 6)
cinci1 = Replace(cinci, " ", "")
End If
If Len(baar1) > 20 Then
cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentProperties("keywords").Value), "/", ".") & Chr(32), 9)
cinci1 = Replace(cinci, " ", "")
End If

fisword = "R" & raport & "_" & BAAR & nr & " " & MARCA
FOLDER = "BAAR-Dosarxxx" & raport & "_" & cinci1 & " " & nr & " " & MARCA & "-" & data & " Mihai FIN"
anexa1 = "Anexa4_R" & raport & "_" & "DevizAudatex " & nr
anexa5 = "Anexa5_R" & raport & "_" & "Evaluare auto " & nr

AUDATEX = "Anexa4" & " - Calcula" & ChrW(539) & "ie deviz de repara" & ChrW(539) & "ii pentru auto " & MARCA & " cu nr. de înmatriculare " & ActiveDocument.BuiltInDocumentProperties("Company").Value

strsubfoldernewname = strDrive & FOLDER
Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(strDrive)
    For Each oSubFolder In oFolder.SubFolders
        If Not oSubFolder.Name Like "MICHAEL_*" Then 'Optional
            strSubFolderPath = oSubFolder.Path
            Name strSubFolderPath As strsubfoldernewname
                      Exit For
        End If 'Optional
    Next oSubFolder
Set fso = Nothing
Set oFolder = Nothing
Set oSubFolder = Nothing

FileCopy strDrive & "RP.vcp", strsubfoldernewname & "\RP.vcp"
MkDir strsubfoldernewname & "\X\"

ActiveDocument.SaveAs2 strsubfoldernewname & "\X\" & "_" & fisword & ".docx"
ActiveDocument.SaveAs2 FileName:=strsubfoldernewname & "\" & fisword & ".doc", FileFormat:=wdFormatDocument
ActiveDocument.ExportAsFixedFormat OutputFileName:=strsubfoldernewname & "\X\" & "_" & anexa1 & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, From:=1, to:=1, _
Item:=wdExportDocumentContent, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=wdExportCreateHeadingBookmarks, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
ActiveDocument.ExportAsFixedFormat OutputFileName:=strsubfoldernewname & "\X\" & "_" & anexa5 & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, From:=1, to:=1, _
Item:=wdExportDocumentContent, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=wdExportCreateHeadingBookmarks, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
ActiveDocument.ExportAsFixedFormat OutputFileName:=strsubfoldernewname & "\X\" & "_" & AUDATEX & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, From:=1, to:=1, _
Item:=wdExportDocumentContent, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=wdExportCreateHeadingBookmarks, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
ActiveDocument.ExportAsFixedFormat OutputFileName:=strsubfoldernewname & "\X\" & marca1 & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, From:=1, to:=1, _
Item:=wdExportDocumentContent, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=wdExportCreateHeadingBookmarks, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False

strmessageAU = "Raport de verif pt. dosar " & baar1 & vbCr & _
             "In atentia d-lui Adrian Uta" & "," & vbCr & vbCr & _
             "Urmare a verificarii dosarului " & baar1 & " auto pagubit marca " & MARCA & " " & _
             "va transmitem atasat raportul de verificare." & vbCr & _
             "Rog confirmati primirea." & vbCr & vbCr & _
             "Cu stima," & vbCr & "Mihai STAICU"
strmessageCT = "Raport de verif pt. dosar " & baar1 & vbCr & _
             "In atentia d-lui Cristi Turcu" & "," & vbCr & vbCr & _
             "Urmare a verificarii dosarului " & baar1 & " auto pagubit marca " & MARCA & " " & _
             "va transmitem atasat raportul de verificare." & vbCr & _
             "Rog confirmati primirea." & vbCr & vbCr & _
             "Cu stima," & vbCr & "Mihai STAICU"
strmessageEN = "Raport de verif pt. dosar " & baar1 & vbCr & _
             "In atentia d-nei Emilia Negoita" & "," & vbCr & vbCr & _
             "Urmare a verificarii dosarului " & baar1 & " auto pagubit marca " & MARCA & " " & _
             "va transmitem atasat raportul de verificare." & vbCr & _
             "Rog confirmati primirea." & vbCr & vbCr & _
             "Cu stima," & vbCr & "Mihai STAICU"

Set fso = CreateObject("Scripting.FileSystemObject")
Select Case True
   Case fso.FileExists(strsubfoldernewname & "\" & "Mail AU.docx")
            Set oDoc = Documents.Add(Template:=strsubfoldernewname & "\" & "Mail AU.docx")
            oDoc.Range.Text = strmessageAU
            oDoc.SaveAs2 FileName:=strsubfoldernewname & "\X\" & "XAU.docx", addtorecentfiles:=False
   Case fso.FileExists(strsubfoldernewname & "\" & "Mail CT.docx")
            Set oDoc = Documents.Add(Template:=strsubfoldernewname & "\" & "Mail CT.docx")
            oDoc.Range.Text = strmessageCT
            oDoc.SaveAs2 FileName:=strsubfoldernewname & "\X\" & "XCT.docx", addtorecentfiles:=False
  Case fso.FileExists(strsubfoldernewname & "\" & "Mail EN.docx")
            Set oDoc = Documents.Add(Template:=strsubfoldernewname & "\" & "Mail EN.docx")
            oDoc.Range.Text = strmessageEN
            oDoc.SaveAs2 FileName:=strsubfoldernewname & "\X\" & "XEN.docx", addtorecentfiles:=False
End Select
Set fso = Nothing
Set oDoc = Nothing
       
With Application
.ScreenUpdating = False
Do Until .Documents.Count = 0
.Documents(1).Close SaveChanges:=wdDoNotSaveChanges
Loop
.Quit SaveChanges:=wdDoNotSaveChanges
End With
lbl_Exit:
Exit Sub
End Sub

Have a great day!

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to highlight repeated words in word file and extract into excel file	aabri	Word VBA	1	06-14-2015 07:20 AM
Word 2007 , when I save a .doc or .docx file the file type is showing "Empty"	Tomc29	Word	9	06-10-2015 03:04 AM
How to create a MS word file that automatically logs something specific inside other WORD files?	meys	Word VBA	1	01-04-2015 05:22 AM
Macro to create new word doc and save the file using String found in the document	VBNation	Word VBA	2	02-08-2013 07:14 AM
Word Macro That Checks a Check Box Form Field When File Print is Executed	DKerne	Word VBA	4	06-09-2011 11:54 AM