Daniel Popa
Automotive
Hello
I am trying to create a macro that would cycle through all the parts in a folder, open them one by one, reframe and go to ISO view, take a screenshot and save it in a ppt. I have found smaller macros that are doing parts of this and managed to botch what I need. it works fine with the exception of the image quality.
If I run the capture macro by itself the quality of the image is great, but when it cycles through parts the quality goes down considerably. There might be something I do not understand from the smaller macros (the one opening all the files) as it does not seem to work as expected. It seems to open then close the part and then take the screenshot somehow...
I would be extremely grateful if someone could give me any tips.
Thank you.
I am trying to create a macro that would cycle through all the parts in a folder, open them one by one, reframe and go to ISO view, take a screenshot and save it in a ppt. I have found smaller macros that are doing parts of this and managed to botch what I need. it works fine with the exception of the image quality.
If I run the capture macro by itself the quality of the image is great, but when it cycles through parts the quality goes down considerably. There might be something I do not understand from the smaller macros (the one opening all the files) as it does not seem to work as expected. It seems to open then close the part and then take the screenshot somehow...
I would be extremely grateful if someone could give me any tips.
Thank you.
Code:
'Declaration for timeout window
Private Declare PtrSafe Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) _
As Long
Sub Main()
folderinput = InputBox("Take your files from here", "Input", "C:\tempin\", 2000, 4000)
Dim INTRAre As String
Dim Name As String
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderinput)
Set fc = f.Files
For Each f1 In fc
Dim partDocument1 'As Document
Set documents1 = CATIA.Documents
Dim Document1 'As Document
INTRAre = folderinput & f1.Name
Set partDocument1 = CATIA.Documents.Open(INTRAre)
' FileName = CATIA.ActiveDocument.Name
' Length = Len(FileName)
' CutLength = InStr(FileName, ".") - 1
' Name = Left(FileName, CutLength)
Capture
CATIA.ActiveDocument.Close
Next
End Sub
Sub Capture()
'Spec and Compass Off
'Remove commented rows for question
'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"
'Reframe and ISO view
Set viewer3D1 = Window1.ActiveViewer
viewer3D1.Reframe
Set viewpoint3D1 = viewer3D1.Viewpoint3D
CATIA.StartCommand "* iso"
'Else
'End If
'Call timed messagebox to allow reframe
TestMsgbox
On Error Resume Next
CATIA.ActiveWindow.Height = 5000
CATIA.ActiveWindow.Width = 5000
CATIA.ActiveWindow.Viewers.Item(1).CaptureToFile 1, "C:\Temp\OBMSectionR1.emf"
' CATIA.ActiveWindow.Viewers.Item(1).CaptureToFile catCaptureFormatJPEG
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
Sub TestMsgbox()
Dim ReturnValue
ReturnValue = MsgBoxTimeout(0, "Give me a second. I need time to adjust" & vbCrLf & "This message box will be closed after 1 second.", "Return Choice", vbQuestion + vbYesNoCancel, 0, 1000)
Select Case ReturnValue
Case vbYes
Debug.Print "You picked Yes."
Case vbNo
Debug.Print "You picked No."
Case vbCancel
Debug.Print "You picked Cancel."
Case 32000
Debug.Print "Timeout before user made selection."
End Select
End Sub