Hi,
Yes, can be edit, of course, still, you will need to set up the layout for each slide after capturing the pictures . You need also to edit in line 33 the path and name of the ppt file. I've done also few small improvements (option to capture or not the spec tree and compass, deletion of the temporary picture file at the end of running macro).
Sub CATMain()
' Spec and Compass Off ?
Dim response
response = MsgBox ("Click YES to capture picture without spec tree and compass" & Chr(13) & Chr(13) & "Click NO to capture picture with spec tree and compass", 16 Or 4)
If response = vbYes Then
On Error Resume Next
Dim Window1
Set Window1 = CATIA.ActiveWindow
Dim WindowLayout1
WindowLayout1 = Window1.Layout
Window1.Layout = catWindowGeomOnly
CATIA.StartCommand "CompassDisplayOff"
Else
End If
on error resume next
Catia.ActiveWindow.Viewers.item(1).CaptureToFile 1, "C:\Temp\OBMSectionR1.emf"
On error goto 0
' Set PowerPoint
Dim ppt
On Error Resume Next
Set ppt = GetObject (,"PowerPoint.Application")
If Err.Number = 0 Then
Err.Clear
Else
Set ppt = CreateObject("PowerPoint.Application")
PPT.Visible=True
Set Pres = PPT.Presentations.Open("C:\Temp\Test.ppt")
on error resume next
End If
Set uNewS = ppt.ActivePresentation.slides.Add(ppt.ActivePresentation.slides.count + 1 , 2)
If (err) then
Set uNewP = ppt.Presentations.Add(True)
ppt.Visible = true
ppt.windowstate = 2
Set uNewS = uNewP.slides.Add(uNewP.slides.count + 1 , 2)
else
Set uNewP = ppt.ActivePresentation
End if
On error goto 0
uNewS.Layout = 12
uuInput = 1
uPictureFormat = 0
call ppt.Windows.item(1).Activate
call pasteGraphic( ppt, uNewP, ab, uMultiGraph )
CATIA.ActiveWindow.ActiveViewer.FullScreen = false
End Sub
'----------------------------------------------------------------------------------------
Public Function pasteGraphic( ppt, uNewP, ab, uuInput )
ppt.ActiveWindow.view.GotoSlide(uNewP.slides.count)
fullname = "C:\Temp\OBMSectionR1" & uuInput-1 & ".emf"
If uuInput < 2 then fullname = "C:\Temp\OBMSectionR1.emf"
set oyoy = ppt.ActiveWindow.Selection.SlideRange.item(1).Master
ppt.ActiveWindow.Selection.SlideRange.Shapes.AddPicture(fullname, 0,1,65,68,595,450).select
Set yoyo = ppt.ActiveWindow.Selection.ShapeRange.item(1)
yoyo.PictureFormat.Contrast = 0.5
yoyo.PictureFormat.Brightness = 0.5
yoyo.PictureFormat.ColorType = 1
yoyo.PictureFormat.TransparentBackground = 0
yoyo.Fill.Visible = 0
yoyo.Line.Visible = 0
yoyo.Rotation = 0
yoyo.PictureFormat.CropLeft = 0
yoyo.PictureFormat.CropRight = 0
yoyo.PictureFormat.CropTop = 0
yoyo.PictureFormat.CropBottom = 0
yoyo.LockAspectRatio = -1
yoyo.ScaleHeight 1, 1, 0
yoyo.ScaleWidth 1, 1, 0
yoyo.Width = oyoy.Width
if (oyoy.Height < yoyo.Height ) then yoyo.Height = oyoy.Height
'''''set distance from top and left side
yoyo.top = 80
yoyo.Left = 0
ppt.ActiveWindow.Selection.Unselect
'Back Spec and Compass
Dim Window1
Set Window1 = CATIA.ActiveWindow
Dim WindowLayout1
WindowLayout1 = Window1.Layout
Window1.Layout = catWindowSpecsAndGeom
CATIA.StartCommand "CompassDisplayOn"
On Error GoTo 0
Set PptObject = Nothing
Set Viewer1 = Nothing
''''''''''''''delete captured picture
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile"C:\Temp\OBMSectionR1.emf"
Set fso = nothing
End Function
Regards
Fernando