[编程交流] 更改层以匹配另一个

Dim objENT As AcadEntity
Dim ssetObj As AcadSelectionSet
Dim layercode As String
Dim objLayers As AcadLayers
Dim objLayer As AcadLayer
Dim X, Y, J, k As Integer
Dim lname, ans, ltype As String
Dim MyLAYERNAME(256) As String
Dim MyLAYERCOLOR(256) As Integer
Dim MyLAYERLINETYPE(256) As String
'On Error GoTo filediafix
' 256 max LINES 3 VARIABLES
Open "S:\Autodesk\lisp\civilcad6layercodes.txt" For Input As #1
' setvar filedia to 0
ThisDrawing.SendCommand "filedia" & vbCr & "0" & vbCr
'loads all custom linetypes purges first then reloads
'ThisDrawing.SendCommand "-purge" & vbCr & "lt" & vbCr & "*" & vbCr & "N" & vbCr
'ThisDrawing.SendCommand "-linetype" & vbCr & "l" & vbCr & "*" & vbCr & "s:\Autodesk\supportfiles\custom.lin" & vbCr & vbCr
' reset all solid linetypes to continuous
Set objLayers = ThisDrawing.Layers
For Each objLayer In objLayers
 If objLayer.Linetype = "solid" Or objLayer.Linetype = "SOLID" Then
 objLayer.Linetype = "Continuous"
 End If
Next objLayer
MsgBox "Solid Linetypes reset in the layers"
For Each objLayer In objLayers
'If objLayer.Name = "FENCE" Then
 
 'If objLayer.Linetype = "903" Then
' objLayer.Linetype = "FENCE"
' End If
Next objLayer
MsgBox "903 Linetypes reset in the layers"
For Each objLayer In objLayers
 If objLayer.Linetype = "dash" Then
 objLayer.Linetype = "DASHED"
 End If
Next objLayer
MsgBox "DASH Linetypes reset in the layers"
For Each objLayer In objLayers
 If objLayer.Linetype = "VEGETATION" Then
 objLayer.Linetype = "TREE"
 End If
Next objLayer
MsgBox "Vegetation Linetypes reset in the layers"
' now change layer colors and linEtype for all entities to bylayer
Set ssetObj = ThisDrawing.SelectionSets.Add("MYsSS")
ssetObj.Select acSelectionSetAll
For Each objENT In ssetObj
objENT.color = acByLayer
objENT.Linetype = "ByLayer"
Next objENT
ThisDrawing.SelectionSets.Item("MYsSS").Delete
'read in each line of data file with layer name colour and linetype
Y = 0
Do While Not EOF(1)    ' Check for end of file.
 Line Input #1, layercode    ' Read line of data.
  ' MsgBox "1   lines" & layercode
   
  ans = Mid(layercode, 1, 22)    'LAYER NAME
  J = 22
  lname = ""
  For k = 1 To J
  character = Mid(ans, k, 1)
  If character = " " Then k = J Else lname = lname + character
  Next k
  MyLAYERNAME(Y) = lname
  
  MyLAYERCOLOR(Y) = CInt(Mid(layercode, 23, 1))    'COLOR NUMBER
  
  ans = Mid(layercode, 25, 10)
  
  J = 10
  ltype = ""
  For k = 1 To J
  character = Mid(ans, k, 1)
  If character = " " Then k = J Else ltype = ltype + character
  Next k
  MyLAYERLINETYPE(Y) = ltype    ' LINETYPE
  
   
   Y = Y + 1
Loop
Close #1    ' Close file.
For Each objLayer In objLayers
 For X = 1 To Y
 If objLayer.Name = MyLAYERNAME(X) Then
 objLayer.color = MyLAYERCOLOR(X)
 objLayer.Linetype = MyLAYERLINETYPE(X)
 X = Y
 Else
z = z + 1
 End If
 Next X
Next objLayer
MsgBox "Linetypes and colours have been reset all the layers"
filediafix:
ThisDrawing.SendCommand "filedia" & vbCr & "1" & vbCr