Selektion und visProperties (Dassault Systemes - PLM Solutions/CATIA V5 Programmierung) - Lösung vorhanden!

Hi an alle.

Ich komm direkt zu meinem Anliegen. Bin gerade an der Programmierung eines CATIA Makros das mehrere Geosets und Analysen ein und ausblenden und zwischen durch immer ein Bild machen soll welches in eine PowerPoint exportiert wird. Das Bild machen und exportieren funktioniert schonmal so weit. Mein Problem liegt eher an der Sache mit dem ein und ausblenden bzw. der Selektierung der gewünschten Geosets/Analysen. Zu Beginn sollen alle Geosets und Analysen ausgeblendet werden dies soll zwischen diesen Linien ('********************) erfolgen. Grundsätzlich stellt sich für mich die Frage ob die Selektion so funktioniert? Momentan funktioniert der Code bis zur Deklarierung des HybridBodies dann gibt es eine Fehlermeldung.

Nun der wichtigste Teil der

Code:

Sub CATMain()
' Spec and Compass Off ?
Dim response
response = MsgBox ("Mit einem Klick auf OK beginnt das Makro seine Arbeit. Prüfen sie zuvor ob das Startmodell richtig befüllt ist.", vbOKCancel + vbInformation + vbDefaultButton2)
If response = vbOK Then
On Error resume next
Dim Window1
Set Window1 = CATIA.ActiveWindow
Dim WindowLayout1
WindowLayout1 = Window1.Layout
Window1.Layout = catWindowSpecsAndGeom
CATIA.StartCommand "CompassDisplayOn"
Else
Exit Sub
End If
'********************
Dim oGS As HybridBody
Dim sel As Selection

Set sel = CATIA.ActiveDocument.Selection
Set oGS = "Name=Prepare_part_Input_Part,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Surface_analysis"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Porcupine_Curvature,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Surfacic Curvature Analysis_Inflection_area,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Surfacic Curvature Analysis_Gaussian,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Surfacic Curvature Analysis_Minimum_Curvature,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Connect Checker Analysis_Punktsteigkeit_G0,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Connect Checker Analysis_Tangentensteigkeit_G1,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Connect Checker Analysis_Kruemmungssteigkeit_G2,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Surfacic Curvature Analysis_Maximum_Curvature,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Surfacic Curvature Analysis_Limited,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Surfacic Curvature Analysis_Surfacic_Curvature_R10000,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Connect Checker Analysis_Surfacic_Curvature_R30000,all"
sel.Add oGS
oGS.Clear
Set oGS = "Name=Connect Checker Analysis_Surfacic_Curvature_R100000,all"
sel.Add oGS
oGS.Clear
Set visProperties1 = CATIA.ActiveDocument.Selection.VisProperties
visProperties1.SetShow catVisPropertyNoShowAttr
'********************
On Error resume next
Catia.ActiveWindow.Viewers.item(1).CaptureToFile 1, "C:\Temp\temp_pic.jpg"
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("G:\CATIA_Makro_Vorlage\PowerPoint_template.pptx")
on error resume next
End If
Set uNewS = ppt.ActivePresentation.slides.Add(ppt.ActivePresentation.slides.count + 1 , 3)
If (err) then
Set uNewP = ppt.Presentations.Add(True)
ppt.Visible = true
ppt.windowstate = 2
Set uNewS = uNewP.slides.Add(uNewP.slides.count + 1 , 3)
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

Set oDoc = CATIA.ActiveDocument
Set oCams = oDoc.Cameras
Set oCam = oCams.Item(2)
Set oViewPoint = oCam.Viewpoint3D
Set oSpecWindow = CATIA.ActiveWindow
Set oViewer = oSpecWindow.ActiveViewer
oViewer.Viewpoint3D = oViewPoint
oViewer.Reframe

Public Function pasteGraphic( ppt, uNewP, ab, uuInput )
ppt.ActiveWindow.view.GotoSlide(uNewP.slides.count)
fullname = "C:\Temp\temp_pic" & uuInput-1 & ".jpg"
If uuInput < 2 then fullname = "C:\Temp\temp_pic.jpg"
set oyoy = ppt.ActiveWindow.Selection.SlideRange.item(1).Master
ppt.ActiveWindow.Selection.SlideRange.Shapes.AddPicture(fullname, 0,1,65,68,1024,576).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/3*2

'''''set distance from top and left side
yoyo.top = 150
yoyo.Left = 290
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\temp_pic.jpg"
Set fso = nothing

End Function

[Diese Nachricht wurde von Ramoon am 14. Jan. 2020 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP