Tomáš
07.11.2006, 15:52
Dobrý den.
Prosím o radu, neboť jsem se nějak zamotal.
Potřeboval bych otevřít jeden výkres z adresáře.
A vněm spustit toto VBA tak, aby proběhlo přes všechny výkresy v tomto adresáři....Což mě
Předem děkuji za popostrčení.
Tomáš
Sub VytvorHlad()
'Vytvoří hladiny "PID_CHECK_START" a "PID_AUDIT" (pokud neexistují)
Dim col As AcadAcCmColor
Dim lrs As AcadLayers
Dim lr As AcadLayer
Set lrs = ThisDrawing.Layers
Set col = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.17")
Call col.SetRGB(255, 0, 0)
'přidání hladiny "PID_CHECK_START"
On Error Resume Next
If IsEmpty(lrs.Item("PID_CHECK_START")) Then
On Error GoTo 0
MsgBox "hladina PID_CHECK_START neexistuje a bude vytvořena"
lrs.Add "PID_CHECK_START"
Set lr = lrs.Item("PID_CHECK_START")
lr.TrueColor = col
lr.Lineweight = acLnWt050
lr.Lock = True
End If
Call col.SetRGB(0, 255, 0)
'přidání hladiny "PID_AUDIT"
On Error Resume Next
If IsEmpty(lrs.Item("PID_AUDIT")) Then
On Error GoTo 0
MsgBox "hladina PID_AUDIT neexistuje a bude vytvořena"
lrs.Add "PID_AUDIT"
Set lr = lrs.Item("PID_AUDIT")
lr.TrueColor = col
lr.Lineweight = acLnWtByLwDefault
lr.Lock = True
End If
MsgBox "KonecA"
End Sub
Sub PresunBloku()
'Přesune značky měření do výchozí hladiny "PID_CHECK_START"
Dim blkref As AcadBlockReference
Dim blks As AcadBlocks
Dim blk As AcadBlock
Dim lrs As AcadLayers
Dim lr As AcadLayer
Set lrs = ThisDrawing.Layers
Set blks = ThisDrawing.Blocks
Dim i As Integer
For i = 0 To ThisDrawing.ModelSpace.Count - 1
If ThisDrawing.ModelSpace.Item(i).ObjectName = "AcDbBlockReference" Then
Set blkref = ThisDrawing.ModelSpace.Item(i)
If blkref.Name = "MIST_MER" Or blkref.Name = "DAL_MER" Then
blkref.Layer = "PID_CHECK_START"
End If
End If
Next i
MsgBox "KonecB"
End Sub
Sub VymenaHladiny()
'Přesune značky měření do hladiny "PID_AUDIT"
Dim blkref As AcadBlockReference
Dim blks As AcadBlocks
Dim blk As AcadBlock
Dim lrs As AcadLayers
Dim lr As AcadLayer
Set lrs = ThisDrawing.Layers
Set blks = ThisDrawing.Blocks
Dim i As Integer
'Odemkne hladiny
Set lr = lrs.Item("PID_CHECK_START")
lr.Lock = False
Set lr = lrs.Item("PID_AUDIT")
lr.Lock = False
For i = 0 To ThisDrawing.ModelSpace.Count - 1
If ThisDrawing.ModelSpace.Item(i).ObjectName = "AcDbBlockReference" Then
Set blkref = ThisDrawing.ModelSpace.Item(i)
If blkref.Name = "MIST_MER" Or blkref.Name = "DAL_MER" Then
blkref.Layer = "PID_AUDIT"
End If
End If
Next i
'Uzamkne hladiny
Set lr = lrs.Item("PID_CHECK_START")
lr.Lock = True
Set lr = lrs.Item("PID_AUDIT")
lr.Lock = True
MsgBox "KonecC"
End Sub
Prosím o radu, neboť jsem se nějak zamotal.
Potřeboval bych otevřít jeden výkres z adresáře.
A vněm spustit toto VBA tak, aby proběhlo přes všechny výkresy v tomto adresáři....Což mě
Předem děkuji za popostrčení.
Tomáš
Sub VytvorHlad()
'Vytvoří hladiny "PID_CHECK_START" a "PID_AUDIT" (pokud neexistují)
Dim col As AcadAcCmColor
Dim lrs As AcadLayers
Dim lr As AcadLayer
Set lrs = ThisDrawing.Layers
Set col = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.17")
Call col.SetRGB(255, 0, 0)
'přidání hladiny "PID_CHECK_START"
On Error Resume Next
If IsEmpty(lrs.Item("PID_CHECK_START")) Then
On Error GoTo 0
MsgBox "hladina PID_CHECK_START neexistuje a bude vytvořena"
lrs.Add "PID_CHECK_START"
Set lr = lrs.Item("PID_CHECK_START")
lr.TrueColor = col
lr.Lineweight = acLnWt050
lr.Lock = True
End If
Call col.SetRGB(0, 255, 0)
'přidání hladiny "PID_AUDIT"
On Error Resume Next
If IsEmpty(lrs.Item("PID_AUDIT")) Then
On Error GoTo 0
MsgBox "hladina PID_AUDIT neexistuje a bude vytvořena"
lrs.Add "PID_AUDIT"
Set lr = lrs.Item("PID_AUDIT")
lr.TrueColor = col
lr.Lineweight = acLnWtByLwDefault
lr.Lock = True
End If
MsgBox "KonecA"
End Sub
Sub PresunBloku()
'Přesune značky měření do výchozí hladiny "PID_CHECK_START"
Dim blkref As AcadBlockReference
Dim blks As AcadBlocks
Dim blk As AcadBlock
Dim lrs As AcadLayers
Dim lr As AcadLayer
Set lrs = ThisDrawing.Layers
Set blks = ThisDrawing.Blocks
Dim i As Integer
For i = 0 To ThisDrawing.ModelSpace.Count - 1
If ThisDrawing.ModelSpace.Item(i).ObjectName = "AcDbBlockReference" Then
Set blkref = ThisDrawing.ModelSpace.Item(i)
If blkref.Name = "MIST_MER" Or blkref.Name = "DAL_MER" Then
blkref.Layer = "PID_CHECK_START"
End If
End If
Next i
MsgBox "KonecB"
End Sub
Sub VymenaHladiny()
'Přesune značky měření do hladiny "PID_AUDIT"
Dim blkref As AcadBlockReference
Dim blks As AcadBlocks
Dim blk As AcadBlock
Dim lrs As AcadLayers
Dim lr As AcadLayer
Set lrs = ThisDrawing.Layers
Set blks = ThisDrawing.Blocks
Dim i As Integer
'Odemkne hladiny
Set lr = lrs.Item("PID_CHECK_START")
lr.Lock = False
Set lr = lrs.Item("PID_AUDIT")
lr.Lock = False
For i = 0 To ThisDrawing.ModelSpace.Count - 1
If ThisDrawing.ModelSpace.Item(i).ObjectName = "AcDbBlockReference" Then
Set blkref = ThisDrawing.ModelSpace.Item(i)
If blkref.Name = "MIST_MER" Or blkref.Name = "DAL_MER" Then
blkref.Layer = "PID_AUDIT"
End If
End If
Next i
'Uzamkne hladiny
Set lr = lrs.Item("PID_CHECK_START")
lr.Lock = True
Set lr = lrs.Item("PID_AUDIT")
lr.Lock = True
MsgBox "KonecC"
End Sub