Hot News:

Mit Unterstützung durch:

  Foren auf CAD.de (alle Foren)
  Inventor
  Makro Maßstab: Wechsel auf Blatt 1

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
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



Sehen Sie sich das Profil von fberthold an!   Senden Sie eine Private Message an fberthold  Schreiben Sie einen Gästebucheintrag für fberthold

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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



Sehen Sie sich das Profil von lbcad an!   Senden Sie eine Private Message an Lothar Boekels  Schreiben Sie einen Gästebucheintrag für Lothar Boekels

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für fberthold 10 Unities + Antwort hilfreich

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



Sehen Sie sich das Profil von fberthold an!   Senden Sie eine Private Message an fberthold  Schreiben Sie einen Gästebucheintrag für fberthold

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Vielen Dank,
das hat mir sehr geholfen 10*U

Gruß
Frank

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2024 CAD.de | Impressum | Datenschutz