| | | Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte | | | | PNY bietet das umfangreichste Ökosystem von B2B als auch B2C-Lösungen für IT-Akteure auf dem Markt |
Autor
|
Thema: Makro Maßstab: Wechsel auf Blatt 1 (1694 mal gelesen)
|
fberthold Mitglied
Beiträge: 383 Registriert: 19.07.2006 Windows 10 Pro Intel Core i7, 16gb RAM Nvidia Quadro P2000 IV2019 Pofessional Vault2019
|
erstellt am: 15. Apr. 2009 13:46 <-- editieren / zitieren --> Unities abgeben:
Hallo, ich habe vor längerem mal dieses ältere Makro hier aus dem Forum kopiert und die Norm.idw eingebunden, um den Maßstab ins Schriftfeld zu bekommen. Nun ist mir aufgefallen, das der ausgegebene Maßstab abhängig davon ist, auf welchem Blatt ich mich gerade befinde. D.h. stehe ich auf Blatt 1, ist alles i.O. Stehe ich aber auf Blatt 2 o. 3, etc. wird beim Speichern der Maßstab der Erstansicht des jeweils aktiven Blattes gezogen, und nicht der von Blatt 1. Nun meine Frage: Könnte ich das Makro irgendwie ergänzen, damit beim Speichern zuallererst auf Blatt 1 gewechselt, und danach erst der Maßstab ins Schriftfeld übertragen wird? Anbei nochmal das Makro. Viele Grüße Frank Code: ' Attribute VB_Name = "Massstab_AIS7" Option Explicit 'Programm zur Ermittlung der Anzeigemaßstäbe '(c) Event Engineering Jörgen Pisarz Berlin 2003 ' www.event-engineering.de 'ergänzt auf Autodesk Inventor R7 '(c) Robby Lampe Dresden 2003 '=========================================================== Private Function EE_FormatScale(ByVal S As Double) As String ' Stand: 01.09.2003 If S >= 1 Then If (10 * S Mod 10) = 0 Then EE_FormatScale = Format(S, "0") + ":1" Else EE_FormatScale = Format(S, "0.0") + ":1" End If Else If (10 * (1 / S) Mod 10) = 0 Then EE_FormatScale = "1:" + Format(1 / S, "0") Else EE_FormatScale = "1:" + Format(1 / S, "0.0") End If End If End Function Sub Massstab() Dim I, J, K As Integer Dim EE_MainScale, EE_TestScale As Double Dim EE_SiteScale(10) As Double Dim EE_Text As String Dim EE_Da As Boolean Dim EE_Prop As Property Dim oDoc As Document Dim EE_Objekt As Object 'Objekt herstellen Set oDoc = ThisApplication.ActiveDocument 'Funktioniert nur, wenn Drawing und mindestens eine Ansicht vorhanden ist: If oDoc.DocumentType <> kDrawingDocumentObject Then Exit Sub If oDoc.ActiveSheet.DrawingViews.Count = 0 Then Exit Sub 'Ermittle die Hauptansicht und Hauptmaßstab EE_MainScale = oDoc.ActiveSheet.DrawingViews(1).Scale 'Ermittle weitere Ansichten J = 0 For I = 1 To oDoc.ActiveSheet.DrawingViews.Count 'Ermittle weitere Maßstäbe EE_TestScale = oDoc.ActiveSheet.DrawingViews(I).Scale 'Prüfe, ob gleich hauptmaßstab If EE_TestScale <> EE_MainScale Then 'Prüfe, ob schon als Nebenmaßstab vorhanden If J > 0 Then For K = 0 To J If EE_TestScale = EE_SiteScale(K) Then EE_TestScale = 0 Exit For End If Next K End If 'If EE_TestScale <> 0 Then ''Nimm in die Liste auf 'EE_SiteScale(J) = EE_TestScale 'J = J + 1 ''Die liste ist begrenzt... 'If J = 11 Then Exit For 'End If End If Next I EE_Text = EE_FormatScale(EE_MainScale) If J > 0 Then EE_Text = EE_Text + " (" For I = 0 To J - 1 If (I > 0) And (I < 2) Then EE_Text = EE_Text + " " End If If (I > 1) Then EE_Text = EE_Text + ", " End If EE_Text = EE_Text + EE_FormatScale(EE_SiteScale(I)) Next I EE_Text = EE_Text + ")" End If 'Füge Zeichenfolge ein 'Maßstab vorhanden? EE_Da = False For Each EE_Prop In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'Benutzerdefiniert If EE_Prop.Name = "Massstab" Then EE_Da = True Exit For End If Next If EE_Da Then oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Massstab").Value = EE_Text Else oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add EE_Text, "Massstab" End If End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
lbcad Ehrenmitglied V.I.P. h.c. Dipl.-Ing. Maschinenbau und CAD-Trainer
Beiträge: 3823 Registriert: 15.02.2001 DELL Precision 7520 Win10Pro-64 Inventor mit Vault Professional 2024 --------------------- Während man es aufschiebt, verrinnt das Leben. Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)
|
erstellt am: 15. Apr. 2009 15:02 <-- editieren / zitieren --> Unities abgeben: Nur für fberthold
Hi, Du mußt nur diese Zeilen einfügen: Code:
'Objekt herstellen Set oDoc = ThisApplication.ActiveDocument' neu: Dim oDrawDoc As DrawingDocument Set oDrawDoc = oDoc ' erstes Blatt aktivieren oDrawDoc.Sheets.Item(1).Activate ' bis hierher
'Funktioniert nur, wenn Drawing und mindestens eine Ansicht vorhanden ist:
------------------ Gruß Lothar --------------------------------------------------- Während man es aufschiebt, verrinnt das Leben. Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.) ----------------------------------------------------- Wir unterstützen die Arbeit der: - Rettungshundestaffel des DRK Viersen - Rettungshundestaffel Isar Ost Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
fberthold Mitglied
Beiträge: 383 Registriert: 19.07.2006 Windows 10 Pro Intel Core i7, 16gb RAM Nvidia Quadro P2000 IV2019 Pofessional Vault2019
|
erstellt am: 15. Apr. 2009 15:58 <-- editieren / zitieren --> Unities abgeben:
|
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|