Image capture and dump to a powerpoint script 1

Years ago I snagged this little gem off the catiav5forum.de forum. I don't know who to give the credit to but here it is.

I just tested it as is with R20 and it works.

Regards,
Derek


Win XP64
R20/21, 3DVIA Composer 2012, ST R20
Dell T7400 16GB Ram
Quadro FX 4800 - 1.5GB

That's the one

Thanks Derek

Joe
Mold Designer

Is there a way to edit this script so it will start with my company's default powerpoint as opposed to the default windows blank template?

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

I've set this script up on several of our users machines with no problems except one. This is the error I get and don't know how to fix it.

sorry, here is the attachment

Jopal,
Perhaps the problem child's settings do not include all the language libraries. Tools - Options - Parameters and Measure - Knowledge Environment. Both options should be checked.

Regards,
Derek


Win XP64
R20SP7/21SP5, 3DVIA Composer 2013, ST R20
Dell T7400 16GB Ram
Quadro FX 4800 - 1.5GB

Yep double checked that and both are checked on. I'm thinking it's more of a windows issue then a catia issue, just trying to cover all my options

Ferdo,
I like the enhancements.

Regards,
Derek


Win XP64
R20SP7/21SP5, 3DVIA Composer 2013, ST R20
Dell T7400 16GB Ram
Quadro FX 4800 - 1.5GB

Hi,

Error is saying that the file cannot be found (line 67)

If uuInput < 2 then fullname = "C:\Temp\OBMSectionR1.emf"

So, do you have a Temp folder where the file should be created temporary and delete at the end of running script?

If not, should be created previously to run the macro.



Regards
Fernando

Thank you Ferdo,

That was the problem. All fixed now.