CAD Fórum : Hromadný Edit celého adresáře https://www.cadforum.cz/forum/ Fri, 03 Jul 2026 22:59:38 +0000 Wed, 08 Nov 2006 07:11:44 +0000 http://blogs.law.harvard.edu/tech/rss Web Wiz Forums 12.04 360 https://www.cadforum.cz/forum/RSS_post_feed.asp?TID=3400 <![CDATA[CAD Fórum]]> https://www.cadforum.cz/forum/forum_images/web_wiz_forums.png https://www.cadforum.cz/forum/ <![CDATA[Hromadný Edit celého adresáře : A problém je v čem? Nechodí Vám...]]> https://www.cadforum.cz/forum/forum_posts.asp?TID=3400&PID=15799&title=hromadny-edit-celeho-adresare#15799 Autor: Seiner
Předmět: 3400
Zasláno: 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/)
]]> Wed, 08 Nov 2006 07:11:44 +0000 https://www.cadforum.cz/forum/forum_posts.asp?TID=3400&PID=15799&title=hromadny-edit-celeho-adresare#15799 <![CDATA[Hromadný Edit celého adresáře : Dobrý den. Prosím o radu, neboť...]]> https://www.cadforum.cz/forum/forum_posts.asp?TID=3400&PID=15794&title=hromadny-edit-celeho-adresare#15794 Autor: Tomáš
Předmět: 3400
Zasláno: 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]]> Tue, 07 Nov 2006 15:52:57 +0000 https://www.cadforum.cz/forum/forum_posts.asp?TID=3400&PID=15794&title=hromadny-edit-celeho-adresare#15794