| |
| Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte |
| |
| Request a special discount on NVIDIA RTX 5000 Ada Generation GPU !, eine Pressemitteilung
|
Autor
|
Thema: Bild exportieren (2409 mal gelesen)
|
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2015
|
erstellt am: 22. Apr. 2015 07:22 <-- editieren / zitieren --> Unities abgeben:
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 |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2015
|
erstellt am: 27. Apr. 2015 07:57 <-- editieren / zitieren --> Unities abgeben:
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 |
Chris 31 Mitglied Konstrukteur und Mädchen für alles
Beiträge: 575 Registriert: 23.04.2013 Inventor 2013/2015 Windows 7 64 bit 16GB RAM nVidia Quadro 600
|
erstellt am: 27. Apr. 2015 11:36 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
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 |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2015
|
erstellt am: 27. Apr. 2015 11:59 <-- editieren / zitieren --> Unities abgeben:
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 |
Chris 31 Mitglied Konstrukteur und Mädchen für alles
Beiträge: 575 Registriert: 23.04.2013 Inventor 2013/2015 Windows 7 64 bit 16GB RAM nVidia Quadro 600
|
erstellt am: 27. Apr. 2015 12:03 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
|
Chris 31 Mitglied Konstrukteur und Mädchen für alles
Beiträge: 575 Registriert: 23.04.2013 Inventor 2013/2015 Windows 7 64 bit 16GB RAM nVidia Quadro 600
|
erstellt am: 27. Apr. 2015 12:07 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
|
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2015
|
erstellt am: 27. Apr. 2015 12:20 <-- editieren / zitieren --> Unities abgeben:
|
Chris 31 Mitglied Konstrukteur und Mädchen für alles
Beiträge: 575 Registriert: 23.04.2013 Inventor 2013/2015 Windows 7 64 bit 16GB RAM nVidia Quadro 600
|
erstellt am: 27. Apr. 2015 12:28 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
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 |
Martin_0103 Mitglied
Beiträge: 181 Registriert: 05.02.2003 3,4 GHz - Quadro 4000 - 12 GB RAM - WIN7 - IV2015
|
erstellt am: 27. Apr. 2015 13:06 <-- editieren / zitieren --> Unities abgeben:
|
Chris 31 Mitglied Konstrukteur und Mädchen für alles
Beiträge: 575 Registriert: 23.04.2013 Inventor 2013/2015 Windows 7 64 bit 16GB RAM nVidia Quadro 600
|
erstellt am: 27. Apr. 2015 13:09 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
|
dg2405 Mitglied Ingenieur MB
Beiträge: 30 Registriert: 16.06.2011 I7-4960X@4.7Ghz Radeon R9-295X2 Samsung 840EVO Win7-64bit SP1 IV2014 SP1
|
erstellt am: 09. Jun. 2015 22:19 <-- editieren / zitieren --> Unities abgeben: Nur für Martin_0103
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 |