View Single Post
 
Old 11-14-2016, 09:47 PM
staicumihai staicumihai is offline Windows 7 32bit Office 2010 32bit
Advanced Beginner
 
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