Diskuzní fórum a databáze tipů a utilit pro AutoCAD, Inventor, Revit a další produkty Autodesk - od firmy Arkance Systems [www.cadforum.cz]
CZ | SK | EN | DE
Přihlášení
či registrace
   právě nás čte: 12240 
RSS kanál - CAD tipy RSS tipy
RSS diskuze

Diskuze Diskuzní fórum, poradna

 

NápovědaCAD diskuze, rady, výměna zkušeností

 
CAD Fórum - Homepage Veřejné diskuzní fórum k CAD aplikacím - ptejte se na libovolné otázky týkající se oboru CAx, podělte se o vaše znalosti a zkušenosti s programy AutoCAD, Inventor, Revit, Fusion 360, 3ds Max a s dalšími CAD aplikacemi. Zaregistrujte se nebo se přihlašte a zašlete váš příspěvek do odpovídajícího fóra. Viz další informace o CAD Fóru. Nechcete se registrovat? Zeptejte se v naší Facebook poradně.
Fórum nenahrazuje technický support firmy Arkance Systems (CAD Studio) - přímá podpora pro zákazníky funguje na helpdesk.cadstudio.cz
  FAQ FAQ  Prohledat fórum   Události   Registrovat Registrovat  Přihlásit Přihlásit

Téma uzavřenoZměna rámečku na výkrese - VBA

 Odpovědět Odpovědět archiv
Autor
 Hodnocení: Hodnocení tématu: 1 Hlasů, Průměrné 5,00  Najít Téma Najít Téma  Možnosti tématu Možnosti tématu
jirka007CZ Zobrazit panel
Diskutér
Diskutér

Přihlášen: 07.led.2007
Lokalita: ČR (SČ)
Používám:
Inventor 2014
Stav: Offline
Bodů: 27
Přímý odkaz na tuto zprávu Téma: Změna rámečku na výkrese - VBA
    Zasláno: 05.zář.2014 v 09:32
Dobrý den, ve firmě používáme několik druhů rámečků výkresů. Než je výkresová dokumentace schválená, tak máme rámeček s příčným vodoznakem "informativní". Po schválení dokumentace měníme rámeček na totožný, ale bez vodoznaku. Obdobně máme řešené speciální listy s kusovníkem.

Cílem je zjednodušit tuto změnu...snížit počet kliků. Vydal jsem se cestou "čudlíku", který tyto kroky provede přes VBA makro. Základní kód jsem získal na zahraničním fóru a v zásadě funguje dobře. Jediným problémem je, že z našich rámečků odstraní horizontální a vertikální zóny. Další vadou je, že změnu provádí na všech výkresech. 

Rád bych touto cestou poprosil o radu jak kód upravit ku prospěchu věci, tudíž rámečky se zónami a změna rámečku pouze na aktivním listu. Moc děkuji za radu, kód níže.



Public Sub InsertCustomBorderOnSheet()
    ' Set a reference to the drawing document.
    ' This assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument

    ' Obtain a reference to the desired border definition.
    Dim oBorderDef As BorderDefinition
    Set oBorderDef = oDrawDoc.BorderDefinitions.Item("Název požadovaného rámečku")
    
    ' Set a reference to count all sheets in document
    Dim oSheets As Sheets
    Set oSheets = oDrawDoc.Sheets
    
    Dim iSheets As Integer
    For iSheets = 1 To oSheets.Count

    ' Check to see if the sheet already has a border and delete it if it does.
    If Not oSheets(iSheets).Border Is Nothing Then
        oSheets(iSheets).Border.Delete
    End If

    ' Add an instance of the border definition to the sheet.
    Dim oBorder As Border
    Set oBorder = oSheets(iSheets).AddBorder(oBorderDef)
    
    Next
End Sub

Chyba je vždy mezi monitorem a židlí...
Zpět nahoru
Navara Zobrazit panel
Arkance Systems support
Arkance Systems support
Avatar
Arkance Systems

Přihlášen: 08.zář.2008
Lokalita: ČR (Pha)
Používám:
Inventor
Stav: Offline
Bodů: 1636
Přímý odkaz na tuto zprávu Zasláno: 05.zář.2014 v 11:02

Úprava tak, aby se měnil rámeček na aktuálním listu je jednoduchá

Public Sub InsertCustomBorderOnActiveSheet()
    ' Set a reference to the drawing document.
    ' This assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    ' Obtain a reference to the desired border definition.
    Dim oBorderDef As BorderDefinition
    Set oBorderDef = oDrawDoc.BorderDefinitions.Item("Watermark")
    ' Set a reference to active sheet
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    ' Check to see if the sheet already has a border and delete it if it does.
    If Not oSheet.Border Is Nothing Then
        oSheet.Border.Delete
    End If
    ' Add an instance of the border definition to the sheet.
    Dim oBorder As Border
    Set oBorder = oSheets(iSheets).AddBorder(oBorderDef)
End Sub
 
S tím mizením zón je to horší, protože to vypadá na nějakou chybu Autodesku. Doporučuju si dát trochu práce a namalovat si vlastní rámeček se zónami a nepoužívat ten výchozí, nebo automaticky generovaný.
Další možnost je neměnit rámeček, ale do rámečku doplnit textové pole, které bude zobrazovat nějakou iVlastnost výkresu a pokud bude její hodnota prázdná, tak se žádný vodoznak nezobrazí. Jinak tam můžete mít libovolný text.
Zpět nahoru
jirka007CZ Zobrazit panel
Diskutér
Diskutér

Přihlášen: 07.led.2007
Lokalita: ČR (SČ)
Používám:
Inventor 2014
Stav: Offline
Bodů: 27
Přímý odkaz na tuto zprávu Zasláno: 05.zář.2014 v 13:42
Dobrý den, moc děkuji za radu a upravený kód. Bohužel v předposledním řádku funkce zkolabuje.

Set oBorder = oSheets(iSheets).AddBorder(oBorderDef)

Následně vyhlásí chybu:
Sub or Function not defined.

Textové pole s ivlastností nebo i statickým textem jsem byl nucený v prvopočátku mého snažení zavrhnout. Důvod byly různé formáty výkresů. Text ve výkresu se mi nepodařilo přemluvit, aby se přizpůsobovalo různým formátům listů. Tudíž východiskem se staly různé rámečky se statickým vodoznakem pro všechny používané formáty listu a jeden rámeček bez textu univerzální pro všechny formáty.
Chyba je vždy mezi monitorem a židlí...
Zpět nahoru
Vladimír Michl Zobrazit panel
Moderátor
Moderátor
Avatar
Arkance Systems

Přihlášen: 09.zář.2004
Lokalita: ČR (JČ)
Používám:
Dodáváme produkty Autodesk
Stav: Offline
Bodů: 21434
Přímý odkaz na tuto zprávu Zasláno: 05.zář.2014 v 15:47
Zřejmě tam má být "oSheet.AddBorder(oBorderDef)" - jde o to zda pracujete s aktuálním listem nebo se všemi.
Vladimír Michl (moderátor)
Arkance Systems s.r.o. - www.arkance-systems.cz
(podpora viz hd.cads.cz)
Zpět nahoru
jirka007CZ Zobrazit panel
Diskutér
Diskutér

Přihlášen: 07.led.2007
Lokalita: ČR (SČ)
Používám:
Inventor 2014
Stav: Offline
Bodů: 27
Přímý odkaz na tuto zprávu Zasláno: 08.zář.2014 v 14:24
Dobrý den, děkuji moc, funkce již pracuje jak má. Ještě nějakým způsobem vyřeším problém s mizejícími zónami a bude to dokonalé.
Ještě jednou moc děkuji.
Chyba je vždy mezi monitorem a židlí...
Zpět nahoru

Pro technickou podporu CAD
kontaktujte Helpdesk

Příbuzné CAD tipy:
Tip 9798:VIPiLogic pravidlo pro automatické směrování tisku (formát/tiskárna).
Tip 9713:VIPNastavení barev komponentám výkresu Inventoru (VBA makro)
Tip 6508:Snadná změna měřítka celého strojařského výkresu.
Tip 10689:VIPiLogic: Hromadné nastavení iVlastností pro všechny součásti sestavy
Tip 8352:Přidání dynamického rámečku k jakémukoliv textu.
Tip 4784:Snadno čitelné kóty.


 Odpovědět Odpovědět

Přejít na fórum Oprávnění fóra Zobrazit panel



Stránka byla vygenerována za 0,813 sekund.