Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
'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_Vertical
IDC_Filled
IDC_Clear
IDC_StatusBar
End Enum
Global hDlg,hGraphic As Dword, arrowRC As Rect
Global ArrowDrawInWork, OldGraphicProc,Vertical,Filled As Long
Function PBMain() As Long
Dialog New Pixels, 0, "gbArrow",300,300,300,200, %WS_OverlappedWindow To hDlg
Control Add CheckBox, hDlg, %IDC_Vertical,"Vertical", 10,7,70,20
Control Add CheckBox, hDlg, %IDC_Filled, "Filled",90,7,50,20
Control Add Button, hDlg, %IDC_Clear, "Clear",160,7,50,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_Filled : Filled Xor = 1 : DrawArrow
Case %IDC_Vertical : Vertical Xor= 1 : DrawArrow
Case %IDC_Clear : Reset arrowRC : 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.nTop = Hi(Integer, LParam)
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,r,s,LSH,RSH,LSV,RSV,V As Long, Arrow As ArrowType
Graphic Clear
'just to make typing easier in the equations
a = arrowRC.nLeft : b = arrowRC.nTop
c = arrowRC.nRight : d = arrowRC.nBottom
If a <= c And b >= d Then LSH = +1 : RSH = D : LSV = +1 : RSV = B : V = -1 'Q1
If a >= c And b >= d Then LSH = -1 : RSH = D : LSV = -1 : RSV = B : V = -1 'Q2
If a >= c And b <= d Then LSH = -1 : RSH = B : LSV = -1 : RSV = B : V = +1 'Q3
If a <= c And b <= d Then LSH = +1 : RSH = B : LSV = +1 : RSV = B : V = +1 'Q4
Reset arrow
arrow.count = 7
If Vertical Then
'vertical
r = Abs((d-b)\4) 'top-to-bottom divsions
s = Abs((c-a)\3) 'left-to-right divisions
arrow.x1 = a+LSV*s : arrow.y1 = RSV
arrow.x2 = a+LSV*s : arrow.y2 = RSV+3*r*V
arrow.x3 = a : arrow.y3 = RSV+3*r*V
arrow.x4 = (a+c)\2 : arrow.y4 = RSV+4*r*V
arrow.x5 = a+LSV*3*s : arrow.y5 = RSV+3*r*V
arrow.x6 = a+LSV*2*s : arrow.y6 = RSV+3*r*V
arrow.x7 = a+LSV*2*s : arrow.y7 = RSV
Else
'horizontal
r = Abs((c-a)\4) 'left-to-right divisions
s = Abs((d-b)\3) 'top-to-bottom divsions
arrow.x1 = a : arrow.y1 = RSH+s
arrow.x2 = a+LSH*3*r : arrow.y2 = RSH+s
arrow.x3 = a+LSH*3*r : arrow.y3 = RSH
arrow.x4 = a+LSH*4*r : arrow.y4 = (b+d)\2
arrow.x5 = a+LSH*3*r : arrow.y5 = RSH+3*s
arrow.x6 = a+LSH*3*r : arrow.y6 = RSH+2*s
arrow.x7 = a : arrow.y7 = RSH+2*s
End If
Graphic Polygon Arrow, %Color, %Color
Graphic ReDraw
Statusbar Set Text hDlg, %IDC_StatusBar, 1,0, "(" + Trim$(Str$(arrowRC.nLeft)) + "," + Trim$(Str$(arrowRC.nTop)) + ") - (" +_
Trim$(Str$(arrowRC.nRight)) + "," + Trim$(Str$(arrowRC.nBottom)) + ")"
End Sub
'gbs_01407
'Date: 10-17-2014
http://www.garybeene.com/sw/gbsnippets.htm