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)        NextEnd Sub

Úprava tak, aby se měnil rámeček na aktuálním listu je jednoduchá [code]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[/code] 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.

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.

Zřejmě tam má být "oSheet.AddBorder(oBorderDef)" - jde o to zda pracujete s aktuálním listem nebo se všemi.

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.