CATIA二次开发VBA入门——一些代码合集（2）

Sub dd()
Set document1 = CATIA.ActiveDocument
Set opart = document1.Part
Set obodies = opart.Bodies
For i = 12 To 1 Step -2

obodies.Add.Name = i
Next
End Sub

Sub CATMain()
Set partdoc = CATIA.ActiveDocument

 Set partRoot = partdoc.Part
 Dim annotationSets As annotationSets
 Set annotationSets = partRoot.annotationSets
MsgBox annotationSets.Item(1).Name

End Sub

Sub CATMain()
    Dim sDocPath As String
    sDocPath = CATIA.SystemService.Environ("CATStartupPath")
    m = CATIA.FileSystem.FolderExists(sDocPath)
    If (Not m) Then
      Err.Raise 9999, , "No Doc Path Defined"
    End If
    
    
    
    Dim sFilePath As String
    sFilePath = CATIA.FileSystem.ConcatenatePaths("H:\test", "rr\Ford start part.CATPart")
    Dim idocuments As Documents
    Set idocuments = CATIA.Documents
    
    Dim iPartDoc As Document
    Set iPartDoc = CATIA.Documents.Open(sFilePath)

    '关闭当前活动的文档
     CATIA.ActiveDocument.Close

    '再次打开相同的文档。
    Set iPartDoc = CATIA.Documents.Open(sFilePath)

    '使用为文档定义的变量关闭文档。
     iPartDoc.Close

     '第三次打开相同的文档。
     Set iPartDoc = idocuments.Open(sFilePath)

     '关闭由其名称指定的CATIA文档，最后,关闭CATIA文档的第三种方法是执行关闭方法在文档本身的名称检索使用文档集合的项目方法:因此从文档中删除文档收集和所有的窗户都包含它也关闭,从windows集合中删除。
      CATIA.Documents.Item("Ford start part.CATPart").Close

   
End Sub

Sub CATMain()
Set partDoc = CATIA.ActiveDocument


 Set partRoot = partDoc.Part
 Set obj = partRoot.FindObjectByName("Point.1")
 If TypeName(obj) = "Nothing" Then
      MsgBox "Object not found"
 End If
 
MsgBox TypeName(obj)


End Sub

Sub CATMain()
Set partDoc = CATIA.ActiveDocument


 Set partRoot = partDoc.Part
Set partRoot = partDoc.Part
 Set pad1 = partRoot.FindObjectByName("Pad.1")
 partRoot.Inactivate (pad1)


End Sub

Sub CATMain()

Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument

Dim part1 As Part
Set part1 = partDocument1.Part

Dim bodies1 As Bodies
Set bodies1 = part1.Bodies

Dim body1 As Body
Set body1 = bodies1.Item("几何体.7")

Dim shapes1 As Shapes
Set shapes1 = body1.Shapes

Dim thickness2 As Thickness
Set thickness2 = shapes1.Item("厚度.1")
Set offset1 = thickness2.Offset
MsgBox offset1.Value

End Sub

Sub CATMain()

Dim partDocument1 As Document
On Error Resume Next
Set partDocument1 = CATIA.ActiveDocument
If Err.Number <> 0 Then
MsgBox "Open a CATPart first!!!", vbCritical, "Error"
Exit Sub
End If

Dim part1 As Part
On Error Resume Next
Set part1 = partDocument1.Part
If Err.Number <> 0 Then
MsgBox "This macro is good only for a CATPart!!!", vbCritical, "Error"
Exit Sub
End If

Dim Bodies1 As Bodies
Set Bodies1 = part1.Bodies

N = Bodies1.Count

Dim body1 As Body
Set body1 = Bodies1.Item("PartBody") 'The fisrt body of my CATPart

Dim shapeFactory1 As Factory
Set shapeFactory1 = part1.ShapeFactory
On Error Resume Next
Dim i As Integer

For i = 2 To N
part1.InWorkObject = body1
Dim body2 As Body
Set body2 = Bodies1.Item(2)
'MsgBox body2.Name
'~ MsgBox body2.Name
Dim assemble1 As Assemble
Set assemble1 = shapeFactory1.AddNewAssemble(body2)
part1.UpdateObject assemble1

Next

On Error GoTo 0

'~ MsgBox "Finish"

part1.Update

Dim specsAndGeomWindow1 As Window
Set specsAndGeomWindow1 = CATIA.ActiveWindow

Dim viewer3D1 As Viewer
Set viewer3D1 = specsAndGeomWindow1.ActiveViewer

Dim viewpoint3D1 As Viewpoint3D
Set viewpoint3D1 = viewer3D1.Viewpoint3D

viewer3D1.Reframe

Set viewpoint3D1 = viewer3D1.Viewpoint3D

Set body1 = Bodies1.Item("PartBody")
part1.InWorkObject = body1

End Sub

Sub CATMain()

Set partDocument1 = CATIA.ActiveDocument
MsgBox partDocument1.Name

' 获取product，方法一：
Set product1 = partDocument1.GetItem("partDocument1")

' 方法二
Set product1 = partDocument1.Product

Set parameters1 = product1.UserRefProperties
    
Set strParam1 = parameters1.CreateString("name5", "")

strParam1.ValuateFromString "mypet"

End Sub

Sub CATMain()

' New CATPart creationn
Dim CATPart As Part
Dim Doc As Document
Set Doc = CATIA.Documents.Add("Part")
Set CATPart = Doc.Part

' Get Sketches
Dim Sketch As Sketches
Set Sketch = CATPart.MainBody.Sketches

' Reference Plane creation
Dim ReferenceElement, Plane
Set ReferenceElement = CATPart.OriginElements
Set Plane = ReferenceElement.PlaneYZ

' Sketch creation
Dim Sk As Sketch
Set Sk = Sketch.Add(Plane)

' Sketch edition open
Dim Wzk As Factory2D
Set Wzk = Sk.OpenEdition

' Geometry creation
Dim Line As Line2D
Set Line = Wzk.CreateLine(-30, 0, -10, 50)
Line.Construction = False
Set Line = Wzk.CreateLine(-10, 50, 10, 50)
Line.Construction = False
Set Line = Wzk.CreateLine(10, 50, 30, 0)
Line.Construction = False

' Sketch close and CATpart update
Sk.CloseEdition
CATPart.Update

End Sub

Sub CATMain()

Dim partDocument1
Set partDocument1 = CATIA.ActiveDocument

Dim part1 As Part
Set part1 = partDocument1.Part

Dim selection 'As selection
Set selection = CATIA.ActiveDocument.selection

Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory

'~ setup filter
      ReDim sFilter(0)
         MsgBox "Select a Face"
         sFilter(0) = "Face"
         sStatus = selection.SelectElement2(sFilter, "select a Face", False)

Dim Obj 'As VispProperties
Set Obj = selection.VisProperties

'Set visProperties1 = CATIA.ActiveDocument.selection.VisProperties

'~ change layer
 Obj.SetLayer catVisLayerBasic, 200

 '~ change colour
Obj.SetRealColor 255, 255, 0, 0

part1.Update
    
End Sub

Sub CATMain()

Dim partDocument1
Set partDocument1 = CATIA.ActiveDocument

Dim part1 As Part
Set part1 = partDocument1.Part

Dim selection 'As selection
Set selection = CATIA.ActiveDocument.selection

Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory

'~ setup filter
      ReDim sFilter(0)
         MsgBox "Select a Line"
         sFilter(0) = "Line"
         sStatus = selection.SelectElement2(sFilter, "select a Face", False)

Dim Obj 'As VispProperties
Set Obj = selection.VisProperties

'Set visProperties1 = CATIA.ActiveDocument.selection.VisProperties

'~ change layer
 Obj.SetLayer catVisLayerBasic, 200

 '~ change colour
Obj.SetRealColor 255, 255, 0, 0
Obj.SetRealLineType 4, 0
'Obj.SetShow catVisPropertyNoShowAttr


part1.Update

End Sub