Eine kleine Demo zu 'Rubber banding'; mit der Maus ein Rechteck aufziehen.
Das Ergebnis sieht so aus:
Folgenden Code in ein VBA-Modul koperen oder hier herunter laden und importieren.
Hinweis: Es muss eine Zeichnung offen sein.
Option Explicit
Sub catmain()
Dim oAD As Object 'Active Document
Dim drVw As Object 'DrawingView
Dim dblWptInd01(1) ' As Double; 'window point coordinates of indicates with
Dim dblWptInd02(1) ' As Double 'respect to the view coordinate system, but not the 3D-axis
Dim strRet As String
Set oAD = CATIA.ActiveDocument
Set drVw = CATIA.ActiveDocument.Sheets.ActiveSheet.Views.Item(1) 'main view
'---------------------------------------------------------------------------------------------
'get indicates
strRet = GetTwoIndDragBox(oAD, drVw, 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(oParent As Object, odrVw As Object, ptStart(), ptEnd()) As String
Dim oSel
Dim Status As String
Dim InputObjectType(0)
Dim bIsDrawn As Boolean
Dim ObjectSelected
On Error GoTo GetTwoIndDragBox_Error
Set oSel = oParent.Selection
AppActivate "CATIA", False 'switch to catia
'---------------------------------------------------------------------------------
Status = oParent.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 = oSel.IndicateOrSelectElement2D("Click to locate the second point!", _
InputObjectType, False, False, True, ObjectSelected, ptEnd)
Do While (Status = "MouseMove") 'rubber band!
DrawRect odrVw.Name, ptStart, ptEnd, 6, 1, 128, 0, 255
bIsDrawn = True
Status = oSel.IndicateOrSelectElement2D("Click to locate the endpoint!", _
InputObjectType, False, False, True, ObjectSelected, ptEnd)
GoSub CleanUp
Loop
If (Status = "Cancel") Or (Status = "Undo") Or (Status = "Redo") Then 'escape entered
MsgBox "Canceled by user!", vbInformation Or vbOKOnly, "GetTwoIndDragBox"
GetTwoIndDragBox = Status
GoSub CleanUp
Exit Function
End If
GetTwoIndDragBox = Status
Exit Function
'---------------------------------------------------------------------------------------
CleanUp:
If bIsDrawn = True Then
oSel.Search "Name=TEMPRECT_*,all"
If oSel.Count > 0 Then oSel.Delete
oSel.Clear
End If
Return
'---------------------------------------------------------------------------------------
GetTwoIndDragBox_Error:
Dim errMsg As String
Dim errRet As VbMsgBoxResult
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(strView As String, dPStart(), dPEnd(), _
Optional iLnType As Integer, _
Optional iLnThck As Integer, _
Optional iLnColR As Integer = -1, _
Optional iLnColG As Integer = -1, _
Optional iLnColB As Integer = -1)
Dim oAD As Object 'DrawingDocument
Dim odrVw As DrawingView
Dim oF2D As Factory2D
Dim lnRect(3) ' As Line2D
Dim oSel As Selection
Dim visProps As VisPropertySet
Set oAD = CATIA.ActiveDocument
Set odrVw = oAD.Sheets.ActiveSheet.Views.Item(strView)
odrVw.Activate
Set oF2D = odrVw.Factory2D
Set oSel = CATIA.ActiveDocument.Selection
Set lnRect(0) = oF2D.CreateLine(dPStart(0), dPStart(1), dPEnd(0), dPStart(1))
Set lnRect(1) = oF2D.CreateLine(dPEnd(0), dPStart(1), dPEnd(0), dPEnd(1))
Set lnRect(2) = oF2D.CreateLine(dPEnd(0), dPEnd(1), dPStart(0), dPEnd(1))
Set lnRect(3) = oF2D.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
Set visProps = oSel.VisProperties
oSel.Search "Name=TEMPRECT_*,all"
If oSel.Count2 > 0 Then
If Not IsMissing(iLnColR) And Not IsMissing(iLnColG) And Not IsMissing(iLnColB) Then
visProps.SetRealColor iLnColR, iLnColG, iLnColB, 0
End If
If Not IsMissing(iLnType) Then visProps.SetRealLineType iLnType, 0
If Not IsMissing(iLnThck) Then visProps.SetRealWidth iLnThck, 0
oSel.Clear
End If
End Sub