Post by Walt Decker on Dec 17, 2021 15:32:52 GMT -5
Small bug in the code, probably a timing thing since LB is a little slow. Working on it
EDIT:
Fixed it.
With a little imigination one can easily change the button colors and/or the text font and color.
With the exception of CreateDIBsection() all the API functions are in the "Things You Do Not Want to Know..." reader.
'
WHITE = HEXDEC("&HFFFFFF")
SYSTEM.FONT = 13
OPEN "User32.Dll" FOR DLL AS #USER
OPEN "Gdi32.Dll" FOR DLL AS #GDI
RetVal = 0
WinHndl = 0
ChrCnt = -1
GLOBAL SysFont, _
LowId
DIM ChrStr$(25)
SysFont = FN.StockObj(SYSTEM.FONT)
LowId = 1000
A$ = ""
FOR I = ASC("A") TO ASC("Z")
ChrCnt = ChrCnt + 1
ChrStr$(ChrCnt) = FN.StrRepeat$(CHR$(I), 4)
NEXT I
RetVal = FN.CreateMemBmp(50, 50, WHITE)
RetVal = FN.SetMemBmpHndl("WHITE", RetVal)
RetVal = FN.SaveMemBmp("WHITE", "WHITE.BMP")
RetVal = FN.KillMemBmp("WHITE")
OPEN "BMPBUTTONS" FOR WINDOW AS #WIN
PRINT #WIN, "TRAPCLOSE CLOSE.WIN"
WinHndl = FN.GetHandle("#WIN")
RetVal = FN.CreateBmpButtons(WinHndl, 1000, 25, 50, 50, "WHITE.BMP")
RetVal = FN.MoveButtons(50, 50)
WAIT
END
'----------------------------------------------------------------
'----------------------------------------------------------------
SUB BTN.EVENT BtnHndl$
DT.CENTER = HEXDEC("&H00000001") 'See "DrawTextA"
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
ChrId = INT(RND(1) * 25)' + 1
Char$ = LEFT$(ChrStr$(ChrId), 1)
MemHndl = FN.LoadBmpFile("WHITE", "WHITE.BMP")
WinHndl = FN.DeskTop()
WinDc = FN.GetDc(WinHndl)
WinCmDc = FN.CompatDc(WinDc)
OldBmp = FN.AttachObj(WinCmDc, MemHndl)
OldFnt = FN.AttachObj(WinCmDc, SysFont)
tRect.X.struct = 4
tRect.Y.struct = 4
tRect.X1.struct = 46
tRect.Y1.struct = 46
CALLDLL #USER, "DrawTextA", WinCmDc AS ULONG, Char$ AS PTR, 1 AS LONG, _
tRect AS STRUCT, DT.TXT AS ULONG, RetVal AS LONG
OldBmp = FN.AttachObj(WinCmDc, OldBmp)
OldFnt = FN.AttachObj(WinCmDc, OldFnd)
WinCmDc = FN.KillDc(WinCmDc)
PRINT #BtnHndl$, "bitmap WHITE"
END SUB
'----------------------------------------------------------------
'----------------------------------------------------------------
SUB CLOSE.WIN WinStr$
FOR I = 1 TO 25
Title$ = "#" + STR$(I) + "BMP"
CLOSE #Title$
NEXT I
CLOSE #USER
CLOSE #GDI
CLOSE #WinStr$
END SUB
'----------------------------------------------------------------
'----------------------------------------------------------------
FUNCTION FN.StrRepeat$(Char$, NumChrs)
ChrStr$ = ""
FOR I = 1 TO NumChrs
ChrStr$ = ChrStr$ + Char$
NEXT I
FN.StrRepeat$ = ChrStr$
END FUNCTION
'----------------------------------------------------------------
'----------------------------------------------------------------
FUNCTION FN.CreateBmpButtons(PrntHndl, BtnId, NumBtns, Wwide, Whigh, FileName$)
WS.CHILD = HEXDEC("&H40000000")
WS.VISIBLE = HEXDEC("&H10000000")
WS.CLIPCHILDREN = HEXDEC("&H02000000")
WS.TABSTOP = HEXDEC("&H00010000")
WS.EX.TOPMOST = HEXDEC("&H00000008")
WS.EX.CONTROLPARENT = HEXDEC("&H00010000")
GWL.STYLE = -16
GWL.EXSTYLE = -20
Style = WS.CHILD OR WS.VISIBLE OR WS.CLIPCHILDREN OR WS.TABSTOP
ExStyle = WS.EX.TOPMOST OR WS.EX.CONTROLPARENT
WinHndl = 0
BtnHndl = 0
RetVal = 0
Xoffs = 2
Yoffs = 2
Count = 0
Wwide = Wwide + 1
Whigh = Whigh + 1
BtnId = BtnId - 1
DIM BtnName$(24)
FOR I = 1 TO NumBtns
Count = Count + 1
BtnId = BtnId + 1
Title$ = "BMP"
BMPBUTTON #BMP.BMP1, FileName$, BTN.EVENT, UL, 0, 0
OPEN "DUMMY" FOR WINDOW AS #BMP
BtnHndl = FN.GetHandle("BMP.BMP1")
WinHndl = FN.GetHandle("#BMP")
CALLDLL #USER, "SetWindowLongA", WinHndl AS ULONG, GWL.STYLE AS LONG, _
Style AS ULONG, RetVal AS VOID
CALLDLL #USER, "SetWindowLongA", WinHndl AS ULONG, GWL.EXSTYLE AS LONG, _
ExStyle AS ULONG, RetVal AS VOID
Title$ = "#" + STR$(I) + Title$
BtnName$(Count - 1) = Title$
MAPHANDLE #BMP, Title$
CALLDLL #USER, "SetParent", WinHndl AS ULONG, PrntHndl AS ULONG, RetVal AS VOID
' CALLDLL #USER, "MoveWindow", WinHndl AS ULONG, Xoffs AS LONG, Yoffs AS LONG, _
' Wwide AS LONG, Whigh AS LONG, 1 AS LONG, RetVal AS VOID
' Xoffs = Xoffs + Wwide
' IF Count = 5 THEN
' Count = 0
' Xoffs = 2
' Yoffs = Yoffs + Whigh
' END IF
NEXT I
END FUNCTION
'----------------------------------------------------------------
'----------------------------------------------------------------
FUNCTION FN.MoveButtons(Wwide, Whigh)
Xoffs = 3
Yoffs = 3
I = 0
J = 0
Count = -1
WinHndl = 0
Title$ = ""
FOR I = 1 TO 5
FOR J = 1 TO 5
Count = Count + 1
Trace 2
'Title$ = "#" + STR$(Count) + "BTN"
Title$ = BtnName$(Count)
WinHndl = FN.GetHandle(Title$)
CALLDLL #USER, "MoveWindow", WinHndl AS ULONG, Xoffs AS LONG, _
Yoffs AS LONG, Wwide AS LONG, Whigh AS LONG, _
1 AS LONG, RetVal AS VOID
Xoffs = Xoffs + Wwide
NEXT J
Xoffs = 3
Yoffs = Yoffs + Whigh
NEXT I
REDIM BtnName$(-1)
END FUNCTION
'----------------------------------------------------------------
'----------------------------------------------------------------
FUNCTION FN.LoadBmpFile(Tag$, LoadName$)
BmpHndl = 0
LOADBMP Tag$, LoadName$
BmpHndl = HBMP(Tag$)
FN.LoadBmpFile = BmpHndl
END FUNCTION
'---------------------------------------------------------------------
'---------------------------------------------------------------------
FUNCTION FN.SaveMemBmp(Tag$, SaveName$)
'###########################################################
' Save a memory bitmap to mass storage.
' ARGUMENTS:
' Tag$: String name assigned when the bitmap was
' loaded by LOADBMP or creaged by "getbmp"
' SaveName$: File name to use for saving. May include
' a mass storage path.
'###########################################################
BMPSAVE Tag$, SaveName$
END FUNCTION
'---------------------------------------------------------------------
'---------------------------------------------------------------------
FUNCTION FN.KillMemBmp(Tag$)
'###########################################################
' Remove bitmap created by Liberty Basic from memory
' ARGUMENTS:
' Tag$: String name assigned to memory bitmap
' when it was created by LOADBMP or "getbmp"
'###########################################################
UNLOADBMP Tag$
END FUNCTION
'---------------------------------------------------------------------
'---------------------------------------------------------------------
FUNCTION FN.SetMemBmpHndl(Tag$, BmpHndl)
'###########################################################
' Assign a name to a memory bitmap object and set its
' numeric handle property.
' ARGUMENTS:
' Tag$: String name to assign. EXAMPLE: Tag$ = "SPIDER".
' BmpHndl: Numeric handle of a memory bitmap.
'###########################################################
LOADBMP Tag$, BmpHndl
END FUNCTION
'---------------------------------------------------------------------
'---------------------------------------------------------------------
FUNCTION FN.CheckTag$(Tag$)
IF LEFT$(Tag$, 1) <> "#" THEN Tag$ = "#" + Tag$
FN.CheckTag$ = Tag$
END FUNCTION
'---------------------------------------------------------------------
'---------------------------------------------------------------------
FUNCTION FN.GetHandle(WinTag$)
Handle = 0
WinTag$ = FN.CheckTag$(WinTag$)
Handle = HWND(#WinTag$)
FN.GetHandle = Handle
END FUNCTION
'---------------------------------------------------------------------
'---------------------------------------------------------------------
FUNCTION FN.CreateMemBmp(BmpWide, BmpHigh, RgbColor)
PS.SOLID = 0
DARKGRAY = HEXDEC("&HA9A9A9")
PAILGRAY = HEXDEC("&HDCDCDC")
RetVal = 0
WinHndl = 0
MemHndl = 0
WinCmDc = 0
WinDc = 0
OrigPen = 0
Pen = 0
OrigBmp = 0
WinHndl = FN.DeskTop()
WinDc = FN.GetDc(WinHndl)
WinCmDc = FN.CompatDc(WinDc)
WinDc = FN.DetachDc(WinHndl, WinDc)
MemHndl = FN.CreateDIB(WinCmDc, BmpWide, BmpHigh)
OrigBmp = FN.AttachObj(WinCmDc, MemHndl)
RetVal = FN.ClearBmp(WinCmDc, RgbColor, BmpWide, BmpHigh)
Pen = FN.Pen(PS.SOLID, 3, PAILGRAY)
OrigPen = FN.AttachObj(WinCmDc, Pen)
RetVal = FN.MoveTo(WinCmDc, 0, 1)
RetVal = FN.LineTo(WinCmDc, 47, 1)
RetVal = FN.MoveTo(WinCmDc, 0, 1)
RetVal = FN.LineTo(WinCmDc, 0, 47)
RetVal = FN.AttachObj(WinCmDc, OrigPen)
RetVal = FN.KillObj(Pen)
Pen = FN.Pen(PS.SOLID, 3, DARKGRAY)
OrigPen = FN.AttachObj(WinCmDc, Pen)
RetVal = FN.MoveTo(WinCmDc, 48, 0)
RetVal = FN.LineTo(WinCmDc, 48, 50)
RetVal = FN.MoveTo(WinCmDc, 0, 48)
RetVal = FN.LineTo(WinCmDc, 50, 48)
OrigPen = FN.AttachObj(WinCmDc, OrigPen)
Pen = FN.KillObj(Pen)
OrigBmp = FN.AttachObj(WinCmDc, OrigBmp)
WinCmDc = FN.KillDc(WinCmDc)
FN.CreateMemBmp = MemHndl
END FUNCTION
'--------------------------------------------------------------------
'--------------------------------------------------------------------
FUNCTION FN.DeskTop()
'######################################################################
' Get a handle to the monitor
'######################################################################
DtHndl = 0
CALLDLL #USER, "GetDesktopWindow", DtHndl AS ULONG
FN.DeskTop = DtHndl
END FUNCTION
'---------------------------------------------------------------
'---------------------------------------------------------------
FUNCTION FN.GetDc(WinHndl)
'######################################################################
' Get a context from MSWIN for the device (form window, control,
' printer, audio, external device).
'######################################################################
WinDc = 0
CALLDLL #USER, "GetDC", WinHndl AS ULONG, WinDc AS ULONG
FN.GetDc = WinDc
END FUNCTION
'---------------------------------------------------------------
'---------------------------------------------------------------
FUNCTION FN.CompatDc(WinDc)
'######################################################################
' Create a context compatible with a device.
'
' ARGUMENTS:
' WinDc: Device context.
' Do NOT use user32.dll ReleaseDC(), use gdi32.DLL
' DeleteDC() instead.
'######################################################################
ComPatDc = 0
CALLDLL #GDI, "CreateCompatibleDC", WinDc AS ULONG, ComPatDc AS ULONG
FN.CompatDc = ComPatDc
END FUNCTION
'-------------------------------------------------------------------
'-------------------------------------------------------------------
FUNCTION FN.DetachDc(WinHndl, WinDc)
'######################################################################
' Release a device context and its resources
'
' ARGUMENTS:
' WinHndl: The handle of a form window or control.
' WinDc: Device context obtained from GetDc().
'######################################################################
RetVal = 0
CALLDLL #USER, "ReleaseDC", WinHndl AS ULONG, WinDc AS ULONG, RetVal AS VOID
END FUNCTION
'---------------------------------------------------------------
'---------------------------------------------------------------
FUNCTION FN.CreateDIB(ComPatDc, BmWide, BmHigh)
STRUCT tBITMAPINFO, _ '<--- bitmap information structure
StrSize AS ULONG, _ '<--- size of structure
Width AS LONG, _ '<--- width of bitmap
Height AS LONG, _ '<--- height of bitmap
Planes AS SHORT, _ '<--- number of color planes
BitCount AS SHORT, _ '<--- number of bits to define colors
Compression AS ULONG, _ '<--- type of compression; See Below
SizeImage AS ULONG, _ '<--- size of image
XPelsPerMeter AS LONG, _ '<--- number of pixels per meter
YPelsPerMeter AS LONG, _
ClrUsed AS ULONG, _ '<--- number of colors in the bitmap
ClrImportant AS ULONG, _ '<--- important colors
Colors AS ULONG '<--- array of color in BRG format
BI.RGB = 0 'An uncompressed format.
DIB.RGB.COLORS = 0
BmpHndl = 0
tBITMAPINFO.StrSize.struct = LEN(tBITMAPINFO.struct)
tBITMAPINFO.Width.struct = BmWide
tBITMAPINFO.Height.struct = -1 * BmHigh '<--- top-down instead of bottom up
tBITMAPINFO.Planes.struct = 1
tBITMAPINFO.BitCount.struct = 32
tBITMAPINFO.Compression.struct = BI.RGB
CALLDLL #GDI, "CreateDIBSection", ComPatDc AS ULONG, tBITMAPINFO AS STRUCT, _
DIB.RGB.COLORS AS LONG, 0 AS LONG, 0 AS LONG, 0 AS LONG, _
BmpHndl AS ULONG
FN.CreateDIB = BmpHndl
END FUNCTION
'-----------------------------------------------------------
'-----------------------------------------------------------
FUNCTION FN.ClearBmp(BmpDc, RgbColor, Wide, High)
'###################################################
' Fill a memory bitmap with color
' ARGUMENTS:
' BmpDc: Compatible device context
' RgbColor: 32-bit value defining a color
' Wide, High: Size of bitmap
'###################################################
PS.SOLID = 0 '<--- pen style
RetVal = 0 '<--- dummy value
Brush = 0 '<--- brush handle
Pen = 0 '<--- pen handle
OldBrsh = 0 '<--- original objects
OldPen = 0
Wide = Wide + 1
High = High + 1
Brush = FN.SolidBrush(RgbColor) '<--- create a brush
Pen = FN.Pen(PS.SOLID, 0, RgbColor) '<--- create a pen
OldPen = FN.AttachObj(BmpDc, Pen) '<--- make pen and brush active
OldBrsh = FN.AttachObj(BmpDc, Brush)
'<----------- color the bitmap ---------------------------------->
CALLDLL #GDI, "Rectangle", BmpDc AS ULONG, -1 AS LONG, -1 AS LONG, _
Wide AS LONG, High AS LONG, RetVal AS VOID
OldPen = FN.AttachObj(BmpDc, OldPen) '<--- detatch pen and brush
OldBrsh = FN.AttachObj(BmpDc, OldBrsh)
RetVal = FN.KillObj(Brush) '<--- delete brush and pen
RetVal = FN.KillObj(Pen)
END FUNCTION
'------------------------------------------------------------
'------------------------------------------------------------
FUNCTION FN.AttachObj(WinDc, ThisObject)
'######################################################################
' Make an object (pen, brush, font, bitmap) active.
'
' ARGUMENTS:
' WinDc: Device context handle
' ThisObject: Object to make active.
'######################################################################
OrgObj = 0
CALLDLL #GDI, "SelectObject", WinDc AS ULONG, ThisObject AS ULONG, _
OrgObj AS ULONG
FN.AttachObj = OrgObj
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.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.StockObj(ObjIdx)
'####################################################################
' Return a windows standard object
' ARGUMENTS:
' ObjIdx: Index of windows standard object
'####################################################################
Object = 0
CALLDLL #GDI, "GetStockObject", ObjIdx AS LONG, Object AS ULONG
FN.StockObj = Object
END FUNCTION
'------------------------------------------------------------
'------------------------------------------------------------
FUNCTION FN.KillDc(WinDc)
'############################################################
' Destroy a device context and release WIN resources
'
' ARGUMENTS:
' WinDc: Device context to destroy.
' Do NOT use this function to destroy a device
' context obtained with the GetDC() function.
'############################################################
RetVal = 0
CALLDLL #GDI, "DeleteDC", WinDc AS ULONG, RetVal AS VOID
END FUNCTION
'-----------------------------------------------------------------
'-----------------------------------------------------------------
FUNCTION FN.KillObj(ThisObj)
'######################################################################
' Destroy an object (brush, pen, font) and release its resources
'######################################################################
DeadObj = 0
CALLDLL #GDI, "DeleteObject", ThisObj AS ULONG, DeadObj AS VOID
END FUNCTION
'---------------------------------------------------------------
'---------------------------------------------------------------
FUNCTION FN.MoveTo(WinDc, Xp, Yp)
RetVal = 0
CALLDLL #GDI, "MoveToEx", WinDc AS ULONG, Xp AS LONG, Yp AS LONG, _
0 AS LONG, RetVal AS VOID
END FUNCTION
'---------------------------------------------------------------------
'---------------------------------------------------------------------
FUNCTION FN.LineTo(WinDc, Xp, Yp)
RetVal = 0
CALLDLL #GDI, "LineTo", WinDc AS ULONG, Xp AS LONG, Yp AS LONG, RetVal AS VOID
END FUNCTION
'---------------------------------------------------------------------
'---------------------------------------------------------------------
'