Discussion thread for this post here: https://forum.powerbasic.com/forum/u...ion#post823790
'
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 %OIC_WARNING = 32515 %OIC_ERROR = 32513 %OIC_INFORMATION = 32516 %OIC_QUESTION = 32514 %STM_SETIMAGE = &H0172 %IMAGE_ICON = 1 %WM_NEXTDLGCTL = &H0028 '================== End of Required WInAPI includes ======================= ENUM ctrls SINGULAR btn1 = 1001 btn2 = 1002 btn3 = 1003 lblText lblFoot grph1 END ENUM FUNCTION DlgMsgBox(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 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 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 '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 'show messagebox and get button clicked DIALOG SHOW MODAL hDlg, CALL DlgMsgCB TO lngRet FUNCTION = retval(lngRet) END FUNCTION CALLBACK FUNCTION DlgMsgCB() STATIC btnID AS LONG LOCAL hBtn AS DWORD LOCAL lngSecs AS LONG SELECT CASE CB.MSG CASE %WM_INITDIALOG DIALOG GET USER CB.HNDL,1 TO BtnID 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 %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 LOCAL x,y AS LONG FONT NEW wsfont,lFontsize TO hFont GRAPHIC BITMAP NEW 1000, 20 TO hBmp GRAPHIC ATTACH hBmp,0 GRAPHIC SET FONT hFont x = GRAPHIC(TEXT.SIZE.X, wsText) GRAPHIC BITMAP END FUNCTION = x FONT END hFont END FUNCTION '
'
Code:
'Test code for Dialog message box with optional selectable font,colours and timeout. Autosizes and positions in centre of screen. #COMPILE EXE #DIM ALL #LINK "DlgMsgBox.SLL" #RESOURCE MANIFEST, 1, "XPTheme.xml" FUNCTION PBMAIN() AS LONG LOCAL lRet AS LONG LOCAL wsMsg AS WSTRING wsMsg = "This is a Warning Message." & $LF & _ "It tells you something important" & $LF & _ "..." & $LF & _ "Thie message will time out after five seconds" & _ " and return 'Cancel' (%MB_DEBBUTTON1)." DO lRet = DlgMsgBox(wsMsg,%MB_CANCELTRYCONTINUE OR %MB_DEFBUTTON2,"This is a Messagebox", _ "Arial Bold",12,%RGB_RED,%RGB_YELLOW,5) SELECT CASE lRet CASE %IDCANCEL ? "Cancelled" EXIT FUNCTION CASE %IDRETRY ? "Retry" CASE %IDCONTINUE ? "Continue" END SELECT LOOP WHILE lRet = %IDRETRY ? "We've continued" END FUNCTION '
Comment