Secondary menu

Macro - hacer agujero pasante en un pto seleccionado

9 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


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

Hola wiliamgav

Muchas gracias por la evolución de la macro. Funciona muy bien. Podrías explicarme por qué a la hora de seleccionar el punto donde hacer el agujero, sólo reconoce los puntos 3D que estén definidos y no los puntos que haya dibujados en un sketch?

Además de esto, cómo tendría que hacer para quitar la repetición de la operación? es decir, lo que quiero es que al ejecutar la macro sólo me haga un agujero en el punto seleccionado (preferiblemente un punto de un sketch)

ya queda poco para poder cerrarlo por completo.

 

 


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

Lo siento por la demora en responder. que es dificil, jajaja!!!!!

basta con crear una sktech con el punto seleccionado, y crear el agujero de una sktech

 

En el siguiente código se resalta lo que ha cambiado

y se ha eliminado el loop, sólo se ejecuta una vez

 

 

Sub CATMain()

 

Dim sel 'As Selection

Dim Filter(1), iReturn

Dim iPart As Part

Dim iBody As Body

Dim iPoint As AnyObject

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

Dim skt As Sketch

Set sel = CATIA.ActiveDocument.Selection

 

 

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 Sub

 

 

 

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

 

 

 

Filter(0) = "Vertex"

 

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

 

If iReturn = "Cancel" Then Exit Sub

 

Set iPoint = sel.Item(1).Value

 

sel.Clear

 

Set skt = iBody.Sketches.Add(iFace)

skt.OpenEdition

skt.Constraints.AddBiEltCst catCstTypeOn, skt.Factory2D.CreateProjection(iPoint), skt.Factory2D.CreatePoint(0, 0)

skt.CloseEdition

 

'crear agugeros

iPart.InWorkObject = iBody

iPart.Update

Set iHole = sFact.AddNewHoleFromSketch(skt, 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

 

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

 

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

en algunas versiones del catia, ciertas logicas, generan errores.

A continuación se muestra una lógica que funcionó en la versión R19.

 

Sub CATMain()
 
Dim sel 'As Selection
Dim Filter(1), iReturn
Dim iPart As Part
Dim iBody As Body
Dim iPoint As AnyObject
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
Dim skt As Sketch
Dim Ref1, Ref2 As Reference
 
Set sel = CATIA.ActiveDocument.Selection
 
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 Sub
 
Set iFace = sel.Item(1).Value
Set iObj = iFace
sel.Clear
 
 
'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
Filter(0) = "Vertex"
iReturn = sel.SelectElement2(Filter, "Seleccione punto...presione ESC para volver a la selección de 'FACE'", False)
If iReturn = "Cancel" Then Exit Sub
Set iPoint = sel.Item(1).Value
sel.Clear
Set skt = iBody.Sketches.Add(iFace)
 
skt.OpenEdition
Set Ref1 = iPart.CreateReferenceFromObject(skt.Factory2D.CreateProjection(iPoint))
Set Ref2 = iPart.CreateReferenceFromObject(skt.Factory2D.CreatePoint(0, 0))
skt.Constraints.AddBiEltCst 2, Ref1, Ref2
 
skt.CloseEdition
 
'crear agugeros
iPart.InWorkObject = iBody
iPart.Update
Set iHole = sFact.AddNewHoleFromSketch(skt, 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  
Case False
    With iHole
        .ThreadingMode = catSmoothHoleThreading
        .BottomLimit.LimitMode = catOffsetLimit
        .BottomLimit.Dimension.Value = HoleDepth
        .Type = catSimpleHole
        .Diameter.Value = HoleDiameter
        .Name = "Ø" & resp
    End With   
End Select
iPart.Update
HideSkt iHole.Sketch
End Sub

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