Sub CATMain()

  ' Den Pfad zum speichern festlegen
  Dim TempPfad
  TempPfad = "U:\catia_model"
  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")
  Dim Dateiname
  Dateiname = fso.GetTempName()
  TempPfad = TempPfad+Dateiname+".bmp"

  ' Catia-Viewer
  Dim Viewer1
  Set Viewer1 = CATIA.ActiveWindow.ActiveViewer

  ' Blende den Strukturbaum und Kompass aus
  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  

  ' Sichert die aktuelle Hintergrundfarbe
  Dim color(2)
  Viewer1.GetBackgroundColor color
  'Setzt einen weißen Hintergrund
  Viewer1.PutBackgroundColor Array(1, 1, 1)

  ' Catia-Viewpoint
  Dim Viewpoint1
  Set Viewpoint1 = Viewer1.Viewpoint3D

  ' Ansicht ändern zu 'Ansicht oben'
  Viewpoint1.PutOrigin array(-310,0,0)
  Viewpoint1.PutSightDirection array(0,0,-1)
  Viewpoint1.PutUpDirection array(0,0,0)
  Viewpoint1.ProjectionMode = catProjectionCylindric
  Viewpoint1.Zoom = 0.0015
 
 ' das Bild erstellen
  Viewer1.Update
  Viewer1.CaptureToFile catCaptureFormatBMP, TempPfad
 
  ' PowerPoint verwenden bzw. öffnen
  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
 
  ' Falls noch keine Folie vorhanden ist, eine Folie einfügen
  If PowerPoint.Presentations.Count = 0 Then
    Dim PptPresentations
    Dim PptCurrentSlide
    Set PptPresentations = PowerPoint.Presentations.Add
    Set PptCurrentSlide = PptPresentations.Slides.Add (1, 12)
  End If
 
  ' Das Einfügen von Objekten auf die aktuelle Folie vorbereiten
  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, True, True, 70, 70)
 
  ' Die Größe des Bildes anpassen
  Dim PictureWitdh 'as Integer
  Dim PictureHeight 'as Integer
  PptShape.LockAspectRatio = True
  PptShape.Width = 632
  PictureHeight = PptShape.Height
  If PictureHeight > 430 Then
    PictureHeight = 430
    PptShape.Height = PictureHeight
  End If

  ' Ansicht ändern zu 'Ansicht unten'
  Viewpoint1.PutOrigin array(-310,0,0)
  Viewpoint1.PutSightDirection array(0,0,1)
  Viewpoint1.PutUpDirection array(0,0,0)
  Viewpoint1.ProjectionMode = catProjectionCylindric
  Viewpoint1.Zoom = 0.0015

 ' das Bild erstellen
  Viewer1.Update
  Viewer1.CaptureToFile catCaptureFormatBMP, TempPfad

  ' Eine Folie einfügen
  Set PptCurrentSlide = PptPresentations.Slides.Add (1, 12)

  ' Das Einfügen von Objekten auf die aktuelle Folie vorbereiten
  Set PptSlideRange = PowerPoint.ActiveWindow.Selection.SlideRange
  Set PptShapes = PptSlideRange.Shapes
 
  ' Das Bild in die Folie einfügen
  Set PptShape = PptShapes.AddPicture (TempPfad, True, True, 70, 70)
 
  ' Die Größe des Bildes anpassen
  PptShape.LockAspectRatio = True
  PptShape.Width = 632
  PictureHeight = PptShape.Height
  If PictureHeight > 430 Then
    PictureHeight = 430
    PptShape.Height = PictureHeight
  End If



  ' Alles wieder zurücksetzten
  Viewer1.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)
  Set fso = nothing  
 
End Sub