Secondary menu

Macro - hacer agujero pasante en un pto seleccionado

6 envios / 0 nuevos
Último envío
goroscar
Desconectado
Posts:
Última visita: 05/25/2009
Macro - hacer agujero pasante en un pto seleccionado

Hola. Estoy tratando de desarrollar/encontrar una macro que permita hacer una agujero (parametrizado) en un punto seleccionado con el ratón. Es un agujero patrón que siempre es de igual dimensiones y lo que busco es evitar que estar siempre colocando las mismas cotas (Ø, longitud....)

Hasta ahora he conseguido que al iniciar la macro, te pida seleccionar el punto donde quieres insertar el agujero pero ya no se como continuar. todos los intentos han sido fracasos. Podeis ayudarme a conseguir esta macro? Muchas gracias

Os dejo el codigo que tengo:

Sub CATMain()

Dim Selection1 As Object
Set Selection1 = CATIA.ActiveDocument.Selection

Dim InPutObjectType(0)
InPutObjectType(0) = "CATPoint"
Status = Selection1.SelectElement2(InPutObjectType, "Select a point", False)

End Sub

 


edu
Desconectado
Posts:
Última visita: 02/10/2008
Re: Macro - hacer agujero pasante en un pto seleccionado

Hola Goroscar

No lo he probado y seguramente falle en algún sitio, pero aqui te dejo el código para lo que buscas.

 

Sub CATMain()

 

Dim partDocument1 As PartDocument

Set partDocument1 = CATIA.ActiveDocument

 

Dim Selection1 As Object

Set Selection1 = CATIA.ActiveDocument.Selection

 

Dim part1 As Part

Set part1 = partDocument1.Part

 

Dim shapeFactory1 As ShapeFactory

Set shapeFactory1 = part1.ShapeFactory

 

Dim bodies1 As Bodies

Set bodies1 = part1.Bodies

 

Dim body1 As Body

Set body1 = bodies1.Item("PartBody")

 

Dim sketches1 As Sketches

Set sketches1 = body1.Sketches

 

Dim sketch1 As Sketch

Set sketch1 = sketches1.Item("Sketch.4")

 

Selection1.Clear

Dim InPutObjectType(0)

InPutObjectType(0) = "CATPoint"

Status = Selection1.SelectElement2(InPutObjectType, "Select a point", False)

 

 

Dim reference1 As Reference

Set reference1 = Selection1.Item(1)

 

Dim shapes1 As Shapes

Set shapes1 = body1.Shapes

 

Dim pad1 As Pad

Set pad1 = shapes1.Item("Pad.1")

 

Selection1.Clear

InPutObjectType(0) = "CATPlane"

Status = Selection1.SelectElement2(InPutObjectType, "Select a plane", False)

 

Dim reference2 As Reference

Set reference2 = Selection1.Item(1)

 

Dim hole1 As Hole

Set hole1 = shapeFactory1.AddNewHoleFromRefPoint(reference1, reference2, 10#)

 

hole1.Type = catSimpleHole

 

hole1.AnchorMode = catExtremPointHoleAnchor

 

hole1.BottomType = catFlatHoleBottom

 

Dim limit1 As Limit

Set limit1 = hole1.BottomLimit

 

limit1.LimitMode = catOffsetLimit

 

Dim length1 As Length

Set length1 = hole1.Diameter

 

length1.Value = 10#

hole1.ThreadingMode = catSmoothHoleThreading

hole1.ThreadSide = catRightThreadSide

part1.Update

End Sub


goroscar
Desconectado
Posts:
Última visita: 05/25/2009
Re: Macro - hacer agujero pasante en un pto seleccionado

Hola Edu. Muchas gracias por tu esfuerzo. me da un error en la linea

 

Set hole1 = shapeFactory1.AddNewHoleFromRefPoint(reference1, reference2, 10#)

 

y como referencia del error pone que esparaba un ")".

 

Alguna idea de como continuar?

 

la petición del punto y del plano lo hace bien.

 

Gracias por tu ayuda


wiliamgava
Desconectado
Posts:
Última visita: 02/29/2016
Re: Macro - hacer agujero pasante en un pto seleccionado

Saludos Amigo:

 

Por lo que entendí, usted necesita esa macro ...

 

Sub CATMain()

Dim sel 'As Selection

Dim Filter(1), iReturn

Dim iPArt As Part

Dim iBody As Body

Dim iPoint As Reference

Dim iHole As Hole

Dim sFact As ShapeFactory

Dim iFace As AnyObject

Dim iObj As AnyObject

Dim r As Long

Dim g As Long

Dim b As Long

 

Set sel = CATIA.ActiveDocument.Selection

Do

Filter(0) = "PlanarFace": Filter(1) = "Plane"

iReturn = sel.SelectElement2(Filter, "seleccione una 'FACE'o un 'PLANE' para hacer los agujeros...presione ESC para salir", False)

If iReturn = "Cancel" Then Exit Do

Set iFace = sel.Item(1).Value

Set iObj = iFace

sel.Clear

'colorear la face seleccionada

GetColor r, g, b, iFace: SetColor iFace, 255, 0, 0

'obtener el body y la part

Do

Set iObj = iObj.Parent

If TypeName(iObj) = "Shape" Or TypeName(iObj) = "Body" Then Set iBody = iObj

Loop Until TypeName(iObj) = "PartDocument"

Set iPArt = iObj.Part

Set sFact = iPArt.ShapeFactory

'obtener el puntos de referencia

Do

Filter(0) = "Point"

iReturn = sel.SelectElement2(Filter, "Seleccione punto...presione ESC para volver a la selección de 'FACE'", False)

If iReturn = "Cancel" Then Exit Do

Set iPoint = sel.Item(1).Value

sel.Clear

'crear agugeros

iPArt.InWorkObject = iBody

Set iHole = sFact.AddNewHoleFromRefPoint(iPoint, iFace, 10)

With iHole

.BottomLimit.LimitMode = catUpThruNextLimit

.Diameter.Value = 9 'diametro del agujero

.Type = catSimpleHole

.ThreadingMode = catSmoothHoleThreading 'no thread

End With

iPArt.Update

HideSkt iHole.Sketch

Loop

Loop

SetColor iFace, r, g, b

End Sub

'*********************************************************

Function GetColor(r As Long, g As Long, b As Long, myObject)

Dim mySel As Selection

Set mySel = CATIA.ActiveDocument.Selection

With mySel

.Add myObject

.VisProperties.GetRealColor r, g, b

.Clear

End With

End Function

'************************************************

Function SetColor(myObject, r, g, b)

Dim mySel As Selection

Set mySel = CATIA.ActiveDocument.Selection

With mySel

.Add myObject

.VisProperties.SetRealColor r, g, b, 1

.Clear

End With

End Function

'*********************************************

Function HideSkt(myObject)

Dim mySel As Selection

Set mySel = CATIA.ActiveDocument.Selection

With mySel

.Add myObject

.VisProperties.SetShow 1

.Clear

End With

End Function

aceda lo site:

http://catiav5macrosbygava.blogspot.com.br/2014/07/otimos-executaveis-para-auxiliar-no.html

 

goroscar
Desconectado
Posts:
Última visita: 05/25/2009
Re: Macro - hacer agujero pasante en un pto seleccionado

Hola wiliamgava

Si, esto era lo que buscaba. Hace exactamente lo que necesito.

Me puedes ayudar a personalizarla? me explico:

* si quiero hacer un agujero roscado M6x16 longitud, que paremetros tendría que colocar?

* si quiero hacer un agujero Ø10 profundidad 15, que paremetros tendría que colocar?

* además de esto, se podría renombrar la operacion en el arbol del part con la designacion del agujero? por ejemplo, si hacemos un agujero roscado de M6 profundidad 15, que la operación quedase nombrada como M6x15.

Muchas gracias por tu ayuda. Vamos muy bien encaminados.

 

 

 


wiliamgava
Desconectado
Posts:
Última visita: 02/29/2016
Re: Macro - hacer agujero pasante en un pto seleccionado

Lo siento por la demora en responder

sigue macro actualizada

si necesitas algo más, puedes contactarme: v5macros@gmail.com

 

Sub CATMain()

 

Dim sel 'As Selection

Dim Filter(1), iReturn

Dim iPArt As part

Dim iBody As Body

Dim iPoint As Reference

Dim iHole As hole

Dim sFact As ShapeFactory

Dim iFace As AnyObject

Dim iObj As AnyObject

Dim r As Long

Dim g As Long

Dim b As Long

Dim HoleThread As Boolean

Dim HoleDiameter As Double

Dim HoleThreadDia As String

Dim HoleDepth As Double

Dim resp As String

 

Set sel = CATIA.ActiveDocument.Selection

Do

 

Filter(0) = "PlanarFace": Filter(1) = "Plane"

 

iReturn = sel.SelectElement2(Filter, "seleccione una 'FACE'o un 'PLANE' para hacer los agujeros...presione ESC para salir", False)

 

If iReturn = "Cancel" Then Exit Do

 

Set iFace = sel.Item(1).Value

 

Set iObj = iFace

 

sel.Clear

 

'colorear la face seleccionada

 

GetColor r, g, b, iFace: SetColor iFace, 255, 0, 0

 

'obtener el body y la part

 

Do

 

Set iObj = iObj.Parent

 

If TypeName(iObj) = "Shape" Or TypeName(iObj) = "Body" Then Set iBody = iObj

 

Loop Until TypeName(iObj) = "PartDocument"

 

Set iPArt = iObj.part

 

Set sFact = iPArt.ShapeFactory

 

'definições dos furos / Hole definitions / definiciones de los agujeros

iReturn = MsgBox("Furo Roscado?" & vbLf & "Threaded Hole?" & vbLf & "Agugero con rosca?", vbYesNo, "Threaded Hole")

Select Case iReturn

Case 6

HoleThread = True

iReturn = "Rosca y profundidad del agujero" & vbLf & "Rosca e profundidade do furo" & vbLf & "Thread and depht of hole"

resp = UCase(InputBox(iReturn, "Hole definitions", "M8x30"))

splitTxt = Split(resp, "X", -1, vbTextCompare)

HoleThreadDia = splitTxt(0)

HoleDepth = splitTxt(1)

Case Else

HoleThread = False

iReturn = "Diametro y profundidad del agujero" & vbLf & "Diametro e profundidade do furo" & vbLf & "Diameter and depht of hole"

resp = UCase(InputBox(iReturn, "Hole definitions", "9x20"))

splitTxt = Split(resp, "X", -1, vbTextCompare)

HoleDiameter = splitTxt(0)

HoleDepth = splitTxt(1)

End Select

'obtener el puntos de referencia

Do

Filter(0) = "Point"

iReturn = sel.SelectElement2(Filter, "Seleccione punto...presione ESC para volver a la selección de 'FACE'", False)

If iReturn = "Cancel" Then Exit Do

Set iPoint = sel.Item(1).Value

sel.Clear

'crear agugeros

iPArt.InWorkObject = iBody

Set iHole = sFact.AddNewHoleFromRefPoint(iPoint, iFace, 10)

Select Case HoleThread

Case True

    With iHole

        .ThreadingMode = catThreadedHoleThreading

        .CreateStandardThreadDesignTable catHoleMetricThickPitch

        .HoleThreadDescription.Value = HoleThreadDia

        .BottomLimit.LimitMode = catOffsetLimit

        .ThreadDepth.Value = HoleDepth

        .BottomLimit.Dimension.Value = HoleDepth + 3

        .Type = catSimpleHole

        .Name = resp

    End With

    SetColor iHole, 0, 255, 0 ' color Green to Threading Hole. Change color editing the rgb

Case False

    With iHole

        .ThreadingMode = catSmoothHoleThreading

        .BottomLimit.LimitMode = catOffsetLimit

        .BottomLimit.Dimension.Value = HoleDepth

        .Type = catSimpleHole

        .Diameter.Value = HoleDiameter

        .Name = "Ø" & resp

    End With

    SetColor iHole, 0, 0, 255 ' color Blue to Hole. Change color editing the rgb

End Select

iPArt.Update

HideSkt iHole.Sketch

Loop

SetColor iFace, r, g, b

Loop

SetColor iFace, r, g, b

End Sub

 

'*********************************************************

 

Function GetColor(r As Long, g As Long, b As Long, myObject)

Dim mySel As Selection

Set mySel = CATIA.ActiveDocument.Selection

With mySel

.Add myObject

.VisProperties.GetRealColor r, g, b

.Clear

End With

End Function

 

'************************************************

 

Function SetColor(myObject, r, g, b)

Dim mySel As Selection

Set mySel = CATIA.ActiveDocument.Selection

With mySel

.Add myObject

.VisProperties.SetRealColor r, g, b, 1

.Clear

End With

End Function

 

'*********************************************

 

Function HideSkt(myObject)

Dim mySel As Selection

Set mySel = CATIA.ActiveDocument.Selection

With mySel

.Add myObject

.VisProperties.SetShow 1

.Clear

End With

End Function


El gran libro de catia
Autor: Eduardo Torrecilla Insagurbe
2ª Edición revisada
Editorial MARCOMBO, S.A.
39.99 € (IVA incluído)


12% de descuento para
usuarios registrados
forum | by Dr. Radut