Hallo
Ich habe jetzt ein Makro in Ecxel, das ein Bild von Catia Bidschirm erstellt,
und in eine Powerpoint Folie einfügt.
Das Makro hat in Excel zuerst nicht funktioniert.
Ich habe dann bei den Verweise bei allen Catia einträgen einen Hacken gesetzt
jetzt funktioniert es bei mir super auch von Excel aus
code:
Sub Power()
'
' Power Makro
' Makro am 29.01.2011 von G aufgezeichnet
'
Dim CATIA As Object
Dim Activedoc As Object
Set CATIA = GetObject(, "Catia.Application")
Set Activedoc = CATIA.ActiveDocument
Dim TempPfad
TempPfad = "c:\tmp\"
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Dateiname
Dateiname = fso.GetTempName()
'TempPfad = TempPfad + Dateiname + ".bmp"
Dim viewer3D1 'As Viewer
Set viewer3D1 = CATIA.ActiveWindow.ActiveViewer
Dim viewpoint3D1 As Viewpoint3D
Set viewpoint3D1 = viewer3D1.Viewpoint3D
On Error Resume Next
Dim Window1
Set Window1 = CATIA.ActiveWindow
Dim WindowLayout1
WindowLayout1 = Window1.Layout
Window1.Layout = catWindowGeomOnly
CATIA.StartCommand "CompassDisplayOff"
On Error GoTo 0
Dim Color(2)
viewer3D1.GetBackgroundColor Color
viewer3D1.PutBackgroundColor Array(1, 1, 1)
viewer3D1.Update
viewer3D1.CaptureToFile catCaptureFormatBMP, TempPfad & Dateiname
Dim PowerPoint
On Error Resume Next
Set PowerPoint = GetObject(, "PowerPoint.Application")
If Err.Number <> 0 Then
Err.Clear
Set PowerPoint = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
PowerPoint.Visible = True
If PowerPoint.Presentations.Count = 0 Then
Dim PptPresentations
Dim PptCurrentSlide
Set PptPresentations = PowerPoint.Presentations.Add
Set PptCurrentSlide = PptPresentations.Slides.Add(1, 12)
End If
Dim PptSlideRange
Set PptSlideRange = PowerPoint.ActiveWindow.Selection.SlideRange
Dim PptShapes
Set PptShapes = PptSlideRange.Shapes
'das Bild in die Folie einfügen
Dim PptShape
Set PptShape = PptShapes.AddPicture(TempPfad & Dateiname, True, True, 70, 70)
viewer3D1.PutBackgroundColor Array(Color(0), Color(1), Color(2))
On Error Resume Next
Window1.Layout = WindowLayout1
CATIA.StartCommand "CompassDisplayOn"
On Error GoTo 0
Set PptObject = Nothing
Set Viewer1 = Nothing
fso.DeleteFile (TempPfad & Dateiname)
Set fso = Nothing
End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
