Create and Position Callouts Example (VBA)
This example shows how to create callouts and position them.
Main module
'---------------------------------------------------------
' Preconditions:
' 1)
Part or assembly is open.
' 2)
If an assembly is open, then it must be fully resolved.
' 3)
At least one or more geometric entities are
' selected
in the graphics area.
'
' Postconditions: Entities are reselected. Each entity
has a callout
' attached
to the selection point.
'
' NOTE: Selecting features in FeatureManager design tree
is not currently supported.
'
'---------------------------------------------------------
Option Explicit
Sub main()
Dim
swApp As
SldWorks.SldWorks
Dim
swModel As
SldWorks.ModelDoc2
Dim
swModelExt As
SldWorks.ModelDocExtension
Dim
swSelMgr As
SldWorks.SelectionMgr
Dim
vSelPos() As
Variant
Dim
vNewSelPos As
MathPoint
Dim
swCallout() As
Object
Dim
nSelCount As
Long
Dim
i As
Long
Dim
bRet As
Boolean
Dim
callH As
New callouthandler
Dim
boolstatus As
Boolean
Set
swApp = CreateObject("SldWorks.Application")
Set
swModel = swApp.ActiveDoc
Set
swModelExt = swModel.Extension
Set
swSelMgr = swModel.SelectionManager
nSelCount
= swSelMgr.GetSelectedObjectCount2(-1)
ReDim
vSelPos(nSelCount)
ReDim
swCallout(nSelCount)
For
i = 0 To nSelCount - 1
vSelPos(i)
= swSelMgr.GetSelectionPoint2((i
+ 1), -1)
Next
i
swModel.ClearSelection2 True
For
i = 0 To nSelCount - 1
callH.Init
Nothing
Set
swCallout(i) = swSelMgr.CreateCallout2(4,
callH)
swCallout(i).Label2(1) = "Product"
swCallout(i).Label2(2) = "Radius"
swCallout(i).Label2(3) = "Number"
swCallout(i).Value(0) = "10685"
swCallout(i).Value(1) = "Washer"
swCallout(i).Value(2) = "30"
swCallout(i).Value(3) = "1"
swCallout(i).SetTargetPoint 0, vSelPos(i)(0), vSelPos(i)(1),
vSelPos(i)(2)
swCallout(i).SetTargetPoint 1, vSelPos(i)(0), vSelPos(i)(1),
vSelPos(i)(2)
swCallout(i).SetTargetPoint 2, vSelPos(i)(0), vSelPos(i)(1),
vSelPos(i)(2)
swCallout(i).SetTargetPoint 3, vSelPos(i)(0), vSelPos(i)(1),
vSelPos(i)(2)
swCallout(i).TextColor(0) = swSystemColorsRefTriadX
swCallout(i).TextColor(1) = swSystemColorsRefTriadY
swCallout(i).TextColor(2) = swSystemColorsRefTriadZ
swCallout(i).TextColor(3) = swSystemColorsRefTriadX
swCallout(i).OpaqueColor = swSystemColorsSelectedItem4
swCallout(i).MultipleLeaders = False
bRet
= swModelExt.SelectByID2("",
"", vSelPos(i)(0), vSelPos(i)(1), vSelPos(i)(2), True, 0, swCallout(i),
0)
swCallout(i).ValueInactive(3) = True
Dim
v As Variant
Set
vNewSelPos = swCallout(i).Position
v
= vNewSelPos.ArrayData
swCallout(i).Position = vNewSelPos
Next
i
End
Sub
Class module
Option Explicit
Implements SwCalloutHandler
Dim m_pCallout As SldWorks.Callout
Public Sub Init(clout As SldWorks.Callout)
Set
m_pCallout = clout
End Sub
Private Sub Class_Initialize()
Debug.Print
"Class_Initialize"
End Sub
Private Sub Class_Terminate()
Debug.Print
"Class_Terminate"
End Sub
'******************************************************************************'
'These methods are the implementations of the SolidWorks
notifications
Public Function SwCalloutHandler_OnStringValueChanged(ByVal
pManipulator As Object, ByVal Index As Long, ByVal Text As String) As
Boolean
Debug.Print
Index
Debug.Print
Text
Dim
retval As Boolean
retval
= True
If
Text = "XXXXXX" Then
retval
= False
pManipulator.ValueInactive(Index) = True
pManipulator.Label2(Index) = "Wrong!"
End
If
SwCalloutHandler_OnStringValueChanged
= retval
End Function