---

Hallo
ich habe mir mit Hilfe des Forum ein Makro geschrieben um den Zeichnungsrahmen auszutauschen.
Leider wird bei dieser Methode die Beschriftung verschoben.
Ich denke das liegt an der Massstabskorrektur da der Rahmenwechsel im Massstab 1:1 erfolgt.
Kennt jemand eine bessere Methode so dass ich keine Beschriftungsprobleme bekomme?

Anbei der benutzte Code.

LG
Udo

Code:

---

Private Sub Rahmen_austauschen()

Dim Name                As String
Dim templateName        As String
Dim Breite_neu          As Double
Dim Hoehe_neu          As Double
Dim Blattmasstab_vorn  As Single
Dim Blattmasstab_hinten As Single
Dim boolstatus          As Boolean

Set swApp = Application.SldWorks
Set DrawingDoc = swApp.ActiveDoc
Set Sheet = DrawingDoc.GetCurrentSheet
Set LayerMgr = DrawingDoc.GetLayerManager
Set Part = swApp.ActiveDoc

If (DrawingDoc.GetType <> swDocDRAWING) Then
    ' wenn keine Zeichnung aktiv wird das Makro wieder beendet
    MsgBox "Nur für Zeichnungen geeignet.", vbOKOnly + vbInformation, "Keine Zeichnung"
    Exit Sub
End If

vSheetProps = Sheet.GetProperties
Breite = vSheetProps(5) * 1000
Hoehe = vSheetProps(6) * 100
Blattmasstab_vorn = vSheetProps(2)
Blattmasstab_hinten = vSheetProps(3)
Name = Sheet.GetName

Select Case Breite
Case "210"
    Breite_neu = "210"
    Hoehe_neu = "297"
    templateName = "K:\Bibliotheken\Bibilothek SolidWorks\Blattformate\A4-hoch_ECTR.slddrt"
Case "420"
    Breite_neu = "420"
    Hoehe_neu = "297"
    templateName = "K:\Bibliotheken\Bibilothek SolidWorks\Blattformate\A3-quer_ECTR.slddrt"
Case "594"
    Breite_neu = "594"
    Hoehe_neu = "420"
    templateName = "K:\Bibliotheken\Bibilothek SolidWorks\Blattformate\A2-quer_ECTR.slddrt"
Case "841"
    Breite_neu = "841"
    Hoehe_neu = "594"
    templateName = "K:\Bibliotheken\Bibilothek SolidWorks\Blattformate\A1-quer_ECTR.slddrt"
Case "1189"
    Breite_neu = "1189"
    Hoehe_neu = "841"
    templateName = "K:\Bibliotheken\Bibilothek SolidWorks\Blattformate\A0-quer_ECTR.slddrt"

End Select

retval = DrawingDoc.SetupSheet4(Name, swDwgPapersUserDefined, swDwgTemplateCustom, "1", "1", False, templateName, Breite_neu, Hoehe_neu, "Standard")
 
Set Sheet = DrawingDoc.GetCurrentSheet
vSheetProps = Sheet.GetProperties
Breite = vSheetProps(5) * 1000
Hoehe = vSheetProps(6) * 1000

boolstatus = Sheet.SetScale(Blattmasstab_vorn, Blattmasstab_hinten, True, False)

End Sub

---

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

---

Lass doch das skalieren weg...

Statt

Code:

---

retval = DrawingDoc.SetupSheet4(Name, swDwgPapersUserDefined, swDwgTemplateCustom, "1", "1", False, templateName, Breite_neu, Hoehe_neu, "Standard")

---

einfach

Code:

---

retval = DrawingDoc.SetupSheet4(Name, swDwgPapersUserDefined, swDwgTemplateCustom, Blattmasstab_vorn, Blattmasstab_hinten, False, templateName, Breite_neu, Hoehe_neu, "Standard")

---

sollte eigentlich ausreichen. Das SetScale dann weglassen. Das Makro, das wir hier verwenden, sieht ansonsten fast identisch aus:

Code:

---

    Blattnamen = Part.GetSheetNames
   
        For Each Blattname In Blattnamen
           
            Part.ActivateSheet (Blattname)
           
            Set swSheet = Part.GetCurrentSheet()
                   
            boolstatus = Part.ForceRebuild3(False)
           
            SheetProperties = swSheet.GetProperties
            papersize = SheetProperties(0)
           
            scale1 = SheetProperties(2)
            scale2 = SheetProperties(3)
            firstAngle = CBool(SheetProperties(4))
           
            templateName = ""      'no sheetformat = no path
           
            Width = SheetProperties(5)
            Height = SheetProperties(6)
            propViewName = swSheet.CustomPropertyView
   
            Part.SetupSheet5 Blattname, swDwgPapersUserDefined, swDwgTemplateNone, scale1, scale2, firstAngle, "", Width, Height, propViewName, True      'Leeres Blatt setzen
           
            boolstatus = Part.ForceRebuild3(False)
           
            templatePfad = "D:\...\Vorlagen 2017\"
           
                If Width = "1,189" Then
                    papersize = swDwgPaperA0size
                    templateName = templatePfad & "a0....slddrt"
                ElseIf Width = "0,841" Then
                    papersize = swDwgPaperA1size
                    templateName = templatePfad & "a1....slddrt"
                ElseIf Width = "0,594" Then
                    papersize = swDwgPaperA2size
                    templateName = templatePfad & "a2....slddrt"
                ElseIf Width = "0,42" Then
                    papersize = swDwgPaperA3size
                    templateName = templatePfad & "a3....slddrt"
                Else
                    papersize = swDwgPaperA4size
                    templateName = templatePfad & "a4....slddrt"
                End If

            Part.SetupSheet5 Blattname, swDwgPapersUserDefined, swDwgTemplateCustom, scale1, scale2, firstAngle, templateName, Width, Height, propViewName, True '    Reload the sheet format from the specified location
           
          Part.ViewZoomtofit2
            Part.ForceRebuild3 False
           
        Next Blattname

---

Gruß, Jens

PS: Dir fehlt bei der ersten Höhe eine Null...

------------------
CSWE =)

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

---

Hallo Jens,

vielen Dank für deine Antwort. Das mit dem Masstab hat wunderbar geklappt.
Ich vermute ich brauch auch noch die andere Methode Part.SetupSheet5.
Bei mir werden momentan die Ansichten auf Amerikanisch umgestellt.
Leider weis ich nicht wie dein Part definiert ist.
Kannst du mir die Definition noch zukommen lassen?

Danke
Gruß Udo

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

---

Des einen Part ist des nächsten DrawingDoc... 

Gruß, Jens

------------------
CSWE =)

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

---

Morgen Jens
War nur Blind.
Läuft mittlerweile top.
Danke für die Tipps.
Gruß Udo

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