Share your snippets (functions)

[metro]

Tasp made an interesting comment in another post regarding Brandon's propensity to create useful functions.

is it worth creating a repository for others to learn from?

I found this code useful when scratching my head thinking I maybe I already have a function to do this!

dim functionTitle$(4000)
dim functionEndLine(4000)
dim functionLines$(4000,300)
dim info$(10,10)

'DefaultDir$= ""
print "Reading  directory..."
files DefaultDir$,info$()

fileCount = val(info$(0,0))
print "Found ";fileCount;" file to scan..."

print "Starting"
for a = 1 to fileCount
   filename$ = info$(a,0)
   gosub [getFunctions]
next a

print
print "Found ";functionCount;" functions"


gosub [cleanDuplicateFunctions]


print "Done"
end

[getFunctions]
   print "Scanning ";filename$
   functionLineCount = 0
   writeFlag = 0
   if lower$(right$(filename$,3)) = "bas" then
       open DefaultDir$+"\"+filename$ for input as #2
       while not(eof(#2))
           line input #2, a$
           if lower$(left$(trim$(a$),9)) = "function " then
               writeFlag = 1
               functionCount = functionCount + 1
               functionTitle$(functionCount) = trim$(a$)
           end if
           if lower$(left$(trim$(a$),12)) = "end function" then
               writeFlag = 0
               functionEndLine(functionCount) = functionLineCount + 1
               functionLines$(functionCount,functionLineCount+1) = a$
               functionLineCount = 0
           end if
           if writeFlag = 1 then
               functionLineCount = functionLineCount+1
               functionLines$(functionCount,functionLineCount) = a$
           end if
       wend
       close #2
   end if
   return

[cleanDuplicateFunctions]
   print "Removing duplicate functions"

   dim finalList$(4000,2)

   for a = 1 to functionCount
       titleToCheck$ = functionTitle$(a)
       if functionTitle$(a) <> "DUPLICATE" then
           for b = a+1 to functionCount
               if functionTitle$(b) = titleToCheck$ then
                   functionTitle$(b) = "DUPLICATE"
               end if
           next b
       end if
   next a

   print "Writing to file"
   open "foundfunctions.bas" for output as #1

   for a = 1 to functionCount
       if functionTitle$(a) <> "DUPLICATE" then
           #1 "'####################################"
           for b = 1 to functionEndLine(a)
               #1 functionLines$(a,b)
           next b
       end if
   next a

   close #1
   return


Thanks to who ever created this too :   Function_Reference.htm (25.4 KB)

[Walt Decker]

The attached zip contains the below code and the dll necessary to run it.

Basically it moniters the keyboard for VK_RETURN and uses that to move from one edit control to the next.

TXTBOX_ENTER.ZIP (9.13 KB)

'
ES.MULTILINE  = HEXDEC("&H0004")
ES.WANTRETURN = HEXDEC("&H1000")
ES.UPPERCASE  = HEXDEC("&H0008")

SS.CENTER      = HEXDEC("&H00000001")
SS.CENTERIMAGE = HEXDEC("&H00000200")

WS.EX.DLGMODALFRAME = HEXDEC("&H00000001")

GLOBAL CRLF$
GLOBAL Ecnt

CRLF$ = CHR$(13) + CHR$(10) + CHR$(0)

DIM ECtrl$(2, 1)

OPEN "User32.dll" FOR DLL AS #USER
OPEN "NUMBERMANDLL" FOR DLL AS #NUM

STYLEBITS #TST.LBLNAME, SS.CENTERIMAGE OR SS.CENTER, 0, 0, 0
STYLEBITS #TST.LBLLAST, SS.CENTERIMAGE OR SS.CENTER, 0, 0, 0
STYLEBITS #TST.LBLFIRST, SS.CENTERIMAGE OR SS.CENTER, 0, 0, 0
STYLEBITS #TST.LBLMI, SS.CENTERIMAGE OR SS.CENTER, 0, 0, 0

STATICTEXT #TST.LBLNAME, "NAME", 5, 5, 200, 15
STATICTEXT #TST.LBLLAST, "LAST", 5, 20, 60, 15
STATICTEXT #TST.LBLFIRST, "FIRST", 70, 20, 60, 15
STATICTEXT #TST.LBLMI, "MI", 135, 20, 45, 15

STYLEBITS #TST.TXBLAST, ES.MULTILINE OR ES.WANTRETURN OR ES.UPPERCASE, 0, _
                       WS.EX.DLGMODALFRAME, 0
STYLEBITS #TST.TXBFIRST, ES.MULTILINE OR ES.WANTRETURN OR ES.UPPERCASE, 0, _
                        WS.EX.DLGMODALFRAME, 0
STYLEBITS #TST.TXBMI, ES.MULTILINE OR ES.WANTRETURN OR ES.UPPERCASE, 0, _
                       WS.EX.DLGMODALFRAME, 0
TEXTBOX #TST.TXBLAST, 5, 40, 60, 25
TEXTBOX #TST.TXBFIRST, 70, 40, 60, 25
TEXTBOX #TST.TXBMI, 135, 40, 45, 25

ECtrl$(0, 0) = "#TST.TXBLAST"
ECtrl$(1, 0) = "#TST.TXBFIRST"
ECtrl$(2, 0) = "#TST.TXBMI"

OPEN "TXT INPUT" FOR WINDOW AS #TST

ECtrl$(0, 1) = STR$(HWND(#TST.TXBLAST))
ECtrl$(1, 1) = STR$(HWND(#TST.TXBFIRST))
ECtrl$(2, 1) = STR$(HWND(#TST.TXBMI))


PRINT #TST, "TRAPCLOSE TST.DONE"
PRINT #TST.TXBLAST, "!setfocus"
TIMER 100, [CK.TIMER]

[WAIT.KEY]

WAIT

'------------------------------------------------------------------
'------------------------------------------------------------------

SUB TST.DONE WinHndl$

CLOSE #USER
CLOSE #NUM
CLOSE #TST
END

END SUB

'----------------------------------------------------------------
'----------------------------------------------------------------

[CK.TIMER]

A = FN.CkEnter()
GOTO [WAIT.KEY]

'----------------------------------------------------------------
'----------------------------------------------------------------

FUNCTION FN.CkEnter()

EM.CHARFROMPOS          = HEXDEC("&H00D7")
EM.LINELENGTH           = HEXDEC("&H00C1")
EM.GETLINECOUNT         = HEXDEC("&H00BA")
EM.LINELENGTH           = HEXDEC("&H00C1")
EM.LINEINDEX            = HEXDEC("&H00BB")
EM.POSFROMCHAR          = HEXDEC("&H00D6")
EM.SETSEL               = HEXDEC("&H00B1")
EM.REPLACESEL           = HEXDEC("&H00C2")

VK.RETURN = HEXDEC("&H0D")

STRUCT tPnt, _
 X AS LONG, _
 Y AS LONG

Mask = HEXDEC("&H8000")
Ctl$ = ""
KeyState = 0
CALLDLL #USER, "GetKeyState", VK.RETURN AS ULONG, KeyState AS SHORT

IF (KeyState AND Mask) THEN
 RetVal = 0
 ChrIdx = -1
 wParam = 0
 lParam = 0

 CALLDLL #USER, "GetCaretPos", tPnt AS STRUCT, RetVal AS VOID
 wParam = tPnt.X.struct
 lParam = tPnt.Y.struct
 CALLDLL #NUM, "FN_SetLong", wParam AS SHORT, lParam AS SHORT, lParam AS LONG
 CALLDLL #USER, "SendMessageA", EdtHndl AS ULONG, EM.CHARFROMPOS AS ULONG, _
                 0 AS LONG, lParam AS LONG, wParam AS LONG
 CALLDLL #NUM, "FN_GetLowWord", wParam AS LONG, ChrIdx AS SHORT
 CALLDLL #USER, "SendMessageA", EdtHndl AS ULONG, EM.SETSEL AS ULONG, _
                 ChrIdx AS LONG, ChrIdx AS LONG, wParam AS LONG
 CALLDLL #USER, "SendMessageA", EdtHndl AS ULONG, EM.SETSEL AS ULONG, _
                 ChrIdx AS LONG, ChrIdx AS LONG, wParam AS LONG
 CALLDLL #USER, "SendMessageA", EdtHndl AS ULONG, EM.REPLACESEL AS ULONG, _
                 1 AS LONG, CRLF$ AS PTR, wParam AS VOID
 Ecnt = Ecnt + 1
 IF Ecnt > 2 THEN Ecnt = 0

 Ctl$ = ECtrl$(Ecnt, 0)


 PRINT #Ctl$, "!setfocus"
END IF

END FUNCTION
'

[Walt Decker]

Transparent text, i. e., display text with the background showing around and between the text characters.

'
nomainwin

FontHndl = 0

UpperLeftX = 1
UpperLeftY = 75
WindowWidth = 280
WindowHeigth = 150

OPEN "User32.dll" FOR DLL AS #USER
OPEN "gdi32.dll" FOR DLL AS #GDI

GRAPHICBOX #GFX.UP, 5, 5, 250, 150

OPEN "GFX TEST" FOR WINDOW AS #GFX
PRINT #GFX, "TRAPCLOSE GFX.DONE"

PRINT #GFX.UP, "setfocus"

'<--- fill control with gradient red color ---->
Y  = 0
Y1 = 150
R  = 0
G  = 0
B  = 0
FOR X = 0 TO 250
 PRINT #GFX.UP, "Color ";R;" ";G;" ";B
 PRINT #GFX.UP, "down"
 PRINT #GFX.UP, "line ";X;" ";Y;" ";X;" ";Y1
 PRINT #GFX.UP, "up"
 R = X + 4
NEXT X

'######################################################
'   Get the current font
'   In this case it will be the system font.
'   If the GFX control is set to a different font
'   you must create that font indepentantly and
'   attach it to the control
'#######################################################
FontHndl = FN.GetFont()
X = 100
Y = 75
Txt$ = "Hello Dolly"
GfxHndl = HWND(#GFX.UP)
X = FN.RenderText(GfxHndl, FontHndl, X, Y, Txt$)

PRINT #GFX.UP, "getbmp BMP 0 0 250 150"
PRINT #GFX.UP, "drawbmp BMP 0 0"
PRINT #GFX.UP, "flush"
UNLOADBMP "BMP"
WAIT

'----------------------------------------------------------------------
'----------------------------------------------------------------------

SUB GFX.DONE GfxHndl$

CLOSE #GDI
CLOSE #USER
CLOSE #GFX
END

END SUB

'----------------------------------------------------------------------
'----------------------------------------------------------------------

FUNCTION FN.GetFont()

WM.GETFONT      = HEXDEC("&H0031")

CtlHndl  = 0
FontHndl = -1

CtlHndl = HWND(#GFX.UP)
CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, WM.GETFONT AS ULONG, _
              0 AS LONG, 0 AS LONG, FontHndl AS ULONG

FN.GetFont = FontHndl
END FUNCTION

'----------------------------------------------------------------------
'----------------------------------------------------------------------

FUNCTION FN.RenderText(GfxHndl, FontHndl, X, Y, Txt$)
'#########################################################
'           DISPLAY THE TEXT
'#########################################################

YELLOW.WHIP     = HEXDEC("&HD5EFFF")

TRANSPARENT = 1

GfxDc   = 0
PrevObj = 0
PrevClr = 0
PrevMod = 0
TxtLen  = LEN(Txt$)

CALLDLL #USER, "GetDC", GfxHndl AS ULONG, GfxDc AS ULONG
CALLDLL #GDI, "SelectObject", GfxDc AS ULONG, FontHndl AS ULONG, PrevObj AS ULONG
CALLDLL #GDI, "SetTextColor", GfxDc AS ULONG, YELLOW.WHIP AS ULONG, _
              PrevClr AS ULONG
CALLDLL #GDI, "SetBkMode", GfxDc AS ULONG, TRANSPARENT AS LONG, PrevMod AS LONG

CALLDLL #GDI, "TextOutA", GfxDc AS ULONG, X AS LONG, Y AS LONG, Txt$ AS PTR, _
             TxtLen AS LONG, RetVal AS LONG
CALLDLL #GDI, "SetBkMode", GfxDc AS ULONG, PrevMod AS LONG, PrevMod AS LONG
CALLDLL #GDI, "SetTextColor", GfxDc AS ULONG, PrevClr AS ULONG, _
              PrevClr AS ULONG
CALLDLL #GDI, "SelectObject", GfxDc AS ULONG, PrevObj AS ULONG, RetVal AS VOID
CALLDLL #USER, "ReleaseDC", GfxHndl AS ULONG, GfxDc AS ULONG

END FUNCTION
'

[Walt Decker]

These two functions prepare a two-dimensional string array for table display and/or edit in an edit control.


FUNCTION FN.DataPad(UbndRow, UbndCol)
'#############################################################
'      THIS MODULE FINDS THE MAXIMUM TEXT LENGTH IN A
'      M BY N STRING ARRAY
'
'  The array should start at zero rows and zero columns
'  UbndRow = # of rows in array
'  UbndCol = # of cols in array
'#############################################################

DtaLen = 0   '<--- length of current column
MaxLen = -1  '<--- maximum length found

FOR I = 0 TO UbndRow
 FOR J = 0 TO UbndCol
   DtaLen = LEN(DtaAry$(I, J))
   IF DtaLen > MaxLen THEN
     MaxLen = DtaLen
   END IF
 NEXT J

NEXT I

MaxLen = MaxLen + 1
FN.DataPad = MaxLen
END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.Concatenate$(MaxLen, UbndRow, UbndCol)
'#############################################################
'  THIS MODULE PADS EACH COLUMN TO (MaxLen - TxtLen) and creates
'  a string for display in an edit control
''#############################################################

TxtOut$ = ""  '<--- string to display
TxtIn$  = ""  '<--- string to pad

CRLF$   = CHR$(13) + CHR$(10)  '<--- enter plus line feed

TxtLen = 0

FOR I = 0 TO UbndRow
 FOR J = 0 TO UbndCol
   TxtIn$ = DtaAry$(I, J) '<--- data from array
   TxtLen = LEN(TxtIn$)   '<--- length of data
   TxtIn$ = TxtIn$ + SPACE$(MaxLen - TxtLen) '<--- padding
   TxtOut$ = TxtOut$ + TxtIn$ '<--- concatenation
 NEXT J
 TxtOut$ = TxtOut$ + CRLF$  '<--- creates next line
NEXT I

FN.Concatenate$ = TxtOut$
END FUNCTION
'

[Walt Decker]

Wide string list box with input from edit control

'
LBS.NOTIFY      = HEXDEC("&H0001")  '<--- send LBN_CLICKED to form
LBS.HASSTRINGS  = HEXDEC("&H0040")  '<--- ensure list box has strings
LBS.SORT        = HEXDEC("&H0002")  '<--- sort list box items

LB.SETHORIZONTALEXTENT  = HEXDEC("&H0194")  '<--- allow horizontal scrolling

WS.HSCROLL      = HEXDEC("&H00100000") '<--- add a scroll bar to the list box
WS.TABSTOP      = HEXDEC("&H00010000") '<--- ensure movement to list box when
                                      'TAB key is pressed

SS.CENTER       = HEXDEC("&H00000001") '<--- center text in
SS.CENTERIMAGE  = HEXDEC("&H00000200") 'static control

WS.EX.DLGMODALFRAME   = HEXDEC("&H00000001") '<--- add a raised look to ctrl

ES.MULTILINE   = HEXDEC("&H0004") '<--- make edit control multi-line
ES.WANTRETURN  = HEXDEC("&H1000") '<--- recognize ENTER key

VK.RETURN      = HEXDEC("H0D")    '<--- enter key virtural code

DIM LbxItms$(-1)   '<--- list box array

OPEN "User32.dll" FOR DLL AS #USER

GLOBAL Finished   '<--- timer flag

Finished = 0

RetVal = 0
A      = 0  '<--- dummy variable

STYLEBITS #DMO.LBL, SS.CENTER OR SS.CENTERIMAGE, 0, WS.EX.DLGMODALFRAME, 0
STATICTEXT #DMO.LBL, "ENTER DATA", 5, 5, 100, 25

STYLEBITS #DMO.TXB, ES.MULTILINE OR ES.WANTRETURN, 0, WS.EX.DLGMODALFRAME, 0
TEXTBOX #DMO.TXB, 5, 35, 100, 25

Style = LBS.NOTIFY OR LBS.HASSTRING OR LBS.SORT OR WS.HSCROLL OR WS.TABSTOP
STYLEBITS #DMO.LBX, Style, 0, 0, 0
LISTBOX #DMO.LBX, LbItms(), LB.EVENT, 5, 65, 100, 100

BUTTON #DMO.BTN, "DONE", ADD.ITEM.DONE, UL, 5, 170, 45, 25

OPEN "LBX DMO" FOR WINDOW AS #DMO
PRINT #DMO, "TRAPCLOSE END.DMO"
Hndl = HWND(#DMO.LBX)

'<-------------- set list box horizontal scroll range -------------->
CALLDLL #USER, "SendMessageA", Hndl AS ULONG, LB.SETHORIZONTALEXTENT AS ULONG, _
               200 AS LONG, 0 AS LONG, RetVal AS VOID

A = FN.SetLbxItems(Hndl) '<--- set initial list box items

PRINT #DMO.TXB, "!setfocus"  '<--- activate text box

TIMER 100, [SPINNER.CHECK] '<--- timer code

[SPINNER.WAIT]
WAIT

'----------------------------------------------------------
'----------------------------------------------------------

[SPINNER.CHECK]

EnterPress = 0
TxtIn$ = ""

IF Finished THEN      '<--- disable timer if DONE button pressed
 TIMER 0
 GOTO [SPINNER.WAIT]
END IF

TIMER 0

EnterPress = FN.CkEnter() '<--- check for VK.RETURN press
IF EnterPress THEN
 PRINT #DMO.TXB, "!contents? TxtIn$"
 EnterPress = FN.AddLbxItem(Hndl, TxtIn$) '<--- add item to list box
 TxtIn$ = ""              '<--- clear text box
 PRINT #DMO.TXB, TxtIn$
END IF

TIMER 100, [SPINNER.CHECK]
GOTO [SPINNER.WAIT]

'----------------------------------------------------------
'----------------------------------------------------------

SUB END.DMO WinHndl$

CLOSE #USER
CLOSE #DMO
END
END SUB

'----------------------------------------------------------
'----------------------------------------------------------

SUB LB.EVENT LbxHndl$
'<---------- YOUR CODE HERE ----------->
END SUB

'----------------------------------------------------------
'----------------------------------------------------------

SUB ADD.ITEM.DONE BtnHndl$

Finished = 1  '<--- no more items can be added to list box

END SUB

'----------------------------------------------------------
'----------------------------------------------------------

FUNCTION FN.SetLbxItems(LbxHndl)

DATA "Peter Piper Picked a peck"
DATA "Now is the time"
DATA "Foundations and Empire"
DATA "Through the Looking Glass"
DATA "Mary had a little lamb"
DATA "Norman Rockwell"
DATA "Little Miss Muffet"

LB.ADDSTRING  = HEXDEC("&H0180")

RetVal = 0
I      = 0

StrOut$ = ""

'##################################################
'  add initial items to list box and let it sort
'  the items as they are added
'##################################################

FOR I = 0 TO 6
 READ StrOut$
 CALLDLL #USER, "SendMessageA", LbxHndl AS ULONG, LB.ADDSTRING AS LONG, _
              0 AS LONG, StrOut$ AS PTR, RetVal AS LONG
NEXT I

RetVal = FN.SetLbxArray(LbxHndl) '<--- set list box array to list box contents
FN.SetLbxItems = RetVal
END FUNCTION

'----------------------------------------------------------
'----------------------------------------------------------

FUNCTION FN.SetLbxArray(LbxHndl)

LB.GETCOUNT   = HEXDEC("&H018B")
LB.GETTEXT    = HEXDEC("&H0189")
LB.GETTEXTLEN = HEXDEC("&H018A")

TxtLen  = 0  '<--- # characters in each list box row
NumRecs = 0  '<--- zero-based # of list box rows
I       = 0

TxtIn$  = ""

'<---------- get # of zero-based list box rows ----------->
CALLDLL #USER, "SendMessageA", LbxHndl AS ULONG, LB.GETCOUNT AS ULONG, _
              0 AS LONG, 0 AS LONG, NumRecs AS LONG

NumRecs = NumRecs - 1
REDIM LbxItms$(NumRecs) '<--- set # of array elements
                       'arrays start at zero and NOT one
FOR I = 0 TO NumRecs
'<----------- get length of text --------------->
 CALLDLL #USER, "SendMessageA", LbxHndl AS ULONG, LB.GETTEXTLEN AS ULONG, _
                0 AS LONG, 0 AS LONG, TxtLen AS LONG

 TxtIn$ = SPACE$(TxtLen) '<--- set the length of return string

'<------ get the text in row I ------------>
 CALLDLL #USER, "SendMessageA", LbxHndl AS ULONG, LB.GETTEXT AS ULONG, _
                I AS LONG, TxtIn$ AS PTR, TxtLen AS LONG

'<---------- set array element I --------->
 LbxItms$(I) = LEFT$(TxtIn$, TxtLen)
NEXT I

FN.SetLbxArray = NumRecs
END FUNCTION

'---------------------------------------------------------
'---------------------------------------------------------

FUNCTION FN.CkEnter()

VK.RETURN = HEXDEC("&H0D")

Mask = HEXDEC("&H8000") '<--- mask out bits
KeyState = 0
CALLDLL #USER, "GetKeyState", VK.RETURN AS ULONG, KeyState AS SHORT

IF (KeyState AND Mask) THEN  '<--- check state of set bit
 FN.CkEnter = 1
 EXIT FUNCTION
END IF

END FUNCTION
'-----------------------------------------------------------
'-----------------------------------------------------------

FUNCTION FN.AddLbxItem(LbxHndl, StrOut$)

LB.ADDSTRING  = HEXDEC("&H0180")

'<--------- add data from text box to list box ----------->
ItmIdx = 0
CALLDLL #USER, "SendMessageA", LbxHndl AS ULONG, LB.ADDSTRING AS LONG, _
              0 AS LONG, StrOut$ AS PTR, ItmIdx AS LONG

ItmIdx = FN.SetLbxArray(LbxHndl)

FN.AddLbxItem = ItmIdx
END FUNCTION
'

[Walt Decker]

Basic file attributes functions:

FILE.ATTRIBUTE.READONLY = HEXDEC("&H00000001")
FILE.ATTRIBUTE.HIDDEN = HEXDEC("&H00000002")
FILE.ATTRIBUTE.SYSTEM = HEXDEC("&H00000004")
FILE.ATTRIBUTE.DIRECTORY HEXDEC("= &H00000010")
FILE.ATTRIBUTE.ARCHIVE = HEXDEC("&H00000020")
FILE.ATTRIBUTE.NORMAL = HEXDEC("&H00000080")

A = 0
Attr = FILE.ATTRIBUTE.READONLY OR FILEATTRIBUTE.HIDDEN
FileSpec$ = DefaultDir$ + "SomeFile.File"

A = FN.SetAttrib(FileSpec$, Attr)

A = FN.GetAttrib(FileSpec$)

IF (A AND Attr) = Attr THEN PRINT "read-only and hidden set"
END

'-----------------------------------------------------------
'-----------------------------------------------------------

FUNCTION FN.SetAttrib(FileSpec$, Attrib)

RetVal = 0
OPEN "kernel32.dll" FOR DLL AS #KERN
CALLDLL #KERN, "SetFileAttrubutesA", FileSpec$ AS PTR, Attrib AS LONG, _
RetVal AS LONG

CLOSE #KERN

FN.SetAttrib = RetVal
END FUNCTION

'----------------------------------------------------------------------
'----------------------------------------------------------------------

FUNCTION FN.GetAttrib(FileSpec$)

OPEN "kernel32.dll" FOR DLL AS #KERN
CALLDLL #KERN, "GetFileAttrubutesA", FileSpec$ AS PTR, Attrib AS LONG

CLOSE #KERN

FN.GetAttrib = Attrib
END FUNCTION





[Walt Decker]

Enhance your windows.  The following colors the main window, traps the ENTER key in a multi-line edit control and places a CRLF in the proper place, and displays the character count in a program drawn static control.

'
NOMAINWIN

'<--------------- window styles -------------->
WS.CAPTION        = HEXDEC("&H00C00000")
WS.SYSMENU        = HEXDEC("&H00080000")
WS.MINIMIZEBOX    = HEXDEC("&H00020000")
WS.MAXIMIZEBOX    = HEXDEC("&H00010000")
WS.BORDER         = HEXDEC("&H00800000")
WS.THICKFRAME     = HEXDEC("&H00040000")
WS.VISIBLE        = HEXDEC("&H10000000")
WS.VSCROLL        = HEXDEC("&H00200000")
WS.GROUP          = HEXDEC("&H00020000")
WS.TABSTOP        = HEXDEC("&H00010000")

WS.EX.APPWINDOW       = HEXDEC("&H00040000")
WS.EX.DLGMODALFRAME   = HEXDEC("&H00000001")
WS.EX.TRANSPARENT     = HEXDEC("&H00000020")

'<----------------- edit control styles ----------->
ES.MULTILINE      = HEXDEC("&H0004")
ES.AUTOVSCROLL    = HEXDEC("&H0040")
ES.AUTOHSCROLL    = HEXDEC("&H0080")
ES.NOHIDESEL      = HEXDEC("&H0100")

'<----------------- static control styles ---------->
SS.OWNERDRAW        = HEXDEC("&H0000000D")

VK.RETURN    = HEXDEC("&H0D")  '<--- enter key

SM.CYCAPTION = 4 '<--- height of caption

[GLOBAL.VARBS]
GLOBAL Brx, _    '<--- initial size of window
      Bry

GLOBAL EdtUbnd, _  '<--- # of row elements in EdtCtrl()
      LblUbnd     '<--- # or row elements in LblCtrl()

GLOBAL FntHndl     '<--- handle of font

DIM EdtCtrl(2)     '<--- Edit control handles
DIM LblCtrl(2)     '<--- static control handles

[INITIALIZE.GLOBALS]

EdtUbnd = 2
LblUbnd = 2
Iconic  = 0
Brx     = 0
Bry     = 0

[INITIALIZE.LOCALS]

WinHndl = 0  '<--- handle of window
CurFocus= 0  '<--- current focus
RetVal  = 0  '<--- dummy varb
Style   = 0  '<--- control style
Nstyle  = 0  '<--- control style
CurEdt  = 0  '<--- current edit control
LstLen  = 0  '<--- text length

Hndl = 0     '<--- control handle
Mask = HEXDEC("&H8000") '<--- key down mask

OPEN "User32.dll" FOR DLL AS #USER
OPEN "gdi32.dll" FOR DLL AS #GDI

'<------------ get height of caption --------------->
CALLDLL #USER, "GetSystemMetrics", SM.CYCAPTION AS LONG, Ly AS LONG

Style = WS.MULTILINE OR WS.AUTOVSCROLL OR WS.NOHIDESEL OR WS.GROUP _
       OR WS.TABSTOP OR WS.VSCROLL
Nstyle = WS.MULTILINE OR WS.AUTOVSCROLL OR WS.NOHIDESEL OR WS.TABSTOP _
        OR WS.VSCROLL

'<------------ set and remove edit control styles ---->
STYLEBITS #DMO.EDL, Style, ES.AUTOHSCROLL, 0, 0
STYLEBITS #DMO.EDM, Nstyle, ES.AUTOHSCROLL, 0, 0
STYLEBITS #DMO.EDR, Nstyle, ES.AUTOHSCROLL, 0, 0

TEXTBOX #DMO.EDL, 5, 5, 150, 80
TEXTBOX #DMO.EDM, 160, 5, 150, 80
TEXTBOX #DMO.EDR, 315, 5, 150, 80

'<--------- set static control style ----------->
STYLEBITS #DMO.LBL, SS.OWNERDRAW, 0, 0, 0
STYLEBITS #DMO.LBM, SS.OWNERDRAW, 0, 0, 0
STYLEBITS #DMO.LBR, SS.OWNERDRAW, 0, 0, 0

STATICTEXT #DMO.LBL, "", 5, 95, 150, 20
STATICTEXT #DMO.LBM, "", 160, 95, 150, 20
STATICTEXT #DMO.LBR, "", 315, 95, 150, 20

UpperLeftX  = 100
UpperLeftY  = 200
WindowWidth = 478
WindowHeight= 125 + Ly '<--- window height + caption

'<--------------- set window style ------------------->
STYLEBITS #DMO, WS.CAPTION OR WS.SYSMENU, WS.BORDER OR _
               WS.THICKFRAME OR WS.MINIMIZEBOX OR WS.MAXIMIZEBOX, _
               WS.EX.APPWINDOW OR WS.EX.TRANSPARENT, 0

OPEN "DMO" FOR WINDOW AS #DMO
PRINT #DMO, "TRAPCLOSE DMO.DONE"         '<--- kill every thing

WinHndl = HWND(#DMO)
EdtCtrl(0) = HWND(#DMO.EDL) '<--- define edit control handles
EdtCtrl(1) = HWND(#DMO.EDM)
EdtCtrl(2) = HWND(#DMO.EDR)

LblCtrl(0) = HWND(#DMO.LBL) '<--- define static control handles
LblCtrl(1) = HWND(#DMO.LBM)
LblCtrl(2) = HWND(#DMO.LBR)

FntHndl = FN.GetFont(WinHndl)  '<--- create a font

RetVal = FN.ClientRect(WinHndl, Brx, Bry) '<--- get client window size

A = FN.GradientFill(WinHndl) '<--- fill the window with color

'<-------------- make controls visible ---------->
FOR I = 0 TO 2
 Hndl = EdtCtrl(I)
 CALLDLL #USER, "SetFocus", Hndl AS ULONG, A AS VOID
 Hndl = LblCtrl(I)
 A = FN.DrawLabel(Hndl, "0")
NEXT I

PRINT #DMO.EDL, "!SETFOCUS"

[SPIN.WAIT]
TIMER 100, [SPINNER] '<--- set up a timed branch

WAIT

'-------------------------------------------------------------
'-------------------------------------------------------------

[SPINNER]
'################################################################
'                       Timed branch
'  Checks the current focus
'  Checks the state of the ENTER key
'  Displays the # of characters typed in
'    the appropriate static control
'##################################################################

TIMER 0      '<--- turn off timer

KeyPress = 0 '<--- recipient of key query
TxtLen   = 0 '<--- current text length
I        = 0 '<--- counter
Found    = -1 '<--- search flag

Txt$     = "" '<--- receives text length

'<------------ check status of ENTER key ---------->
 [REDO.FOCUS]
CALLDLL #USER, "GetAsyncKeyState", VK.RETURN AS LONG, KeyPress AS SHORT
State = (KeyPress AND Mask) '<--- mask out pressed bit

CALLDLL #USER, "GetFocus", CurFocus AS ULONG '<--- current edit control focus
IF CurFocus = EdtCtrl(CurEdt) THEN '<--- is it a match?
 IF State THEN  '<--- set CRLF if ENTER is pressed
   Hndl = EdtCtrl(CurEdt)
   RetVal = FN.EditCtrl(Hndl)
 END IF

'<------------- get lenght of text ---------------->
 CALLDLL #USER, "GetWindowTextLengthA", CurFocus AS ULONG, TxtLen AS LONG

 IF TxtLen = LstLen THEN GOTO [SPIN.WAIT] '<--- reset timer

 Hndl = LblCtrl(CurEdt)
 Txt$ = STR$(TxtLen)
 A = FN.DrawLabel(Hndl, Txt$) '<--- display character count
 LstLen = TxtLen
ELSE
 FOR I = 0 TO EdtUbnd   '<--- find which edit control has focus
   IF CurFocus = EdtCtrl(I) THEN
     Found = I
     EXIT FOR
   END IF
 NEXT I

 IF Found > -1 THEN
   CurEdt = Found
   GOTO [REDO.FOCUS] '<--- check again
 END IF
END IF

GOTO [SPIN.WAIT] '<--- reset timer
[SPINNER.END]

'-------------------------------------------------------------
'-------------------------------------------------------------

SUB DMO.DONE WinHndl$

FntHndl = FN.KillObj(FntHndl) '<--- destroy the font
CLOSE #USER
CLOSE #GDI
CLOSE #DMO
END

END SUB

'-------------------------------------------------------------
'-------------------------------------------------------------

FUNCTION FN.GetDc(WinHndl)
'#####################################
'  get a device context
'#####################################

GfxDc = 0
CALLDLL #USER, "GetDC", WinHndl AS ULONG, GfxDc AS ULONG

FN.GetDc = GfxDc
END FUNCTION

'--------------------------------------------------------------------------
'--------------------------------------------------------------------------

FUNCTION FN.GetFont(WinHndl)
'###############################################
'    create a font and return a handle to it
'###############################################

OUT.TT.PRECIS       = 4
CLIP.DEFAULT.PRECIS = 0
DEFAULT.QUALITY     = 0
FF.DONTCARE         = 0

LOGPIXELSY    = 90

PointSize = 12
FontHndl  = 0
CyPixels  = 0
HndlDc    = 0
A         = 0

FontName$ = "Courier New"

HndlDc = FN.GetDc(WinHndl)  '<--- device context
CALLDLL #GDI, "GetDeviceCaps", HndlDc AS ULONG, LOGPIXELSY AS LONG, _
             CyPixels AS LONG   '<--- height of pixels for the font
A = FN.DetachDc(WinHndl, HndlDc) '<--- release the dc

PointSize = -1 * INT((PointSize * CyPixels) / 72)

CALLDLL #GDI, "CreateFontA", _
                   PointSize AS LONG, _ '<--- font height
                           0 AS LONG, _ '<--- font width
                           0 AS LONG, _ '<--- angle relative to horizontal
                           0 AS LONG, _ '<--- base-line orientation angle
                           0 AS LONG, _ '<--- boldness
                           0 AS LONG, _ '<--- italic attribute flag
                           0 AS LONG, _ '<--- underline attribute flag
                           0 AS LONG, _ '<--- strikeout attribute flag
                           0 AS LONG, _ '<--- character set identifier
               OUT.TT.PRECIS AS LONG, _ '<--- output precision
         CLIP.DEFAULT.PRECIS AS LONG, _ '<--- clipping precision
             DEFAULT.QUALITY AS LONG, _ '<--- output quality
                 FF.DONTCARE AS LONG, _ '<--- pitch and family
                   FontName$ AS PTR , _ '<--- pointer to typeface name string
                    FontHndl AS ULONG
FN.GetFont = FontHndl
END FUNCTION

'--------------------------------------------------------------------------
'--------------------------------------------------------------------------

FUNCTION FN.AttachObj(WinDc, ThisObject)
'###########################################################
'  Attaches the object to the device context
'  A device context may have more than one object attached
'  to it
'###########################################################

OrigObj = 0
CALLDLL #GDI, "SelectObject", WinDc AS ULONG, ThisObject AS ULONG, _
             OrigObj AS ULONG

FN.Attach = OrigObj
END FUNCTION

'------------------------------------------------------------------------
'------------------------------------------------------------------------

FUNCTION FN.DetachDc(WinHndl, WinDc)
'###########################################################
'  Dereference the device context
'###########################################################

RetVal = 0

CALLDLL #USER, "ReleaseDC", WinHndl AS ULONG, WinDc AS ULONG, RetVal AS LONG

END FUNCTION

'--------------------------------------------------------------------------
'--------------------------------------------------------------------------

FUNCTION FN.DetachObj(WinDc, OldObj)
'###########################################################
'  Replace the current object with the previous object
'###########################################################

RetVal = FN.AttachObj(WinDc, OldObj)

END FUNCTION

'---------------------------------------------------------------------
'---------------------------------------------------------------------

FUNCTION FN.Pen(Pstyle, Wide, Pcolor)
'###########################################################
'  Creates a pen of the specied style, width and color.
'  If the Pstyle parameter is not PS.SOLID and the
'  Wide parmeter is greather than one, the style will
'  be PS.SOLID regardless of the style specified by
'  Pstyle
'###########################################################

PenHndl = 0
CALLDLL #GDI, "CreatePen", Pstyle AS LONG, Wide AS LONG, _
             Pcolor AS ULONG, PenHndl AS ULONG

FN.Pen = PenHndl
END FUNCTION

'-------------------------------------------------------------------------
'-------------------------------------------------------------------------

'FUNCTION FN.WindowDc(WinHndl)
'###################################################
'  get a device context for the entire window
'  !!!! not used in ths app !!!
'###################################################

'WinDc = 0
'CALLDLL #USER, "GetWindowDC", WinHndl AS ULONG, WinDc AS ULONG

'FN.WindowDc = WinDc
'END FUNCTION

'--------------------------------------------------------------------
'--------------------------------------------------------------------

FUNCTION FN.GradientFill(WinHndl)

PS.SOLID      = 0

STRUCT tRect, _
 X  AS LONG, _
 Y  AS LONG, _
 X1 AS LONG, _
 Y1 AS LONG

Pen    = 0
Dmy    = 0
Red    = 0
Flg    = 0
RetVal = 0
OldPen = 0
WinDc  = 0
Y1     = 0
X1     = 0
I      = 0

RetVal = FN.ClientRect(WinHndl, X1, Y1)  '<--- size of window

WinDc = FN.GetDc(WinHndl) '<--- device context for client area

FOR I = 0 TO X1 STEP 2   '<--- draws lines 2 pix wide
 Pen = FN.Pen(PS.SOLID, 2, Red)
 OldPen = FN.AttachObj(WinDc, Pen)

 CALLDLL #GDI, "MoveToEx", WinDc AS ULONG, I AS LONG, 0 AS LONG, _
               0 AS ULONG, RetVal AS LONG
 CALLDLL #GDI, "LineTo", WinDc AS ULONG, I AS LONG, Y1 AS LONG, _
               RetVal AS LONG
 Dmy = FN.DetachObj(WinDc, OldPen)  '<--- release the pen
 RetVal = FN.KillObj(Pen)           '<--- destroy the pen

 IF Flg = 0 THEN
   Red = Red + 2
   IF Red > 255 THEN
     Red = Red - 2
     Flg = 1
   END IF
 ELSE
   Red = Red - 2
   IF Red <= 0 THEN
     Flg = 0
     Red = Red + 2
   END IF
 END IF
NEXT I

I = FN.DetachDc(WinHndl, WinDc) '<--- release the device context
END FUNCTION

'------------------------------------------------------------------------
'------------------------------------------------------------------------

FUNCTION FN.DrawLabel(LblHndl, TxtIn$)
'#################################################
'  draw a raised edge around a static control
'#################################################

BDR.RAISEDOUTER = HEXDEC("&H0001")
BDR.SUNKENOUTER = HEXDEC("&H0002")
BDR.RAISEDINNER = HEXDEC("&H0004")
BDR.SUNKENINNER = HEXDEC("&H0008")

BDR.RAISED      = (BDR.RAISEDOUTER OR BDR.RAISEDINNER)

EDGE.RAISED     = (BDR.RAISEDOUTER OR BDR.RAISEDINNER)

' Border flags
BF.LEFT         = HEXDEC("&H0001")
BF.TOP          = HEXDEC("&H0002")
BF.RIGHT        = HEXDEC("&H0004")
BF.BOTTOM       = HEXDEC("&H0008")

BF.RECT         = (BF.LEFT OR BF.TOP OR BF.RIGHT OR BF.BOTTOM)

BF.ADJUST    = HEXDEC("&H2000")  ' Calculate the space left over

OLD.BRICK = HEXDEC("&H5C5CCD")
GOLDENROD = HEXDEC("&HAAE8EE")
LEMONWHIP = HEXDEC("&HD5EFFF")
SNOW      = HEXDEC("&HFAFAFF")

DT.CENTER      = HEXDEC("&H00000001")
DT.VCENTER     = HEXDEC("&H00000004")
DT.SINGLELINE  = HEXDEC("&H00000020")
DT.TXT = DT.CENTER OR DT.VCENTER OR DT.SINGLELINE

TRANSPARENT = 1

STRUCT tRect, _
 X  AS LONG, _
 Y  AS LONG, _
 X1 AS LONG, _
 Y1 AS LONG

Brush   = 0
DwFlags = 0
OrgMode = 0
OrgFont = 0
Edge    = 0
LblDc   = 0
LenTxt  = 0

TxtStr$ = TxtIn$
LenTxt = LEN(TxtStr$)

'<--------------- get static control client size ----------->
CALLDLL #USER, "GetClientRect", LblHndl AS ULONG, tRect AS STRUCT, _
               RetVal AS VOID

Brush = FN.SolidBrush(OLD.BRICK) '<--- create a fill brush

LblDc = FN.GetDc(LblHndl)
CALLDLL #USER, "FillRect", LblDc AS ULONG, tRect AS STRUCT, _
              Brush AS ULONG, OrgMode AS VOID '<--- erase current text

OrgMode = FN.KillObj(Brush) '<--- destroy the brush
OrgMode = FN.RenderMode(LblDc, TRANSPARENT) '<--- set drawing mode
OrgClr  = FN.TextColor(LblDc, SNOW)    '<--- set text color
OrgFont = FN.AttachObj(LblDc, FntHndl)      '<--- enable the font

'<---------- render the text in the static control -------->
CALLDLL #USER, "DrawTextA", LblDc AS ULONG, TxtStr$ AS PTR, LenTxt AS LONG, _
              tRect AS STRUCT, DT.TXT AS ULONG, RetVal AS LONG

'<---------------- draw a raised border ----------->
Edge = EDGE.RAISED
DwFlags = BF.RECT OR BF.ADJUST
CALLDLL #USER, "DrawEdge", LblDc AS ULONG, tRect AS STRUCT,  _
              Edge AS ULONG, DwFlags AS ULONG, RetVal AS LONG

OrgMode = FN.RenderMode(LblDc, OrgMode) '<--- reset the draw mode
OrgClr = FN.TextColor(LblDc, OrgClr)    '<--- reset the text color
OrgFont = FN.DetachObj(LblDc, OrgFont)  '<--- release the font
A = FN.DetachDc(LblHndl, LblDc)  '<--- release the device context

FN.DrawLabel = OrgFont
END FUNCTION

'--------------------------------------------------------------------
'--------------------------------------------------------------------

FUNCTION FN.KillObj(ThisObj)
'###############################################
'  Destroy an object
'###############################################

CallDLL #GDI, "DeleteObject", ThisObj AS ULONG, RevVal AS VOID

END FUNCTION

'------------------------------------------------------------------------
'------------------------------------------------------------------------

FUNCTION FN.SolidBrush(FillColor)
'###########################################################
'  Creats a fill bitmap of the specified color
'###########################################################

BrushHndl = 0
CALLDLL #GDI, "CreateSolidBrush", FillColor AS ULONG, BrushHndl AS ULONG

FN.SolidBrush = BrushHndl
END FUNCTION

'------------------------------------------------------------------------
'------------------------------------------------------------------------

FUNCTION FN.RenderMode(WinDc, Mode)
'#############################################################
'  Set the render mode for broken lines and text
'  If Mode is TRANSPARENT the background color shows through
'  the spaces between broken lines an text characters
'#############################################################

OldMode = 0
CALLDLL #GDI, "SetBkMode", WinDc AS ULONG, Mode AS LONG, OldMode AS LONG

FN.RenderMode = OldMode
END FUNCTION

'---------------------------------------------------------------------
'---------------------------------------------------------------------

FUNCTION FN.TextColor(WinDc, TxtColor)
'#######################################################
'  Set text color and return original color
'#######################################################

OldColor = 0

CALLDLL #GDI, "SetTextColor", WinDc AS ULONG, TxtColor AS ULONG, _
             OldColor AS ULONG

FN.TextColor = OldColor
END FUNCTION

'------------------------------------------------------------------
'------------------------------------------------------------------

FUNCTION FN.ClientRect(WinHndl, BYREF Bx, BYREF By)
'##############################################
'  Client area of a window
'##############################################

STRUCT tRect, _
 X  AS LONG, _
 Y  AS LONG, _
 X1 AS LONG, _
 Y1 AS LONG

RetVal = 0

CALLDLL #USER, "GetClientRect", WinHndl AS ULONG, tRect AS STRUCT, RetVal AS VOID

Bx = tRect.X1.struct
By = tRect.Y1.struct

END FUNCTION

'----------------------------------------------------------------
'----------------------------------------------------------------

FUNCTION FN.EditCtrl(CtlHndl)

'<---------------- edit control messages ------------>
EM.CHARFROMPOS          = HEXDEC("&H00D7")
EM.GETSEL               = HEXDEC("&H00B0")
EM.SETSEL               = HEXDEC("&H00B1")
EM.REPLACESEL           = HEXDEC("&H00C2")

CRLF$ = CHR$(13) + CHR$(10)

RetVal  = 0

'<---------------- insert CRLF ---------------->
CALLDLL #USER, "SendMessageA", CtlHndl AS ULONG, EM.REPLACESEL AS ULONG, _
              1 AS LONG, CRLF$ AS PTR, RetVal AS VOID
END FUNCTION
'

[Walt Decker]

Unfortunately LB will not allow one to change the image on a bmp button, so I came up with the following solution.  The attached zip contains Unchecked.bmp and Checked.bmp.

'
WS.MINIMIZEBOX    = HEXDEC("&H00020000")
WS.MAXIMIZEBOX    = HEXDEC("&H00010000")
WS.THICKFRAME     = HEXDEC("&H00040000")

BtnHndl = 0
RetVal  = 0

OPEN "User32.dll" FOR DLL AS #USER
OPEN "gdi32.dll" FOR DLL AS #GDI

BMPBUTTON #DMO.LFT, "Unchecked.bmp", CHECK.BMP, UL, 5, 5

UpperLeftX = 100
UpperLeftY = 100
WindowWidth = 326
WindowHeight = 300

STYLEBITS #DMO, 0, WS.MINIMIZEBOX OR WS.MAXIMIZEBOX OR WS.THICKFRAME, 0, 0
OPEN "BUTTON IMAGE" FOR WINDOW AS #DMO
PRINT #DMO, "TRAPCLOSE [CLOSE.DMO]"

'#################################################################
'  SET BUTTON PROPERTIES
'  This is done so that the number of bitmaps resident in memory
'  are limited.
'
'  Unfortunately, LB does not allow the retrieval of the original
'  bitmap handle via BM.GETIMAGE so the original will always be
'  in memory until the parent window of the button is closed.
'
'  If there are many bitmap buttons, a more efficient approach would
'  be to put the data in an array.
'##################################################################

BtnHndl = HWND(#DMO.LFT)
CALLDLL #USER, "SetPropA", BtnHndl AS ULONG, "CHECKED" AS PTR, _
              0 AS LONG, RetVal AS LONG
CALLDLL #USER, "SetPropA", BtnHndl AS ULONG, "BMP" AS PTR, _
              0 AS ULONG, RetVal AS LONG

WAIT

[END.WAIT]
END

'---------------------------------------------------------------
'---------------------------------------------------------------

SUB CHECK.BMP BmpHndl$

Inst    = 0  '<--- application instance handle
Prop    = 0  '<--- boolean value zero or 1
OldBmp  = 0  '<--- original handle of btn image
RetVal  = 0  '<--- return value

DktHndl = 0  '<--- desktop window handle
DktDc   = 0  '<--- desktop window device context
BmpDc   = 0  '<--- compatible device context

Bx = 0   '<--- client area of bmp button
By = 0

BtnHndl = HWND(#BmpHndl$)  '<--- bmp button handle

Fl$ = "Checked.bmp"        '<--- bitmap file name

'<-------------------- get state and bmp info ------------->
CALLDLL #USER, "GetPropA", BtnHndl AS ULONG, "CHECKED" AS PTR, _
              Prop AS LONG
CALLDLL #USER, "GetPropA", BtnHndl AS ULONG, "BMP" AS PTR, _
              OldBmp AS ULONG

IF Prop = 1 THEN
 Fl$ = "Unchecked.Bmp"
END IF

RetVal = FN.KillObj(OldBmp)  '<--- destroy current memory bitmap

RetVal = FN.ClientRect(BtnHndl, Bx, By)  '<--- get button client size

DktHndl = FN.DeskTop()   '<--- handle to desktop
DktDc = FN.GetDc(DktHndl)'<--- get device context
BmpDc = FN.CompatDc(DktDc) '<--- make it DIB compatible
RetVal = FN.DetachDc(DktHndl, DktDc) '<--- release desktop device context

BtnDc = FN.GetDc(BtnHndl) '<--- get device context for bmp button
Inst = FN.GetModule()     '<--- get app instance

BmpHndl = FN.LoadImage(Fl$, Inst, 0, 0) '<--- load the bitmap
OldBmp = FN.AttachObj(BmpDc, BmpHndl)   '<--- make it active

RetVal = FN.Blt(BtnDc, 0, 0, Bx, By, BmpDc, 0, 0)  '<--- render it on the
                                                  ' button
RetVal = FN.DetachDc(BtnHndl, BtnDc)  '<--- deactiveate the btn device context
RetVal = FN.DetachObj(BmpDc, OldBmp)  '<--- replace the new bmp with old bmp
RetVal = FN.KillDc(BmpDc)             '<--- destroy compatible device context

IF Prop = 0 THEN
 Prop = 1
ELSE
 Prop = 0
END IF

'<--------------- reset propeties to current info -------------->
CALLDLL #USER, "SetPropA", BtnHndl AS ULONG, "CHECKED" AS PTR, _
              Prop AS LONG, RetVal AS LONG
CALLDLL #USER, "SetPropA", BtnHndl AS ULONG, "BMP" AS PTR, _
              BmpHndl AS ULONG, RetVal AS LONG

END SUB
'---------------------------------------------------------------
'---------------------------------------------------------------

[CLOSE.DMO]

RetVal = 0
BtnHndl = 0
BmpHndl = 0

'<---------------------- CLEAN UP ---------------------->
BtnHndl = HWND(#DMO.LFT)
CALLDLL #USER, "GetPropA", BtnHndl AS ULONG, "BMP" AS PTR, _
              BmpHndl AS ULONG
RetVal = FN.KillObj(BmpHndl)

CALLDLL #USER, "RemovePropA", BmpHndl AS ULONG, "CHECK" AS PTR, _
              RetVal AS LONG
CALLDLL #USER, "RemovePropA", BmpHndl AS ULONG, "BMP" AS PTR, _
              RetVal AS LONG

CLOSE #USER
CLOSE #GDI
CLOSE #DMO

GOTO [END.WAIT]
[END.CLOSE.DMO]

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.ClientRect(WinHndl, BYREF Bx, BYREF By)
'#########################################################
'  Retrive the client area of a window.
'  Since the upper left corner of the client area is always
'  zero, zero the lower left corner only is of importance
'###########################################################

STRUCT tRect, _
 X  AS LONG, _
 Y  AS LONG, _
 X1 AS LONG, _
 Y1 AS LONG

RetVal = 0
CALLDLL #USER, "GetClientRect", WinHndl AS ULONG, tRect AS STRUCT, _
              RetVal AS VOID
Bx = tRect.X1.struct
By = tRect.Y1.struct
END FUNCTION

'------------------------------------------------------------
'------------------------------------------------------------

FUNCTION FN.GetModule()
'##########################################################
'  Every application has an instance handle.
'  Could use GetWindowLong() to retrieve the
'  instance handl/
'##########################################################

Instance = 0

CALLDLL #kernel32, "GetModuleHandleA", 0 AS ULONG, Instance AS ULONG

FN.GetModule = Instance
END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.LoadImage(BmpName$, MdHndl, BmpWide, BmpHigh)
'############################################################
'  Loads an image either from the application resources or
'  from a file and optional creates either a bitmap compatible
'  with the device or a device independant bitmap.
'############################################################

IMAGE.BITMAP      = 0

LR.DEFAULTCOLOR     = HEXDEC("&H00000000")
LR.LOADFROMFILE     = HEXDEC("&H00000010")
LR.CREATEDIBSECTION = HEXDEC("&H00002000")

BmpHndl = 0
Style   = LR.LOADFROMFILE OR LR.DEFAULTCOLOR OR LR.CREATEDIBSECTION

CALLDLL #USER, "LoadImageA", MdHndl AS LONG, BmpName$ AS PTR, _
       IMAGE.BITMAP AS LONG, BmpWide AS LONG, BmpHigh AS LONG, _
       Style AS ULONG, BmpHndl AS ULONG

FN.LoadImage = BmpHndl
END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.GetDc(WinHndl)
'#############################################################
'  retrieve a device context from the MS Win system
'#############################################################

WinDc = 0
CALLDLL #USER, "GetDC", WinHndl AS ULONG, WinDc AS ULONG

FN.GetDc = WinDc
END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.AttachObj(WinDc, ThisObject)
'############################################################
'  Equate an object (bitmap, brush, pen, font) with a
'  device.
'############################################################

OrgObj = 0
CALLDLL #GDI, "SelectObject", WinDc AS ULONG, ThisObject AS ULONG, _
          OrgObj AS ULONG

FN.AttachObj = OrgObj
END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.DetachObj(WinDc, OrgObj)
'############################################################
'  Deactivate an object by replacing it with the previous
'  object of the same type.
'############################################################

ThisObj = 0
ThisObj = FN.AttachObj(WinDc, OrgObj)
FN.DetachObj = ThisObj
END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.DetachDc(WinHndl, WinDc)
'##################################################################
'  Deactivate a device
'##################################################################

RetVal = 0
CALLDLL #USER, "ReleaseDC", WinHndl AS ULONG, WinDc AS ULONG, RetVal AS VOID
END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.KillObj(ThisObj)
'#######################################################
'  Destroy the object to release MS Win resources and
'  prevent over-flow.
'########################################################

DeadObj = 0
CALLDLL #GDI, "DeleteObject", ThisObj AS ULONG, DeadObj AS VOID

END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.DeskTop()
'#############################################
'  Get handle of desktop window
'#############################################

DtHndl = 0
CALLDLL #USER, "GetDesktopWindow", DtHndl AS ULONG

FN.DeskTop = DtHndl
END FUNCTION

'---------------------------------------------------------------
'---------------------------------------------------------------

FUNCTION FN.CompatDc(WinDc)
'############################################################
'  Create a context compatible with the current device
'  context.
'############################################################

ComPatDc = 0
CALLDLL #GDI, "CreateCompatibleDC", WinDc AS ULONG, ComPatDc AS ULONG

FN.CompatDc = ComPatDc
END FUNCTION

'-------------------------------------------------------------------
'-------------------------------------------------------------------

FUNCTION FN.KillDc(WinDc)
'############################################################
'  Destroy a compatible context and release resources
'############################################################

RetVal = 0
CALLDLL #GDI, "DeleteDC", WinDc AS ULONG, RetVal AS VOID

END FUNCTION

'-----------------------------------------------------------------
'-----------------------------------------------------------------

FUNCTION FN.Blt(DestDc, Dx, Dy, Wide, High, SrcDc, Sx, Sy)
'############################################################
'  Render a bitmap on a device.  The origin can be anywhere
'  on the device and the bitmap can be stretched or reduced
'  by making Wide and/or High <> the actual bitmap size.
'
'  By changing the Sx and/or Sy parameters a portion of
'  the original bitmap can be displayed
'############################################################

SRCCOPY = HEXDEC("&H00CC0020")

RetVal = 0
CALLDLL #GDI, "BitBlt", DestDc AS ULONG, Dx AS LONG, Dy AS LONG, _
             Wide AS LONG, High AS LONG, SrcDc AS ULONG, _
             Sx AS LONG, Sy AS LONG, SRCCOPY AS ULONG, RetVal AS LONG
FN.Blt = RetVal
END FUNCTION

'------------------------------------------------------
'------------------------------------------------------
'

If the window size is changed the coder will have to redraw the image (routine to do so is not included).

BMPBTNS.ZIP (1.18 KB)

[Rod]

I am pretty sure Liberty can change the bmp button image with ease. #handle "bitmap bitmapname" from memory. The bitmapname has to have been loaded previously like any bmp in Liberty.

[Walt Decker]

Oct 31, 2021 14:37:44 GMT -5 Rod said:

I am pretty sure Liberty can change the bmp button image with ease. #handle "bitmap bitmapname" from memory. The bitmapname has to have been loaded previously like any bmp in Liberty.

I stand corrected.  I missed that in the docs.  Guess that is what happens when one is  80% blind and sometimes sees double or not at all.

[Walt Decker]

4-way non-recursive flood fill bucket.  The code is faster if the DC points to a memory bitmap, and could be made much faster by using gdi32.dll function GetDIBits(); however, LB does not have the tools to use that function.

Edit:

An advantage of this is one can define a rectangular area and pass the upper left and lower right coordinates of the area to the function and it will do its thing up to and including the limits of the rectangle.


FUNCTION FN.FloodFill(WinDc, PntX, PntY, Xs, Ys, Ex, Ey, OldClr, NewClr)
'#######################################################################
'  
'  This is a 4-way, non-recursive flood fill.  It is slower than the
'  gdi32.dll function ExtFloodFill() but offers the advantage of
'  changing the replacement color based on some criterion.
'
'#######################################################################
'
'ARGUMENTS:
'  WinDc:  Device context obtained by calling
'          User32.dll function GetDc(WinHndl)
'          This may be a form window, control,
'          or memory bitmap.
'
'   PntX:  Where to start filling coordinates  
'   PntY:    
'  
'     Xs:  Upper left corner of fill boundry.
'     Ys:  
'          
'     Ex:  Lower right corner of fill boundry
'     Ey:
'
' OldClr:  Color to replace
' NewClr:  Replacement color
'
'#####################################################################

StackSize = 0
StackPtr  = 0
RetVal    = 0

Nx = 0
Ny = 0
X  = 0
Y  = 0

TmpColor = 0

StackSize = (Ex - Xs) * (Ey - Ys) + 2

DIM Stack(StackSize, 1)

StackPtr = 0
X = PntX
Y = PntY

Nx = X
Ny = Y

CALLDLL #gdi32, "SetPixelV", WinDc AS ULONG, X AS LONG, Y AS LONG, NewClr AS ULONG, RetVal AS VOID  

GOSUB [Npush]

 [Cont1]
GOSUB [NPop]

IF StackPtr < 0 THEN GOTO [EndFF4]

IF X - 1 >= Xs THEN
 Nx = X - 1
 Ny = Y
 CALLDLL #gdi32, "GetPixel", WinDc AS ULONG, Nx AS LONG, Ny AS LONG, TmpColor AS ULONG
 IF TmpColor = OldClr THEN GOSUB [Npush]
END IF

IF X + 1 <= Ex THEN
 Nx = X + 1
 Ny = Y
 CALLDLL #gdi32, "GetPixel", WinDc AS ULONG, Nx AS LONG, Ny AS LONG, TmpColor AS ULONG
 IF TmpColor = OldClr THEN GOSUB [Npush]
END IF

IF Y - 1 >= Ys THEN
 Nx = X
 Ny = Y - 1
 CALLDLL #gdi32, "GetPixel", WinDc AS ULONG, Nx AS LONG, Ny AS LONG, TmpColor AS ULONG
 IF TmpColor = OldClr THEN GOSUB [Npush]
END IF

IF Y + 1 <= Ey THEN
 Nx = X
 Ny = Y + 1
 CALLDLL #gdi32, "GetPixel", WinDc AS ULONG, Nx AS LONG, Ny AS LONG, TmpColor AS ULONG
 IF TmpColor = OldClr THEN GOSUB [Npush]
END IF

CALLDLL #gdi32, "SetPixelV", WinDc AS ULONG, X AS LONG, Y AS LONG, NewClr AS ULONG, RetVal AS VOID
GOTO [Cont1]

 [EndFF4]
REDIM Stack(-1, -1)

EXIT FUNCTION

 [Npush]
Stack(StackPtr, 0) = Nx
Stack(StackPtr, 1) = Ny
StackPtr = StackPtr + 1
RETURN

 [NPop]
StackPtr = StackPtr - 1

IF StackPtr < 0 THEN RETURN

X = Stack(StackPtr, 0)
Y = Stack(StackPtr, 1)

RETURN

END FUNCTION


[Walt Decker]

Gussy up your windows with tabs and color.

The following source code and required dlls are in the attached zip.

'
WS.CHILD          = HEXDEC("&H40000000")
WS.VISIBLE        = HEXDEC("&H10000000")
WS.CLIPCHILDREN   = HEXDEC("&H02000000")
WS.DLGFRAME       = HEXDEC("&H00400000")

SS.CENTER       = HEXDEC("&H00000001")
SS.CENTERIMAGE  = HEXDEC("&H00000200")
WS.DLGFRAME     = HEXDEC("&H00400000")

WS.EX.DLGMODALFRAME   = HEXDEC("&H00000001")
WS.EX.CONTROLPARENT   = HEXDEC("&H00010000")

PINK     = HEXDEC("&HCBC0FF")
MOCCASIN = HEXDEC("&HB5E4FF")

TabHndl = 0  '<--- handle of tab control
RetVal  = 0  '<--- recieves results of most functions
Xoffs   = 0  '<--- tab control offset from
Yoffs   = 0  ' upper left corner of parent upper left corner of parent

OPEN "User32" FOR DLL AS #USER
OPEN "TABCTL" FOR DLL AS #TAB
OPEN "CTL_COLOR" FOR DLL AS #CTL

STYLEBITS #TAB1.LBLAST, SS.CENTER OR SS.CENTERIMAGE OR WS.DLGFRAME, _
                       0, WS.EX.DLGMODALFRAME, 0
STYLEBITS #TAB1.LBFRST, SS.CENTER OR SS.CENTERIMAGE OR WS.DLGFRAME, _
                       0, WS.EX.DLGMODALFRAME, 0
STYLEBITS #TAB1.LBMI, SS.CENTER OR SS.CENTERIMAGE OR WS.DLGFRAME, _
                       0, WS.EX.DLGMODALFRAME, 0

STATICTEXT #TAB1.LBLAST, "Last Name", 5, 5, 60, 20
STATICTEXT #TAB1.LBFRST, "First Name", 5, 30, 60, 20
STATICTEXT #TAB1.LBMI, "MI", 5, 55, 60, 20

TEXTBOX #TAB1.TXLAST, 70, 5, 120, 20
TEXTBOX #TAB1.TXFRST, 70, 30, 120, 20
TEXTBOX #TAB1.TXMI, 70, 55, 120, 20

BUTTON #TAB1.BTN, "APPLY", APPLY.BTN, UL, 60, 80, 65, 20
TEXTEDITOR #TAB2.EDT, 5, 5, 373, 225

WindowWidth = DisplayWidth / 2
WindowHeight = DisplayHeight / 2

OPEN "NAME ENTRY" FOR WINDOW AS #TAB1
OPEN "TEXT EDITOR" FOR WINDOW AS #TAB2

RetVal = FN.SetCtrlProp("#TAB1.LBLAST", "TXTC", 128, "BKGC", PINK)
RetVal = FN.SetCtrlProp("#TAB1.LBFRST", "TXTC", 128, "BKGC", PINK)
RetVal = FN.SetCtrlProp("#TAB1.LBMI", "TXTC", 128, "BKGC", PINK)

RetVal = FN.SetCtrlProp("#TAB1.TXLAST", "TXTC", 1, "BKGC", MOCCASIN)
RetVal = FN.SetCtrlProp("#TAB1.TXFRST", "TXTC", 1, "BKGC", MOCCASIN)
RetVal = FN.SetCtrlProp("#TAB1.TXMI", "TXTC", 1, "BKGC", MOCCASIN)

RetVal = FN.InitColors("#TAB1", "TXTC", "BKGC", PINK XOR 64, 0)
RetVal = FN.InitColors("#TAB2", "TXTC", "BKGC", PINK XOR 128, 0)

OPEN "TAB TEST" FOR WINDOW AS #TST
RetVal = FN.InitColors("#TST", "TXTC", "BKGC", MOCCASIN XOR 128, 0)

Xoffs = 5
Yoffs = 30
TabHndl = FN.InitTabCtl("#TST", WinHndl, Xoffs, Yoffs)

RetVal = FN.AddTab("#TAB1", TabHndl, "NAME", 0)
RetVal = FN.AddTab("#TAB2", TabHndl, "EDIT", 1)

Style = WS.VISIBLE OR WS.CLIPCHILDREN OR WS.DLGFRAME
ExStyle = WS.EX.CONTROLPARENT OR WS.EX.DLGMODALFRAME
RetVal = FN.SetStyle(TabHndl, Index, Style, ExStyle)

PRINT #TST, "RESIZEHANDLER [RESIZE.WIN]"
PRINT #TST, "TRAPCLOSE [END.TEST]"

[BEGIN.WAIT]
WAIT

'------------------------------------------------------------------
'------------------------------------------------------------------

[END.TEST]
RetVal = 0
CALLDLL #TAB, "CLOSEALLTABS", RetVal AS VOID '<--- remove tab controls
                                            'from all parent windows
RetVal = FN.CloseColors("#TAB1") '<--- release color reference
RetVal = FN.CloseColors("#TAB2")
RetVal = FN.CloseColors("#TST")

'<--------------------- close all windows ----------->
CLOSE #TAB1
CLOSE #TAB2
CLOSE #TST

'<------------- release dlls --------------->
CLOSE #USER  '<--- release user32.dll
CLOSE #TAB   '<--- release TABCTL.DLL
CLOSE #CTL   '<--- release CTL_COLOR.

END
[END.TEST.END]

'-----------------------------------------------------------------
'-----------------------------------------------------------------

[RESIZE.WIN]

CALLDLL #TAB, "UpdateTab", TabHndl AS ULONG, RetVal AS VOID

GOTO [BEGIN.WAIT]
[RESIZE.WIN.END]

'-----------------------------------------------------------------
'-----------------------------------------------------------------

FUNCTION FN.InitTabCtl(WinName$, BYREF WinHndl, Xoffs, Yoffs)

'<--- structure to define where the tab control is and its style ----->
STRUCT tTab, _
TabStyle    AS ULONG, _  '<--- if this is zero default values are used
        X    AS LONG, _  '<--- upper left corner of tab control
        Y    AS LONG, _
        X1   AS LONG, _  '<--- lower right corner of control
        Y1   AS LONG

'<--- structure for determining client size of parent window --->
STRUCT tRect, _
 X  AS LONG, _
 Y  AS LONG, _
 X1 AS LONG, _
 Y1 AS LONG

WinHndl = 0
TabHndl = 0
RetVal  = 0

WinHndl = HWND(#WinName$)
CALLDLL #USER, "GetClientRect", WinHndl AS ULONG, tRect AS STRUCT, _
               RetVal AS VOID
tTab.X.struct = Xoffs
tTab.Y.struct = Yoffs
tTab.X1.struct = tRect.X1.struct - Xoffs * 2
tTab.Y1.struct = tRect.Y1.struct - Yoffs

CALLDLL #TAB, "FN_InitTab", _
         WinHndl AS ULONG, _  '<--- Parent window handle
           tTab AS STRUCT, _  '<--- Configuration structure
         TabHndl AS ULONG     '<--- RETURN: Handle of tab control
                              'otherwise zero

FN.InitTabCtl = TabHndl
END FUNCTION

'---------------------------------------------------------------------
'---------------------------------------------------------------------

FUNCTION FN.SetCtrlProp(CtlName$, TxtKey$, TxtColr, BkgKey$, BkgColr)

RetVal = 0
CtlHndl = HWND(#CtlName$)

CALLDLL #CTL, "SetProperty", CtlHndl AS ULONG, TxtKey$ AS PTR, _
              TxtColr AS ULONG, BkgKey$ AS PTR, BkgColr AS ULONG, _
              RetVal AS VOID
END FUNCTION

'-------------------------------------------------------------------
'-------------------------------------------------------------------

FUNCTION FN.InitColors(WinName$, TxtKey$, BkgKey$, FrmColr, BmpTrue)

OldProc = 0
WinHndl = HWND(#WinName$)
CALLDLL #CTL, "FN_InitProperties", WinHndl AS ULONG, _
             TxtKey$ AS PTR, BkgKey$ AS PTR, FrmColr AS ULONG, _
             BmpTrue AS LONG, OldProc AS ULONG

END FUNCTION

'----------------------------------------------------------------------
'----------------------------------------------------------------------

FUNCTION FN.AddTab(TabName$, TabHndl, Caption$, Index)

WinHndl = HWND(#TabName$)

CALLDLL #TAB, "FN_AddTab", _
            TabHndl AS ULONG, _   '<--- Obtained from "FN_InitTab"
            WinHndl AS ULONG, _   '<--- Handle associated with this tab
                  0 AS ULONG, _   '<--- RESERVERED FOR FUTURE USE
             Caption$ AS PTR, _   '<--- Text displayed on the tab
               Index AS LONG, _   '<--- ZERO based index of tab
           TabCnt AS LONG
END FUNCTION

'--------------------------------------------------------------
'--------------------------------------------------------------

FUNCTION FN.SetStyle(TabHndl, Index, Style, ExStyle)

Idx = 0
CALLDLL #TAB, "SetWinStyle", _
          TabHndl AS ULONG, _  '<--- handle of tab control
             Index AS LONG, _  '<--- zero based tab index
            Style AS ULONG, _  '<--- new window style
          ExStyle AS ULONG, _  '<--- no extended style
               Idx AS VOID     '<--- no return value
END FUNCTION

'------------------------------------------------------------
'------------------------------------------------------------

FUNCTION FN.CloseColors(ColrName$)

WinHndl = HWND(#ColrName$)

CALLDLL #CTL, "FN_CLOSE", WinHndl AS ULONG, RetVal AS VOID

END FUNCTION
'

COLORTAB.ZIP (42.95 KB)

[Walt Decker]

Tab control within tab control. Can add custom colors (code and dll not included) if desired. The attached zip contains:

TBinTB_0._bas

TABCTL.DLL

'
NOMAINWIN
'###########################################################
'   window styles to remove the caption and system
'   menu from the embedded tab windows.
'##########################################################
WS.CHILD          = HEXDEC("&H40000000")
WS.VISIBLE        = HEXDEC("&H10000000")
WS.CLIPCHILDREN   = HEXDEC("&H02000000")
WS.DLGFRAME       = HEXDEC("&H00400000")
WS.BORDER         = HEXDEC("&H00800000")

WS.EX.DLGMODALFRAME   = HEXDEC("&H00000001") '<--- extended style

SS.CENTERIMAGE      = HEXDEC("&H00000200") '<--- static control styles
SS.CENTER           = HEXDEC("&H00000001")
SS.LBL = SS.CENTERIMAGE OR SS.CENTER OR WS.DLGFRAME

OPEN "User32.dll" FOR DLL AS #USER
OPEN "TABCTL" FOR DLL AS #TAB

'<----- define controls for base window #REPAIR ---------->
STYLEBITS #REPAIR.LBLAST, SS.LBL, 0, 0, 0
STYLEBITS #REPAIR.LBFIRST, SS.LBL, 0, 0, 0
STYLEBITS #REPAIR.LBMI, SS.LBL, 0, 0, 0

STATICTEXT #REPAIR.LBLAST, "LAST NAME", 5, 5, 125, 20
STATICTEXT #REPAIR.LBFIRST, "FIRST NAME", 135, 5, 125, 20
STATICTEXT #REPAIR.LBMI, "INITIAL", 265, 5, 75, 20

STYLEBITS #REPAIR.TXLAST, WS.DLGFRAME, WS.BORDER, 0, 0
STYLEBITS #REPAIR.TXFIRST, WS.DLGFRAME, WS.BORDER, 0, 0
STYLEBITS #REPAIR.TXMI, WS.DLGFRAME, WS.BORDER, 0, 0

TEXTBOX #REPAIR.TXLAST, 5, 30, 125, 25
TEXTBOX #REPAIR.TXFIRST, 135, 30, 125, 25
TEXTBOX #REPAIR.TXLAST, 265, 30, 75, 25

Bottom = 300 - 71
BUTTON #REPAIR.SUBMIT, "APPLY", APPLY.BTN, UL, 165, Bottom, 45, 25

'<---------- define controls for #REPAIR tabs --------------->
LISTBOX #MAK.LBX, Lbx$(), GET.LIST, 5, 5, 200, 200
LISTBOX #MODL.LBX, Lbx$(), GET.LIST, 5, 5, 200, 200

'<---------- define controls for #COST tabs ------------->
LISTBOX #PARTS.LBX, Lbx$(), GET.LIST, 5, 5, 200, 200
LISTBOX #LABOR.LBX, Lbx$(), GET.LIST, 5, 5, 200, 200


WindowWidth = DisplayWidth / 2
WindowHeight = DisplayHeight / 2

OPEN "REPAIRS" FOR WINDOW AS #REPAIR '<--- main window
OPEN "MAKE" FOR WINDOW AS #MAK   '<--- tab windows for #REPAIR
OPEN "MODEL" FOR WINDOW AS #MODL

OPEN "COST" FOR WINDOW AS #COST    '<--- cost window
OPEN "PARTS" FOR WINDOW AS #PARTS  '<--- tab windows for #COST
OPEN "LABOR" FOR WINDOW AS #LABOR

'<---------- put a tab control on #COST -------------->
CostTab = FN.InitTabCtl("#COST", CostHndl, 2, 2, -2, -2)

'<---------- add tabs to #COST ----------------------->
NewTab = FN.AddTab("#PARTS", CostTab, "PARTS", 0)
NewTab = FN.AddTab("#LABOR", CostTab, "LABOR", NewTab)

'<---------- set styles for #COST tab windows ------->
Style = WS.VISIBLE OR WS.CLIPCHILDREN OR WS.DLGFRAME
ExStyle = 0
NewTab = FN.SetStyle(CostTab, 0, Style, ExStyle)
NewTab = FN.SetStyle(CostTab, 1, Style, ExStyle) '<--- NewTab = 0

'<----------- put a tab control on #REPAIR ----------------->
RepairTab = FN.InitTabCtl("#REPAIR", RepairHndl, 5, 60, -5, -40)

'<-------------- add tabs to #REPAIR ----------------->
NewTab = FN.AddTab("#MAK", RepairTab, "MAKE", NewTab)
NewTab = FN.AddTab("#MODL", RepairTab, "MODEL", NewTab)

'<---------------- make #COST a tab of #REPAIR -------------->
NewTab = FN.AddTab("#COST", RepairTab, "COST", NewTab)

'<--------- set the style for tab windows ----------->
NewTab = FN.SetStyle(RepairTab, 0, Style, ExStyle)
NewTab = FN.SetStyle(RepairTab, 1, Style, ExStyle)
NewTab = FN.SetStyle(RepairTab, 2, Style, ExStyle)

PRINT #REPAIR, "RESIZEHANDLER [RESIZE.WIN]"
PRINT #REPAIR, "TRAPCLOSE REPAIR.END"
[BEGIN.WAIT]
WAIT

[RESIZE.WIN]

CALLDLL #TAB, "UpdateTab", RepairTab AS ULONG, RetVal AS VOID
CALLDLL #TAB, "UpdateTab", CostTab AS ULONG, RetVal AS VOID
GOTO [BEGIN.WAIT]
[RESIZE.WIN.END]

'--------------------------------------------------------------------
'--------------------------------------------------------------------

SUB REPAIR.END Hndl$

CALLDLL #TAB, "CLOSEALLTABS", RetVal AS VOID

CLOSE #REPAIR
CLOSE #MAK
CLOSE #MODL
CLOSE #COST
CLOSE #PARTS
CLOSE #LABOR

CLOSE #USER
CLOSE #TAB

END
END SUB

'-----------------------------------------------------------------------
'-----------------------------------------------------------------------

SUB APPLY.BTN BtnHndl$
'#######################################################
'  Button event handler
'#######################################################

END SUB

'-----------------------------------------------------------------
'-----------------------------------------------------------------

FUNCTION FN.InitTabCtl(WinName$, BYREF WinHndl, Xoffs, Yoffs, Bx, By)

'<--- structure to define where the tab control is and its style ----->
STRUCT tTab, _
TabStyle    AS ULONG, _  '<--- if this is zero default values are used
        X    AS LONG, _  '<--- upper left corner of tab control
        Y    AS LONG, _
        X1   AS LONG, _  '<--- lower right corner of control
        Y1   AS LONG

'<--- structure for determining client size of parent window --->
STRUCT tRect, _
 X  AS LONG, _
 Y  AS LONG, _
 X1 AS LONG, _
 Y1 AS LONG

WinHndl = 0
TabHndl = 0
RetVal  = 0

WinHndl = HWND(#WinName$)
CALLDLL #USER, "GetClientRect", WinHndl AS ULONG, tRect AS STRUCT, _
               RetVal AS VOID
tTab.X.struct = Xoffs
tTab.Y.struct = Yoffs

tTab.X1.struct = tRect.X1.struct
tTab.Y1.struct = tRect.Y1.struct

IF Bx < 0 THEN tTab.X1.struct = Bx
IF By < 0 THEN tTab.Y1.struct = By
IF Bx > 0 THEN tTab.X1.struct = Bx
IF By > 0 THEN tTab.Y1.struct = By

CALLDLL #TAB, "FN_InitTab", _
         WinHndl AS ULONG, _  '<--- Parent window handle
           tTab AS STRUCT, _  '<--- Configuration structure
         TabHndl AS ULONG     '<--- RETURN: Handle of tab control
                              'otherwise zero

FN.InitTabCtl = TabHndl
END FUNCTION

'---------------------------------------------------------------------
'---------------------------------------------------------------------

FUNCTION FN.AddTab(TabName$, TabHndl, Caption$, Index)

WinHndl = HWND(#TabName$)

CALLDLL #TAB, "FN_AddTab", _
            TabHndl AS ULONG, _   '<--- Obtained from "FN_InitTab"
            WinHndl AS ULONG, _   '<--- Handle associated with this tab
                  0 AS ULONG, _   '<--- RESERVERED FOR FUTURE USE
             Caption$ AS PTR, _   '<--- Text displayed on the tab
               Index AS LONG, _   '<--- ZERO based index of tab
           TabCnt AS LONG         '<--- RETURN:  same as Index
FN.AddTab = TabCnt + 1
END FUNCTION

'--------------------------------------------------------------
'--------------------------------------------------------------

FUNCTION FN.SetStyle(TabHndl, Index, Style, ExStyle)

Idx = 0
CALLDLL #TAB, "SetWinStyle", _
          TabHndl AS ULONG, _  '<--- handle of tab control
             Index AS LONG, _  '<--- zero based tab index
            Style AS ULONG, _  '<--- new window style
          ExStyle AS ULONG, _  '<--- new extended style
               Idx AS VOID     '<--- no return value
END FUNCTION

'------------------------------------------------------------
'------------------------------------------------------------
'

TABinTAB.ZIP (34.69 KB)

[metro]

Nov 17, 2021 15:03:57 GMT -5 Walt Decker said:

Tab control within tab control. Can add custom colors (code and dll not included) if desired. The attached zip contains:    

WOW, thanks Walt, looks like I now have a weekend of merging my code with this.
Great work !!!

Metro

[xxgeek]

Excellent functions to add to the Liberty Basic Help Lab and Project Organizer I'm working on Walt. Thanks for posting these.

If I may, I'll add some of these (the ones that don't need support files, like dll's)
I'll be updating it all winter, and checking the forums for more stuff to add.

The Help Lab is getting better every day.