Tweet
Code:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Connector.bas by Jordi Vallès version 1a 31/05/2008
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Sometimes, on application with graphic elements, is necessary include arrows
' to mark or indicate distances, flows, directions, links, trends, etc. but not
' always arrows can be a rigth line. To solve this problem the connectors shown
' here can help.
'
' This program is a continuation or complement of my previous post:
' [URL="http://www.powerbasic.com/support/pbforums/showthread.php?t=37391"]Arrows with PB Graphics[/URL]
'
' - Arrows, after created, can be resized, reoriented and dragged using left
' mouse button over each end (or near) of selected arrow.
' - Middle segment of straight arrow can be dragged to adjust the adequate place,
' orientation and arrow shape.
' (This behaviour try to be similar offered to in some Microsoft Office products
' for their straight connector autoshapes)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' - Program developed and tested with PowerBASIC for Windows (PB/Win 8.04) on a
' PC HP Pavilion m7760 1.80 GHz with Windows Vista Home Premium.
' - Only PB Graphic package is used to display information generated by program.
' - Part of code is borrowed from PwrPaint.bas on PB for Windows in Samples folder.
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' SED_PBWIN
#Compile Exe "Connector.exe"
#Dim All
#Include "Win32Api.inc"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%ID_CONN1 = 1001
%ID_CONN2 = 1002
%ID_CONN3 = 1003
%ID_CONN4 = 1004
%ID_CONN5 = 1005
%ID_CONN6 = 1006
%ID_CONN7 = 1007
%ID_GRAPHIC = 1111
%ID_POSIT = 1112
%ID_CLEAR = 1113
%ID_EXIT = 1114
%ID_FRAME = 1115
%ID_CONNTXT = 1116
%ID_MODETXT = 1117
%ID_CBOX2 = 1121
%ID_CBOX3 = 1131
%CANVAS = &hEEFAFA??? 'RGB(250,250,238)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Macro Pi = 3.141592653589793#
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Type POLYARRAY
cnt As Long
xx1 As Single : yy1 As Single
xx2 As Single : yy2 As Single
xx3 As Single : yy3 As Single
xx4 As Single : yy4 As Single
End Type
Type ARROWSTORE
atype As Long 'arrow or connector type
awidth As Long 'graphic pen width
astyle As Long 'graphic style
aform As Long 'orientation 1 = N-S, 2 = W-E
adrag As Long 'drag indicator, 0 = no dragged
arX1 As Double : arY1 As Double 'segment points
arX2 As Double : arY2 As Double
arX3 As Double : arY3 As Double
arX4 As Double : arY4 As Double
ajdX As Double : ajdY As Double 'distance of Xs and Ys
End Type
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Global oldGraphicProc As Dword
Global X1, Y1, X2, Y2 As Double
Global oldX1, oldY1 As Double
Global oldX2, oldY2 As Double
Global j2X, j2Y, j3X, j3Y As Double
Global jdX, jdY, jft As Double
Global contype, savetype As Long
Global conwidth, savewidth As Long
Global constyle, savestyle As Long
Global cntconn, curconn As Long
Global candraw, canresize As Long
Global candrag, newconn As Long
Global conn() As ARROWSTORE
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Declare Function PointToPointDistance(px1 As Double, py1 As Double, px2 As Double, py2 As Double) As Double
Declare Function PointToLineDistance(mx As Double, my as Double, x1 As Double, y1 As Double, _
x2 As Double, y2 As Double) As Double
Declare Function TestPointInLine(mx As Double, my as Double, x1 As Double, y1 As Double, _
x2 As Double, y2 As Double, linew As Long) As Long
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function PBMain () As Long
Local hDlg As Dword
Local w, h As Long
Dialog New Pixels, 0, "Connectors with PB Graphics - 1a", , , 556, 414, _
%WS_CAPTION Or %WS_SYSMENU, 0 To hDlg
Control Add Graphic, hDlg, %ID_GRAPHIC,"", 5, 5, 404, 404, %WS_BORDER Or %SS_NOTIFY
Graphic Attach hDlg, %ID_GRAPHIC, ReDraw
Control Get Client hDlg, %ID_GRAPHIC To w, h 'get client size
Graphic Scale (0, 0) - (w, h) 'scale to pixel coordinate system
Graphic Color %BLUE, %CANVAS 'canvas colors
Control Add Button, hDlg, %ID_CLEAR, "Clear", 416, 387, 66, 22
Control Add Button, hDlg, %ID_EXIT, "Quit", 484, 387, 66, 22
Control Add Label, hDlg, %ID_CONNTXT, "Num : 0", 446, 328, 120, 14
Control Add Label, hDlg, %ID_MODETXT, "Mode : draw ", 446, 344, 120, 14
Control Add Label, hDlg, %ID_POSIT, "Pos : ", 446, 360, 100, 14
Control Add Frame, hDlg, %ID_FRAME, "Connector Styles", 416, 5, 135, 316
Control Add Option, hDlg, %ID_CONN1, "Line", 422, 24, 126, 16, %WS_GROUP
Control Add Option, hDlg, %ID_CONN2, "Simple", 422, 40, 126, 16
Control Add Option, hDlg, %ID_CONN3, "Double", 422, 56, 126, 16
Control Add Option, hDlg, %ID_CONN4, "Aggregation arrow", 422, 72, 126, 16
Control Add Option, hDlg, %ID_CONN5, "Composition arrow", 422, 88, 126, 16
Control Add Option, hDlg, %ID_CONN6, "Generalization arrow", 422, 104, 120, 16
Control Add Option, hDlg, %ID_CONN7, "Interface connector", 422, 120, 120, 16
Control Set Option hDlg, %ID_CONN1, %ID_CONN1, %ID_CONN7
Control Add ComboBox, hDlg, %ID_CBOX2,, 420, 268, 126, 225, %CBS_DROPDOWNLIST Or %WS_TABSTOP
ComboBox Add hDlg, %ID_CBOX2, "Pen width = 1"
ComboBox Add hDlg, %ID_CBOX2, "Pen width = 2"
ComboBox Add hDlg, %ID_CBOX2, "Pen width = 3"
ComboBox Add hDlg, %ID_CBOX2, "Pen width = 4"
ComboBox Add hDlg, %ID_CBOX2, "Pen width = 5"
ComboBox Select hDlg, %ID_CBOX2, 1
Control Add ComboBox, hDlg, %ID_CBOX3,, 420, 294, 126, 125, %CBS_DROPDOWNLIST Or %WS_TABSTOP
ComboBox Add hDlg, %ID_CBOX3, "Pen type = Solid"
ComboBox Add hDlg, %ID_CBOX3, "Pen type = Dash"
ComboBox Add hDlg, %ID_CBOX3, "Pen type = Dot"
ComboBox Add hDlg, %ID_CBOX3, "Pen type = DashDot"
ComboBox Add hDlg, %ID_CBOX3, "Pen type = DashDotDot"
ComboBox Select hDlg, %ID_CBOX3, 1
Dialog Show Modal hDlg Call DialogProc
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
CallBack Function DialogProc() As Long
Local hGraphic As Dword
Select Case As Long CbMsg
Case %WM_INITDIALOG
Control Handle CbHndl, %ID_GRAPHIC To hGraphic
oldGraphicProc = SetWindowLong(hGraphic, %GWL_WNDPROC, CodePtr(GraphicProc))
contype = 1 : conwidth = 1 : constyle = 0
savetype = 1 : savewidth = 1 : savestyle = 0
Call CanvasCleaner(CbHndl, %TRUE, %TRUE)
Case %WM_SETCURSOR
If CbWParam <> hGraphic Then Control Set Text CbHndl, %ID_POSIT, "Pos :"
Case %WM_COMMAND
Select Case CbCtl
Case %ID_CONN1 To %ID_CONN7 'connector type
contype = CbCtl - 1000
savetype = contype
Case %ID_CBOX2 'pen width
If CbCtlMsg = %CBN_SELENDOK Then
Control Send CbHndl, %ID_CBOX2, %CB_GETCURSEL, 0, 0 To conwidth
conwidth = Max(1, conwidth +1)
savewidth = conwidth
If conwidth = 1 Then Control Enable CbHndl, %ID_CBOX3 _
Else Control Disable CbHndl, %ID_CBOX3
End If
Case %ID_CBOX3 'pen type
If CbCtlMsg = %CBN_SELENDOK Then
Control Send CbHndl, %ID_CBOX3, %CB_GETCURSEL, 0, 0 To constyle
savestyle = constyle
End If
Case %ID_EXIT
If CbCtlMsg = %BN_CLICKED Then Dialog End CbHndl
Case %ID_CLEAR
If CbCtlMsg = %BN_CLICKED Then Call CanvasCleaner(CbHndl, %TRUE, %TRUE)
End Select
Case %WM_DESTROY
If oldGraphicProc Then SetWindowLong hGraphic, %GWL_WNDPROC, oldGraphicProc
End Select
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Subclass procedure
Function GraphicProc(ByVal hWnd As Dword, ByVal wMsg As Long, ByVal wParam As Dword, ByVal lParam As Long) As Long
Select Case wMsg
Case %WM_MOUSEMOVE : Call MouseMove (hWnd, wParam, lParam)
Case %WM_LBUTTONDOWN : Call LeftButtonDown (hWnd, wParam, lParam)
Case %WM_LBUTTONUP : Call LeftButtonUp (hWnd, wParam, lParam)
End Select
Function = CallWindowProc(oldGraphicProc, hWnd, wMsg, wParam, lParam)
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub MouseMove(ByVal hWnd As Dword, ByVal wParam As Dword, ByVal lParam As Long)
Local i, j As Long
Local pt As POINTAPI
Local dX, dY, d1, d2 As Double
X2 = Lo(Integer, lParam) : Y2 = Hi(Integer, lParam)
Control Set Text GetParent(hWnd), %ID_POSIT, "Pos : " + Str$(X2) + "," + Str$(Y2)
If canresize And (wParam And %MK_LBUTTON) Then 'if in resize sate then.....
Call CanvasCleaner(hWnd, %FALSE, %FALSE)
GetCursorPos pt
ScreenToClient hWnd, pt
dX = pt.x : dY = pt.y 'convert to double
d1 = PointToPointDistance(dX, dY, conn(curconn).arX1, conn(curconn).arY1)
d2 = PointToPointDistance(dX, dY, conn(curconn).arX4, conn(curconn).arY4)
If d1 < d2 Then 'check wich end is more near to mouse pointer
conn(curconn).arX1 = dX
conn(curconn).arY1 = dY
Else
conn(curconn).arX4 = dX
conn(curconn).arY4 = dY
End If
For i = 1 to cntconn 'redraw all conns
conwidth = conn(i).awidth
contype = conn(i).atype
constyle = conn(i).astyle
If i <> curconn Then j = i Else j = 0
Call DrawConnectors(conn(i).arX1, conn(i).arY1, conn(i).arX4, conn(i).arY4, j)
If j = 0 Then conn(i).aform = jft
conn(i).arX2 = j2X : conn(i).arY2 = j2Y
conn(i).arX3 = j3X : conn(i).arY3 = j3Y
Next i
ElseIf candrag And (wParam And %MK_LBUTTON) Then 'if in drag state then....
Call CanvasCleaner(hWnd, %FALSE, %FALSE)
Call MoveMiddleSegment(X2, Y2, candrag)
For i = 1 to cntconn 'redraw all conns
If candrag <> i Then
conwidth = conn(i).awidth
contype = conn(i).atype
constyle = conn(i).astyle
Call DrawConnectors(conn(i).arX1, conn(i).arY1, conn(i).arX4, conn(i).arY4, i)
End If
Next
ElseIf candraw And (wParam And %MK_LBUTTON) Then 'if in draw state then....
If oldX1 > -1 Then Call DrawConnectors(oldX1, oldY1, oldX2, oldY2, 0)
Call DrawConnectors(X1, Y1, X2, Y2, 0)
oldX1 = X1 : oldY1 = Y1
oldX2 = X2 : oldY2 = Y2
End If
Graphic ReDraw
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub LeftButtonDown(ByVal hWnd As Dword, ByVal wParam As Dword, ByVal lParam As Long)
Local i As Long
SetCapture hWnd
SetFocus hWnd
Graphic Attach GetParent(hWnd), %ID_GRAPHIC, ReDraw
X1 = Max(0, Lo(Integer, lParam)) : Y1 = Max(0, Hi(Integer, lParam))
Control Set Text GetParent(hWnd), %ID_CONNTXT, "Num : " + Str$(cntconn)
If cntconn > 0 Then
curconn = 0
For i = 1 To cntconn
If TestPointInLine(X1, Y1, conn(i).arX2, conn(i).arY2, conn(i).arX3, conn(i).arY3, conn(i).awidth) Then
candrag = i 'set in dragging state
Control Set Text GetParent(hWnd), %ID_MODETXT, "Mode : dragging" + Str$(i)
Exit Sub
ElseIf (PointToPointDistance(X1, Y1, conn(i).arX1, conn(i).arY1) <= 6.0) Or _
(PointToPointDistance(X1, Y1, conn(i).arX4, conn(i).arY4) <= 6.0) Then
canresize = i 'set in resize state
curconn = i
Control Set Text GetParent(hWnd), %ID_MODETXT, "Mode : resizing" + Str$(i)
Exit Sub
End If
Next i
End If
constyle = savestyle
conwidth = savewidth
contype = savetype
oldX1 = X1 : oldY1 = Y1
oldX2 = X1 : oldY2 = Y1
Graphic Set Mix %R2_NOTXORPEN
Call DrawConnectors(X1, Y1, X1, Y1, 0)
Graphic ReDraw
candraw = 1 'set in creation state
Control Set Text GetParent(hWnd), %ID_MODETXT, "Mode : draw"
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub LeftButtonUp(ByVal hWnd As Dword, ByVal wParam As Dword, ByVal lParam As Long)
If canresize Then 'finish mouse resizing state
Graphic Set Mix %R2_COPYPEN
Call DrawConnectors(oldX1, oldY1, oldX2, oldY2, canresize)
canresize = 0
Graphic ReDraw
oldX1 = -1 : oldY1 = 0
oldX2 = 0 : oldY2 = 0
ElseIf candrag Then 'finish conn dragging state
candrag = 0
ElseIf candraw Then 'finish conn creation state
candraw = 0
Graphic Set Mix %R2_COPYPEN
Call DrawConnectors(oldX1, oldY1, oldX2, oldY2, 0)
Graphic ReDraw
If newconn Then
Incr cntconn 'store conn info on conn array
Redim Preserve conn(1 To cntconn)
conn(cntconn).atype = contype
conn(cntconn).awidth = conwidth
conn(cntconn).astyle = constyle
conn(cntconn).aform = jft 'orientation
conn(cntconn).arX1 = oldX1
conn(cntconn).arY1 = oldY1
conn(cntconn).arX2 = j2X
conn(cntconn).arY2 = j2Y
conn(cntconn).arX3 = j3X
conn(cntconn).arY3 = j3Y
conn(cntconn).arX4 = oldX2
conn(cntconn).arY4 = oldY2
conn(cntconn).ajdX = jdX
conn(cntconn).ajdY = jdY
oldX1 = -1 : oldY1 = 0
oldX2 = 0 : oldY2 = 0
End If
End If
ReleaseCapture
Control Set Text GetParent(hWnd), %ID_MODETXT, "Mode : draw"
Control Set Text GetParent(hWnd), %ID_CONNTXT, "Num : " + Str$(cntconn)
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub MoveMiddleSegment(mX As Double, mY As Double, nc As Long)
'--- to be improved with same PowerPoint behaviour ---
newconn = %FALSE
contype = conn(nc).atype
conwidth = conn(nc).awidth
constyle = conn(nc).astyle
Graphic Width conwidth
Graphic Style constyle
Select Case conn(nc).aform 'middle segment orientation
Case 1 'is N-S or S-N
If conn(nc).arX1 < conn(nc).arX4 Then
If mX < conn(nc).arX1+10 Then mX = conn(nc).arX1+10
If mX > conn(nc).arX4-10 Then mX = conn(nc).arX4-10
Else
If mX > conn(nc).arX1-10 Then mX = conn(nc).arX1-10
If mX < conn(nc).arX4+10 Then mX = conn(nc).arX4+10
End If
Graphic Line (conn(nc).arX1, conn(nc).arY1) - (mX, conn(nc).arY2)
Graphic Line - (mX, conn(nc).arY3)
Graphic Line - (conn(nc).arX4, conn(nc).arY4)
conn(nc).arX2 = mX
conn(nc).arX3 = mX
Case 2 'is E-W or W-E
If conn(nc).arY1 < conn(nc).arY4 Then
If mY < conn(nc).arY1+10 Then mY = conn(nc).arY1+10
If mY > conn(nc).arY4-10 Then mY = conn(nc).arY4-10
Else
If mY > conn(nc).arY1-10 Then mY = conn(nc).arY1-10
If mY < conn(nc).arY4+10 Then mY = conn(nc).arY4+10
End If
Graphic Line (conn(nc).arX1, conn(nc).arY1) - (conn(nc).arX2, mY)
Graphic Line - (conn(nc).arX3, mY)
Graphic Line - (conn(nc).arX4, conn(nc).arY4)
conn(nc).arY2 = mY
conn(nc).arY3 = mY
End Select
conn(nc).adrag = %TRUE
conn(nc).ajdX = conn(nc).arX4-conn(nc).arX1
conn(nc).ajdY = conn(nc).arY4-conn(nc).arY1
Call DrawShapes(conn(nc).arX1, conn(nc).arY1, conn(nc).arX4, conn(nc).arY4, conn(nc).ajdX, conn(nc).ajdY)
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub DrawConnectors(frX As Double, frY As Double, toX As Double, toY As Double, nc As Long)
'--- this procedure can be quite optimized, in size and speed ---
'--- here is "as is" in benefit of clarity in code ---
newconn = %FALSE
If PointToPointDistance(frX, frY, toX, toY) <= 20 Then Exit Sub
If not nc Then newconn = %TRUE
'--- common part for all styles
Graphic Width conwidth
Graphic Style constyle
If nc Then
Graphic Line (conn(nc).arX1, conn(nc).arY1) - (conn(nc).arX2, conn(nc).arY2)
Graphic Line - (conn(nc).arX3, conn(nc).arY3)
Graphic Line - (conn(nc).arX4, conn(nc).arY4)
j2X = conn(nc).arX2 : j2Y = conn(nc).arY2
j3X = conn(nc).arX3 : j3Y = conn(nc).arY3
conn(nc).ajdX = conn(nc).arX4-conn(nc).arX1
conn(nc).ajdY = conn(nc).arY4-conn(nc).arY1
If Abs(conn(nc).ajdX) > Abs(conn(nc).ajdY) Then conn(nc).aform = 1 Else conn(nc).aform = 2 'orientation
Call DrawShapes(conn(nc).arX1, conn(nc).arY1, conn(nc).arX4, conn(nc).arY4, conn(nc).ajdX, conn(nc).ajdY)
Else
jdX = toX-frX : jdY = toY-frY
If Abs(jdX) > Abs(jdY) Then
Graphic Line (frX, frY) - (frX+jdX/2, frY)
Graphic Line - (frX+jdX/2, toY)
Graphic Line - (toX, toY)
j2X = frX+jdX/2 : j2Y = frY
j3X = frX+jdX/2 : j3Y = toY
jft = 1 'orientation N-S
Else
Graphic Line (frX, frY) - (frX, frY+jdY/2)
Graphic Line - (toX, frY+jdY/2)
Graphic Line - (toX, toY)
j2X = frX : j2Y = frY+jdY/2
j3X = toX : j3Y = frY+jdY/2
jft = 2
End If 'orientation W-E
Call DrawShapes(frX, frY, toX, toY, jdX, jdY)
End If
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub DrawShapes(frX As Double, frY As Double, toX As Double, toY As Double, jiX As Double, jiY As Double)
'--- this procedure can be quite optimized, in size and speed ---
'--- here is "as is" in benefit of clarity in code ---
Local poly1, poly2 As POLYARRAY
Graphic Style 0
Select Case As Long contype
Case 1 '--- line simple --- nothing to do for this type
Case 2 '--- one end arrow --- one polygon
poly1.cnt = 3
poly1.xx1 = toX : poly1.yy1 = toY
If Abs(jiX) > Abs(jiY) Then
If jiX > jiY Then
poly1.xx2 = toX-10 : poly1.yy2 = toY-4
poly1.xx3 = toX-10 : poly1.yy3 = toY+4
Else
poly1.xx2 = toX+10 : poly1.yy2 = toY-4
poly1.xx3 = toX+10 : poly1.yy3 = toY+4
End If
Else
If jiX < jiY Then
poly1.xx2 = toX-4 : poly1.yy2 = toY-10
poly1.xx3 = toX+4 : poly1.yy3 = toY-10
Else
poly1.xx2 = toX-4 : poly1.yy2 = toY+10
poly1.xx3 = toX+4 : poly1.yy3 = toY+10
End If
End If
Graphic Polygon poly1, %BLUE, %BLUE
Case 3 '--- two ends arrow --- two polygons
poly1.cnt = 3 : poly2.cnt = 3
poly1.xx1 = toX : poly1.yy1 = toY
poly2.xx1 = frX : poly2.yy1 = frY
If Abs(jiX) > Abs(jiY) Then
If jiX > jiY Then
poly1.xx2 = toX-10 : poly1.yy2 = toY-4
poly1.xx3 = toX-10 : poly1.yy3 = toY+4
poly2.xx2 = frX+10 : poly2.yy2 = frY-4
poly2.xx3 = frX+10 : poly2.yy3 = frY+4
Else
poly1.xx2 = toX+10 : poly1.yy2 = toY-4
poly1.xx3 = toX+10 : poly1.yy3 = toY+4
poly2.xx2 = frX-10 : poly2.yy2 = frY-4
poly2.xx3 = frX-10 : poly2.yy3 = frY+4
End If
Else
If jiX < jiY Then
poly1.xx2 = toX-4 : poly1.yy2 = toY-10
poly1.xx3 = toX+4 : poly1.yy3 = toY-10
poly2.xx2 = frX-4 : poly2.yy2 = frY+10
poly2.xx3 = frX+4 : poly2.yy3 = frY+10
Else
poly1.xx2 = toX-4 : poly1.yy2 = toY+10
poly1.xx3 = toX+4 : poly1.yy3 = toY+10
poly2.xx2 = frX-4 : poly2.yy2 = frY-10
poly2.xx3 = frX+4 : poly2.yy3 = frY-10
End If
End If
Graphic Polygon poly1, %BLUE, %BLUE
Graphic Polygon poly2, %BLUE, %BLUE
Case 4, 5 '--- UML arrows --- two polygons
poly1.cnt = 3 : poly2.cnt = 4
poly1.xx1 = toX : poly1.yy1 = toY
poly2.xx1 = frX : poly2.yy1 = frY
If Abs(jiX) > Abs(jiY) Then
If jiX > jiY Then
poly1.xx2 = toX-10 : poly1.yy2 = toY-4
poly1.xx3 = toX-10 : poly1.yy3 = toY+4
poly2.xx2 = frX+10 : poly2.yy2 = frY-4
poly2.xx3 = frX+20 : poly2.yy3 = frY
poly2.xx4 = frX+10 : poly2.yy4 = frY+4
Else
poly1.xx2 = toX+10 : poly1.yy2 = toY-4
poly1.xx3 = toX+10 : poly1.yy3 = toY+4
poly2.xx2 = frX-10 : poly2.yy2 = frY-4
poly2.xx3 = frX-20 : poly2.yy3 = frY
poly2.xx4 = frX-10 : poly2.yy4 = frY+4
End If
Else
If jiX < jiY Then
poly1.xx2 = toX-4 : poly1.yy2 = toY-10
poly1.xx3 = toX+4 : poly1.yy3 = toY-10
poly2.xx2 = frX-4 : poly2.yy2 = frY+10
poly2.xx3 = frX : poly2.yy3 = frY+20
poly2.xx4 = frX+4 : poly2.yy4 = frY+10
Else
poly1.xx2 = toX-4 : poly1.yy2 = toY+10
poly1.xx3 = toX+4 : poly1.yy3 = toY+10
poly2.xx2 = frX-4 : poly2.yy2 = frY-10
poly2.xx3 = frX : poly2.yy3 = frY-20
poly2.xx4 = frX+4 : poly2.yy4 = frY-10
End If
End If
Graphic Polygon poly1, %BLUE, %BLUE
Graphic Polygon poly2, %BLUE, Iif(contype = 4, %WHITE, %BLUE)
Case 6 '--- discriminator arrow --- one polygon
poly1.cnt = 3
poly1.xx1 = toX : poly1.yy1 = toY
If Abs(jiX) > Abs(jiY) Then
If jiX > jiY Then
poly1.xx2 = toX-10 : poly1.yy2 = toY-8
poly1.xx3 = toX-10 : poly1.yy3 = toY+8
Else
poly1.xx2 = toX+10 : poly1.yy2 = toY-8
poly1.xx3 = toX+10 : poly1.yy3 = toY+8
End If
Else
If jiX < jiY Then
poly1.xx2 = toX-8 : poly1.yy2 = toY-10
poly1.xx3 = toX+8 : poly1.yy3 = toY-10
Else
poly1.xx2 = toX-8 : poly1.yy2 = toY+10
poly1.xx3 = toX+8 : poly1.yy3 = toY+10
End If
End If
Graphic Polygon poly1, %BLUE, %WHITE
Case 7 '--- interface connector --- arcs are needed
If Abs(jiX) > Abs(jiY) Then
If jiX > jiY Then
Graphic Arc (toX,toY-10) - (toX+20,toY+10), Pi/2, 3*Pi/2
Else
Graphic Arc (toX-20,toY-10) - (toX,toY+10), 3*Pi/2, Pi/2
End If
Else
If jiX < jiY Then
Graphic Arc (toX-10,toY) - (toX+10,toY+20), 0, Pi
Else
Graphic Arc (toX-10,toY-20) - (toX+10,toY+1), Pi, 0
End If
End If
End Select
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub CanvasCleaner(hWnd As Dword, clearAll As Long, wantRedraw As Long)
Local j As Long
Graphic Clear
Graphic Width 1
If clearAll Then
cntconn = 0 : Redim conn()
Control Set Text hWnd, %ID_CONNTXT, "Num : " + Str$(cntconn)
End If
For j = 0 To 19
Graphic Line (j*20, 00) - (j*20, 400), RGB(234,234,234)
Graphic Line (00, j*20) - (500, j*20), RGB(234,234,234)
Next
If wantRedraw Then Graphic Redraw
Graphic Width conwidth
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function PointToPointDistance(pX1 As Double, pY1 As Double, pX2 As Double, pY2 As Double) As Double
Function = Sqr((pX1-pX2)*(pX1-pX2) + (pY1-pY2)*(pY1-pY2))
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function PointToLineDistance(pX As Double, pY as Double, vX1 As Double, vY1 As Double, _
vX2 As Double, vY2 As Double) As Double
Local dX, dY As Double
If (vX1 = vX2) Then
Function = Abs(vX1 - pX)
ElseIf vY1 = vY2 Then
Function = Abs(vY1 - pY)
Else
dX = vX2 - vX1 : dY = vY2 - vY1
Function = Abs(dY*pX - dX*pY + vX2*vY1 - vX1*vY2) / Sqr(dX*dX + dY*dY)
End If
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function TestPointInLine(mX As Double, mY as Double, vX1 As Double, vY1 As Double, _
vX2 As Double, vY2 As Double, linew As Long) As Long
'return true if the distance from point to line is within the width of line plus margin.
'linew is the existing line width.
Local distance, halflinew, pmargin As Double
pmargin = 5.0
'exit if the mouse click is past the endpoints of the line
halflinew = linew/2
If (vX1 < vX2) Then
If (mX < vX1-pmargin) Or (mX > vX2+pmargin) Then Exit Function
Else
If (mX > vX1+pmargin) Or (mX < vX2-pmargin) Then Exit Function
End If
If (vY1 < vY2) Then
If (mY < vY1-pmargin) Or (mY > vY2+pmargin) Then Exit Function
Else
If (mY > vY1+pmargin) Or (mY < vY2-pmargin) Then Exit Function
End If
distance = Abs(PointToLineDistance(mX, mY, vX1, vY1, vX2, vY2))
Function = (distance >= -halflinew-pmargin) And (distance <= halflinew+pmargin)
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
'eof