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\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(45), "")
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-Dosar" & raport & "_" & cinci1 & " " & nr & " " & MARCA & "-" & data & ""
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 R pt. dosar " & baar1 & vbCr & vbCr & 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 R pt. dosar " & baar1 & vbCr & vbCr & 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 R pt. dosar " & baar1 & vbCr & vbCr & 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
Object doesn't support this property or method.
ActiveDocument.SaveAs2 FileName:=strsubfoldernewname & "\" & fisword & ".doc", FileFormat:=wdFormatDocument
oDoc.SaveAs2 FileName:=strsubfoldernewname & "\X\" & "XEN.docx", addtorecentfiles:=False