Code:
Sub catmain()
Dim Doc_1 As Document 'Active Document
Dim Sketch As Sketch 'Sketch
Dim Selection_1 As Selection Dim dblWptInd01(1) As Object ' 'window point coordinates of indicates with
Dim dblWptInd02(1) As Object 'respect to the view coordinate system, but not the 3D-axis
Dim strRet As String
Doc_1 = Catia.ActiveDocument
Selection_1 = Doc_1.Selection
Selection_1.Search("CATSketchSearch.2DAxis_Origin,in")
Sketch = Selection_1.Item(1).Value.Parent.Parent.Parent
Selection_1.Clear()
'---------------------------------------------------------------------------------------------
'get indicates
strRet = GetTwoIndDragBox(Doc_1, Sketch, dblWptInd01, dblWptInd02) 'get indicates
If (strRet = "Cancel") Or (strRet = "Undo") Or (strRet = "Redo") Then 'escape entered
Exit Sub
End If
MsgBox("x1: " & Format(dblWptInd01(0), "####0.000000") & vbCrLf _
& "Y1: " & Format(dblWptInd01(1), "####0.000000") & vbCrLf _
& "X2: " & Format(dblWptInd02(0), "####0.000000") & vbCrLf _
& "y2: " & Format(dblWptInd02(1), "####0.000000"))
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetTwoIndDragBox
' Author : jherzog
' Date : 07.10.2014
' Time : 22:06
' Languages : VB6 Pro
' V5-Release: V5R19/21
' Purpose : Retrieve indicated points from user;
' Parms : oParent: the active doc
' : odrVw: the active view
' : ptStart():first indicate(start point)
' : ptEnd(): second indicate(endpoint)
' Ret. Value: "Normal", "Cancel", "Undo", "Redo" as returned from IndicateOrSelectElement2D
'
' Syntax : strRet = GetTwoIndDragBox(oAD, drVw, dblWptInd01, dblWptInd02)
'
' Prereqs : -
' Remarks : -
'---------------------------------------------------------------------------------------
'
Function GetTwoIndDragBox(iDoc As Document, iSketch As Sketch, ptStart() As Object, ptEnd() As Object) As String
Dim Selection_1 As Selection
Dim Status As String
Dim InputObjectType(0)
Dim bIsDrawn As Boolean
Dim ObjectSelected
' On Error GoTo GetTwoIndDragBox_Error
Selection_1 = iDoc.Selection
'switch to catia
'---------------------------------------------------------------------------------
Status = iDoc.Indicate2D("Click to define the start point!", ptStart) 'get first corner
If (Status = "Cancel") Or (Status = "Undo") Or (Status = "Redo") Then
GetTwoIndDragBox = Status
Exit Function 'quit on escape
End If
'---------------------------------------------------------------------------------
InputObjectType(0) = "Point2D" 'dummy type
Status = "MouseMove"
bIsDrawn = False
'get second point
Status = Selection_1.IndicateOrSelectElement2D("Click to locate the second point!",
InputObjectType, False, False, True, ObjectSelected, ptEnd)
Do While (Status = "MouseMove") 'rubber band!
DrawRect(iSketch, ptStart, ptEnd, 6, 1, 128, 0, 255)
bIsDrawn = True
Status = Selection_1.IndicateOrSelectElement2D("Click to locate the endpoint!",
InputObjectType, False, False, True, ObjectSelected, ptEnd)
' GoTo CleanUp
Loop
If (Status = "Cancel") Or (Status = "Undo") Or (Status = "Redo") Then 'escape entered
MsgBox("Canceled by user!", vbInformation Or vbOKOnly, "GetTwoIndDragBox")
GetTwoIndDragBox = Status
GoTo CleanUp
Exit Function
End If
GetTwoIndDragBox = Status
Exit Function
'---------------------------------------------------------------------------------------
CleanUp:
If bIsDrawn = True Then
Selection_1.Search("Name=TEMPRECT_*,all")
If Selection_1.Count > 0 Then Selection_1.Delete()
Selection_1.Clear()
End If
' Return
'---------------------------------------------------------------------------------------
GetTwoIndDragBox_Error:
Dim errMsg As String
Dim errRet As Object
Select Case Err.Number
Case 5 'Invalid procedure call or argument
'happens if catia window is minimized
Case -2147467259 'method delete failed
Case Else
errMsg = Err.Number & ": " & Err.Description & " in GetTwoIndDragBox"
errRet = MsgBox(errMsg, vbOKOnly, "GetTwoIndDragBox")
End Select
'Resume Next 'fall thru to quit sub
'---------------------------------------------------------------------------------------
End Function
'---------------------------------------------------------------------------------------
' Procedure : DrawRect
' Author : jherzog
' Date : 07.10.2014
' Time : 22:06
' Languages : VB6 Pro
' V5-Release: V5R19/21
' Purpose : Draw system parallel rubber band box between to points
' Parms : strView: Name of view to draw to
' : dPStart():Start point variant array (0) = x, (1) = y;
' : dPEnd(): End point
' : iLnType(optional): Line type, as specified acc. to catia standards
' : iLnThck(optional): Line thickness
' : iLnColx(optional): RGB-color values
' Ret. Value: -
'
' Syntax : DrawRect odrVw.Name, ptStart, ptEnd, 6, 1, 128, 0, 255
' : (Dot-Dashed, 0.13, light purple)
' Prereqs : -
' Remarks : Only for system parallel views(0°, 90°, 180°, 270°)
'---------------------------------------------------------------------------------------
'
Sub DrawRect(iSketch As Sketch, dPStart() As Object, dPEnd() As Object, Optional iLnType As Integer = Nothing, Optional iLnThck As Integer = Nothing, Optional iLnColR As Integer = Nothing, Optional iLnColG As Integer = Nothing, Optional iLnColB As Integer = Nothing)
Dim Doc_1 As Object 'DrawingDocument
Dim odrVw As DrawingView
Dim Factory2D As Factory2D
Dim lnRect(3) ' As Line2D
Dim Selection_1 As Selection
Dim visProps As VisPropertySet
Doc_1 = Catia.ActiveDocument
Selection_1 = Doc_1.Selection
Factory2D = iSketch.OpenEdition()
lnRect(0) = Factory2D.CreateLine(dPStart(0), dPStart(1), dPEnd(0), dPStart(1))
lnRect(1) = Factory2D.CreateLine(dPEnd(0), dPStart(1), dPEnd(0), dPEnd(1))
lnRect(2) = Factory2D.CreateLine(dPEnd(0), dPEnd(1), dPStart(0), dPEnd(1))
lnRect(3) = Factory2D.CreateLine(dPStart(0), dPEnd(1), dPStart(0), dPStart(1))
lnRect(0).Name = "TEMPRECT_" & lnRect(0).Name
lnRect(1).Name = "TEMPRECT_" & lnRect(1).Name
lnRect(2).Name = "TEMPRECT_" & lnRect(2).Name
lnRect(3).Name = "TEMPRECT_" & lnRect(3).Name
visProps = Selection_1.VisProperties
Selection_1.Search("Name=TEMPRECT_*,all")
If Selection_1.Count2 > 0 Then
If Not iLnColR = Nothing And Not iLnColG = Nothing And Not iLnColB = Nothing Then
visProps.SetRealColor(iLnColR, iLnColG, iLnColB, 0)
End If
If Not iLnType = Nothing Then visProps.SetRealLineType(iLnType, 0)
If Not iLnThck = Nothing Then visProps.SetRealWidth(iLnThck, 0)
Selection_1.Clear()
End If
End Sub
Foren auf CAD.de (alle Foren)
| 
