Vytisknout stránku | Zavřít okno

Hromadný Edit celého adresáře

Vytištěno z: CAD Fórum
Kategorie: Autodesk - stavebnictví, strojírenství, CAD/GIS
Název fóra: CAD programování
Popis fóra: Otázky programování - nadstavby a utility pro CAD a GIS aplikace Autodesk (VBA, AutoLISP, ARX/C++, .Net, JavaScript, Python, MEL...)
URL: https://www.cadforum.cz/forum/forum_posts.asp?TID=3400
Datum vytištění: 03.čvc.2026 v 13:35


Téma: Hromadný Edit celého adresáře
Odeslal: Tomáš
Předmět: Hromadný Edit celého adresáře
Datum odeslání: 07.lis.2006 v 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

-------------
Konstruktér, projektant
Inventor 2008 SP2, AutoCAD 2008 SP2, XP Prof. SP2
ZPA Industry a.s.


Odpovědi:
Odeslal: Seiner
Datum odeslání: 08.lis.2006 v 07:11
A problém je v čem? Nechodí Vám to makro, nebo nevíte, jak ho spustit pro všechny výkresy?
Pokud a), tak Vám neporadím, pokud b) použijte generátor skriptů.
Já používám svůj, ale nikomu ho necpu.
Jen připomínám, že pro AutoCAD 2006 musí být aplikován SP (tuším 2), aby demo soubor (skript) dokázal otevřít soubor.
(Ten můj generátor je tady: http://www2.chrudim.cz/seiner/ - http://www2.chrudim.cz/seiner/ )


-------------
Vítězslav Seiner

Chrudim


Vytisknout stránku | Zavřít okno