Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Arrows with PB Graphics

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Arrows with PB Graphics

    Code:
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' Arrows.bas                   by Jordi Vallès        version 1a      13/05/2008
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Sometimes, on application with graphic elements, is necessary include arrows
    ' to mark or indicate distances, flows, directions, links, trends, etc.
    '
    ' This program shows an small collection of simple arrow shapes and their functions
    ' to build it dinamically using PB Graphics instead to use prebuilt figures and shapes.
    ' Some models can be improved and more combinations can be obtained.
    '
    ' Arrows, after created, can be resized and dragged using left mouse button over
    ' each end (or near) of selected arrow.
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '  - 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.
    '  - Some algorithms has been found on http://vbgraphic.altervista.org/geoalgo.htm
    '  - Part of knowledge needed has been found on MSDN technical interesting articles:
    '        [URL="http://msdn.microsoft.com/en-us/library/ms969932.aspx"]Use of Two-Dimensional Vectors with Windows NT[/URL]
    '        [URL="http://msdn.microsoft.com/en-us/library/ms969920.aspx"]Win32: Hit Testing Lines and Curves[/URL]
    '  - Part of code used is borrowed from PwrPaint.bas on PB for Windows Samples folder.
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' SED_PBWIN
    
    #Compile Exe "Arrows.exe"
    #Dim All
    #Include "WIN32API.INC"
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    %ID_ARROW1    = 1001
    %ID_ARROW2    = 1002
    %ID_ARROW3    = 1003
    %ID_ARROW4    = 1004
    %ID_ARROW5    = 1005
    %ID_ARROW6    = 1006
    %ID_ARROW7    = 1007
    %ID_ARROW8    = 1008
    %ID_ARROW9    = 1009
    %ID_ARROW10   = 1010
    %ID_ARROW11   = 1011
    %ID_ARROW12   = 1012
    %ID_ARROW13   = 1013
    %ID_ARROW14   = 1014
    %ID_ARROW15   = 1015
    %ID_GRAPHIC   = 1111
    %ID_POSIT     = 1112
    %ID_CLEAR     = 1113
    %ID_EXIT      = 1114
    %ID_FRAME     = 1115
    %ID_MODETXT   = 1116
    %ID_CBOX2     = 1121
    %ID_CBOX3     = 1131
    %CANVAS       = &hEEFAFA???  'RGB(250,250,238)
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Macro Pi        = 3.141592653589793# 'no comments
    Macro NearZero  = 0.000000000000001# 'to avoid problems in some divisions
    Macro Margin    = 3.0#   'default pixel miss margin to help when select the line
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    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
       awidth As Long
       astyle As Long
       arx1 As Double  :  ary1 As Double
       arx2 As Double  :  ary2 As Double
    End Type
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Global oldGraphicProc        As Dword
    Global candraw, canmove      As Long
    Global X1, Y1, X2, Y2        As Double
    Global oldX1, oldY1          As Double
    Global oldX2, oldY2          As Double
    Global arrowtype, savetype   As Long
    Global arrowwidth, savewidth As Long
    Global arrowstyle, savestyle As Long
    Global arrow()               As ARROWSTORE
    Global cntarrow, curarrow    As Long
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Declare Function Atn2(Y As Double, X As Double) As Double
    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, "Arrow styles 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_MODETXT, "Mode :  draw ",        450, 344, 120, 12
       Control Add Label,    hDlg, %ID_POSIT,   "Pos : ",               450, 360, 100, 12
       Control Add Frame,    hDlg, %ID_FRAME,   "Arrow Styles",         416,   5, 135, 316
    
       Control Add Option,   hDlg, %ID_ARROW1,  "A simple arrow",       422,  24, 120, 16, %WS_GROUP
       Control Add Option,   hDlg, %ID_ARROW2,  "Another simple arrow", 422,  40, 120, 16
       Control Add Option,   hDlg, %ID_ARROW3,  "Two ends arrow",       422,  56, 120, 16
       Control Add Option,   hDlg, %ID_ARROW4,  "Arrow at middle",      422,  72, 120, 16
       Control Add Option,   hDlg, %ID_ARROW5,  "Broken arrow",         422,  88, 120, 16
       Control Add Option,   hDlg, %ID_ARROW6,  "Ball arrow",           422, 104, 120, 16
       Control Add Option,   hDlg, %ID_ARROW7,  "Ball arrow filled",    422, 120, 120, 16
       Control Add Option,   hDlg, %ID_ARROW8,  "Diamond arrow",        422, 136, 120, 16
       Control Add Option,   hDlg, %ID_ARROW9,  "Diamond arrow filled", 422, 152, 120, 16
       Control Add Option,   hDlg, %ID_ARROW10, "Box arrow",            422, 168, 120, 16
       Control Add Option,   hDlg, %ID_ARROW11, "Box arrow filled",     422, 184, 120, 16
       Control Add Option,   hDlg, %ID_ARROW12, "Sharp arrow",          422, 200, 120, 16
       Control Add Option,   hDlg, %ID_ARROW13, "Sharp arrow filled",   422, 216, 120, 16
       Control Add Option,   hDlg, %ID_ARROW14, "Sharp arrow at middle",422, 232, 120, 16
       Control Add Option,   hDlg, %ID_ARROW15, "None",                 422, 248, 120, 16
       Control Set Option    hDlg, %ID_ARROW1, %ID_ARROW1, %ID_ARROW15
    
       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 DlgProc
    End Function
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    CallBack Function DlgProc() 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))
             arrowtype = 1  :  arrowwidth = 1  :  arrowstyle = 0
             savetype  = 1  :  savewidth  = 1  :  savestyle  = 0
             Call CanvasCleaner(%TRUE)
          Case %WM_SETCURSOR
             If CbWParam <> hGraphic Then  Control Set Text CbHndl, %ID_POSIT, "Pos :"
          Case %WM_COMMAND
             Select Case CbCtl
                Case %ID_ARROW1 To %ID_ARROW15         'arrow type
                   arrowtype = CbCtl - 1000
                   savetype = arrowtype
                Case %ID_CBOX2                         'pen width
                   If CbCtlMsg = %CBN_SELENDOK Then
                      Control Send CbHndl, %ID_CBOX2, %CB_GETCURSEL, 0, 0 To arrowwidth
                      arrowwidth = Max(1, arrowwidth +1)
                      savewidth = arrowwidth
                      If arrowwidth = 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 arrowstyle
                      savestyle = arrowstyle
                   End If
                Case %ID_EXIT
                   If CbCtlMsg = %BN_CLICKED Then Dialog End CbHndl
                Case %ID_CLEAR
                   If CbCtlMsg = %BN_CLICKED Then Call CanvasCleaner(%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 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 canmove And (wParam And %MK_LBUTTON) Then
          Call CanvasCleaner(%FALSE)
          GetCursorPos pt
          ScreenToClient hWnd, pt
          dx = pt.x  :  dy = pt.y    'convert to double
          d1 = PointToPointDistance(dx, dy, arrow(curarrow).arx1, arrow(curarrow).ary1)
          d2 = PointToPointDistance(dx, dy, arrow(curarrow).arx2, arrow(curarrow).ary2)
          If d1 < d2 Then            'check wich end is more near to mouse pointer
             arrow(curarrow).arx1 = dx
             arrow(curarrow).ary1 = dy
          Else
             arrow(curarrow).arx2 = dx
             arrow(curarrow).ary2 = dy
          End If
          For i = 1 to cntarrow      'redraw all arrows
             arrowwidth = arrow(i).awidth
             arrowtype  = arrow(i).atype
             arrowstyle = arrow(i).astyle
             Call DrawArrows(arrow(i).arx1, arrow(i).ary1, arrow(i).arx2, arrow(i).ary2)
          Next i
          Graphic ReDraw
       ElseIf candraw And (wParam And %MK_LBUTTON) Then
          If oldX1 > -1 Then Call DrawArrows(oldX1, oldY1, oldX2, oldY2)
          Call DrawArrows(X1, Y1, X2, Y2)
          oldX1 = X1  :  oldY1 = Y1
          oldX2 = X2  :  oldY2 = Y2
          Graphic ReDraw
       End If
    End Sub
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    Sub LeftButtonDown(ByVal hWnd As Dword, ByVal wParam As Dword, ByVal lParam As Long)
       Local i, dist 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))
    
       If cntarrow > 0 Then
          curarrow = 0
          For i = 1 To cntarrow
             dist = TestPointInLine(X1, Y1, arrow(i).arx1, arrow(i).ary1, arrow(i).arx2, arrow(i).ary2, arrow(i).awidth)
             If dist Then
                canmove = i         'set in resize state
                curarrow = i
                Control Set Text GetParent(hWnd), %ID_MODETXT, "Mode :  resize"
                Exit Sub
             End If
          Next i
       End If
    
       arrowstyle = savestyle
       arrowwidth = savewidth
       arrowtype  = savetype
       oldX1 = X1  :  oldY1 = Y1
       oldX2 = X1  :  oldY2 = Y1
       Graphic Set Mix %R2_NOTXORPEN
       Call DrawArrows(X1, Y1, X1, Y1)
       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 canmove Then              'finish mouse resize state
          canmove = 0
          Graphic Set Mix %R2_COPYPEN
          Call DrawArrows(oldX1, oldY1, oldX2, oldY2)
          Graphic ReDraw
          oldX1  = -1  :  oldY1  = 0
          oldX2  = 0   :  oldY2  = 0
          ReleaseCapture
       ElseIf candraw Then          'finish arrow creation state
          candraw = 0
          Graphic Set Mix %R2_COPYPEN
          Call DrawArrows(oldX1, oldY1, oldX2, oldY2)
          Graphic ReDraw
          Incr cntarrow             'store arrow info on arrow array, arrrgh!
          Redim Preserve arrow(1 To cntarrow)
          arrow(cntarrow).atype  = arrowtype
          arrow(cntarrow).awidth = arrowwidth
          arrow(cntarrow).astyle = arrowstyle
          arrow(cntarrow).arx1   = oldX1
          arrow(cntarrow).ary1   = oldY1
          arrow(cntarrow).arx2   = oldX2
          arrow(cntarrow).ary2   = oldY2
          oldX1  = -1  :  oldY1  = 0
          oldX2  = 0   :  oldY2  = 0
          ReleaseCapture
       End If
       Control Set Text GetParent(hWnd), %ID_MODETXT, "Mode :  draw"
    End Sub
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    Sub DrawArrows(frX As Double, frY As Double, toX As Double, toY As Double)
       '--- this procedure can be optimized a lot, in size and speed
       '--- here is "as is" in benefit of clarity in code
       Local sharp, slopy, cosy, siny, shcosy, shsiny, dist As Double
       Local mdX, mdY, hlX, hlY, hrX, hrY As Double
       Local headangle As Double
       Local poly As POLYARRAY
    
       Select Case As Long arrowtype    'arrow side size
          Case 8 To 9    :  sharp = 6
          Case 10 To 11  :  sharp = 5
          Case 12 To 14  :  sharp = 16
          Case Else      :  sharp = 8
       End Select
    
       dist   = PointToPointDistance(frX, frY, toX, toY)
       If dist <= sharp Then exit Sub
       slopy  = Atn2(frY-toY, frX-toX)
       cosy   = Cos(slopy)
       siny   = Sin(slopy)
       shcosy = sharp*cosy
       shsiny = sharp*siny
    
       Graphic Width arrowwidth
       Select Case As Long arrowtype
          Case 1   '--- one end arrow, very simple ---
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX,toY)
             Graphic Style 0
             Graphic Line           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
             Graphic Line (toX,toY) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
          Case 2   '--- another simple arrow in wireframe style ---
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX,toY)
             Graphic Style 0
             Graphic Line           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
             Graphic Line           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
             Graphic Line           - (toX,toY)
          Case 3   '--- two ends arrow in wireframe style ---
             Graphic Style 0
             Graphic Line (frX,frY) - (frX-(shcosy-shsiny),frY-(shsiny+shcosy))
             Graphic Line           - (frX+(shcosy+shsiny),frY-(shcosy-shsiny))
             Graphic Line           - (frX,frY)
             Graphic Style arrowstyle
             Graphic Line           - (toX,toY)
             Graphic Style 0
             Graphic Line           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
             Graphic Line           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
             Graphic Line           - (toX,toY)
          Case 4   '--- middle arrow in wireframe style ---
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX,toY)
             Graphic Style 0
             mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
             Graphic Line (mdX,mdY) - (mdX+(shcosy-shsiny),mdY+(shsiny+shcosy))
             Graphic Line           - (mdX-(shcosy+shsiny),mdY+(shcosy-shsiny))
             Graphic Line           - (mdX,mdY)
          Case 5   '--- broken arrow, in wireframe style ---
             Graphic Style 0
             Graphic Line (frX,frY) - (frX-(shcosy-shsiny),frY-(shsiny+shcosy))
             Graphic Line           - (frX+(shcosy+shsiny),frY-(shcosy-shsiny))
             Graphic Line           - (frX,frY)
             Graphic Style arrowstyle
             Graphic Line           - (toX,toY)
             Graphic Style 0
             Graphic Line           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
             Graphic Line           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
             Graphic Line           - (toX,toY)
             mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
             hlX = mdX+(shcosy-shsiny)  :  hlY = mdY+(shsiny+shcosy)
             hrX = mdX-(shcosy-shsiny)  :  hrY = mdY-(shsiny+shcosy)
             Graphic Line (hlX,hlY) - (hrX, hry)
             hlX = mdX+(shcosy+shsiny)  :  hlY = mdY+(shsiny-shcosy)
             hrX = mdX-(shcosy+shsiny)  :  hrY = mdY-(shsiny-shcosy)
             Graphic Line (hlX,hlY) - (hrX, hry)
          Case 6   '--- balls arrow in wireframe style ---
             Graphic Line (frX,frY) - (toX,toY)
             Graphic Ellipse (toX-(shsiny)-sharp,toY+(shcosy)-sharp) - (toX-(shsiny)+sharp,toY+(shcosy)+sharp)
             Graphic Line (toX+(shcosy-shsiny),toY+(shsiny+shcosy)) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
          Case 7   '--- balls arrow filled, solid ---
             Graphic Line (frX,frY) - (toX,toY)
             Graphic Ellipse (frX-2,frY-2) - (frX+2,frY+2), %BLUE, %WHITE
             Graphic Ellipse (toX-7,toY-7) - (toX+7,toY+7), %BLUE, %WHITE
          Case 8   '--- diamond arrow, in wireframe style ---
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX,toY)
             Graphic Style 0
             poly.cnt = 4
             poly.xx1 = toX                       :  poly.yy1 = toY
             poly.xx2 = Abs(toX+(shcosy-shsiny))  :  poly.yy2 = Abs(toY+(shsiny+shcosy))
             poly.xx3 = Abs(toX-(2*shsiny))       :  poly.yy3 = Abs(toY+(2*shcosy))
             poly.xx4 = Abs(toX-(shcosy+shsiny))  :  poly.yy4 = Abs(toY+(shcosy-shsiny))
             Graphic Polygon poly
             Graphic Line (toX+(shcosy-shsiny),toY+(shsiny+shcosy)) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
          Case 9   '--- diamond arrow solid fill ---
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX,toY)
             Graphic Style 0
             poly.cnt = 4
             poly.xx1 = toX                       :  poly.yy1 = toY
             poly.xx2 = Abs(toX+(shcosy-shsiny))  :  poly.yy2 = Abs(toY+(shsiny+shcosy))
             poly.xx3 = Abs(toX-(2*shsiny))       :  poly.yy3 = Abs(toY+(2*shcosy))
             poly.xx4 = Abs(toX-(shcosy+shsiny))  :  poly.yy4 = Abs(toY+(shcosy-shsiny))
             Graphic Polygon poly, %BLUE, %BLUE
          Case 10 To 11   '--- Box arrows ---
             Local hzX, hzY As Double
             poly.cnt = 4
             hlX = Abs(toX+sharp*Cos(slopy+Pi))
             hlY = Abs(toY+sharp*Sin(slopy+Pi))
             hrX = Abs(toX-sharp*Cos(slopy+Pi))
             hrY = Abs(toY-sharp*Sin(slopy+Pi))
             poly.xx1 = hlX  :  poly.yy1 = hlY
             poly.xx2 = hrX  :  poly.yy2 = hrY
             hzX = toX-(2*shsiny) : hzY = toY+(2*shcosy)
             hlX = Abs(hzX+sharp*Cos(slopy+Pi))
             hlY = Abs(hzY+sharp*Sin(slopy+Pi))
             hrX = Abs(hzX-sharp*Cos(slopy+Pi))
             hrY = Abs(hzY-sharp*Sin(slopy+Pi))
             poly.xx3 = hrX  :  poly.yy3 = hrY
             poly.xx4 = hlX  :  poly.yy4 = hlY
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX, toY)
             Graphic Style 0
             Select Case As Long arrowtype
                Case 10
                   Graphic Polygon poly, -1, %CANVAS
                   Graphic Line (poly.xx1,poly.yy1) - (poly.xx3,poly.yy3)
                   Graphic Line (poly.xx2,poly.yy2) - (poly.xx4,poly.yy4)
                Case 11  :  Graphic Polygon poly, %BLUE, %YELLOW
             End Select
          Case 12 To 13   '--- sharp arrows ---
             headangle = Pi/2.5
             hlX = Abs(toX+sharp*Cos(slopy+Pi-headangle))
             hlY = Abs(toY+sharp*Sin(slopy+Pi-headangle))
             hrX = Abs(toX-sharp*Cos(slopy+Pi+headangle))
             hrY = Abs(toY-sharp*Sin(slopy+Pi+headangle))
             poly.cnt = 3
             poly.xx1 = toX  :  poly.yy1 = toY
             poly.xx2 = hlX  :  poly.yy2 = hlY
             poly.xx3 = hrX  :  poly.yy3 = hrY
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX, toY)
             Graphic Style 0
             Select Case As Long arrowtype
                Case 12  :  Graphic Polygon poly
                Case 13  :  Graphic Polygon poly, %BLUE, %BLUE
             End Select
          Case 14   '---sharp arrow at middle ---
             headangle = Pi/2.5
             mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
             hlX = Abs(mdX+sharp*Cos(slopy+Pi-headangle))
             hlY = Abs(mdY+sharp*Sin(slopy+Pi-headangle))
             hrX = Abs(mdX-sharp*Cos(slopy+Pi+headangle))
             hrY = Abs(mdY-sharp*Sin(slopy+Pi+headangle))
             poly.cnt = 3
             poly.xx1 = mdX  :  poly.yy1 = mdY
             poly.xx2 = hlX  :  poly.yy2 = hlY
             poly.xx3 = hrX  :  poly.yy3 = hrY
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX, toY)
             Graphic Style 0
             Graphic Polygon poly, %BLUE, %WHITE
          Case 15   '--- line only --- (should be the first)
             Graphic Style arrowstyle
             Graphic Line (frX,frY) - (toX, toY)
       End Select
    End Sub
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    Sub CanvasCleaner(All As long)
       Local j As Long
       Graphic Clear
       Graphic Width 1
       If all Then cntarrow = 0  :  Redim arrow()
       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
       Graphic ReDraw
       Graphic Width arrowwidth
    End Sub
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    Function Atn2(X As Double, Y As Double) As Double
       'Atn2 optimized version. Simple but sufficient for this purpose.
       'Range of the result is 0 to 2pi radians.
       If Y = 0 Then Y = NearZero
       Function = (Atn(Abs(X)/Abs(Y)) * Sgn(X) - Pi/2) * Sgn(Y)
    End Function
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    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(mx As Double, my as Double, vx1 As Double, vy1 As Double, _
                          vx2 As Double, vy2 As Double) As Double
       Local dx, dy As Double
       'mx, my are the mouse points
       If (vx1 = vx2) Then
          Function = Abs(vx1 - mx)
       ElseIf vy1 = vy2 Then
          Function = Abs(vy1 - my)
       Else
          dx = vx2 - vx1  :  dy = vy2 - vy1
          Function = Abs(dy*mx - dx*my + 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 As Double
       'exit if the mouse click is past the endpoints of the line
       halflinew = linew/2
       If (vx1 < vx2) Then
          If (mx < vx1 - Margin) Or (mx > vx2 + Margin) Then Exit Function
       Else
          If (mx > vx1 + Margin) Or (mx < vx2 - Margin) Then Exit Function
       End If
       If (vy1 < vy2) Then
          If (my < vy1 - Margin) Or (my > vy2 + Margin) Then Exit Function
       Else
          If (my > vy1 + Margin) Or (my < vy2 - Margin) Then Exit Function
       End If
       distance = Abs(PointToLineDistance(mx, my, vx1, vy1, vx2, vy2))
       Function = (distance >= -halflinew-Margin) And (distance <= halflinew+Margin)
    End Function
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    'eof

  • #2
    Congratulations on great program,

    very nice design and functionality!

    In case there is lot of arrows, resizing causes visible flicker.
    This is because of sequence:
    - background render
    - bitmap updated
    - arrows render
    - bitmap updated.

    To avoid this I modified CanvasCleaner to:
    SUB CanvasCleaner(ALL AS LONG, wantRedraw AS LONG)
    LOCAL j AS LONG
    GRAPHIC CLEAR
    GRAPHIC WIDTH 1
    IF ALL THEN cntarrow = 0 : REDIM arrow()
    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 arrowwidth
    END SUB
    Then complete code becomes the following and flicker is gone:
    Code:
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' [u] Flicker free resizing
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' Arrows.bas                   by Jordi Valle`s        version 1a      13/05/2008
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Sometimes, on application with graphic elements, is necessary include arrows
    ' to mark or indicate distances, flows, directions, links, trends, etc.
    '
    ' This program shows an small collection of simple arrow shapes and their functions
    ' to build it dinamically using PB Graphics instead to use prebuilt figures and shapes.
    ' Some models can be improved and more combinations can be obtained.
    '
    ' Arrows, after created, can be resized and dragged using left mouse button over
    ' each end (or near) of selected arrow.
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '  - 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.
    '  - Some algorithms has been found on http://vbgraphic.altervista.org/geoalgo.htm
    '  - Part of knowledge needed has been found on MSDN technical interesting articles:
    '        Use of Two-Dimensional Vectors with Windows NT
    '        Win32: Hit Testing Lines and Curves
    '  - Part of code used is borrowed from PwrPaint.bas on PB for Windows Samples folder.
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' SED_PBWIN
    
    #COMPILE EXE "Arrows.exe"
    #DIM ALL
    #INCLUDE "WIN32API.INC"
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    %ID_ARROW1    = 1001
    %ID_ARROW2    = 1002
    %ID_ARROW3    = 1003
    %ID_ARROW4    = 1004
    %ID_ARROW5    = 1005
    %ID_ARROW6    = 1006
    %ID_ARROW7    = 1007
    %ID_ARROW8    = 1008
    %ID_ARROW9    = 1009
    %ID_ARROW10   = 1010
    %ID_ARROW11   = 1011
    %ID_ARROW12   = 1012
    %ID_ARROW13   = 1013
    %ID_ARROW14   = 1014
    %ID_ARROW15   = 1015
    %ID_GRAPHIC   = 1111
    %ID_POSIT     = 1112
    %ID_CLEAR     = 1113
    %ID_EXIT      = 1114
    %ID_FRAME     = 1115
    %ID_MODETXT   = 1116
    %ID_CBOX2     = 1121
    %ID_CBOX3     = 1131
    %CANVAS       = &hEEFAFA???  'RGB(250,250,238)
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    MACRO Pi        = 3.141592653589793# 'no comments
    MACRO NearZero  = 0.000000000000001# 'to avoid problems in some divisions
    MACRO MARGIN    = 3.0#   'default pixel miss margin to help when select the line
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    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
       awidth AS LONG
       astyle AS LONG
       arx1 AS DOUBLE  :  ary1 AS DOUBLE
       arx2 AS DOUBLE  :  ary2 AS DOUBLE
    END TYPE
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    GLOBAL oldGraphicProc        AS DWORD
    GLOBAL candraw, canmove      AS LONG
    GLOBAL X1, Y1, X2, Y2        AS DOUBLE
    GLOBAL oldX1, oldY1          AS DOUBLE
    GLOBAL oldX2, oldY2          AS DOUBLE
    GLOBAL arrowtype, savetype   AS LONG
    GLOBAL arrowwidth, savewidth AS LONG
    GLOBAL arrowstyle, savestyle AS LONG
    GLOBAL arrow()               AS ARROWSTORE
    GLOBAL cntarrow, curarrow    AS LONG
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    DECLARE FUNCTION Atn2(Y AS DOUBLE, X AS DOUBLE) AS DOUBLE
    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, "Arrow styles 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_MODETXT, "Mode :  draw ",        450, 344, 120, 12
       CONTROL ADD LABEL,    hDlg, %ID_POSIT,   "Pos : ",               450, 360, 100, 12
       CONTROL ADD FRAME,    hDlg, %ID_FRAME,   "Arrow Styles",         416,   5, 135, 316
    
       CONTROL ADD OPTION,   hDlg, %ID_ARROW1,  "A simple arrow",       422,  24, 120, 16, %WS_GROUP
       CONTROL ADD OPTION,   hDlg, %ID_ARROW2,  "Another simple arrow", 422,  40, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW3,  "Two ends arrow",       422,  56, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW4,  "Arrow at middle",      422,  72, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW5,  "Broken arrow",         422,  88, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW6,  "Ball arrow",           422, 104, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW7,  "Ball arrow filled",    422, 120, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW8,  "Diamond arrow",        422, 136, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW9,  "Diamond arrow filled", 422, 152, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW10, "Box arrow",            422, 168, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW11, "Box arrow filled",     422, 184, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW12, "Sharp arrow",          422, 200, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW13, "Sharp arrow filled",   422, 216, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW14, "Sharp arrow at middle",422, 232, 120, 16
       CONTROL ADD OPTION,   hDlg, %ID_ARROW15, "None",                 422, 248, 120, 16
       CONTROL SET OPTION    hDlg, %ID_ARROW1, %ID_ARROW1, %ID_ARROW15
    
       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 DlgProc
    END FUNCTION
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    CALLBACK FUNCTION DlgProc() 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))
             arrowtype = 1  :  arrowwidth = 1  :  arrowstyle = 0
             savetype  = 1  :  savewidth  = 1  :  savestyle  = 0
             CALL CanvasCleaner(%TRUE, %TRUE)
          CASE %WM_SETCURSOR
             IF CBWPARAM <> hGraphic THEN  CONTROL SET TEXT CBHNDL, %ID_POSIT, "Pos :"
          CASE %WM_COMMAND
             SELECT CASE CBCTL
                CASE %ID_ARROW1 TO %ID_ARROW15         'arrow type
                   arrowtype = CBCTL - 1000
                   savetype = arrowtype
                CASE %ID_CBOX2                         'pen width
                   IF CBCTLMSG = %CBN_SELENDOK THEN
                      CONTROL SEND CBHNDL, %ID_CBOX2, %CB_GETCURSEL, 0, 0 TO arrowwidth
                      arrowwidth = MAX(1, arrowwidth +1)
                      savewidth = arrowwidth
                      IF arrowwidth = 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 arrowstyle
                      savestyle = arrowstyle
                   END IF
                CASE %ID_EXIT
                   IF CBCTLMSG = %BN_CLICKED THEN DIALOG END CBHNDL
                CASE %ID_CLEAR
                   IF CBCTLMSG = %BN_CLICKED THEN CALL CanvasCleaner(%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 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 canmove AND (wParam AND %MK_LBUTTON) THEN
        
          CALL CanvasCleaner(%FALSE, %FALSE)
          
          GetCursorPos pt
          ScreenToClient hWnd, pt
          dx = pt.x  :  dy = pt.y    'convert to double
          d1 = PointToPointDistance(dx, dy, arrow(curarrow).arx1, arrow(curarrow).ary1)
          d2 = PointToPointDistance(dx, dy, arrow(curarrow).arx2, arrow(curarrow).ary2)
          IF d1 < d2 THEN            'check wich end is more near to mouse pointer
             arrow(curarrow).arx1 = dx
             arrow(curarrow).ary1 = dy
          ELSE
             arrow(curarrow).arx2 = dx
             arrow(curarrow).ary2 = dy
          END IF
          FOR i = 1 TO cntarrow      'redraw all arrows
             arrowwidth = arrow(i).awidth
             arrowtype  = arrow(i).atype
             arrowstyle = arrow(i).astyle
             CALL DrawArrows(arrow(i).arx1, arrow(i).ary1, arrow(i).arx2, arrow(i).ary2)
          NEXT i
          GRAPHIC REDRAW
       ELSEIF candraw AND (wParam AND %MK_LBUTTON) THEN
          IF oldX1 > -1 THEN CALL DrawArrows(oldX1, oldY1, oldX2, oldY2)
          CALL DrawArrows(X1, Y1, X2, Y2)
          oldX1 = X1  :  oldY1 = Y1
          oldX2 = X2  :  oldY2 = Y2
          GRAPHIC REDRAW
       END IF
    END SUB
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    SUB LeftButtonDown(BYVAL hWnd AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG)
       LOCAL i, dist 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))
    
       IF cntarrow > 0 THEN
          curarrow = 0
          FOR i = 1 TO cntarrow
             dist = TestPointInLine(X1, Y1, arrow(i).arx1, arrow(i).ary1, arrow(i).arx2, arrow(i).ary2, arrow(i).awidth)
             IF dist THEN
                canmove = i         'set in resize state
                curarrow = i
                CONTROL SET TEXT GetParent(hWnd), %ID_MODETXT, "Mode :  resize"
                EXIT SUB
             END IF
          NEXT i
       END IF
    
       arrowstyle = savestyle
       arrowwidth = savewidth
       arrowtype  = savetype
       oldX1 = X1  :  oldY1 = Y1
       oldX2 = X1  :  oldY2 = Y1
       GRAPHIC SET MIX %R2_NOTXORPEN
       CALL DrawArrows(X1, Y1, X1, Y1)
       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 canmove THEN              'finish mouse resize state
          canmove = 0
          GRAPHIC SET MIX %R2_COPYPEN
          CALL DrawArrows(oldX1, oldY1, oldX2, oldY2)
          GRAPHIC REDRAW
          oldX1  = -1  :  oldY1  = 0
          oldX2  = 0   :  oldY2  = 0
          ReleaseCapture
       ELSEIF candraw THEN          'finish arrow creation state
          candraw = 0
          GRAPHIC SET MIX %R2_COPYPEN
          CALL DrawArrows(oldX1, oldY1, oldX2, oldY2)
          GRAPHIC REDRAW
          INCR cntarrow             'store arrow info on arrow array, arrrgh!
          REDIM PRESERVE arrow(1 TO cntarrow)
          arrow(cntarrow).atype  = arrowtype
          arrow(cntarrow).awidth = arrowwidth
          arrow(cntarrow).astyle = arrowstyle
          arrow(cntarrow).arx1   = oldX1
          arrow(cntarrow).ary1   = oldY1
          arrow(cntarrow).arx2   = oldX2
          arrow(cntarrow).ary2   = oldY2
          oldX1  = -1  :  oldY1  = 0
          oldX2  = 0   :  oldY2  = 0
          ReleaseCapture
       END IF
       CONTROL SET TEXT GetParent(hWnd), %ID_MODETXT, "Mode :  draw"
    END SUB
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    SUB DrawArrows(frX AS DOUBLE, frY AS DOUBLE, toX AS DOUBLE, toY AS DOUBLE)
       '--- this procedure can be optimized a lot, in size and speed
       '--- here is "as is" in benefit of clarity in code
       LOCAL sharp, slopy, cosy, siny, shcosy, shsiny, dist AS DOUBLE
       LOCAL mdX, mdY, hlX, hlY, hrX, hrY AS DOUBLE
       LOCAL headangle AS DOUBLE
       LOCAL poly AS POLYARRAY
    
       SELECT CASE AS LONG arrowtype    'arrow side size
          CASE 8 TO 9    :  sharp = 6
          CASE 10 TO 11  :  sharp = 5
          CASE 12 TO 14  :  sharp = 16
          CASE ELSE      :  sharp = 8
       END SELECT
    
       dist   = PointToPointDistance(frX, frY, toX, toY)
       IF dist <= sharp THEN EXIT SUB
       slopy  = Atn2(frY-toY, frX-toX)
       cosy   = COS(slopy)
       siny   = SIN(slopy)
       shcosy = sharp*cosy
       shsiny = sharp*siny
    
       GRAPHIC WIDTH arrowwidth
       SELECT CASE AS LONG arrowtype
          CASE 1   '--- one end arrow, very simple ---
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX,toY)
             GRAPHIC STYLE 0
             GRAPHIC LINE           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
             GRAPHIC LINE (toX,toY) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
          CASE 2   '--- another simple arrow in wireframe style ---
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX,toY)
             GRAPHIC STYLE 0
             GRAPHIC LINE           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
             GRAPHIC LINE           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
             GRAPHIC LINE           - (toX,toY)
          CASE 3   '--- two ends arrow in wireframe style ---
             GRAPHIC STYLE 0
             GRAPHIC LINE (frX,frY) - (frX-(shcosy-shsiny),frY-(shsiny+shcosy))
             GRAPHIC LINE           - (frX+(shcosy+shsiny),frY-(shcosy-shsiny))
             GRAPHIC LINE           - (frX,frY)
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE           - (toX,toY)
             GRAPHIC STYLE 0
             GRAPHIC LINE           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
             GRAPHIC LINE           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
             GRAPHIC LINE           - (toX,toY)
          CASE 4   '--- middle arrow in wireframe style ---
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX,toY)
             GRAPHIC STYLE 0
             mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
             GRAPHIC LINE (mdX,mdY) - (mdX+(shcosy-shsiny),mdY+(shsiny+shcosy))
             GRAPHIC LINE           - (mdX-(shcosy+shsiny),mdY+(shcosy-shsiny))
             GRAPHIC LINE           - (mdX,mdY)
          CASE 5   '--- broken arrow, in wireframe style ---
             GRAPHIC STYLE 0
             GRAPHIC LINE (frX,frY) - (frX-(shcosy-shsiny),frY-(shsiny+shcosy))
             GRAPHIC LINE           - (frX+(shcosy+shsiny),frY-(shcosy-shsiny))
             GRAPHIC LINE           - (frX,frY)
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE           - (toX,toY)
             GRAPHIC STYLE 0
             GRAPHIC LINE           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
             GRAPHIC LINE           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
             GRAPHIC LINE           - (toX,toY)
             mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
             hlX = mdX+(shcosy-shsiny)  :  hlY = mdY+(shsiny+shcosy)
             hrX = mdX-(shcosy-shsiny)  :  hrY = mdY-(shsiny+shcosy)
             GRAPHIC LINE (hlX,hlY) - (hrX, hry)
             hlX = mdX+(shcosy+shsiny)  :  hlY = mdY+(shsiny-shcosy)
             hrX = mdX-(shcosy+shsiny)  :  hrY = mdY-(shsiny-shcosy)
             GRAPHIC LINE (hlX,hlY) - (hrX, hry)
          CASE 6   '--- balls arrow in wireframe style ---
             GRAPHIC LINE (frX,frY) - (toX,toY)
             GRAPHIC ELLIPSE (toX-(shsiny)-sharp,toY+(shcosy)-sharp) - (toX-(shsiny)+sharp,toY+(shcosy)+sharp)
             GRAPHIC LINE (toX+(shcosy-shsiny),toY+(shsiny+shcosy)) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
          CASE 7   '--- balls arrow filled, solid ---
             GRAPHIC LINE (frX,frY) - (toX,toY)
             GRAPHIC ELLIPSE (frX-2,frY-2) - (frX+2,frY+2), %BLUE, %WHITE
             GRAPHIC ELLIPSE (toX-7,toY-7) - (toX+7,toY+7), %BLUE, %WHITE
          CASE 8   '--- diamond arrow, in wireframe style ---
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX,toY)
             GRAPHIC STYLE 0
             poly.cnt = 4
             poly.xx1 = toX                       :  poly.yy1 = toY
             poly.xx2 = ABS(toX+(shcosy-shsiny))  :  poly.yy2 = ABS(toY+(shsiny+shcosy))
             poly.xx3 = ABS(toX-(2*shsiny))       :  poly.yy3 = ABS(toY+(2*shcosy))
             poly.xx4 = ABS(toX-(shcosy+shsiny))  :  poly.yy4 = ABS(toY+(shcosy-shsiny))
             GRAPHIC POLYGON poly
             GRAPHIC LINE (toX+(shcosy-shsiny),toY+(shsiny+shcosy)) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
          CASE 9   '--- diamond arrow solid fill ---
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX,toY)
             GRAPHIC STYLE 0
             poly.cnt = 4
             poly.xx1 = toX                       :  poly.yy1 = toY
             poly.xx2 = ABS(toX+(shcosy-shsiny))  :  poly.yy2 = ABS(toY+(shsiny+shcosy))
             poly.xx3 = ABS(toX-(2*shsiny))       :  poly.yy3 = ABS(toY+(2*shcosy))
             poly.xx4 = ABS(toX-(shcosy+shsiny))  :  poly.yy4 = ABS(toY+(shcosy-shsiny))
             GRAPHIC POLYGON poly, %BLUE, %BLUE
          CASE 10 TO 11   '--- Box arrows ---
             LOCAL hzX, hzY AS DOUBLE
             poly.cnt = 4
             hlX = ABS(toX+sharp*COS(slopy+Pi))
             hlY = ABS(toY+sharp*SIN(slopy+Pi))
             hrX = ABS(toX-sharp*COS(slopy+Pi))
             hrY = ABS(toY-sharp*SIN(slopy+Pi))
             poly.xx1 = hlX  :  poly.yy1 = hlY
             poly.xx2 = hrX  :  poly.yy2 = hrY
             hzX = toX-(2*shsiny) : hzY = toY+(2*shcosy)
             hlX = ABS(hzX+sharp*COS(slopy+Pi))
             hlY = ABS(hzY+sharp*SIN(slopy+Pi))
             hrX = ABS(hzX-sharp*COS(slopy+Pi))
             hrY = ABS(hzY-sharp*SIN(slopy+Pi))
             poly.xx3 = hrX  :  poly.yy3 = hrY
             poly.xx4 = hlX  :  poly.yy4 = hlY
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX, toY)
             GRAPHIC STYLE 0
             SELECT CASE AS LONG arrowtype
                CASE 10
                   GRAPHIC POLYGON poly, -1, %CANVAS
                   GRAPHIC LINE (poly.xx1,poly.yy1) - (poly.xx3,poly.yy3)
                   GRAPHIC LINE (poly.xx2,poly.yy2) - (poly.xx4,poly.yy4)
                CASE 11  :  GRAPHIC POLYGON poly, %BLUE, %YELLOW
             END SELECT
          CASE 12 TO 13   '--- sharp arrows ---
             headangle = Pi/2.5
             hlX = ABS(toX+sharp*COS(slopy+Pi-headangle))
             hlY = ABS(toY+sharp*SIN(slopy+Pi-headangle))
             hrX = ABS(toX-sharp*COS(slopy+Pi+headangle))
             hrY = ABS(toY-sharp*SIN(slopy+Pi+headangle))
             poly.cnt = 3
             poly.xx1 = toX  :  poly.yy1 = toY
             poly.xx2 = hlX  :  poly.yy2 = hlY
             poly.xx3 = hrX  :  poly.yy3 = hrY
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX, toY)
             GRAPHIC STYLE 0
             SELECT CASE AS LONG arrowtype
                CASE 12  :  GRAPHIC POLYGON poly
                CASE 13  :  GRAPHIC POLYGON poly, %BLUE, %BLUE
             END SELECT
          CASE 14   '---sharp arrow at middle ---
             headangle = Pi/2.5
             mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
             hlX = ABS(mdX+sharp*COS(slopy+Pi-headangle))
             hlY = ABS(mdY+sharp*SIN(slopy+Pi-headangle))
             hrX = ABS(mdX-sharp*COS(slopy+Pi+headangle))
             hrY = ABS(mdY-sharp*SIN(slopy+Pi+headangle))
             poly.cnt = 3
             poly.xx1 = mdX  :  poly.yy1 = mdY
             poly.xx2 = hlX  :  poly.yy2 = hlY
             poly.xx3 = hrX  :  poly.yy3 = hrY
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX, toY)
             GRAPHIC STYLE 0
             GRAPHIC POLYGON poly, %BLUE, %WHITE
          CASE 15   '--- line only --- (should be the first)
             GRAPHIC STYLE arrowstyle
             GRAPHIC LINE (frX,frY) - (toX, toY)
       END SELECT
    END SUB
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    SUB CanvasCleaner(ALL AS LONG, wantRedraw AS LONG)
       LOCAL j AS LONG
       GRAPHIC CLEAR
       GRAPHIC WIDTH 1
       IF ALL THEN cntarrow = 0  :  REDIM arrow()
       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 arrowwidth
    END SUB
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    FUNCTION Atn2(X AS DOUBLE, Y AS DOUBLE) AS DOUBLE
       'Atn2 optimized version. Simple but sufficient for this purpose.
       'Range of the result is 0 to 2pi radians.
       IF Y = 0 THEN Y = NearZero
       FUNCTION = (ATN(ABS(X)/ABS(Y)) * SGN(X) - Pi/2) * SGN(Y)
    END FUNCTION
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    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(mx AS DOUBLE, my AS DOUBLE, vx1 AS DOUBLE, vy1 AS DOUBLE, _
                          vx2 AS DOUBLE, vy2 AS DOUBLE) AS DOUBLE
       LOCAL dx, dy AS DOUBLE
       'mx, my are the mouse points
       IF (vx1 = vx2) THEN
          FUNCTION = ABS(vx1 - mx)
       ELSEIF vy1 = vy2 THEN
          FUNCTION = ABS(vy1 - my)
       ELSE
          dx = vx2 - vx1  :  dy = vy2 - vy1
          FUNCTION = ABS(dy*mx - dx*my + 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 AS DOUBLE
       'exit if the mouse click is past the endpoints of the line
       halflinew = linew/2
       IF (vx1 < vx2) THEN
          IF (mx < vx1 - MARGIN) OR (mx > vx2 + MARGIN) THEN EXIT FUNCTION
       ELSE
          IF (mx > vx1 + MARGIN) OR (mx < vx2 - MARGIN) THEN EXIT FUNCTION
       END IF
       IF (vy1 < vy2) THEN
          IF (my < vy1 - MARGIN) OR (my > vy2 + MARGIN) THEN EXIT FUNCTION
       ELSE
          IF (my > vy1 + MARGIN) OR (my < vy2 - MARGIN) THEN EXIT FUNCTION
       END IF
       distance = ABS(PointToLineDistance(mx, my, vx1, vy1, vx2, vy2))
       FUNCTION = (distance >= -halflinew-MARGIN) AND (distance <= halflinew+MARGIN)
    END FUNCTION
    
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    'eof
    Last edited by Petr Schreiber jr; 14 May 2008, 06:14 AM.
    [email protected]

    Comment


    • #3
      Thanks Petr.
      You are right. With more than twenty arrows starts some flicker.
      Modification you suggested solves the problem.

      Kind regards.
      Jordi

      Comment

      Working...
      X