[编程交流] 将Dwg集从DA转换为CC

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