|
Post by Walt Decker on Feb 17, 2022 16:10:04 GMT -5
Alternative arc function; renders normal or elliptical arcs
'
FUNCTION FN.Arch(GfxTag$, ArcStrt, ArcCentX, ArcCentY, DegOfArc, MinRadius, MajRadius) '############################################################################ ' PURPOSE: Render an equal or elliptical arc on a graphic target. 'Rendering of the arc is clockwise with zero degrees at geographical north. ' ' ARGUMENTS: ' GfxTag$: String representation of graphic control, e. g. "#DMO.GFX" ' ArcStrt: Starting degree, e. g. 125 ' ArcCentX: X center point of the arc circle in pixels. ' ArcCentY: Y center point of the arc circle in pixels. ' DegOfArc: Number of degrees to draw from the starting point. ' May be positive or negative ' MinRadius: Short radius leg. ' MajRadius: Long radius leg. ' ' NOTE: For a regular (Non-elliptical arc) make the radii equal. If ' the minor radius is greater than the major radius the arc will be ' elliptical horizontally. If the minor radius is less than the major ' radius the arc will be elliptical vertically. ' '############################################################################
Rad = 0 '<--- Radians
ArcEnd = 0 '<--- Ending degrees RetVal = 0 '<--- Return value from a function
Xs = 0 '<--- Where to start rendering Ys = 0
X = 0 '<--- End of line Y = 0
I = 0 '<--- degree counter
Rad = 4 * ATN(1) / 180.0 ArcEnd = ArcStrt + DegOfArc
RetVal = FN.Swap.If(ArcEnd, ArcStrt) RetVal = FN.Swap.If(ArchStrt, ArcEnd) '<--- added to account for negative degrees of arc Xs = ArcCentX + MinRadius * SIN(ArcStrt * rad) Ys = ArcCentY - MajRadius * COS(ArcStrt * rad)
PRINT #GfxTag$, "down"
FOR I = ArcStrt TO ArcEnd X = ArcCentX + MinRadius * SIN(I * rad) Y = ArcCenY - MajRadius * COS(I * rad) PRINT #GfxTag$, "LINE "; Xs;" ";Ys;" ";X;" ";Y Xs = X Ys = Y NEXT I
END FUNCTION
'-------------------------------------------------------------- '--------------------------------------------------------------
FUNCTION FN.Swap.If(BYREF Compare.1, BYREF Compare.2)
Swap = 0
IF Compare.1 > Compare.2 THEN Swap = Compare.1 Compare.1 = Compare.2 Compare.2 = Swap END IF
FN.Swap.If = Swap END FUNCTION
'
|
|
bplus
Full Member
Posts: 127
|
Post by bplus on Feb 17, 2022 18:37:27 GMT -5
Alternative arc function; renders normal or elliptical arcs '
FUNCTION FN.Arch(GfxTag$, ArcStrt, ArcCentX, ArcCentY, DegOfArc, MinRadius, MajRadius) '############################################################################ ' PURPOSE: Render an equal or elliptical arc on a graphic target. 'Rendering of the arc is clockwise with zero degrees at geographical north. ' ' ARGUMENTS: ' GfxTag$: String representation of graphic control, e. g. "#DMO.GFX" ' ArcStrt: Starting degree, e. g. 125 ' ArcCentX: X center point of the arc circle in pixels. ' ArcCentY: Y center point of the arc circle in pixels. ' DegOfArc: Number of degrees to draw from the starting point. ' May be positive or negative ' MinRadius: Short radius leg. ' MajRadius: Long radius leg. ' ' NOTE: For a regular (Non-elliptical arc) make the radii equal. If ' the minor radius is greater than the major radius the arc will be ' elliptical horizontally. If the minor radius is less than the major ' radius the arc will be elliptical vertically. ' '############################################################################
Rad = 0 '<--- Radians
ArcEnd = 0 '<--- Ending degrees RetVal = 0 '<--- Return value from a function
Xs = 0 '<--- Where to start rendering Ys = 0
X = 0 '<--- End of line Y = 0
I = 0 '<--- degree counter
Rad = 4 * ATN(1) / 180.0 ArcEnd = ArcStrt + DegOfArc
RetVal = FN.Swap.If(ArcEnd, ArcStrt) RetVal = FN.Swap.If(ArchStrt, ArcEnd) '<--- added to account for negative degrees of arc Xs = ArcCentX + MinRadius * SIN(ArcStrt * rad) Ys = ArcCentY - MajRadius * COS(ArcStrt * rad)
PRINT #GfxTag$, "down"
FOR I = ArcStrt TO ArcEnd X = ArcCentX + MinRadius * SIN(I * rad) Y = ArcCenY - MajRadius * COS(I * rad) PRINT #GfxTag$, "LINE "; Xs;" ";Ys;" ";X;" ";Y Xs = X Ys = Y NEXT I
END FUNCTION
'-------------------------------------------------------------- '--------------------------------------------------------------
FUNCTION FN.Swap.If(BYREF Compare.1, BYREF Compare.2)
Swap = 0
IF Compare.1 > Compare.2 THEN Swap = Compare.1 Compare.1 = Compare.2 Compare.2 = Swap END IF
FN.Swap.If = Swap END FUNCTION
'
Just asking to show me the code you tested this on?
|
|
bplus
Full Member
Posts: 127
|
Post by bplus on Feb 17, 2022 18:51:07 GMT -5
2 typos fixed and "rad"'s to "Rad"'s and it's finally drawing something.
Seems slower:
global H$, XMAX, YMAX, PI, DEG, RAD H$ = "gr" XMAX = 500 '<======================================== actual drawing space needed YMAX = 500 '<======================================== actual drawing space needed PI = acs(-1) DEG = 180 / PI RAD = PI / 180
nomainwin
WindowWidth = XMAX + 8 WindowHeight = YMAX + 32 UpperLeftX = (1200 - XMAX) / 2 'or delete if XMAX is 1200 or above UpperLeftY = (700 - YMAX) / 2 'or delete if YMAX is 700 or above
open "Spinner" for graphics_nsb_nf as #gr '<======================= title #gr "setfocus" #gr "trapclose quit" #gr "down" #gr "fill black" #gr "size 15" While 1 For r = 20 To 200 Step 20 scan a = b * r / 40 #gr "color blue" 'FN.Arch(GfxTag$, ArcStrt, ArcCentX, ArcCentY, DegOfArc, MinRadius, MajRadius) temp = FN.Arch("#gr", a, 250, 250, 165, r-10, r-10) 'call arc 250, 250, r - 10, a, 165 #gr "color red" temp = FN.Arch("#gr", a + 180, 250, 250, 165, r-10, r-10) 'call arc 250, 250, r - 10, a+ 180, 165 Next b = b + 2 call pause 20 Wend wait
sub arc xCenter, yCenter, arcRadius, dAStart, dAMeasure 'notes: 'you may want to adjust size and color for line drawing 'using angle measures in degrees to match Just Basic ways with pie and piefilled 'this sub assumes drawing in a CW direction if dAMeasure positive
'for Just Basic angle 0 degrees is due East and angle increases clockwise towards South
'dAStart is degrees to start Angle, due East is 0 degrees
'dAMeasure is degrees added (Clockwise) to dAstart for end of arc
rAngleStart = RAD * dAStart rAngleEnd = RAD * dAMeasure + rAngleStart Stepper = RAD* 180/ arcRadius 'fixed lastX = xCenter + arcRadius * cos(rAngleStart) lastY = yCenter + arcRadius * sin(rAngleStart) #gr "set ";int(lastX);" ";int(lastY) for rAngle = rAngleStart+Stepper to rAngleEnd step Stepper nextX = xCenter + arcRadius * cos(rAngle) nextY = yCenter + arcRadius * sin(rAngle) #gr "goto ";int(nextX);" ";int(nextY) 'int speeds things up next end sub
sub pause mil 'tsh version has scan built-in t0 = time$("ms") while time$("ms") < t0 + mil : scan : wend end sub
sub quit H$ close #H$ '<=== this needs Global H$ = "gr" end 'Thanks Facundo, close graphic wo error end sub
FUNCTION FN.Arch(GfxTag$, ArcStrt, ArcCentX, ArcCentY, DegOfArc, MinRadius, MajRadius) '############################################################################ ' PURPOSE: Render an equal or elliptical arc on a graphic target. 'Rendering of the arc is clockwise with zero degrees at geographical north. ' ' ARGUMENTS: ' GfxTag$: String representation of graphic control, e. g. "#DMO.GFX" ' ArcStrt: Starting degree, e. g. 125 ' ArcCentX: X center point of the arc circle in pixels. ' ArcCentY: Y center point of the arc circle in pixels. ' DegOfArc: Number of degrees to draw from the starting point. ' May be positive or negative ' MinRadius: Short radius leg. ' MajRadius: Long radius leg. ' ' NOTE: For a regular (Non-elliptical arc) make the radii equal. If ' the minor radius is greater than the major radius the arc will be ' elliptical horizontally. If the minor radius is less than the major ' radius the arc will be elliptical vertically. ' '############################################################################
Rad = 0 '<--- Radians
ArcEnd = 0 '<--- Ending degrees RetVal = 0 '<--- Return value from a function
Xs = 0 '<--- Where to start rendering Ys = 0
X = 0 '<--- End of line Y = 0
I = 0 '<--- degree counter
Rad = 4 * ATN(1) / 180.0 ArcEnd = ArcStrt + DegOfArc
RetVal = FN.Swap.If(ArcEnd, ArcStrt) RetVal = FN.Swap.If(ArcStrt, ArcEnd) '<--- added to account for negative degrees of arc Xs = ArcCentX + MinRadius * SIN(ArcStrt * Rad) Ys = ArcCentY - MajRadius * COS(ArcStrt * Rad)
PRINT #GfxTag$, "down"
FOR I = ArcStrt TO ArcEnd X = ArcCentX + MinRadius * SIN(I * Rad) Y = ArcCentY - MajRadius * COS(I * Rad) PRINT #GfxTag$, "LINE "; Xs;" ";Ys;" ";X;" ";Y Xs = X Ys = Y NEXT I
END FUNCTION
'-------------------------------------------------------------- '--------------------------------------------------------------
FUNCTION FN.Swap.If(BYREF Compare.1, BYREF Compare.2)
Swap = 0
IF Compare.1 > Compare.2 THEN Swap = Compare.1 Compare.1 = Compare.2 Compare.2 = Swap END IF
FN.Swap.If = Swap END FUNCTION
True doing elliptic arcs is more versatile than just circular.
|
|
|
Post by Walt Decker on Feb 18, 2022 0:40:31 GMT -5
Code used to test:
' #COMPILE EXE "ArcTest"
#INCUDE "CONSOLE.BI"
#DEBUG ERROR ON #DEBUG DISPLAY ON #BREAK ON
#DIM ALL
FUNCTION PBMAIN() AS LONG
LOCAL WinHndl AS DWORD
LOCAL Cx, _ Cy AS SINGLE
LOCAL StrtPos, _ DegOffset AS SINGLE
lOCAL RadiLong, _ RadiShort AS SINGLE
GRAPHIC WINDOW NEW "Test", 100, 100, 300, 300, WinHndl
Cx = 150 Cy = 150 RadiLong = 40 RadiShort = 90 StrtPos = 45 DegOffset = -90
FN_Arch(WinHndl, DegStrt, DegOffset, Cx, Cy RadiLong, RadiShort)
WAITKEY$ GRAPHIC WINDOW END END FUNCTION
'-------------------------------------------------------- '--------------------------------------------------------
FUNCTION FN_Arch(BYVAL Hndl AS DWORD, BYVAl DegPos AS SINGLE, _ BYVAL Offset AS SINGLE, BYVAL CenX AS SINGLE, BYVAL CenY AS SINGLG, _ BYVAL ShortLeg AS SINGLE, BYVAL LongLeg AS SINGLE) AS LONG
LOCAL Rad AS SINGLE
LOCAL DegEnd AS SINGLE
LOCAL Xs, _ Ys, _ X, _ Y AS SINGLE
LOCAL I AS SINGLE
Rad = 4 * ATN(1) / 180.0
DegEnd = DegPos + Offset IF DegEnd > DegPos THEN SWAP DegEnd, DegPos IF DegPos > DegEnd THEN SWAP DegEnd, DegPos
Xs = CenX + ShortLeg * SIN(DegPos * Rad) Ys = CenY - LongLeg * COS(DegPos * Rad)
GRAPHIC ATTACH Hndl, 0
FOR I = DegPos TO DegEnd X = CenX + ShortLeg * SIN(DegPos * Rad) Y = CenY - LongLeg * COS(DegPos * Rad) GRAPHIC LINE (X, Y) - (Xs, Ys), 0 Xs = X Ys = Y NEXT I
GRAPHIC DETACH
END FUNCTION '
|
|
bplus
Full Member
Posts: 127
|
Post by bplus on Feb 18, 2022 1:55:13 GMT -5
Code used to test: ' #COMPILE EXE "ArcTest"
#INCUDE "CONSOLE.BI"
#DEBUG ERROR ON #DEBUG DISPLAY ON #BREAK ON
#DIM ALL
FUNCTION PBMAIN() AS LONG
LOCAL WinHndl AS DWORD
LOCAL Cx, _ Cy AS SINGLE
LOCAL StrtPos, _ DegOffset AS SINGLE
lOCAL RadiLong, _ RadiShort AS SINGLE
GRAPHIC WINDOW NEW "Test", 100, 100, 300, 300, WinHndl
Cx = 150 Cy = 150 RadiLong = 40 RadiShort = 90 StrtPos = 45 DegOffset = -90
FN_Arch(WinHndl, DegStrt, DegOffset, Cx, Cy RadiLong, RadiShort)
WAITKEY$ GRAPHIC WINDOW END END FUNCTION
'-------------------------------------------------------- '--------------------------------------------------------
FUNCTION FN_Arch(BYVAL Hndl AS DWORD, BYVAl DegPos AS SINGLE, _ BYVAL Offset AS SINGLE, BYVAL CenX AS SINGLE, BYVAL CenY AS SINGLG, _ BYVAL ShortLeg AS SINGLE, BYVAL LongLeg AS SINGLE) AS LONG
LOCAL Rad AS SINGLE
LOCAL DegEnd AS SINGLE
LOCAL Xs, _ Ys, _ X, _ Y AS SINGLE
LOCAL I AS SINGLE
Rad = 4 * ATN(1) / 180.0
DegEnd = DegPos + Offset IF DegEnd > DegPos THEN SWAP DegEnd, DegPos IF DegPos > DegEnd THEN SWAP DegEnd, DegPos
Xs = CenX + ShortLeg * SIN(DegPos * Rad) Ys = CenY - LongLeg * COS(DegPos * Rad)
GRAPHIC ATTACH Hndl, 0
FOR I = DegPos TO DegEnd X = CenX + ShortLeg * SIN(DegPos * Rad) Y = CenY - LongLeg * COS(DegPos * Rad) GRAPHIC LINE (X, Y) - (Xs, Ys), 0 Xs = X Ys = Y NEXT I
GRAPHIC DETACH
END FUNCTION '
Really? Is that LB? Since when does LB do Types, and there are still more typos. How about a screen shot?
|
|
rnbw
New Member
Posts: 48
|
Post by rnbw on Feb 18, 2022 11:20:53 GMT -5
' '############################################################### ' SYNCRONIZED EDIT CONTROLS ' NUMBERMANDLL IS HERE: https://libertybasiccom.proboards.com/thread/1400/numbers ' CTL_COLOR IS HERE: https://libertybasiccom.proboards.com/board/9/api-dll-code '###############################################################
'<-------------- CONTROL STYLES -----------> WS.VSCROLL = HEXDEC("&H00200000") WS.HSCROLL = HEXDEC("&H00100000") WS.VISIBLE = HEXDEC("&H10000000") WS.CHILD = HEXDEC("&H40000000")
ES.MULTILINE = HEXDEC("&H0004") ES.AUTOHSCROLL = HEXDEC("&H0080") ES.AUTOVSCROLL = HEXDEC("&H0040") ES.WANTRETURN = HEXDEC("&H1000") ES.NOHIDESEL = HEXDEC("&H0100")
'<--------- EDIT CONTROL MESSAGES ----------> EM.GETTHUMB = HEXDEC("&H00BE") EM.LINEFROMCHAR = HEXDEC("&H00C9") EM.GETSEL = HEXDEC("&H00B0") EM.LINESCROLL = HEXDEC("&H00B6")
VK.LBUTTON = 1 '<--- left mouse button VK.RETURN = HEXDEC("&H0D") '<--- keyboard enter key
SB.VERT = 1 '<--- scroll bar type
'<--------- COLORS ----------> TXTRED = 255 TXTCORNSILK = HEXDEC("&HDCF8FF")
OPEN "User32.dll" FOR DLL AS #USER OPEN "NUMBERMANDLL" FOR DLL AS #NUM OPEN "CTL_COLOR.DLL" FOR DLL AS #CLRCTRL
I = 0 '<--- counters J = 0 K = 0
CtlHndl = 0
CtlLow = 0 '<--- lowest control ID number 'each control on a form window 'is given a unique ID number. 'this is used to calculate the 'element of Handles$() to use.
LstThumb = 0 '<--- scroll bar thumb position. The 'thumb is the box in the scroll bar. LstCtrl = 0 '<--- the control that last had the focus 'used if none of the list boxes has the 'focus. LstLine = 0 Ubnd = 2 '<--- number of row elements in Handles$()
CRLF$ = CHR$(13) + CHR$(10)
DIM Lft$(50) DIM Mdl$(50) DIM Rgt$(50) DIM Handles$(2, 2)
'<--------------- FILL ARRAY FOR INSERTION INTO EACH CONTROL ------> J = 50 K = 50 FOR I = 0 TO 50 Lft$(I) = STR$(I) + CRLF$ '<--- add CRLF for each line K = K + 1 Mdl$(I) = STR$(K) + CRLF$ J = J - 1 Rgt$(I) = STR$(J) + CRLF$ NEXT I
Handles$(0, 0) = "#DMO.TXBL" Handles$(1, 0) = "#DMO.TXBM" Handles$(2, 0) = "#DMO.TXBR"
Style = WS.VSCROLL OR ES.MULTILINE OR ES.AUTOVSCROLL OR ES.WANTRETURN OR _ ES.CHILD OR ES.WANTRETURN OR ES.NOHIDESEL
STYLEBITS #DMO.TXBL, Style, WS.HSCROLL OR ES.AUTHOHSCROLL, 0, 0 STYLEBITS #DMO.TXBM, Style, WS.HSCROLL OR ES.AUTHOHSCROLL, 0, 0 STYLEBITS #DMO.TXBR, Style, WS.HSCROLL OR ES.AUTHOHSCROLL, 0, 0
TEXTBOX #DMO.TXBL, 5, 5, 75, 65 TEXTBOX #DMO.TXBM, 80, 5, 75, 65 TEXTBOX #DMO.TXBR, 155, 5, 75, 65
OPEN "TBX" FOR WINDOW AS #DMO
Handles$(0, 1) = STR$(FN.GetHandle("DMO.TXBL")) '<--- get edit control handles Handles$(1, 1) = STR$(FN.GetHandle("DMO.TXBM")) Handles$(2, 1) = STR$(FN.GetHandle("DMO.TXBR"))
CtlHndl = FN.GetHandle("#DMO.TXBL") LstCtrl = CtlHndl
CtlId = FN.GetCtlId(CtlHndl) '<--- get listbox control ID number 'the fist listbox defined will have the 'lowest ID number CtlLow = CtlId '<--- set for later calculations
'<-------- SET EDIT CONTROL PROPERTIES FOR CTL_COLOR.DLL -------------> RetVal = FN.SetCtrlColor("#DMO.TXBL", "TEXT", "BKG", TXTRED, TXTCORNSILK) RetVal = FN.SetCtrlColor("#DMO.TXBM", "TEXT", "BKG", 1, TXTCORNSILK) RetVal = FN.SetCtrlColor("#DMO.TXBR", "TEXT", "BKG", 1, TXTCORNSILK)
'<----------- INITIALIZE CTL_COLOR.DLL --------------> RetVal = FN.InitClrCtrl("#DMO", "TEXT", "BKG", 0, 0)
'<-------------- PUT DATA IN EDIT CONTROLS ----------> RetVal = FN.PopulateCtrl("#DMO.TXBL", 50, 1) RetVal = FN.PopulateCtrl("#DMO.TXBM", 50, 2) RetVal = FN.PopulateCtrl("#DMO.TXBR", 50, 3)
'<--------- SET THE CARET TO THE TOP ----------> RetVal = FN.SetSelect("DMO.TXBL", 0, 0) RetVal = FN.SetSelect("DMO.TXBM", 0, 0) RetVal = FN.SetSelect("DMO.TXBR", 0, 0)
'<---------- SCROLL THE TEXT INTO VIEW --------> RetVal = FN.ScrollCaret("DMO.TXBL") RetVal = FN.ScrollCaret("DMO.TXBM") RetVal = FN.ScrollCaret("DMO.TXBR")
PRINT #DMO, "TRAPCLOSE END.DMO"
PRINT #DMO.TXBL, "!SETFOCUS"
[BEGIN.TIMER] '<--- begin event trap TIMER 100, [GET.SCROLL]
WAIT
'------------------------------------------------------ '------------------------------------------------------
[GET.SCROLL] '##################################################### ' This is the work-horse of the demo. It is similar to ' a windows callback function except it does not fire ' all the time. Normally I would put most of this in ' functions but I think that keeping it together is a ' little more instructive. '#####################################################
RetVal = 0 '<--- mostly a dummy variable CtlHndl = 0 '<--- handle of current control ArayPos = 0 '<--- row element of Handles$() 'calculated using the current 'control Id and CtlLow AryElm = 0
CurScroll= 0 '<--- current position of the 'scroll bar thumb Clicked = 0 '<--- value indicating whether the 'left mouse button was clicked LineNum = 0 LineLen = 0 ChrIdx = 0
Ulx = 0 '<--- control size/position Uly = 0 Brx = 0 Bry = 0
Cpx = 0 '<--- client position of mouse cursor Cpy = 0
Wcpx = 0 '<--- screen position of mouse cursor Wcpy = 0
I = 0 '<--- counter
HndlStr$ = "" '<--- control tag e. g. "#DMO.LBXL"
CtlHndl = FN.GetFocus() '<--- control or window with focus CtlId = FN.GetCtlId(CtlHndl) '<--- control ID number ArayPos = CtlId - CtlLow '<--- calculate row element of Handles$()
IF (ArayPos < 0) OR (ArayPos > Ubnd) THEN '<--- if a control looses RetVal = FN.SetFocus(LstCtrl) 'the focus set it back to GOTO [BEGIN.TIMER] 'the last control END IF
LstCtrl = CtlHndl '<--- set the last control to the current control
Clicked = FN.KeyState(VK.LBUTTON) '<--- check left mouse button
IF Clicked THEN RetVal = FN.ClientSize(CtlHndl, Brx, Bry) '<--- get edit client area RetVal = FN.CursorPos(Cpx, Cpy) '<--- where the cursor is Wcpx = Cpx '<--- save position for possible later use Wcpy = Cpy
RetVal = FN.ScreenToClient(CtlHndl, Cpx, Cpy) '<--- translate mouse coords IF (Cpx >= 0) AND (Cpx <= Brx) THEN '<--- is mouse in client area IF (Cpy >= 0) AND (Cpy <= Bry) THEN
RetVal = FN.GetSel(Handles$(ArayPos, 0)) '<--- where the caret is
'<---------------- GET CHARACTER POSITION ---------------------> CALLDLL #NUM, "FN_GetLowWord", RetVal AS LONG, Wcpx AS LONG CALLDLL #NUM, "FN_GetHiWord", RetVal AS LONG, Wcpy AS LONG
'<--------- LINE WHERE THE CARET IS ------------------------> LineNum = FN.GetLine(Handles$(ArayPos, 0), Wcpx, 0)
FOR I = 0 TO Ubnd ChrIdx = FN.LineChrIndex(Handles$(I, 0), LineNum) '<--- 1st character on 'line LineLen = FN.GetLineLen(Handles$(I, 0), LineNum) '<--- line length '<--------------- select the line --------------> RetVal = FN.SetSelect(Handles$(I, 0), ChrIdx, ChrIdx + LineLen) RetVal = FN.ScrollCaret(Handles$(I, 0)) '<--- scroll line into view 'may be a slight offset in 'other edit controls NEXT I GOTO [BEGIN.TIMER] END IF ELSE '<--- mouse cursor is not in client area CtlHndl = FN.WinFromPnt(Wcpx, Wcpy, Ubnd, AryElm) '<--- where the cursor is
IF CtlHndl < 0 THEN GOTO [BEGIN.TIMER] '<--- something else was clicked
RetVal = FN.SetFocus(CtlHndl) '<--- focus on new ctrl LstThumb = FN.SetThumb(CtlHndl, AryElm, Ubnd) '<--- scroll other 'edit controls END IF END IF
GOTO [BEGIN.TIMER] [GET.SCROLL.END]
'------------------------------------------------------ '------------------------------------------------------
SUB END.DMO Win$
WinHndl = FN.GetHandle(Win$) CALLDLL #CLRCTRL, "FN_CLOSE", WinHndl AS ULONG CLOSE #USER CLOSE #CLRCTRL CLOSE #NUM CLOSE #DMO END END SUB
'----------------------------------------------------- '-----------------------------------------------------
FUNCTION FN.CheckHandle$(Tag$)
IF LEFT$(Tag$, 1) <> "#" THEN Tag$ = "#" + Tag$
FN.CheckHandle$ = Tag$ END FUNCTION
'----------------------------------------------------- '-----------------------------------------------------
FUNCTION FN.GetHandle(WinTag$)
Handle = 0 WinTag$ = FN.CheckHandle$(WinTag$)
Handle = HWND(#WinTag$) FN.GetHandle = Handle END FUNCTION
'-------------------------------------------------------------------- '--------------------------------------------------------------------
FUNCTION FN.GetCtlId(CtlHndl) '################################################################ ' Each control has a numeric ID number. This module gets that ' ID number '################################################################
CtlId = 0 CALLDLL #USER, "GetDlgCtrlID", CtlHndl AS ULONG, CtlId AS LONG
FN.GetCtlId = CtlId END FUNCTION
'-------------------------------------------------------------------- '--------------------------------------------------------------------
FUNCTION FN.GetFocus() '################################################################ ' This module finds the control or window that has the focus. ' Only a window or control that has the focus can receive input ' vias the keyboard or the mouse. '################################################################
CtlHndl = 0 CALLDLL #USER, "GetFocus", CtlHndl AS ULONG
FN.GetFocus = CtlHndl END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.SetFocus(CtrlHndl) '################################################################ ' This module sets the window or control so it can receive input ' from the mouse or keyboard '################################################################
RetVal = 0 CALLDLL #USER, "SetFocus", CtrlHndl AS ULONG, RetVal AS VOID
END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.ScrollPos(CtlHndl) '################################################################ ' Retrieve the position of the scroll bar thumb, i. e. then box ' in the scroll bar. The API function GetScrollPos() is obsolete ' but can still be used. The preferred method is to use the ' GetScrollInfo() function, but GetScrollPos() is a little ' easier to understand. '################################################################
SB.VERT = 1
CurPos = 0 CALLDLL #USER, "GetScrollPos", CtlHndl AS ULONG, SB.VERT AS LONG, _ CurPos AS LONG
FN.ScrollPos = CurPos
END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.ClientSize(WinHndl, BYREF Bx, BYREF By) '################################################################ ' Retrieve the client area of a window (form or control). Since ' the upper left corner of the client area is always zero, zero ' the size of the client area is determined by the lower right ' corner of the client rectangle. ' ' ARGUMENTS: ' WinHndl: Handle of the window (form or control). ' Bx, By: Lower right corner of the client rectangle '################################################################
STRUCT tRect, _ X AS LONG, _ Y AS LONG, _ X1 AS LONG, _ Y1 AS LONG
RetVal = 0 '<--- dummy variable CALLDLL #USER, "GetClientRect", WinHndl AS ULONG, tRect AS STRUCT, _ RetVal AS VOID
Bx = tRect.X1.struct By = tRect.Y1.struct END FUNCTION
'--------------------------------------------------------------- '---------------------------------------------------------------
FUNCTION FN.WindowSize(Hndl, BYREF Ux, BYREF Uy, BYREF Bx, BYREF By) '################################################################ ' Retrieve the total size of the window or control '################################################################
STRUCT tRect, _ X AS LONG, _ Y AS LONG, _ X1 AS LONG, _ Y1 AS LONG
CALLDLL #USER, "GetWindowRect", Hndl AS ULONG, tRect AS STRUCT, RetVal AS VOID
Ux = tRect.X.struct Uy = tRect.Y.struct Bx = tRect.X1.struct By = tRect.Y1.struct
END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.KeyState(Vkey) '################################################################ ' Determine whether Vkey is pressed '################################################################
VK.SHIFT = HEXDEC("&H10") '<--- keyboard shift key VK.CONTROL = HEXDEC("&H11") '<--- keyboard control key
KeyPressed = 0
Value = 0
Mask = HEXDEC("&H8000") '<--- value used to determine if the 'pressed bit is set
'<--- the following checks to see if 2 keys are pressed at the same time ---> CALLDLL #USER, "GetAsyncKeyState", VK.SHIFT AS LONG, KeyPressed AS SHORT IF KeyPressed AND Mask THEN CALLDLL #USER, "GetAsyncKeyState", Vkey AS LONG, KeyPressed AS SHORT IF KeyPressed AND Mask THEN FN.KeyState = 2 EXIT FUNCTION END IF END IF
CALLDLL #USER, "GetAsyncKeyState", VK.CONTROL AS LONG, KeyPressed AS SHORT IF KeyPressed AND Mask THEN CALLDLL #USER, "GetAsyncKeyState", Vkey AS LONG, KeyPressed AS SHORT IF KeyPressed AND Mask THEN FN.KeyState = 2 EXIT FUNCTION END IF END IF
'<--- only the Vkey parameter is pressed -----------> CALLDLL #USER, "GetAsyncKeyState", Vkey AS LONG, KeyPressed AS SHORT
IF KeyPressed AND Mask THEN FN.KeyState = 1
END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.CursorPos(BYREF Cpx, BYREF Cpy) '################################################################ ' Retrieve the position of the mouse cursor. The position is ' in screen coordinates. '################################################################
STRUCT tPnt, _ X AS LONG, _ Y AS LONG
RetVal = 0 CALLDLL #USER, "GetCursorPos", tPnt AS STRUCT, RetVal AS VOID
Cpx = tPnt.X.struct Cpy = tPnt.Y.struct END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.ScreenToClient(WinHndl, BYREF Cpx, BYREF Cpy) '################################################################ ' Translate screen coordinates to window or control client ' coordinates. Client coordinages are those coordinates that ' are not caption or border. '################################################################
STRUCT tPnt, _ X AS LONG, _ Y AS LONG
RetVal = 0 tPnt.X.struct = Cpx tPnt.Y.struct = Cpy
CALLDLL #USER, "ScreenToClient", WinHndl AS ULONG, tPnt AS STRUCT, _ RetVal AS VOID
Cpx = tPnt.X.struct Cpy = tPnt.Y.struct END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.FindLbx(NumElms, Cpx, Cpy) '################################################################ ' Find the list box that contains the mouse cursor when the left ' mouse button was clicked. This module uses the entire window ' size since the mouse coordinates are in window coordinates. '################################################################
Ulx = 0 Uly = 0 Brx = 0 Bry = 0 Crx = 0 Cry = 0
RetVal = 0 CtlHndl = 0
FOR I = 0 TO NumElms CtlHndl = VAL(Handles$(I, 1))
'<---- get the window coordinates of the list box -------> RetVal = FN.WindowSize(CtlHndl, Ulx, Uly, Brx, Bry)
IF (Cpx >= Ulx) AND (Cpx <= Brx) THEN '<--- is the mouse cursor in this IF (Cpy >= Uly) AND (Cpy <= Bry) THEN 'list box? FN.FindLbx = CtlHndl EXIT FUNCTION END IF END IF NEXT I END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.PopulateCtrl(CtrlTag$, UbndAry, Idx) '################################################# ' Populate edit controls '#################################################
EM.SETSEL = HEXDEC("&H00B1") '<--- edti control messages EM.REPLACESEL = HEXDEC("&H00C2")
NumChrs = 0 '<--- total number of characters in edit control RetVal = 0 '<--- dummy value
TxtOut$ = "" '<--- add to edit control
CtlHndl = FN.GetHandle(CtrlTag$)
FOR I = 0 TO UbndAry '<------ # of characters in control ----------> CALLDLL #USER, "GetWindowTextLengthA", CtlHndl AS ULONG, NumChrs AS LONG NumChrs = NumChrs + 1 '<------------ set character position for insert --------> CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, EM.SETSEL AS ULONG, _ NumChrs AS LONG, NumChrs AS LONG, RetVal AS VOID
SELECT CASE Idx '<--- which array to use CASE 1 TxtOut$ = Lft$(I) CASE 2 TxtOut$ = Mdl$(I) CASE 3 TxtOut$ = Rgt$(I) END SELECT
'<---------- insert text at end of total text in control ---------> CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, EM.REPLACESEL AS ULONG, _ 1 AS LONG, TxtOut$ AS PTR, RetVal AS VOID next I END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.SetCtrlColor(CtlTag$, TxtKey$, BkgKey$, TxtClr, BkgClr)
CtrlHndl = 0 RetVal = 0
CtrlHndl = FN.GetHandle(CtlTag$)
CALLDLL #USER, "SetPropA", CtrlHndl AS ULONG, TxtKey$ AS PTR, _ TxtClr AS ULONG, RetVal AS LONG CALLDLL #USER, "SetPropA", CtrlHndl AS ULONG, BkgKey$ AS PTR, _ BkgClr AS ULONG, RetVal AS LONG
END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.InitClrCtrl(WinTag$, TxtKey$, BkgKey$, WinClr, BmpTrue)
WinHndl = 0 RetVal = 0
WinHndl = FN.GetHandle(WinTag$)
CALLDLL #CLRCTRL, "FN_InitProperties", WinHndl AS ULONG, _ TxtKey$ AS PTR, BkgKey$ AS PTR, _ WinClr AS ULONG, BmpTrue AS LONG, RetVal AS LONG
FN.InitClrCtrl = RetVal END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.SetSelect(CtlTag$, ChrStrt, ChrEnd)
EM.SETSEL = HEXDEC("&H00B1")
CtlHndl = 0 RetVal = 0
CtlHndl = FN.GetHandle(CtlTag$)
CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, EM.SETSEL AS ULONG, _ ChrStrt AS LONG, ChrEnd AS LONG, RetVal AS VOID
END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.ScrollCaret(CtlTag$) '################################################## ' scroll the caret into view if necessary '##################################################
EM.SCROLLCARET = HEXDEC("&H00B7")
CtlHndl = 0 RetVal = 0
CtlHndl = FN.GetHandle(CtlTag$) CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, EM.SCROLLCARET AS ULONG, _ 0 AS LONG, 0 AS LONG, RetVal AS VOID
END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.GetSel(CtlTag$)
EM.GETSEL = HEXDEC("&H00B0")
CtlHndl = 0 SelPos = 0
CtlHndl = FN.GetHandle(CtlTag$) CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, EM.GETSEL AS ULONG, _ 0 AS LONG, 0 AS LONG, SelPos AS LONG
FN.GetSel = SelPos END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------ FUNCTION FN.GetLine(CtlTag$, StrtChr, EndChr)
EM.LINEFROMCHAR = HEXDEC("&H00C9")
CtlHndl = 0 LineNum = 0
CtlHndl = FN.GetHandle(CtlTag$)
CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, _ EM.LINEFROMCHAR AS ULONG, StrtChr AS LONG, _ EndChr AS LONG, LineNum AS LONG
FN.GetLine = LineNum END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.LineChrIndex(CtlTag$, LineNum)
EM.LINEINDEX = HEXDEC("&H00BB")
CtlHndl = 0 ChrIdx = 0
CtlHndl = FN.GetHandle(CtlTag$) CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, EM.LINEINDEX AS ULONG, _ LineNum AS LONG, 0 AS LONG, ChrIdx AS LONG
FN.LineChrIndex = ChrIdx END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.GetLineLen(CtlTag$, LineNum)
EM.LINELENGTH = HEXDEC("&H00C1")
CtlHndl = 0 LineLen = 0
CtlHndl = FN.GetHandle(CtlTag$) CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, EM.LINELENGTH AS ULONG, _ LineNum AS LONG, 0 AS LONG, LineLen AS LONG
FN.GetLineLen = LineLen END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.WinFromPnt(PntX, PntY, Ubnd, BYREF AryPos)
Ux = 0 Uy = 0 Bx = 0 By = 0
Found = 0 RetVal = 0 CtlHndl = 0
FOR I = 0 TO Ubnd CtlHndl = VAL(Handles$(I, 1)) RetVal = FN.WindowSize(CtlHndl, Ux, Uy, Bx, By) Found = -1 IF (PntX >= Ux) AND (PntX <= Bx) THEN IF (PntY >= Uy) AND (PntY <= By) THEN Found = I EXIT FOR END IF END IF NEXT I
IF Found > -1 THEN FN.WinFromPnt = CtlHndl AryPos = Found EXIT FUNCTION END IF
FN.WinFromPnt = Found END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
FUNCTION FN.SetThumb(CtlHndl, ArayPos, Ubnd)
SB.LINEUP = 0 '<--- which way to scroll SB.LINEDOWN = 1
EM.SCROLL = HEXDEC("&H00B5") 'EM.GETTHUMB = HEXDEC("&H00BE") this does not work in LB
CompVar = 0 ThumbPos = 0 CtlThumb = 0 Ctrl = 0 Diff = 0 Stp = 1
ThumbPos = FN.ScrollPos(CtlHndl) '<--- where the scroll bar thumb is
'<--------- PARSE THE EDIT CONTROLS ---------> FOR J = 0 TO Ubnd IF J = ArayPos THEN GOTO [NXT.J] '<--- J = current control
Ctrl = VAL(Handles$(J, 1)) '<--- control handle CtlThumb = FN.ScrollPos(Ctrl) '<--- where the other control thumb is
Diff = ThumbPos - CtlThumb '<--- # of lines to scroll IF Diff < 0 THEN Stp = -1 '<--- scroll down or up based on "Diff"
FOR I = 1 TO Diff STEP Stp IF Stp > 0 THEN '<--- scroll direction CALLDLL #USER, "SendMessageA", Ctrl AS ULONG, EM.SCROLL AS ULONG, _ SB.LINEDOWN AS LONG, 0 AS LONG, RetVal AS LONG ELSE CALLDLL #USER, "SendMessageA", Ctrl AS ULONG, EM.SCROLL AS ULONG, _ SB.LINEUP AS LONG, 0 AS LONG, RetVal AS LONG END IF NEXT I
[NXT.J] NEXT J
FN.SetThumb = ThumbPos END FUNCTION
'------------------------------------------------------------------ '------------------------------------------------------------------
'
This fails for me trying to find FN.InitProperties.
|
|