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