Script to Help

[gerlado]

I want to show my script

This script can show holes and thread, he create a document excel and send it, the diameter and the metric

The script is this:


Sub exportar_num_agujeros()

Dim partdocument1 As Document
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("PartBody")

Dim shapes1 As Shapes
Set shapes1 = body1.Shapes


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

Dim i

selection1.Clear
For i = 1 To shapes1.Count
selection1.Add shapes1.Item(i)
Next

Dim xSelObj() As Variant
Dim xObj As Variant
Dim n As Integer
Dim myObj As AnyObject

Dim nCount As Integer
nCount = 0

For n = 0 To shapes1.Count

On Error Resume Next
Set myObj = selection1.FindObject("CATIAHole") '("CATIAPattern") '("CATIAHole")

ReDim Preserve xSelObj(nCount)
Set xSelObj(nCount) = myObj
nCount = nCount + 1

Next

' Listing holes

Dim sList As String
Dim nI As Integer

'Loop for message

For nI = 0 To nCount - 3

Dim referenceX As Reference
Set referenceX = part1.CreateReferenceFromObject(xSelObj(nI))

Next

part1.Update



Dim Excel As Object
Dim Sheets As Object
Dim Sheet As Object


On Error Resume Next
Set Excel = GetObject(, "EXCEL.Application")
If Err.Number <> 0 Then
Err.Clear
Set Excel = CreateObject("EXCEL.Application")
Else
Err.Clear
MsgBox "Please note you have to close Excel", vbCritical
Exit Sub
End If

Excel.Visible = True

Dim workbooks
Dim myworkbook
Dim myworksheet

Set workbooks = Excel.Application.workbooks
Set myworkbook = Excel.workbooks.Add
Set myworksheet = Excel.ActiveWorkbook.Add
Set myworksheet = Excel.Sheets.Add

Excel.Cells(1, 4) = "diametro"
Excel.Cells(1, 5) = "metrica"

Dim iAnzahlGew
selection1.Search "CATPrtSearch.Hole.Threaded=TRUE,all"
iAnzahlGew = selection1.Count

Dim valor As Integer
valor = 0

'sacar metrica y diametro roscas
Dim Hole
For i = 1 To iAnzahlGew
Set Hole = selection1.Item2(i).Value
Excel.Cells(1 + i, 4) = Hole.Diameter.Value ' diametro roscas
Excel.Cells(1 + i, 5) = Hole.HoleThreadDescription.Value ' metrica roscas
valor = valor + 1
Next

If valor > 1 Then
valor = valor - 1
End If

Excel.Cells(3 + valor, 1) = "numero agujeros"
Excel.Cells(3 + valor, 3) = (nCount - 2) - (selection1.Count) 'numero de agujeros

Excel.Cells(2, 1) = "num roscas"
Excel.Cells(2, 3) = selection1.Count ' numero de roscas

'nueva modificacion
Dim iHoleInSelection
iHoleInSelection = True
Dim oPartDoc
Dim OBody
Set oPartDoc = CATIA.ActiveDocument
Set OBody = oPartDoc.Part.Bodies.Item("PartBody")

Set selection1 = oPartDoc.selection
selection1.Search "(Name=PartBody* & CATPrtSearch.BodyFeature),all"

Dim Selection2
Set Selection2 = oPartDoc.selection

Selection2.Search "CATPrtSearch.Hole.Threaded=FALSE,all" '"Type=Hole,sel"

'stream.Write ("Crt_no" & " " & "Hole_Name" & " " & "Hole_Dia" & " " & "Hole_Type" & crlf) 'first line in output file

For i = 1 To Selection2.Count

Dim oHole
Dim oHoleName
Dim oHoleType

Set oHole = Selection2.Item(i).Value
Set oHoleName = Selection2.Item(i).Value
Set oHoleType = Selection2.Item(i).Value

Excel.Cells(2 + valor + i, 4) = CStr(oHole.Diameter.Value)
Excel.Cells(2 + valor + i, 5) = CStr(oHoleName.Name)
'MsgBox CStr(oHoleName.Name) & " " & " " & "Diameter=" & CStr(oHole.Diameter.Value) & " " & "Type=" & CStr(oHole.Type)

'stream.Write (i & " " & oHoleName.Name & " " & oHole.Diameter.Value & " " & oHole.Type & crlf)


Next
End Sub


The only problem is that this script, can´t read in my part a item to copy of a rectangular or circular pattern...
I try write item to copy, but doesn´t work or I can´t write the wrong code.

I hope that this script can help to other person that start with Macros in Catiav5

Thankss.

 

[gerlado]

Anyone can you help me whit this topic?

Thanks