Announcement

**Stuart McLachlan** · 20 May 2023, 09:41 PM

Deleted - see post above for new version as an SLL.

**Rod Macia** · 20 May 2023, 11:45 PM

I assume this is a Typo "CancelL" should be "Cancel"

CASE %MB_YESNOCANCEL
lngButtons = 3
txtB1 = "CancelL"

**Stuart McLachlan** · 21 May 2023, 01:42 AM

Originally posted by Rod Macia View Post

I assume this is a Typo "CancelL" should be "Cancel"

CASE %MB_YESNOCANCEL
lngButtons = 3
txtB1 = "CancelL"

Thanks, fixed in code above.

**Stuart McLachlan** · 25 May 2023, 07:55 PM

Latest version of SLL - honours %WM_SYSTEMMODAL etc. and Ctrl+C copies the message to the clipboard

'

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
---------------------------

Announcement

Forum Guidelines

DDT custom Message Box

PBWin DDT custom Message Box

Comment

Comment

Comment

Comment