Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 11-09-2016, 10:06 PM
staicumihai staicumihai is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 32bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Advanced Beginner
Macro to check the existence of a word docx file and create a new word file with specific content.
 
Join Date: Dec 2015
Posts: 33
staicumihai is on a distinguished road
Default Macro to check the existence of a word docx file and create a new word file with specific content.

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.

Last edited by macropod; 11-10-2016 at 01:04 AM. Reason: Added code tags & formatting
Reply With Quote
  #2  
Old 11-10-2016, 02:36 AM
gmayor's Avatar
gmayor gmayor is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 10 Macro to check the existence of a word docx file and create a new word file with specific content. Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #3  
Old 11-10-2016, 04:04 AM
staicumihai staicumihai is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 32bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Advanced Beginner
Macro to check the existence of a word docx file and create a new word file with specific content.
 
Join Date: Dec 2015
Posts: 33
staicumihai is on a distinguished road
Default

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 ?

Last edited by staicumihai; 11-10-2016 at 09:32 PM.
Reply With Quote
  #4  
Old 11-10-2016, 04:46 AM
gmayor's Avatar
gmayor gmayor is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 10 Macro to check the existence of a word docx file and create a new word file with specific content. Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

You can't have variables in a constant. Declare the variable as a string and then define the string that is strSubFolderNewName
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #5  
Old 11-10-2016, 03:29 PM
macropod's Avatar
macropod macropod is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 64bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #6  
Old 11-10-2016, 09:32 PM
staicumihai staicumihai is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 32bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Advanced Beginner
Macro to check the existence of a word docx file and create a new word file with specific content.
 
Join Date: Dec 2015
Posts: 33
staicumihai is on a distinguished road
Default

Thanks Macropod!
Reply With Quote
  #7  
Old 11-13-2016, 09:57 PM
staicumihai staicumihai is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 32bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Advanced Beginner
Macro to check the existence of a word docx file and create a new word file with specific content.
 
Join Date: Dec 2015
Posts: 33
staicumihai is on a distinguished road
Default

Thanks a lot Gmayor!

How do I define the string strSubFolderNewName ?
Reply With Quote
  #8  
Old 11-14-2016, 12:08 AM
gmayor's Avatar
gmayor gmayor is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 10 Macro to check the existence of a word docx file and create a new word file with specific content. Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

Code:
Dim strSubFolderNewName as String
strSubFolderNewName = "Whatever you want it to be"
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #9  
Old 11-14-2016, 01:47 AM
staicumihai staicumihai is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 32bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Advanced Beginner
Macro to check the existence of a word docx file and create a new word file with specific content.
 
Join Date: Dec 2015
Posts: 33
staicumihai is on a distinguished road
Default

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.
Reply With Quote
  #10  
Old 11-14-2016, 02:42 AM
gmayor's Avatar
gmayor gmayor is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 10 Macro to check the existence of a word docx file and create a new word file with specific content. Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

Code:
strSubFolderNewName = strDrive & strfolder
It's not rocket science.
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #11  
Old 11-14-2016, 03:24 AM
staicumihai staicumihai is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 32bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Advanced Beginner
Macro to check the existence of a word docx file and create a new word file with specific content.
 
Join Date: Dec 2015
Posts: 33
staicumihai is on a distinguished road
Default

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.
Attached Images
File Type: jpg 1.jpg (135.4 KB, 41 views)
File Type: jpg 2.jpg (125.2 KB, 41 views)
Reply With Quote
  #12  
Old 11-14-2016, 05:32 AM
gmayor's Avatar
gmayor gmayor is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 10 Macro to check the existence of a word docx file and create a new word file with specific content. Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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.
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #13  
Old 11-14-2016, 09:47 PM
staicumihai staicumihai is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 32bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Advanced Beginner
Macro to check the existence of a word docx file and create a new word file with specific content.
 
Join Date: Dec 2015
Posts: 33
staicumihai is on a distinguished road
Default

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 ?
Attached Images
File Type: jpg 2.jpg (182.2 KB, 36 views)
Reply With Quote
  #14  
Old 11-14-2016, 11:11 PM
gmayor's Avatar
gmayor gmayor is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 10 Macro to check the existence of a word docx file and create a new word file with specific content. Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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.
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #15  
Old 11-15-2016, 01:42 AM
staicumihai staicumihai is offline Macro to check the existence of a word docx file and create a new word file with specific content. Windows 7 32bit Macro to check the existence of a word docx file and create a new word file with specific content. Office 2010 32bit
Advanced Beginner
Macro to check the existence of a word docx file and create a new word file with specific content.
 
Join Date: Dec 2015
Posts: 33
staicumihai is on a distinguished road
Default

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!
Reply With Quote
Reply

Thread Tools
Display Modes


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
Macro to check the existence of a word docx file and create a new word file with specific content. 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 check the existence of a word docx file and create a new word file with specific content. 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
Macro to check the existence of a word docx file and create a new word file with specific content. Word Macro That Checks a Check Box Form Field When File Print is Executed DKerne Word VBA 4 06-09-2011 11:54 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 10:57 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft