Convert Dwg set from DA to CC VBA Style

[russell84]

Would someone give me advice on how to improve my coding format etc - any advice on how to improve the below code??

 

Thanks

 

The below code is part of a code i have written to change a drawings set from DA to CC

It first copies a complete drawing set - from say R:\Jobs 2007\07447\Acad\DA and pastes them to R:\Jobs 2007\07447\Acad\CC

and renames the individual drawings from say 07447_DA_C000 to 07447_CC_C000 then it goes into the drawing and renames the attribute in the title block from 07447_DA_C000 to 07447_CC_C000 then it unload the xrefs - renames them from say XR07447_DA_SURVEY to XR07447_CC_SURVEY and repaths them to the new CC folder.

 

I can supply the form if needed.

 

Cheers guys

 

 

Public FormResultREV As Boolean

Sub RevUpDrawings()
Dim tmpyearREV As Integer
Dim JobDirectorycurrentREV, jobdirectoryNEWREV, JobNoDirectory, JobYearREV As String
Dim CURREV, NEWREV, CURREVPATH, NEWREVPATH, result As String
Dim fs
If FormResultREV Then

       tmpyearREV = CDbl(VBA.Left(UserFormcombined.JOBNOREV, 2))
   If tmpyearREV > 80 Then
       tmpyearREV = 1900 + tmpyearREV
   Else
       tmpyearREV = 2000 + tmpyearREV
   End If
       JobYearREV = CStr(tmpyearREV)
       CURREV = "_" & UserFormcombined.CurrentStageREV & "_"
       NEWREV = "_" & UserFormcombined.NewStageREV & "_"
       jobdirectoryNEWREV = "R:\Jobs " & JobYearREV & "\" & UserFormcombined.JOBNOREV & "\ACAD\" & UserFormcombined.NewStageREV
       JobDirectorycurrentREV = "R:\Jobs " & JobYearREV & "\" & UserFormcombined.JOBNOREV & "\ACAD\" & UserFormcombined.CurrentStageREV

   'Create new directory and copy all old contents
   Set fs = CreateObject("scripting.filesystemobject")
   MkDir jobdirectoryNEWREV
   fs.CopyFile JobDirectorycurrentREV & "\*", jobdirectoryNEWREV
   'Rename all drawings
   result = Dir((jobdirectoryNEWREV & "\*.dwg"))
   Do
       If result = "" Then Exit Do
           Name jobdirectoryNEWREV & "\" & result As jobdirectoryNEWREV & "\" & Replace(result, CURREV, NEWREV)
       result = Dir()
   Loop
           MsgBox "The entire " & UserFormcombined.CurrentStageREV & " drawing set for Job Number " & UserFormcombined.JOBNOREV & " has been converted to a " _
           & UserFormcombined.NewStageREV & " drawing set." & VBA.Chr(13) & "Drawings have been created in the new directory " & jobdirectoryNEWREV & VBA.Chr(13) & _
           "Drawings will be now be opened so that title block attributes can be edited and xrefs can be renamed and repathed." & VBA.Chr(13) & VBA.Chr(13) & "Please wait until finished. Thank you", vbInformation, "ATTENTION PLEASE READ"
renamedrawingnumbers
End If
End Sub


Function renamedrawingnumbers()
Dim i, j, k As Integer
Dim element, ArrayAttributes
Dim jobdirectoryNEWREV, JobYearREV, tmpyearREV, OldDWGNO, NewDWGNO As String
Dim CURREV, NEWREV, revtest As String
   tmpyearREV = CDbl(VBA.Left(UserFormcombined.JOBNOREV, 2))
   If tmpyearREV > 80 Then
   tmpyearREV = 1900 + tmpyearREV
   Else
   tmpyearREV = 2000 + tmpyearREV
   End If
   JobYearREV = CStr(tmpyearREV)

   revtest = CStr(VBA.Left(UserFormcombined.NewStageREV, 1))
   If revtest = "C" Then
   revtest = "A"
   Else
   revtest = "01"
   End If

       CURREV = "_" & UserFormcombined.CurrentStageREV & "_"
       NEWREV = "_" & UserFormcombined.NewStageREV & "_"
       jobdirectoryNEWREV = "R:\Jobs " & JobYearREV & "\" & UserFormcombined.JOBNOREV & "\ACAD\" & UserFormcombined.NewStageREV

On Error Resume Next
       For i = 1 To UserFormcombined.ListBox5REV.ListCount
       UserFormcombined.ListBox5REV.ListIndex = i - 1
       Documents.Open jobdirectoryNEWREV & "\" & UserFormcombined.ListBox5REV.Text    'open each drawing in listbox

                   For j = 0 To ThisDrawing.Layouts.Count - 1 'loop through each tab and update info
               If ThisDrawing.Layouts(j).Name = "Model" Then GoTo 10
               ThisDrawing.SendCommand "layout s " & ThisDrawing.Layouts(j).Name & vbCr
               For Each element In ThisDrawing.PaperSpace
                   If element.EntityType = 7 Then
                       If Err Then GoTo 5
                       If element.HasAttributes = True Then
                           ArrayAttributes = element.GetAttributes
                           For k = LBound(ArrayAttributes) To UBound(ArrayAttributes)
                               If ArrayAttributes(k).TagString = "DATE" Then ArrayAttributes(k).TextString = VBA.UCase(VBA.Format(VBA.Date, "Mmm yyyy"))
                               If ArrayAttributes(k).TagString = "R" Then ArrayAttributes(k).TextString = revtest
                               If ArrayAttributes(k).TagString = "A" Then ArrayAttributes(k).TextString = revtest
                               If ArrayAttributes(k).TagString = "DESCRIPTION" Then ArrayAttributes(k).TextString = "REVISION IN PROGRESS"
                               If ArrayAttributes(k).TagString = "DWG-NO." Then
                               OldDWGNO = ArrayAttributes(k).TextString
                               NewDWGNO = Replace(OldDWGNO, CURREV, NEWREV)
                               ArrayAttributes(k).TextString = NewDWGNO
                               ThisDrawing.ActiveLayout.Name = NewDWGNO
                               End If
                           Next k
                       End If
5
                   End If
               Next
10
           Next j
  RenameXrefBlockAttribs
       Next i
End Function



Function RenameXrefBlockAttribs()
Dim AttribValues, XrefOld, XrefNew, XrefPathOld, XrefPathNew, ListXref, TEST As String
Dim CURREV, NEWREV, CURREVPATH, NEWREVPATH As String
Dim element As AcadBlockReference
       CURREV = "_" & UserFormcombined.CurrentStageREV & "_"
       NEWREV = "_" & UserFormcombined.NewStageREV & "_"
       CURREVPATH = "\" & UserFormcombined.CurrentStageREV & "\"
       NEWREVPATH = "\" & UserFormcombined.NewStageREV & "\"
On Error Resume Next
       ListXref = "" 'Create a list of xrefs to avoid repeating - for some reason it lists each element more than once
       For Each element In ThisDrawing.ModelSpace
           If element.EntityType = 42 Then 'Test if it is an xref
              ' ListXref = ListXref & ", " & element.Name
              ' GoTo 10
               'If LCase(Left(element.Name, 2)) = "xr" Then
'                    MsgBox element.Name
                   If InStr(0, ListXref, element.Name) > 0 Then
                       If Err = 5 Then Err = 0: GoTo 5
                       GoTo 10 'check if xref in list
                   End If
5
                   ListXref = ListXref & ", " & element.Name
                   XrefOld = element.Name
                   XrefNew = Replace(XrefOld, CURREV, NEWREV)
                  ''''' XrefNew = InputBox("Rename Xref from " & XrefOld & " to:", "Rename Xref", XrefNew)
                   If XrefNew = "" Then GoTo 10 'cancel pressed
                   XrefPathOld = element.Path
                   XrefPathNew = Replace(XrefPathOld, XrefOld, XrefNew)
                   XrefPathNew = Replace(XrefPathNew, CURREVPATH, NEWREVPATH)
                  ''''' XrefPathNew = InputBox("Rename XrefPath from " & XrefPathOld & " to:", "Rename XrefPath", XrefPathNew)
                   If XrefPathNew = "" Then GoTo 10 'cancel pressed
                   'check if new path file exists and rename if it doesn't - warn if still not present
                   If Dir(XrefPathNew) = "" Then
                       Name Replace(XrefPathNew, XrefNew, XrefOld) As XrefPathNew
                       If Dir(XrefPathNew) = "" Then
                           MsgBox "Could not find file in xref path."
                           GoTo 10
                       End If
                   End If
                   'rename xref
                   ThisDrawing.SendCommand VBA.Chr(27) & VBA.Chr(27) & "-rename" & VBA.vbCr & "b" & VBA.vbCr & XrefOld & VBA.vbCr & XrefNew & VBA.vbCr
                   'check if xref loaded and unload

                   'unload xref
                   ThisDrawing.SendCommand VBA.Chr(27) & VBA.Chr(27) & "-xref" & VBA.vbCr & "u" & VBA.vbCr & XrefNew & VBA.vbCr
                   'repath xref
                   ThisDrawing.SendCommand VBA.Chr(27) & VBA.Chr(27) & "-xref" & VBA.vbCr & "p" & VBA.vbCr & XrefNew & VBA.vbCr & XrefPathNew & VBA.vbCr
                   'if previously loaded then reload xref

                   ThisDrawing.SendCommand VBA.Chr(27) & VBA.Chr(27) & "-xref" & VBA.vbCr & "r" & VBA.vbCr & XrefNew & VBA.vbCr

               End If
10
           'End If
       Next
End Function