'
Code:
'A Message box replacement as a PowerBasic Static Link Library
'Selectable font and optional colours and timeout.
'Autosizes and positions in centre of screen.
'by S McLachlan May 2023
'Contains one callable COMMON function: DlgMsgBox(....)
' Parameters
' wsText - required. Text to display. Delimit multiple lines in wsText with $LF
' lButtons - required. Use standard messagebox %MB_xxxxxxxxx constants. N.B. it always displays as %MB_TASKMODAL
' wsTitle - required. The message box caption (can be an empty string)
' wsFont - required. Any available Windows TTF font. For a standard appearance uses "Segoe UI"
' lFontSize - required. Points. For a standard appearance uses 8 point Segoe UI.
' lFGColour - optional. Foreground colour - use RGB() or PB's built in equates (defaults to black)
' lBGColour - optional Background colour - use RGB() or PB's built in equates (Defaults to white)
' lTimeOutSecs - optional - Time out in seconds. Defaults to 0 (No timeout)
'======================================================================================================================
#COMPILE SLL "DlgMsgBox"
'================== Required WInAPI includes =======================
DECLARE FUNCTION LoadIcon LIB "User32.dll" ALIAS "LoadIconA" _
(BYVAL hInstance AS DWORD, lpIconName AS ASCIIZ) AS DWORD
DECLARE FUNCTION SetTimer LIB "User32.dll" ALIAS "SetTimer" _
(BYVAL hWnd AS DWORD, BYVAL nIDEvent AS DWORD, BYVAL uElapse AS DWORD, _
OPTIONAL BYVAL lpTimerFunc AS DWORD) AS DWORD
DECLARE FUNCTION SetWindowPos LIB "User32.dll" ALIAS "SetWindowPos" _
(BYVAL hWnd AS DWORD, BYVAL hWndInsertAfter AS DWORD, BYVAL x AS LONG, _
BYVAL y AS LONG, BYVAL cx AS LONG, BYVAL cy AS LONG, _
BYVAL wFlags AS DWORD) AS LONG
%OIC_WARNING = 32515
%OIC_ERROR = 32513
%OIC_INFORMATION = 32516
%OIC_QUESTION = 32514
%STM_SETIMAGE = &H0172
%IMAGE_ICON = 1
%WM_NEXTDLGCTL = &H0028
%FVIRTKEY = 1
%VK_CONTROL = &H11
%VK_C = &H43
%FCONTROL = &H08
%VK_Z = &H5A
TYPE ACCELAPI WORD
fVirt AS BYTE ' Also called the flags field
Key AS WORD
cmd AS WORD
END TYPE
%HWND_TOP = 0
%HWND_TOPMOST = (-1 AND &HFFFFFFFF???) ' LO(DWORD,-1)
%SWP_NOMOVE = &H0002
%SWP_NOSIZE = &H0001
'================== End of Required WInAPI includes =======================
%Accel = 2000
GLOBAL hAccelHndl AS DWORD
GLOBAL ac() AS accelapi
ENUM ctrls SINGULAR
btn1 = 1001
btn2 = 1002
btn3 = 1003
lblText
lblFoot
grph1
END ENUM
FUNCTION DlgMsgBox(hParent AS DWORD, wsText AS WSTRING,lButtons AS LONG,wsTitle AS WSTRING, _
wsFont AS WSTRING,lFontsize AS LONG, _
OPT lFGColour AS LONG, lBGColour AS LONG, lTimeOutSecs AS LONG) COMMON AS LONG
LOCAL txtB1,txtB2,txtB3 AS WSTRING
LOCAL hDlg ,hIcon,hLst AS DWORD
LOCAL lngRet, x, lngLines,lngMaxLen,lngMaxLenPx, lngButtonLen AS LONG
LOCAL dlgX AS LONG, dlgY AS LONG
LOCAL lngPX,lngPY,lngDUX,lngDUY AS LONG
LOCAL lngButtons,lngDefBut AS LONG
LOCAL lngFGColour,lngBGColour,lngTOSecs,lngModal AS LONG
DIM Retval(1 TO 3) AS LONG
'Handle missing optionals parameters
IF (VARPTR(lFGColour) = 0) OR (lFGColour = -1) THEN lngFGCOlour = %RGB_BLACK ELSE lngFGColour = lFGColour
IF (VARPTR(lBGColour) = 0) OR (lFGColour = -1) THEN lngBGColour = %RGB_WHITE ELSE lngBGColour = lBGColour
IF (VARPTR(lTimeOutSecs) = 0) THEN lngTOSecs = 0 ELSE lngTOSecs = lTimeOutSecs
'Get required buttons
SELECT CASE AS LONG (lButtons AND &B0111)
CASE %MB_OK
lngButtons = 1
txtB1 = "OK"
retval(1) = %IDOK
CASE %MB_OKCANCEL
lngButtons = 2
txtB1 = "Cancel"
txtB2 = "OK"
retval(1) = %IDCANCEL
retval(2) = %IDOK
CASE %MB_ABORTRETRYIGNORE
lngButtons = 3
txtB1 = "Ignore"
txtB2 = "Try Again"
txtB3 = "ABORT"
retval(1) = %IDIGNORE
retval(2) = %IDRETRY
retval(3) = %IDABORT
CASE %MB_YESNOCANCEL
lngButtons = 3
txtB1 = "Cancel"
txtB2 = "No"
txtB3 = "Yes"
retval(1) = %IDCANCEL
retval(2) = %IDNO
retval(3) = %IDYES
CASE %MB_YESNO
lngButtons = 2
txtB1 = "No"
txtB2 = "Yes"
retval(1) = %IDNO
retval(2) = %IDYES
CASE %MB_RETRYCANCEL
lngButtons = 2
txtB1 = "Cancel"
txtB2 = "Try Again"
retval(1) = %IDCANCEL
retval(2) = %IDRETRY
CASE %MB_CANCELTRYCONTINUE
lngButtons = 3
txtB1 = "Continue"
txtB2 = "Try Again"
txtB3 = "Cancel"
retval(1) = %IDCONTINUE
retval(2) = %IDRETRY
retval(3) = %IDCANCEL
END SELECT
'Get Icon
'To scale icon we need to do it by loading into an appropriately sized imagelist
'and then copy it to a graphic control.
IMAGELIST NEW ICON (lFontsize * 4),(lFontsize * 4),32, 1 TO hLst
SELECT CASE AS LONG (lButtons AND &B01110000)
CASE %MB_ICONERROR
hIcon = LoadIcon(BYVAL 0, BYVAL %OIC_ERROR)
IMAGELIST ADD ICON hLst, hIcon
CASE %MB_ICONWARNING
hIcon = LoadIcon(BYVAL 0, BYVAL %OIC_WARNING)
IMAGELIST ADD ICON hLst, hIcon
CASE %MB_ICONINFORMATION
hIcon = LoadIcon(BYVAL 0, BYVAL %OIC_INFORMATION)
IMAGELIST ADD ICON hLst, hIcon
CASE %MB_ICONQUESTION
hIcon = LoadIcon(BYVAL 0, BYVAL %OIC_QUESTION)
IMAGELIST ADD ICON hLst, hIcon
END SELECT
'GetDefaultButton - 'Default Button numbered from left To right
lngDefBut = 1
IF lngButtons = 2 AND (lButtons AND &B1100000000) = %MB_DEFBUTTON1 THEN lngDefBut = 2
IF lngButtons = 3 THEN
SELECT CASE AS LONG (lButtons AND &B1100000000)
CASE %MB_DEFBUTTON1 : lngDefBut = 3
CASE %MB_DEFBUTTON2 : lngDefBut = 2
CASE %MB_DEFBUTTON3 : lngDefBut = 1
END SELECT
END IF
'get modal
SELECT CASE AS LONG (lButtons AND &B11000000000000)
CASE %MB_APPLMODAL : lngModal = 0
CASE %MB_SYSTEMMODAL : lngModal = 1
CASE %MB_TASKMODAL : lngModal = 2
END SELECT
'Get number of lines and longest line in pixels
lngLines = PARSECOUNT(wsText,$LF)
DIM wsARR(1 TO lngLines) AS WSTRING
PARSE wsText,wsArr(), $LF
LOCAL lTmp AS LONG
FOR x= 1 TO lngLines
lTmp = TextLen(wsFont,lFontSize,wsARr(x))
IF lTmp > lngMaxLenPx THEN lngMaxLenPx = lTmp
NEXT
'initialise Dialog
DIALOG DEFAULT FONT wsFont,lFontSize
DIALOG NEW 0,wsTitle,,,0,0 TO hDlg
DIALOG SET COLOR hdlg, lngFGColour,lngBGColour
IF lngModal = 2 AND hPArent > 0 THEN
DIALOG DISABLE hParent
setwindowpos hDlg, %HWND_TOPMOST,0,0,0,0,%SWP_NOMOVE
END IF
IF lngModal THEN
setwindowpos hDlg, %HWND_TOP,0,0,0,0,%SWP_NOMOVE
IF hParent > 0 THEN DIALOG DISABLE hParent
END IF
'Calculate required size of dialog in Dialog Units
lngButtonLen = (60 * lngButtons) + 16 'make sure we have enough width for the number of buttons
'convertt maximum line length from pixels to DUs
DIALOG PIXELS hDLg, lngMaxLenPx,lngMaxLenPx TO UNITS dlgX,dlgY
#IF %PB_REVISION = &H1004 ' if compiler PBWIN10.04
SWAP dlgX, dlgY ' we need to swap result
#ENDIF
'Add margins
dlgX = dlgX + 20 ' margins
IF hIcon THEN dlgX = dlgX + 32 ' plus space for icon if required
dlgX = MAX(lngButtonLen, dlgX)
dlgY = 68 + lngLines *8 '1 x DU = 1/8 of average character height for the font (and 1/4 of average character width)
'position in centre of screen and size to fit font
DESKTOP GET SIZE TO lngPX,lngPY
DIALOG PIXELS hDlg,lngPX,lngPY TO UNITS lngDUX,lngDUY
#IF %PB_REVISION = &H1004 ' if compiler PBWIN10.04
SWAP lngDUX, lngDUY ' we need to swap result
#ENDIF
DIALOG SET LOC hDlg, (lngDUX - dlgX)/2,(lngDUY - dlgY)/2
DIALOG SET SIZE hDlg, dlgX,dlgY
'now build the controls
'buttons
CONTROL ADD LABEL ,hdlg,%lblFoot,"", 0,dlgY-44,dlgX, 44
IF lngButtons =3 THEN
CONTROL ADD BUTTON, hDlg,%btn3,txtB3,dlgX - 186,dlgY - 38,50,16,%WS_CHILD OR %WS_TABSTOP
END IF
IF lngButtons > 1 THEN
CONTROL ADD BUTTON ,hDlg,%btn2,txtB2,dlgX - 126,dlgY -38,50,16,%WS_CHILD OR %WS_TABSTOP
END IF
CONTROL ADD BUTTON ,hDlg,%btn1,txtB1,dlgX - 66,dlgY - 38,50,16,%WS_CHILD OR %WS_TABSTOP
'body
IF hIcon THEN
CONTROL ADD GRAPHIC ,hDlg,%grph1,"", 10, 12, 32, 32,%WS_CHILD OR %WS_VISIBLE 'styles needed to avoid default OwnerDraw which messes up the button tab cycle
GRAPHIC ATTACH hDlg,1006
GRAPHIC CLEAR lngBGColour
GRAPHIC IMAGELIST (0,0), hLst, 1,0, %ILD_TRANSPARENT
IMAGELIST KILL hLst
GRAPHIC DETACH
CONTROL ADD LABEL ,hdlg,%lblText, wsText,44,12,dlgX - 5, dlgY - 60
ELSE
CONTROL ADD LABEL ,hdlg,%lblText, wsText,8,12,dlgX - 5, dlgY - 60
END IF
CONTROL SET COLOR HdLG,%lblText,lngFGColour,lngBGColour
CONTROL SET COLOR hDlg,%lblFoot,RGB(240,240,240),RGB(240,240,240) ' Default light grey
' Store parameters for use in CALLBACK InitDialog
DIALOG SET USER hDlg,1 ,lngDefBut
DIALOG SET USER hDlg,2 ,lngTOSecs
DIALOG SET USER hDLg,3, lngButtons
DIM Ac(0 TO 0)
Ac(0).key = %VK_C : Ac(0).cmd = %Accel : Ac(0).fvirt = %FVIRTKEY OR %FCONTROL
ACCEL ATTACH hdlg,ac() TO hAccelHndl
'show messagebox and get button clicked
DIALOG SHOW MODAL hDlg, CALL DlgMsgCB TO lngRet
FUNCTION = retval(lngRet)
DIALOG ENABLE hParent
setwindowpos hParent, %HWND_TOP,0,0,0,0,%SWP_NOMOVE OR %SWP_NOSIZE
END FUNCTION
CALLBACK FUNCTION DlgMsgCB()
STATIC btnID,lBUttons,x AS LONG
LOCAL hBtn AS DWORD
LOCAL lngSecs AS LONG
LOCAL wsCB,wsTmp AS WSTRING
SELECT CASE CB.MSG
CASE %WM_INITDIALOG
DIALOG GET USER CB.HNDL,1 TO BtnID
DIALOG GET USER CB.HNDL, 3 TO lButtons
CONTROL HANDLE CB.HNDL, 1000+BtnID TO hBtn
DIALOG POST CB.HNDL, %WM_NEXTDLGCTL , hBtn, 1
DIALOG GET USER CB.HNDL, 2 TO lngSecs
IF lngSecs THEN settimer CB.HNDL, 1,lngSecs * 1000,0
CASE %WM_TIMER
IF CB.WPARAM = 1 THEN ' timed out
DIALOG END CB.HNDL, BtnID
END IF
CASE %WM_COMMAND
SELECT CASE CB.CTL
CASE %Accel
DIALOG GET TEXT CB.HNDL TO wsTmp
wsCB = CHR$$("---------------------------",$CRLF,wsTmp,$CRLF,"---------------------------",$CRLF)
CONTROL GET TEXT CB.HNDL,%lblText TO wsTmp
wsCB &= CHR$$(wsTmp,$CRLF,"---------------------------",$CRLF)
FOR x = 1 TO lButtons
CONTROL GET TEXT CBHNDL,1000+x TO wsTmp
wsCB &= wsTmp & " "
NEXT
wsCB = wsCB & $CRLF & "---------------------------" & $CRLF
CLIPBOARD RESET
CLIPBOARD SET TEXT wsCB
CASE %btn1
DIALOG END CB.HNDL ,1
CASE %btn2
DIALOG END CB.HNDL ,2
CASE %btn3
DIALOG END CB.HNDL ,3
END SELECT
END SELECT
END FUNCTION
FUNCTION TextLen(wsfont AS WSTRING,lFontSize AS LONG,wsText AS WSTRING) AS LONG
'Get actual length of text string in pixels for selected font
LOCAL hBmp,hFont AS DWORD
FONT NEW wsfont,lFontsize TO hFont
GRAPHIC BITMAP NEW 1000, 20 TO hBmp
GRAPHIC ATTACH hBmp,0
GRAPHIC SET FONT hFont
FUNCTION = GRAPHIC(TEXT.SIZE.X, wsText)
GRAPHIC BITMAP END
FONT END hFont
END FUNCTION
'
Now Ctrl+C copies Unicode text properly to the clipboard:
'
Code:
'Test code for Dialog message box
'Includes demo of Ctrl+C copy of Unicode text to clipboard
#COMPILE EXE "test4"
#DIM ALL
#DEBUG DISPLAY ON
#DEBUG ERROR ON
#LINK "DlgMsgBox.SLL"
#RESOURCE MANIFEST, 1, "XPTheme.xml"
%IDC_btnAction = 1001
#INCLUDE "win32api.inc"
FUNCTION PBMAIN() AS LONG
LOCAL lRslt AS LONG
LOCAL hDLg AS DWORD
DIALOG NEW 0, EXE.FULL$, , , 200, 180, %WS_SYSMENU, TO hDlg
CONTROL ADD BUTTON , hDlg,%IDC_btnAction,"Action",60,130,80,20
DIALOG SHOW MODAL hDlg, CALL MainDlgCB TO lRslt
END FUNCTION
CALLBACK FUNCTION MainDlgCB()
SELECT CASE AS LONG CB.MSG
CASE %WM_INITDIALOG
CASE %WM_NCACTIVATE
CASE %WM_COMMAND
SELECT CASE AS LONG CB.CTL
CASE %IDC_btnAction
'IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN
TestDLgMsg(CB.HNDL)
' END IF
END SELECT
END SELECT
END FUNCTION
FUNCTION TestDlgMsg(hDlg AS DWORD) AS LONG
LOCAL wsMsg AS WSTRING
LOCAL lRet AS LONG
wsMsg = "This is a Warning Message." & $LF & _
"It tells you something important" & $LF & _
"..." & $LF & _
"This message will time out after ten seconds" & _
"and return 'Cancel' (%MB_DEFBUTTON1)." & $LF & _
"Unicode (Greek ALphabet) " & CHR$$(&H0391 TO &H03A9)
DO
lRet = DlgMsgBox(hDlg,wsMsg,%MB_CANCELTRYCONTINUE OR %MB_DEFBUTTON1 OR %MB_ICONWARNING OR %MB_TASKMODAL,"This is a Messagebox", _
"Arial Bold",10,%RGB_RED,%RGB_YELLOW,10)
SELECT CASE lRet
CASE %IDCANCEL
? "Cancelled"
EXIT FUNCTION
CASE %IDRETRY
? "Retry"
CASE %IDCONTINUE
? "Continue"
END SELECT
LOOP WHILE lRet = %IDRETRY
END FUNCTION
'
Clipboard content of above :
---------------------------
This is a Messagebox
---------------------------
This is a Warning Message.
It tells you something important
...
This message will time out after ten secondsand return 'Cancel' (%MB_DEFBUTTON1).
Unicode (Greek ALphabet) ΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩ
---------------------------
Continue Try Again Cancel
---------------------------
Leave a comment: