Draw Arrows at Angle

Date: 02-16-2022

Return to Index

 
'Compilable Example:  (Jose Includes)
#Compiler PBWin 10
#Compile Exe  "demo.exe"
#Dim All
 
#Debug Error On
#Debug Display On
 
%Unicode=1
#Include "Win32API.inc"   'Jose Roca Includes
%Color = %Blue
 
Type ArrowType
   count As Long
   x1 As Single
   y1 As Single
   x2 As Single
   y2 As Single
   x3 As Single
   y3 As Single
   x4 As Single
   y4 As Single
   x5 As Single
   y5 As Single
   x6 As Single
   y6 As Single
   x7 As Single
   y7 As Single
End Type
 
Enum Equates Singular
   IDC_Graphic = 500
   IDC_Filled
'   IDC_VH
   IDC_Clear
   IDC_StatusBar
End Enum
 
Global hDlg,hGraphic As Dword, arrowRC As Rect
Global ArrowDrawInWork, OldGraphicProc,Vertical,Filled,VH As Long
 
Function PBMain() As Long
   Dialog New Pixels, 0, "gbArrow",300,300,300,200, %WS_OverlappedWindow To hDlg
   Control Add Button, hDlg, %IDC_Clear, "Clear",10,7,50,20
   Control Add CheckBox, hDlg, %IDC_Filled, "Filled",100,7,50,20
'   Control Add CheckBox, hDlg, %IDC_VH,"Vert/Horz", 100,7,70,20
   Control Add Graphic, hDlg, %IDC_Graphic,"", 0,30,10,10, %WS_Visible Or %WS_Border Or %SS_Notify
   Control Handle hDlg, %IDC_Graphic To hGraphic
   OldGraphicProc = SetWindowLong(hGraphic, %GWL_WndProc, CodePtr(NewGraphicProc))  'subclass
   Graphic Attach hDlg, %IDC_Graphic, ReDraw
   Graphic Color %Color, %rgb_LightGray
   Graphic Clear
   Control Add Statusbar, hDlg, %IDC_StatusBar, "", 0,0,0,0
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Select Case Cb.Msg
      Case %WM_Command
         Select Case Cb.Ctl
            Case %IDC_Clear    : Reset arrowRC   : DrawArrow
            Case %IDC_Filled   : Filled Xor= 1   : DrawArrow
         End Select
      Case %WM_Destroy
         SetWindowLong hGraphic, %GWL_WNDPROC, OldGraphicProc
      Case %WM_Size
         ResizeWindow
   End Select
End Function
 
Sub ResizeWindow
   Local w,h,vw,vh As Long
   Dialog Get Client hDlg To w,h
   Control Set Size hDlg, %IDC_Graphic, w,h-30
End Sub
 
Function NewGraphicProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Local pt As Point,rc As Rect, i,iResult,ddx,ddy As Long
   Select Case Msg
       Case %WM_LButtonUp
          ArrowDrawInWork = 0
          ReleaseCapture
       Case %WM_LButtonDown
          ArrowDrawInWork = 1
          SetFocus
          SetCapture hGraphic
          arrowRC.nLeft = Lo(Integer,LParam) : arrowRC.nRight = arrowRC.nLeft
          arrowRC.nTop = Hi(Integer, LParam) : arrowRC.nBottom = arrowRC.nTop
       Case %WM_MouseMove
          If ArrowDrawInWork Then
             arrowRC.nRight = Lo(Integer,LParam)
             arrowRC.nBottom = Hi(Integer, LParam)
             DrawArrow
          End If
   End Select
   Function = CallWindowProc(OldGraphicProc, hWnd, Msg, wParam, lParam)
End Function
 
Sub DrawArrow
   Local a,b,c,d,e,f,dist As Single, Arrow As ArrowType, unit,rx,ry As Single
   Graphic Clear
   'just to make typing easier in the equations
   a = arrowRC.nLeft   :  b = arrowRC.nTop
   c = arrowRC.nRight  :  d = arrowRC.nBottom
   e = a + (c-a) * 2/3 :  f = b + (d-b) * 2/3
   rx = a-c   : ry = b-d
   dist = Sqr(rx*rx + ry*ry)
   rx /= dist : ry /= dist
   unit = 1/12 * dist
   arrow.count = 7
   arrow.x1 = a+unit*ry   : arrow.y1 = b-unit*rx
   arrow.x2 = e+unit*ry   : arrow.y2 = f-unit*rx
   arrow.x3 = e+2*unit*ry : arrow.y3 = f-2*unit*rx
   arrow.x4 = c           : arrow.y4 = d
   arrow.x5 = e-2*unit*ry : arrow.y5 = f+2*unit*rx
   arrow.x6 = e-unit*ry   : arrow.y6 = f+unit*rx
   arrow.x7 = a-unit*ry   : arrow.y7 = b+unit*rx
   Graphic Polygon Arrow, %Color, IIf(Filled,%Color,-2)
   Statusbar Set Text hDlg, %IDC_StatusBar, 1,0, "(" + Trim$(Str$(arrowRC.nLeft)) + "," + Trim$(Str$(arrowRC.nTop)) + ") - (" + Trim$(Str$(arrowRC.nRight)) + "," + Trim$(Str$(arrowRC.nBottom)) + ")"
   Graphic ReDraw
End Sub
 
'gbs_01408
'Date: 10-17-2014

created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm