---

Hallo Forum,
ich bin auf der Suche nach einem Script, selbst habe ich leider nur ganz wenig Ahnung von VBA.
Würde gerne per Makro von der geöffneten Datei ein Bild exportieren. Der Exportordner als auch die Auflösung sollte im Makro editierbar sein. Optimal wäre es, wenn der Hintergrund beim Erzeugen des Bildes auf Präsentation (weiß) gestellt werden würde und nach dem Erstellen wieder in den, der eingestellt war. Das BKS Symbol sollte bei Erstellung ausgeschaltet werden.
Hoffentlich hat jemand von euch einen ähnlichen Script den ich auch mit sehr wenig Wissen über VBA ändern kann.
Viele Grüße aus Hessen
Martin

------------------
Wenn man einen Hund so dressiert hat, dass er über einen See fliegt, dann gibt es sicher ein paar Neider die das Tier für Wasserscheu halten...

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

---

Folgenden Script konnte ich erstellen. Das Problem ist der Dateiname, ich bekomme es nicht hin, dass der original Dateiname übergeben wird. Kann mir hierbei jemand helfen?
Vielen Dank schon jetzt.
Gruß Martin

Code:

---

    Sub SavePic()
    If ThisApplication.ColorSchemes.BackgroundType = kGradientBackgroundType Then
        ThisApplication.ColorSchemes.Item("Präsentation").Activate
        ThisApplication.ColorSchemes.BackgroundType = kOneColorBackgroundType
       
    ThisApplication.GeneralOptions.Show3DIndicator = False
    ThisApplication.ActiveView.SaveAsBitmap "r:\cad_grafik\bild.png", 4000, 0
    ThisApplication.GeneralOptions.Show3DIndicator = True
   
        ThisApplication.ColorSchemes.Item("Millennium").Activate
        ThisApplication.ColorSchemes.BackgroundType = kGradientBackgroundType
    End If
   
    End Sub

---

------------------
Wenn man einen Hund so dressiert hat, dass er über einen See fliegt, dann gibt es sicher ein paar Neider die das Tier für Wasserscheu halten...

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

---

Code:

---

Dim sDateiname as string
'Dateipfad in Stringübergeben und Dateiendung wegkürzen
sDateiname=left(ThisApplication.ActiveDocument.FullFileName,len(ThisApplication.ActiveDocument.FullFileName)-3)
'Bild im Dateipfad mit neuer Endung speichern
jpeg.saveas(sDateiname & "jpg")

---

------------------
MFG

Chris

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

---

Hallo Chris,
danke für die Antwort, ich bekomme allerdings einen Run-time error in der Zeile:
jpeg.SaveAs (sDateiname & "jpg")
Kann es sein, dass es an unserem veralteten Inventor 2010 liegt?
Viele Grüße
Martin

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

---

nein, das liegt vermutlich daran, dass du dein zu speicherndes Bild nicht in der Variable "jpg" hinterlegt hast.

Poste doch mal deinen gesamten Code bisher.

------------------
MFG

Chris

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

---

ah sorry, habe das speichern im Code oben überlesen.

Soll die Grafik immer in dem r: - Pfad gespeichert werden?

------------------
MFG

Chris

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

---

Ja, die Grafik sollte immer in dem Verzeichnis gespeichert werden.

Danke Dir

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

---

Code:

---

  Sub SavePic()
    If ThisApplication.ColorSchemes.BackgroundType = kGradientBackgroundType Then
        ThisApplication.ColorSchemes.Item("Präsentation").Activate
        ThisApplication.ColorSchemes.BackgroundType = kOneColorBackgroundType
       
    ThisApplication.GeneralOptions.Show3DIndicator = False
    Dim Dateiname As String
    Dim Var() As String
    Dim MitEndung As String
    Dateiname = ThisApplication.ActiveDocument.FullFileName
    Var = Split(Dateiname, "\")
    MitEndung = Var(UBound(Var))
    Dateiname = Left(MitEndung, Len(MitEndung) - 4)
    ThisApplication.ActiveView.SaveAsBitmap "r:\cad_grafik\" & Dateiname & ".png", 4000, 0
    ThisApplication.GeneralOptions.Show3DIndicator = True
   
        ThisApplication.ColorSchemes.Item("Millennium").Activate
        ThisApplication.ColorSchemes.BackgroundType = kGradientBackgroundType
    End If
   
    End Sub

---

So sollte es gehen.

------------------
MFG

Chris

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

---

Es funktioniert, danke Dir Chris...  !!!

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

---

Kein Problem, immer wieder gerne

------------------
MFG

Chris

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

---

Mann kann auch direkt Bilder mit weißem Hintergrund exportieren, ohne das Color-Schema zu wechseln. Hier so wie ich es benutze:

Code:

---

Sub png()
Dim oDoc As Document
Set oDoc = ThisApplication.ActiveDocument
Dim oView As View
Set oView = oDoc.Views(1)
Set oCamera = oView.Camera
oCamera.Apply
Dim oTO As TransientObjects
Set oTO = ThisApplication.TransientObjects
Dim oTop As Color
Set oTop = oTO.CreateColor(255, 255, 255)
Dim oBottom As Color
Set oBottom = oTO.CreateColor(255, 255, 255)
Dim dsplmode As String
Dim i As Integer
Dim i2 As String
Dim filename As String
Dim User As String
dsplmode = 0
If ThisApplication.ActiveView.DisplayMode = kShadedRendering Then
dsplmode = 1
ThisApplication.ActiveView.DisplayMode = kShadedWithEdgesRendering
End If
i = 0
For i = 1 To 99 Step 1
If i < 10 Then
i2 = "0" + CStr(i)
End If
If i > 9 Then
i2 = "" + CStr(i)
End If
User = Environ(" USERNAME ")
filename = "C:\Users\" + User + "\Desktop\Bild_" + i2 + ".png"
If Dir(filename) = "" Then Exit For
Next
oCamera.SaveAsBitmap filename, 3840, 2160, oTop, oBottom
If dsplmode = 1 Then
ThisApplication.ActiveView.DisplayMode = kShadedRendering
End If
End Sub

---

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