将Dwg集从DA转换为CC
有人能给我一些关于如何改进我的编码格式等的建议吗？关于如何改进下面的代码有什么建议吗？？谢谢
下面的代码是我编写的将图形集从DA更改为CC的代码的一部分
它首先从R:\Jobs 2007\07447\Acad\DA复制完整的图形集，并将其粘贴到R:\Jobs 2007\07447\Acad\CC
将单个图形从07447\u DA\u C000重命名为07447\u CC\u C000，然后进入图形并将标题栏中的属性从07447\u DA\u C000重命名为07447\u CC\u C000，然后卸载外部参照-将其从XR07447\u DA\u SURVEY重命名为XR07447\u CC\u SURVEY，并将其重新定位到新的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
页:
[1]