Pozz,imam problem sa kreiranjem novog layera u autocadu preko visual basica,tacnije ja sam resio kako da kreiram novi layer,i skonto sam kako da dafinisem boju tog layera,i to mi radi ali ne znam kako da mu ubacim "LINETYPE",ima li neko resenje ?
Imam problem sa kreiranjem novog LAYERA u autocadu preko Visual Basica
Zaključano
Zakačeno
trebao bi prvo definisati osobine layera, zatim pozivati tipove linija, a one se nalaze u fajlu acad.lin
evo malo sam kopao po svojoj arhivi i mislim da ti baš ovako nešto treba
evo malo sam kopao po svojoj arhivi i mislim da ti baš ovako nešto treba
Code:
Sub SetLayerAndLineType()
LoadLineType
GenLayers "Primary"
GenLayers "Dimension", , acGreen, acLnWt000
GenLayers "Label", , acMagenta, acLnWt005
GenLayers "Text", , acBlue, acLnWt005
GenLayers "Center", "Center", acRed, acLnWt005
GenLayers "Hidden", "Hidden", acYellow, acLnWt005
GenLayers "Steel", , acRed, acLnWt009
End Sub
Public Sub LoadLineType()
On Error Resume Next
ThisDrawing.Linetypes.Load "CENTER", "ACAD.LIN"
ThisDrawing.Linetypes.Load "HIDDEN", "ACAD.LIN"
ThisDrawing.Linetypes.Load "PHANTOM", "ACAD.LIN"
Err.Clear
On Error Goto 0
End Sub
Public Sub GenLayers(iLyrNm As String, Optional iLnTyp = _
"Continuous", Optional iClr = acBlue, Optional iLnWght _
= acLnWt015)
Dim mTmpLyer As AcadLayer
Set mTmpLyer = MakeALayer(iLyrNm)
mTmpLyer.Color = iClr
mTmpLyer.Linetype = iLnTyp
mTmpLyer.LayerOn = True
mTmpLyer.Lineweight = iLnWght
Set mTmpLyer = Nothing
End Sub
Function MakeALayer(LayerName As String) As AcadLayer
Dim mLyrNm As AcadLayer
On Error Resume Next
Set mLyrNm = ThisDrawing.Layers.Add(LayerName)
If Err.Number <> 0 Then
Set mLyrNm = ThisDrawing.Layers(LayerName)
End If
Err.Clear
On Error Goto 0
Set MakeALayer = mLyrNm
Set mLyrNm = Nothing
End Function
Sub SetLayerAndLineType()
LoadLineType
GenLayers "Primary"
GenLayers "Dimension", , acGreen, acLnWt000
GenLayers "Label", , acMagenta, acLnWt005
GenLayers "Text", , acBlue, acLnWt005
GenLayers "Center", "Center", acRed, acLnWt005
GenLayers "Hidden", "Hidden", acYellow, acLnWt005
GenLayers "Steel", , acRed, acLnWt009
End Sub
Public Sub LoadLineType()
On Error Resume Next
ThisDrawing.Linetypes.Load "CENTER", "ACAD.LIN"
ThisDrawing.Linetypes.Load "HIDDEN", "ACAD.LIN"
ThisDrawing.Linetypes.Load "PHANTOM", "ACAD.LIN"
Err.Clear
On Error Goto 0
End Sub
Public Sub GenLayers(iLyrNm As String, Optional iLnTyp = _
"Continuous", Optional iClr = acBlue, Optional iLnWght _
= acLnWt015)
Dim mTmpLyer As AcadLayer
Set mTmpLyer = MakeALayer(iLyrNm)
mTmpLyer.Color = iClr
mTmpLyer.Linetype = iLnTyp
mTmpLyer.LayerOn = True
mTmpLyer.Lineweight = iLnWght
Set mTmpLyer = Nothing
End Sub
Function MakeALayer(LayerName As String) As AcadLayer
Dim mLyrNm As AcadLayer
On Error Resume Next
Set mLyrNm = ThisDrawing.Layers.Add(LayerName)
If Err.Number <> 0 Then
Set mLyrNm = ThisDrawing.Layers(LayerName)
End If
Err.Clear
On Error Goto 0
Set MakeALayer = mLyrNm
Set mLyrNm = Nothing
End Function
što ti treba ovo