![]() |
#1
|
|||
|
|||
![]()
Hi guys!
I have this macro: 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 Const strDrive As String = "D:\MIHAI\DOSARE\BAAR\" raport = Trim(ActiveDocument.BuiltInDocumentProperties("Tit le").Value) BAAR = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("keywords").Value), "/", ".") & Chr(32) nr = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("Company").Value), Chr(150), "") marca = ActiveDocument.BuiltInDocumentProperties("Comments ").Value nr1 = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("Company").Value), Chr(150), "-") marca1 = marca & ", " & nr1 data = ActiveDocument.BuiltInDocumentProperties("Content status").Value cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentP roperties("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 Exit Sub End Sub Can anyone help me to add a code in the macro to copy a file named rp.vcp from the folder D:\MIHAI\DOSARE\BAAR to the new renamed folder D:\MIHAI\DOSARE\BAAR\strSubFolderNewName and also keep the original file ? Any ideas ? Thanks a lot! |
#2
|
||||
|
||||
![]()
The macro (use the code button - # - to format your codes), which is very loosely based on a macro I helped you with, in response to an earlier question.
You have filled a load of string variables from values (that hopefully exist - though there is no error checking), some of which have no apparent purpose, although IO have not delved too deeply, and you have assigned your default path to two separate variables? Without referring back to the original macro to check, I seem to recall that the process there renamed a sub folder if it existed? If there is a file in your folder defined at strpath and strdrive called rp.vcp then it can be copied easily enough using the command Code:
FileCopy strDrive & "rp.vcp", strDrive & FOLDER & "\rp.vcp"
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
![]()
Thanks a lot man.
The macro is based on the macro you helped me earlier. Actually I use two macros you helped me with. I dont'k know how to merge them into 1. Macro nr. 1 to rename folder and copy RP.vcp # 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 Const strDrive As String = "D:\MIHAI\DOSARE\BAAR\" raport = Trim(ActiveDocument.BuiltInDocumentProperties("Tit le").Value) BAAR = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("keywords").Value), "/", ".") & Chr(32) nr = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("Company").Value), Chr(150), "") marca = ActiveDocument.BuiltInDocumentProperties("Comments ").Value nr1 = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("Company").Value), Chr(150), "-") marca1 = marca & ", " & nr1 data = ActiveDocument.BuiltInDocumentProperties("Content status").Value cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentP roperties("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 # Macro nr 2. # Option Explicit Sub BAAR() 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 MkDir "D:\MIHAI\DOSARE\BAAR\X" Const strDrive As String = "D:\MIHAI\DOSARE\BAAR\" raport = Trim(ActiveDocument.BuiltInDocumentProperties("Tit le").Value) BAAR = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("keywords").Value), "/", ".") & Chr(32) nr = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("Company").Value), Chr(150), "") marca = ActiveDocument.BuiltInDocumentProperties("Comments ").Value nr1 = Replace(Trim(ActiveDocument.BuiltInDocumentPropert ies("Company").Value), Chr(150), "-") marca1 = marca & ", " & nr1 data = ActiveDocument.BuiltInDocumentProperties("Content status").Value cinci = Right(Replace(Trim(ActiveDocument.BuiltInDocumentP roperties("keywords").Value), "/", ".") & Chr(32), 6) cinci1 = Replace(cinci, " ", "") primit = "BAAR-Dosarxxx" & "_" & cinci1 & "-" & data & " Mihai" fisword = "R" & raport & "_" & BAAR & nr & " " & marca 'folder = "BAAR-Dosar" & raport & "_" & cinci1 & " " & nr & " " & marca & "-" & data FOLDER = "BAAR-Dosarxxx" & raport & "_" & cinci1 & " " & nr & " " & marca & "-" & data & " Mihai FIN" 'Name strDrive & primit As strDrive & folder anexa1 = "Anexa4_R" & raport & "_" & "DevizAudatex " & nr anexa5 = "Anexa5_R" & raport & "_" & "Evaluare auto " & nr Selection.Font.Bold = True anexa4 = "Anexa4" Selection.Font.Bold = False AUDATEX = anexa4 & " - Calcula" & ChrW(539) & "ie deviz de repara" & ChrW(539) & "ii pentru auto " & marca & " cu nr. de înmatriculare " & ActiveDocument.BuiltInDocumentProperties("Company" ).Value ActiveDocument.SaveAs2 strDrive & "_" & fisword & ".docx" 'ActiveDocument.ExportAsFixedFormat OutputFileName:=strDrive & fisword & ".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.SaveAs2 strDrive & fisword & ".docx" 'ActiveDocument.ExportAsFixedFormat OutputFileName:=strDrive & fisword & ".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.SaveAs2 FileName:=strDrive & fisword & ".doc", FileFormat:=wdFormatDocument 'ActiveDocument.ExportAsFixedFormat OutputFileName:=strDrive & FOLDER & ".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:=strDrive & "_" & 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:=strDrive & "_" & 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:=strDrive & "_" & 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:=strDrive & "_" & 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 'ActiveDocument.ExportAsFixedFormat OutputFileName:=strDrive & ",trimis R" & raport & "_" & Right(BAAR, 6) & ".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 lbl_Exit: With Application .ScreenUpdating = False 'Loop Through open documents Do Until .Documents.Count = 0 'Close no save .Documents(1).Close SaveChanges:=wdDoNotSaveChanges Loop 'Quit Word no save .Quit SaveChanges:=wdDoNotSaveChanges End With Exit Sub End Sub # |
#4
|
|||
|
|||
![]()
I don't know how it works but it does so thanks a lot!
|
![]() |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
klpw | Excel Programming | 2 | 12-24-2015 12:31 AM |
Copy and paste file but folder doesn't update | Haha88 | Windows | 2 | 09-24-2015 09:54 AM |
![]() |
sidbisk | Excel | 2 | 09-01-2015 02:11 PM |
unable to copy / move file from Outlook preview pane to zip folder | dgiardina | Outlook | 0 | 01-26-2015 06:33 AM |
'Save As' to same folder as original opened file | thepuppyprince | Office | 0 | 01-18-2013 08:13 AM |