ATOUTFOX
COMMUNAUTÉ FRANCOPHONE DES PROFESSIONNELS FOXPRO
Visual FoxPro : le développement durable

Nouvelle idée pour une boite de message   



L'auteur

Mike Gagnon
Canada Canada
Membre Simple
# 0000000025
enregistré le 14/10/2004

Gagnon Mike
Pointe Cla H9R 3K8
de la société Carver Technologies Inc.
Fiche personnelle


Note des membres
20/20
1 vote


Contributions > 05 - API et appels systèmes

Nouvelle idée pour une boite de message
# 0000000968
ajouté le 12/05/2020 16:43:57 et modifié le 27/05/2020
consulté 1284 fois
Niveau initié

Version(s) Foxpro :
VFP 9.0

Description
Vous pouvez trouver 402 icones dans le ImageRes.dll de windows 10, autres versions de Windows contient moins d'icones.
Code source :
&& Contribution additionel de Cesar Chalom, Anatolyi Mogylevets et Tore Bleken

* File: NEWDIALOG
* Version 2.2 - 2020-05-24
* https://vfpimaging.blogspot.com/2020/05/messagebox-using-simple-vista-task.html
* Displays a Task dialog simple dialog, with custom captions and icons
* Based on the sample from Anatolyi Mogylevets and Tore Bleken from VFPX
* https://github.com/VFPX/Win32API/blob/master/samples/sample_557.md
* Usage:

*!*  * Sample 1
*!*  ? NewDialog("Covid-19 warning", ;
*!*      "Custom title with no icon and background" + CHR(13) + "PLEASE STAY HOME!" + CHR(13) + "I hope you'll keep your word!", ;
*!*      " - Clean your hands often." + CHR(13) + ;
*!*      " - Avoid close contact with people who are sick." + CHR(13) + ;
*!*      " - Stay at home as much as possible." + CHR(13) + ;
*!*      " - Put distance between yourself and other people." + CHR(13) + ;
*!*      " - If you have a fever, cough and difficulty breathing, seek medical attention." + CHR(13), ;
*!*      ",S", ; && No icon, silver background
*!*      "\More Info,I agree,Leave me!") && Button captions, 1st button disabled
? NewDialog("Playing with Unicodes in buttons", ;
    "You did it!!!" + CHR(13) + "Custom title icon and background!" + CHR(13) + "Predefined unicode buttons", ;
 "There are currently 5 predefined buttons that will add a unicode icon automatically." + CHR(13) + CHR(13) + ;
 "Add an asterisk - '*' after the words below, and the corresponding icons will be added to the buttons:" + CHR(13) + CHR(13) + ;
 " Ok* <UC>27f6</UC> Ok <UC>2713</UC>" + CHR(13) + ;
 " Cancel* <UC>27f6</UC> Cancel <UC>d83dddd9</UC>" + CHR(13) + ;
 " Print* <UC>27f6</UC> Print <UC>2399</UC>" + CHR(13) + ;
 " Save* <UC>27f6</UC> Save <UC>d83dddab</UC>" + CHR(13) + ;
 " Search* <UC>27f6</UC> Search <UC>d83ddd0e</UC>", ;
    "Ok3,G", ; && Ok icon, green background
    "Ok*,Cancel*,Print*,Save*,Search*")  && Button captions
* Sample 10
? NewDialog("Playing with real icons in buttons", ;
    "Custom title icon and background!" + CHR(13) + "Predefined buttons with colored icons", ;
 "There are currently 5 predefined buttons that will add some colored icons automatically." + CHR(13) + CHR(13) + ;
 "Add an HASHTAG - '#' after the words below, and the corresponding icons will be added to the buttons:" + CHR(13) + CHR(13) + ;
 " - Ok# " + CHR(13) + ;
 " - Cancel# " + CHR(13) + ;
 " - Print# " + CHR(13) + ;
 " - Save# " + CHR(13) + ;
 " - Search# ", ;
    "I,B", ; && Information icon, blue background
    "Ok#,Cancel#,Print#,Save#,Search#")  && Button captions
    * Sample 9
? NewDialog("Covid-19 crazy warning - See the timer -->", ;
    "Please stay home!", ;
    " - Clean your hands often." + CHR(13) + ;
    " - Avoid close contact with people who are sick." + CHR(13) + ;
    " - Stay at home as much as possible." + CHR(13) + ;
    " - Put distance between yourself and other people." + CHR(13) + ;
    " - If you have a fever, cough and difficulty breathing, seek medical attention." + CHR(13), ;
    "!2", ; && Exlamation default with yellow backgound (default)
    "\More Info_99,I agree_5341,Leave me!_89,Ok_116802", ; && Button captions, 1st button disabled
    2, ;  && Default button
    "8000,<SECS> secs."&& Timeout
* Sample 8
? NewDialog("Covid-19 warning", ;
    "Custom title with no icon and background" + CHR(13) + "PLEASE STAY HOME!" + CHR(13) + "I hope you'll keep your word!", ;
    " - Clean your hands often." + CHR(13) + ;
    " - Avoid close contact with people who are sick." + CHR(13) + ;
    " - Stay at home as much as possible." + CHR(13) + ;
    " - Put distance between yourself and other people." + CHR(13) + ;
    " - If you have a fever, cough and difficulty breathing, seek medical attention." + CHR(13), ;
    ",S", ; && No icon, silver background
    "\More Info,I agree,Leave me!"&& Button captions, 1st button disabled
*!*  * Sample 2
*!*  ? NewDialog("Covid-19 crazy warning - See the timer -->", ;
*!*      "Please stay home!", ;
*!*      " - Clean your hands often." + CHR(13) + ;
*!*      " - Avoid close contact with people who are sick." + CHR(13) + ;
*!*      " - Stay at home as much as possible." + CHR(13) + ;
*!*      " - Put distance between yourself and other people." + CHR(13) + ;
*!*      " - If you have a fever, cough and difficulty breathing, seek medical attention." + CHR(13), ;
*!*      "!2", ; && Exlamation default with yellow backgound (default)
*!*      "\More Info_99,I agree_5341,Leave me!_89,Ok_116802", ; && Button captions, 1st button disabled
*!*      2, ;  && Default button
*!*      "8000,<SECS> secs.") && Timeout

*!*  * Sample 3
*!*  ? NewDialog("Playing with real icons in buttons", ;
*!*      "Custom title icon and background!" + CHR(13) + "Predefined buttons with colored icons", ;
*!*    "There are currently 5 predefined buttons that will add some colored icons automatically." + CHR(13) + CHR(13) + ;
*!*    "Add an HASHTAG - '#' after the words below, and the corresponding icons will be added to the buttons:" + CHR(13) + CHR(13) + ;
*!*    "  -  Ok#     " + CHR(13) + ;
*!*    "  -  Cancel# " + CHR(13) + ;
*!*    "  -  Print#  " + CHR(13) + ;
*!*    "  -  Save#   " + CHR(13) + ;
*!*    "  -  Search# ", ;
*!*      "I,B", ; && Information icon, blue background
*!*      "Ok#,Cancel#,Print#,Save#,Search#")  && Button captions


*!*  * Sample 4
*!*  ? NewDialog("Playing with Unicodes in buttons", ;
*!*      "You did it!!!" + CHR(13) + "Custom title icon and background!" + CHR(13) + "Predefined unicode buttons", ;
*!*    "There are currently 5 predefined buttons that will add a unicode icon automatically." + CHR(13) + CHR(13) + ;
*!*    "Add an asterisk - '*' after the words below, and the corresponding icons will be added to the buttons:" + CHR(13) + CHR(13) + ;
*!*    "     Ok*        <UC>27f6</UC>     Ok <UC>2713</UC>" + CHR(13) + ;
*!*    "     Cancel*    <UC>27f6</UC>     Cancel <UC>d83dddd9</UC>" + CHR(13) + ;
*!*    "     Print*     <UC>27f6</UC>     Print <UC>2399</UC>" + CHR(13) + ;
*!*    "     Save*      <UC>27f6</UC>     Save <UC>d83dddab</UC>" + CHR(13) + ;
*!*    "     Search*    <UC>27f6</UC>     Search <UC>d83ddd0e</UC>", ;
*!*      "Ok3,G", ; && Ok icon, green background
*!*      "Ok*,Cancel*,Print*,Save*,Search*")  && Button captions


*!*  * Sample 5
*!*   ? NewDialog("Critical error", ;
*!*      "Corrupted Data", ;
*!*      "An unexpected error has occurred and the system needs to be restarted." + ;
*!*      CHR(13) + CHR(13) + "What do you want to do ?", ;
*!*      "X5,R", ;
*!*      "Restart Now,Restart later,Keep working", ; && Button captions
*!*      2, ;  && Default button
*!*      8000) && Timeout



#DEFINE BM_SETIMAGE                     0xF7

#DEFINE TDM_SET_MARQUEE_PROGRESS_BAR  0x00000467
#DEFINE TDM_SET_PROGRESS_BAR_STATE      0x00000468
#DEFINE TDM_SET_PROGRESS_BAR_RANGE      0x00000469
#DEFINE TDM_SET_PROGRESS_BAR_POS    0x0000046A
#DEFINE TDM_SET_PROGRESS_BAR_MARQUEE  0x0000046B
#DEFINE TDM_SET_ELEMENT_TEXT          0x0000046C
#DEFINE TDM_UPDATE_ICON                   0x00000474

#DEFINE PBST_NORMAL  0x0001
#DEFINE PBST_ERROR  0x0002
#DEFINE PBST_PAUSED  0x0003

#DEFINE TDE_CONTENT                     0
#DEFINE TDE_EXPANDED_INFORMATION        1
#DEFINE TDE_FOOTER                      2
#DEFINE TDE_MAIN_INSTRUCTION            3

* Enum TASKDIALOG_ICON_ELEMENTS
#DEFINE TDIE_ICON_MAIN           0
#DEFINE TDIE_ICON_FOOTER         1

#DEFINE ICON_EMPTY 14


#DEFINE TDCBF_OK_BUTTON         1
#DEFINE TDCBF_YES_BUTTON        2
#DEFINE TDCBF_NO_BUTTON         4
#DEFINE TDCBF_CANCEL_BUTTON     8
#DEFINE TDCBF_RETRY_BUTTON      0x0010
#DEFINE TDCBF_CLOSE_BUTTON      0x0020

#DEFINE S_OK                    0
#DEFINE TD_WARNING_ICON         -1          && !
#DEFINE TD_ERROR_ICON           -2          && X
#DEFINE TD_INFORMATION_ICON     -3          && i
#DEFINE TD_SHIELD_ICON          -4          && Shield
#DEFINE TD_SHIELD_GRADIENT_ICON -5          && Shield Green BackGnd
#DEFINE TD_SHIELD_WARNING_ICON  -6          && ! Yellow BackGnd
#DEFINE TD_SHIELD_ERROR_ICON    -7          && X Red BackGnd
#DEFINE TD_SHIELD_OK_ICON       -8          && Ok Green BackGnd
#DEFINE TD_SHIELD_GRAY_ICON     -9          && Shield Silver BackGnd
#DEFINE IDI_APPLICATION         0x00007f00  && App
#DEFINE IDI_QUESTION            0x00007f02  && ?

#DEFINE GW_HWNDFIRST            0
#DEFINE GW_HWNDLAST             1
#DEFINE GW_HWNDNEXT             2
#DEFINE GW_CHILD                5

#DEFINE WM_LBUTTONDOWN          0x0201
#DEFINE WM_LBUTTONUP            0x0202

#DEFINE XMB_TIMERINTERVAL       200


FUNCTION NewDialog(tcTitle, tcInstruction, tcContent, tnIcon, tcButtons, tnDefaultBtn, tnTimeout) && , tcTimeoutCaption2)

    LOCAL loMsgB, lnOption
    m.loMsgB = CREATEOBJECT("xmbMsgBoxEx")

    m.lnOption = m.loMsgB.SendMessage(m.tcTitle, m.tcInstruction, m.tcContent, m.tnIcon, m.tcButtons, m.tnDefaultBtn, m.tnTimeout) &&, m.tcTimeoutCaption2)
    m.loMsgB  = NULL

    RETURN m.lnOption
ENDFUNC


DEFINE CLASS xmbMsgBoxEx AS CUSTOM
    Interval     = 0
    nXmbTimeout  = 0
    hDialog      = 0
    nSeconds     = SECONDS()
    cHeading     = ""
    hDialog2     = 0
    cFontName    = "Arial"
    nFontSize    = 9
    nDefaultBtn  = 1
    nRows        = 1
    nButtons     = 0
    cTimeoutCaption = ""
    nIconBack    = 0
    nIconMain    = 0
    lFakeTimeOut = .F.
    nDefaultInterval = XMB_TIMERINTERVAL
  hLibImageRes = 0
  hLibShell32  = 0

    PROCEDURE Init
        This.AddProperty("aKeys[1,4]".F.)
        This.aKeys(1, 3) = 0
        This.AddObject("oTimer""xmbTimer")
        This.AddProperty("aButtonsHwnd[1]", 0)

    * We need to put the API declaration here to avoid acrazy error ???
        DECLARE SHORT TaskDialog IN comctl32 ;
            AS xmbTaskDialog ;
            INTEGER hWndParent, INTEGER hInstance, ;
            STRING pszWindowTitle, STRING pszMainInstruction, ;
            STRING pszContent, INTEGER dwCommonButtons, ;
            INTEGER pszIcon, INTEGER @pnButton

    DECLARE LONG LoadLibrary IN kernel32 AS LoadLibraryA STRING lpLibFileName

    DECLARE LONG FreeLibrary IN kernel32 LONG hLibModule

    DECLARE LONG LoadImage   IN user32   AS LoadImageA ;
      LONG hinst, LONG lpsz, LONG dwImageType, LONG dwDesiredWidth, LONG dwDesiredHeight, LONG dwFlags

    DECLARE LONG DestroyIcon IN user32 LONG hIcon


    ENDPROC

     PROCEDURE SendMessage(tcTitle, tcInstruction, tcContent, tnIcon, tcButtons, tnDefaultBtn, tnTimeout) && , tcTimeoutCaption)

    m.tcTitle       = EVL(m.tcTitle, "")
    m.tcInstruction = EVL(m.tcInstruction, "")
    m.tcContent     = EVL(m.tcContent, "")
    m.tcButtons     = EVL(m.tcButtons, "Ok")

        LOCAL lnButtons, lnResult, N, lnButtonId, lcCaption2
        LOCAL laAnswer[1]laButtonId[1], lnOffset, lnPos, lnReturn, lnlast
        LOCAL lnBtnCount
        m.lnBtnCount = GETWORDCOUNT(m.tcButtons, ",")
        IF m.lnBtnCount > 6
          MESSAGEBOX("Maximum buttons available is 6!",16,"Dialog error")
          RETURN .F.
        ENDIF

        m.lcCaption2 = ""
        IF VARTYPE(m.tnTimeout) = "C"
            m.lcCaption2 = GETWORDNUM(m.tnTimeout,2,",")
            m.tnTimeout = VAL(GETWORDNUM(m.tnTimeout,1,","))
        ENDIF

        IF NOT VARTYPE(m.tnDefaultBtn) $ "NL"
          MESSAGEBOX("Invalid parameter for the default button!",16,"Dialog error")
          RETURN .F.
        ENDIF
        This.nDefaultBtn = IIF(EMPTY(m.tnDefaultBtn), 1, m.tnDefaultBtn)
    IF NOT BETWEEN(This.nDefaultBtn,1,m.lnBtnCount)
      This.nDefaultBtn = 1
    ENDIF


        LOCAL lnIconMain, lnIconBack, lcIconMain, lcIconBack, lnIconToDraw
         lnIconMain = 0
         lnIconBack = 0

        IF VARTYPE(m.tnIcon) = "C"
          IF LEFT(ALLTRIM(m.tnIcon),1) = "," && GETWORDNUM fails if the 1st item is empty
        lcIconMain = ""
        lcIconBack = GETWORDNUM(m.tnIcon,1,",")
      ELSE
            lcIconMain = GETWORDNUM(m.tnIcon,1,",")
            lcIconBack = LEFT(UPPER(GETWORDNUM(m.tnIcon,2,",")),1)
      ENDIF

          lnIconBack = 0
          IF NOT EMPTY(lcIconBack)
        DO CASE
        CASE m.lcIconBack = "S" && Silver
          lnIconBack = -9
        CASE m.lcIconBack = "G" && Green
          lnIconBack = -8
        CASE m.lcIconBack = "R" && Red
          lnIconBack = -7
        CASE m.lcIconBack = "Y" && Yellow
          lnIconBack = -6
        CASE m.lcIconBack = "B" && Blue
          lnIconBack = -5
        CASE m.lcIconBack = "-" && Empty, no margin
          lnIconBack = 0
        OTHERWISE
        ENDCASE

        IF EMPTY(m.tnTimeout)
          m.tnTimeout = 1000
          This.lFakeTimeout = .T.
        ENDIF
      ELSE
        lnIconBack = ICON_EMPTY
      ENDIF


           IF VAL(m.lcIconMain) > 0
             m.lnIconMain = VAL(m.lcIconMain)
           ELSE
              m.tnIcon = UPPER(m.tnIcon)
              DO CASE
                  CASE m.tnIcon = "!4" && Warning
                      m.lnIconMain = 1403
                  CASE m.tnIcon = "!3" && Warning
                      m.lnIconMain = 84
                  CASE m.tnIcon = "!2" && Warning
                      m.lnIconMain = -6
                  CASE m.tnIcon = "!" && Warning
                      m.lnIconMain = -1

                  CASE m.tnIcon = "X5" && Error
                      m.lnIconMain = 1402
                  CASE m.tnIcon = "X4" && Error
                      m.lnIconMain = 98
                  CASE m.tnIcon = "X3" && Error
                      m.lnIconMain = 89
                  CASE m.tnIcon = "X2" && Error
                      m.lnIconMain = -7
                  CASE m.tnIcon = "X" && Error
                      m.lnIconMain = -2

                  CASE m.tnIcon = "I2" && Information
                      m.lnIconMain = 81
                  CASE m.tnIcon = "I" && Information
                      m.lnIconMain = -3
                  CASE m.tnIcon = "?2" && Question
                      m.lnIconMain = 104
                  CASE m.tnIcon = "?" && Question
                      m.lnIconMain = 0x7f02 && IDI_QUESTION

                  CASE m.tnIcon = "OK4" && Success
                      m.lnIconMain = 1405
                  CASE m.tnIcon = "OK3" && Success
                      m.lnIconMain = 1400
                  CASE m.tnIcon = "OK2" && Success
                      m.lnIconMain = -8 && TD_SHIELD_OK_ICON
                  CASE m.tnIcon = "OK" && Success
                      m.lnIconMain = 106

                  CASE m.tnIcon = "SHIELD" && Question
                      m.lnIconMain = -4

                  CASE m.tnIcon = "KEY2" && Key
                      m.lnIconMain = 5360 && Key icon
                  CASE m.tnIcon = "KEY" && Key
                      m.lnIconMain = 82 && Key icon
                  CASE m.tnIcon = "LOCK3" && Lock
                      m.lnIconMain = 5381 && Lock icon
                  CASE m.tnIcon = "LOCK2" && Lock
                      m.lnIconMain = 1304 && Lock icon
                  CASE m.tnIcon = "LOCK" && Lock
                      m.lnIconMain = 59 && Lock icon
                  CASE m.tnIcon = "ZIP" && Zip
                      m.lnIconMain = 174

                  CASE m.tnIcon = "SEARCH2" && Search
                      m.lnIconMain = 5332
                  CASE m.tnIcon = "SEARCH" && Search
                      m.lnIconMain = 177

                  CASE m.tnIcon = "USER2" && User
                      m.lnIconMain = 5356
                  CASE m.tnIcon = "USER" && User
                      m.lnIconMain = 1029

                  CASE m.tnIcon = "CLOUD2" && Cloud
                      m.lnIconMain = 1404
                  CASE m.tnIcon = "CLOUD" && Cloud
                      m.lnIconMain = 1043

                  CASE m.tnIcon = "STAR"
                      m.lnIconMain = 1024
                  CASE m.tnIcon = "FOLDER"
                      m.lnIconMain = 1023

                  CASE m.tnIcon = "MAIL"
                      m.lnIconMain = 20
                  CASE m.tnIcon = "CONNECT2"
                      m.lnIconMain = 179
                  CASE m.tnIcon = "CONNECT"
                      m.lnIconMain = 25
                  CASE m.tnIcon = "PRINTER2"
                      m.lnIconMain = 45
                  CASE m.tnIcon = "PRINTER"
                      m.lnIconMain = 51
                  CASE m.tnIcon = "CAMERA"
                      m.lnIconMain = 57
                  CASE m.tnIcon = "FILM"
                      m.lnIconMain = 46
                  CASE m.tnIcon = "FAX"
                      m.lnIconMain = 76
                  CASE m.tnIcon = "DOCUMENT"
                      m.lnIconMain = 90
                  CASE m.tnIcon = "SCAN"
                      m.lnIconMain = 95
                  CASE m.tnIcon = "COMPUTER2"
                      m.lnIconMain = 149
                  CASE m.tnIcon = "COMPUTER"
                      m.lnIconMain = 109
                  CASE m.tnIcon = "DIAGNOSE"
                      m.lnIconMain = 150

                  CASE m.tnIcon = "MUSIC"
                      m.lnIconMain = 1026
                  CASE m.tnIcon = "CANCEL"
                      m.lnIconMain = 1027
                  CASE m.tnIcon = "WRITE"
                      m.lnIconMain = 5306
                  CASE m.tnIcon = "PLAY"
                      m.lnIconMain = 5341
                  CASE m.tnIcon = "CLOCK"
                      m.lnIconMain = 5368
                  CASE m.tnIcon = "MOBILE"
                      m.lnIconMain = 6400

                  OTHERWISE
                      m.lnIconMain = 0
              ENDCASE
      ENDIF

    ELSE
      m.lnIconMain = EVL(m.tnIcon, 0) && If passed no parameter or .F.
        ENDIF  && IF VARTYPE(m.tnIcon) = "C"

    This.nIconMain = m.lnIconMain
    This.nIconBack = m.lnIconBack
    m.lnIcontoSend = IIF(NOT EMPTY(lnIconBack), lnIconBack, lnIconMain)



        This.nXmbTimeout = IIF(VARTYPE(m.tnTimeout)="N", m.tnTimeout, 0)
        This.cTimeoutCaption = EVL(m.lcCaption2, "")
        IF NOT EMPTY(m.lcCaption2)
            LOCAL lcFontName, lnFontSize
            =GetDialogFont(@m.lcFontName, @m.lnFontSize)
            This.cFontName = EVL(m.lcFontName, "Arial")
            This.nFontSize = EVL(m.lnFontSize, 9)

            IF NOT "<SECS>" $ m.lcCaption2
                This.cTimeoutCaption = " - " + "<SECS>" + m.lcCaption2
            ENDIF
        ENDIF




        LOCAL lnButtonsA
        This.nButtons = m.lnBtnCount
        DIMENSION THIS.aButtonsHwnd(m.lnBtnCount)

        THIS.ADDPROPERTY("aButtons[1,2]""")
        DIMENSION THIS.aButtons(m.lnBtnCount, 2)
        DIMENSION m.laButtonId(6)
        m.laButtonId(1) = 32
        m.laButtonId(2) = 32 + 16
        m.laButtonId(3) = 32 + 16 + 8
        m.laButtonId(4) = 32 + 16 + 8 + 4
        m.laButtonId(5) = 32 + 16 + 8 + 4 + 2
        m.laButtonId(6) = 32 + 16 + 8 + 4 + 2 + 1

    LOCAL lcBtnComplete, lcBtnCaption, lnBtnIcon
        FOR m.N = 1 TO m.lnBtnCount
            lcBtnComplete = GETWORDNUM(m.tcButtons, m.N, ",")
            lcBtnCaption = GETWORDNUM(m.lcBtnComplete, 1, "_")
            lnBtnIcon    = VAL(GETWORDNUM(m.lcBtnComplete, 2, "_"))

      * Update predefined Unicode buttons
      IF "*" $ m.lcBtnCaption
        DO CASE
        CASE LOWER(m.lcBtnCaption) = "ok*"
          m.lcBtnCaption = "Ok <UC>2713</UC>"
        CASE LOWER(m.lcBtnCaption) = "cancel*"
          m.lcBtnCaption = "Cancel <UC>d83dddd9</UC>"
        CASE LOWER(m.lcBtnCaption) = "print*"
          m.lcBtnCaption = "Print <UC>2399</UC>"
        CASE LOWER(m.lcBtnCaption) = "save*"
          m.lcBtnCaption = "Save <UC>d83dddab</UC>"
        CASE LOWER(m.lcBtnCaption) = "search*"
          m.lcBtnCaption = "Search <UC>d83ddd0e</UC>"
        OTHERWISE
        ENDCASE
      ENDIF

      * Update predefined colored icons
      IF "#" $ m.lcBtnCaption
        DO CASE
        CASE LOWER(m.lcBtnCaption) = "ok#"
          m.lcBtnCaption = "Ok_116802"
        CASE LOWER(m.lcBtnCaption) = "cancel#"
          m.lcBtnCaption = "Cancel_89"
        CASE LOWER(m.lcBtnCaption) = "print#"
          m.lcBtnCaption = "Print_51"
        CASE LOWER(m.lcBtnCaption) = "save#"
          m.lcBtnCaption = "Save_116761"
        CASE LOWER(m.lcBtnCaption) = "search#"
          m.lcBtnCaption = "Search_116774"
        OTHERWISE
        ENDCASE
              lnBtnIcon    = VAL(GETWORDNUM(m.lcBtnCaption, 2, "_"))
              lcBtnCaption = GETWORDNUM(m.lcBtnCaption, 1, "_")
      ENDIF

            THIS.aButtons(m.N, 1) = lcBtnCaption
            THIS.aButtons(m.N, 2) = m.lnBtnIcon
            m.lnButtonsA   = m.laButtonId(m.N)
        ENDFOR

        m.tcTitle       = ToUnicode(m.tcTitle)
        m.tcInstruction = ToUnicode(m.tcInstruction)
        m.tcContent     = ToUnicode(m.tcContent)

        * a substitute for the MAKEINTRESOURCE
        m.lnIcontoSend = BITAND(0x0000ffff, m.lnIcontoSend)
        m.lnButtons  = m.lnButtonsA
        m.lnButtonId = 0  && the must

        #DEFINE WM_ACTIVATE    0x0006
        #DEFINE WM_KEYUP    0x0101
        #DEFINE SC_CLOSE    0xF060
        BINDEVENT(0, WM_KEYUP, This'WndProc')
        BINDEVENT(0, WM_ACTIVATE, This'WndProc')

        m.lnResult = xmbTaskDialog(_SCREEN.HWND, 0, m.tcTitle, ;
            m.tcInstruction, m.tcContent, m.lnButtons, m.lnIcontoSend, @m.lnButtonId)

        UNBINDEVENTS(0, WM_ACTIVATE)

        DO CASE
            CASE m.lnResult < 0
                m.lnReturn = 0
            CASE m.lnBtnCount = 2 AND m.lnButtonId = 4 && 1st button
                m.lnReturn = 1
            OTHERWISE
                DIMENSION m.laAnswer(6)
                m.laAnswer(1) = 1
                m.laAnswer(2) = 6
                m.laAnswer(3) = 7
                m.laAnswer(4) = 4
                m.laAnswer(5) = 2
                m.laAnswer(6) = 8
                m.lnPos    = ASCAN(m.laAnswer, m.lnButtonId)
                m.lnOffset = 6 - m.lnBtnCount + 1
                m.lnReturn = m.lnPos - m.lnOffset + 1
        ENDCASE

        * Last check to know if CANCEL or <ESC> was pressed
        INKEY(.2)
        m.lnlast = This.aKeys(ALEN(This.aKeys, 1), 3)
        DO CASE
        CASE This.nXmbTimeout = -1
            m.lnReturn = -1
    CASE m.lnlast = 27
            m.lnReturn = 0
        OTHERWISE
        ENDCASE

        UNBINDEVENTS( 0, WM_KEYUP )        && Free the Keyboard
        RETURN m.lnReturn
    ENDPROC


    * Windows event handler procedure
    * MSDN WindowProc callback function
    * http://msdn.microsoft.com/en-us/library/windows/desktop/ms633573(v=vs.85).aspx
    * http://hermantan.blogspot.com/2008/07/centering-vfp-messagebox-in-any-form.html
    * Here we will make all the modifications in the Windows dialog
    PROCEDURE WndProc( th_Wnd, tn_Msg, t_wParam, t_lParam)

        LOCAL lcCaption, lcText, lhFirst, lhLast, lhLastFound, lhWindow, lhWndButton, lnButton, lhWndMain
        LOCAL lnRows, n, liIcon
        IF (m.tn_Msg == WM_ACTIVATE) AND (m.t_wParam == 0) AND (m.t_lParam <> 0)

            m.lhWndMain = m.t_lParam
            This.hDialog = m.lhWndMain

            * Getting the 1st Client Window
            m.lhWindow = 0
            m.lhLastFound = 0
            DO WHILE .T.
                m.lhWindow = xmbFindWindowEx(m.lhWndMain, m.lhWindow, NULLNULL)

                IF m.lhWindow = 0
                    * 123=ERROR_INVALID_NAME
                    * 127=ERROR_PROC_NOT_FOUND
                    * DECLARE INTEGER GetLastError IN kernel32
                    * ? "Exit on error:", GetLastError()
                    EXIT
                ELSE
                    m.lhLastFound = m.lhWindow
                ENDIF
            ENDDO

            * Set the focus at the desired button
            FOR m.n = 1 TO This.nDefaultBtn - 1
                KEYBOARD '{TAB}'
            ENDFOR

            * Getting the Child objects from the client Window
            m.lhWindow = m.lhLastFound
            m.lhFirst  = xmbGetWindow(m.lhWindow, GW_CHILD)
            m.lhWindow = xmbGetWindow(m.lhFirst, GW_HWNDFIRST)
            m.lhLast   = xmbGetWindow(m.lhFirst, GW_HWNDLAST)

            m.lnButton = 0
            DO WHILE .T.
                m.lhWndButton = xmbFindWindowEx(m.lhWindow, 0, NULLNULL)
                m.lcText  = ALLTRIM(GetWinText(m.lhWndButton))

                * Changing the captions
                IF NOT EMPTY(m.lcText) && AND GetWindowClass(lhWndButton) = "Button"
                    m.lnButton  = m.lnButton + 1

                    * Store the button hWnd
                    This.aButtonsHwnd(m.lnButton) = m.lhWndButton
                    m.lcCaption = THIS.aButtons(m.lnButton, 1)
                    * Disable button if needed
                    IF LEFT(m.lcCaption, 1) = "\"
                        m.lcCaption = SUBSTR(m.lcCaption, 2) && get the rest of the string
                        =xmbEnableWindow(m.lhWndButton, 0)
                    ENDIF
          m.lcCaption = TOUNICODE(m.lcCaption)
          =xmbSetWindowTextZ(m.lhWndButton, m.lcCaption)

          * Adding the button icons
          m.liIcon = This.aButtons(m.lnButton, 2)
          IF NOT EMPTY(m.liIcon)
            =This.SetButtonIcon(m.lhWndButton, 1, m.liIcon)
          ENDIF
                 ELSE
                    *!* * Close a window having its handle
                    *!* #DEFINE WM_SYSCOMMAND  0x0112
                    *!* #DEFINE SC_CLOSE       0xF060
                    *!* XmbSendMessage(lhWndButton, WM_SYSCOMMAND, SC_CLOSE, 0)
                ENDIF

                * Disable the 'X' close button
                IF m.lhWindow = m.lhLast
                    * Declare Integer GetSystemMenu In User32 Integer HWnd, Integer bRevert
                    * Declare INTEGER EnableMenuItem IN User32 Long hMenu, LONG wIDEnableItem, LONG wEnable
                    * DECLARE LONG GetMenuItemCount IN user32 LONG hMenu
                    * DECLARE LONG RemoveMenu IN user32 LONG HMENU, LONG NPOSITION, LONG WFLAGS
                    #DEFINE SC_CLOSE          0xF060
                    #DEFINE MF_BYCOMMAND      0
                    #DEFINE MF_BYPOSITION     0x400
                    #DEFINE MF_CHECKED        8
                    #DEFINE MF_DISABLED       2
                    #DEFINE MF_GRAYED         1
                    #DEFINE MF_REMOVE         0x00001000

                    * EnableMenuItem(GetSystemMenu(t_lParam, 0), SC_CLOSE, MF_BYCOMMAND + MF_DISABLED + MF_GRAYED)
                    xmbEnableMenuItem(xmbGetSystemMenu(m.t_lParam, 0), SC_CLOSE, MF_DISABLED)
                    EXIT
                ENDIF
                m.lhWindow = xmbGetWindow(m.lhWindow, GW_HWNDNEXT)
            ENDDO

            * All buttons initialized, start timer, if needed
            IF This.nXmbTimeout > 1
                This.nXmbTimeout = This.nXmbTimeout && - (SECONDS() - This.nSeconds)*1000 && Discount the elapsed time
                This.oTimer.Interval = 35
                This.oTimer.Enabled = .T.
                This.oTimer.nCurrentTimeout = ROUND(This.nXmbTimeout / 1000,0)

                IF NOT EMPTY(This.cTimeoutCaption)
                    This.cHeading = ALLTRIM(GetWinText(This.hDialog))

                    * Obtain the Dialog width
                    DECLARE INTEGER GetWindowRect IN user32 INTEGER hwndSTRING @lpRect

                    LOCAL lcNewHeading, lnLeft, lnRemain, lnRepeat, lnRight, lnSizeCompl, lnSizeSpace, lnSizeTitle
                    LOCAL lnWidth, lcRect
                    m.lcRect = REPLICATE(CHR(0),16)
                    = GetWindowRect(This.hDialog, @m.lcRect)
                    m.lnLeft = CTOBIN(SUBSTR(m.lcRect, 1,4),"4RS")
                    m.lnRight = CTOBIN(SUBSTR(m.lcRect, 9,4),"4RS")
                    m.lnWidth = m.lnRight - m.lnLeft
                    *lnTop = CTOBIN(SUBSTR(lcRect, 5,4),"4RS")
                    *lnBottom = CTOBIN(SUBSTR(lcRect, 13,4),"4RS")

                    m.lnSizeTitle = getTextSize(This.cHeading, This.cFontName, This.nFontSize)
                    m.lnSizeCompl = getTextSize(ALLTRIM(This.cTimeoutCaption), This.cFontName, This.nFontSize)
                    m.lnSizeSpace = getTextSize(SPACE(10), This.cFontName, This.nFontSize)

                    m.lnRemain = m.lnWidth - m.lnSizeTitle - m.lnSizeCompl
                    m.lnRepeat = FLOOR(m.lnRemain / m.lnSizeSpace) - 1

                    IF m.lnRepeat > 0
                        m.lcNewHeading = This.cHeading + REPLICATE(SPACE(10),m.lnRepeat) + ALLTRIM(This.cTimeoutCaption)
                    ELSE
                        m.lcNewHeading = This.cHeading + This.cTimeoutCaption
                    ENDIF

                    This.cHeading = m.lcNewHeading
                ENDIF

            ENDIF

        ENDIF

        IF m.tn_Msg == WM_KEYUP
            m.lnRows = This.nRows + 1
            DIMENSION This.aKeys(m.lnRows, 4)
            This.aKeys(m.lnRows, 1) = m.th_Wnd
            This.aKeys(m.lnRows, 2) = m.tn_Msg
            This.aKeys(m.lnRows, 3) = m.t_wParam
            This.aKeys(m.lnRows, 4) = m.t_lParam
        ENDIF

        LOCAL pOrgProc
        m.pOrgProc = xmbGetWindowLong( _VFP.HWND, -4 )
        = xmbCallWindowProc( m.pOrgProc, m.th_Wnd, m.tn_Msg, m.t_wParam, m.t_lParam )
    ENDPROC


     PROCEDURE CloseDialog
        * searching a command button to be virtually pressed
        This.nXmbTimeout = -1 && Flag to tell we finished
        LOCAL lhTarget
        m.lhTarget = This.aButtonsHwnd(This.nDefaultBtn)
        * simulates mouse click on the target button
        = xmbSendMessage(m.lhTarget, WM_LBUTTONDOWN, 0, 0)
        DOEVENTS  && just in case
        = xmbSendMessage(m.lhTarget, WM_LBUTTONUP, 0, 0)
    ENDPROC


  PROCEDURE UpdateIcon(tnIcon)
    LOCAL lnIcon
    lnIcon = EVL(tnIcon, This.nIconMain)

    IF EMPTY(lnIcon)
      lnIcon = ICON_EMPTY
    ENDIF
    lnIcon = BITAND(0x0000ffff, lnIcon)

    *xmbSendMessage(hHwnd, TDM_UPDATE_ICON, TDIE_ICON_MAIN, 0)
    =xmbSendMessage(This.hDialog, TDM_UPDATE_ICON, TDIE_ICON_MAIN, m.lnIcon)
    RETURN
  ENDPROC

  FUNCTION SetButtonIcon(tnHwnd, tnModule, tnIndex)
    IF m.tnIndex < 100000 && Use ImageRes.Dll
      IF This.hLibImageRes = 0
        lhModule = LoadLibraryA("imageres.dll")
      ELSE
        lhModule = This.hLibImageRes
      ENDIF
    ELSE  && Use Shell32.Dll
      IF This.hLibShell32 = 0
        lhModule = LoadLibraryA("shell32.dll")
        * lhModule = LoadLibraryA("%SystemRoot%\system32\shell32.dll")
      ELSE
        lhModule = This.hLibShell32
      ENDIF
      tnIndex = tnIndex - 100000 && fix the correct index
    ENDIF
      lhIco = LoadImageA(lhModule, tnIndex, 1, 16, 16, 0)
      =xmbSendMessage(tnHwnd, BM_SETIMAGE, 1, lhIco)
      DestroyIcon(lhIco)
    RETURN
ENDFUNC

PROCEDURE Destroy
  IF This.hLibImageRes > 0
    FreeLibrary(This.hLibImageRes)
  ENDIF
  IF This.hLibShell32 > 0
    FreeLibrary(This.hLibShell32)
  ENDIF
ENDPROC

ENDDEFINE


*********************************************************************
FUNCTION xmbGetWindowText(HWND, lpString, nMaxCount)&& (hWnd, @lpString, nMaxCount)
*********************************************************************
    DECLARE INTEGER GetWindowText IN user32 ;
        AS xmbGetWindowText ;
        INTEGER HWNDSTRING @lpString, INTEGER nMaxCount
    RETURN xmbGetWindowText(m.HWND, @m.lpString, m.nMaxCount)
ENDFUNC

*********************************************************************
FUNCTION xmbEnableWindow(HWND, fEnable)
*********************************************************************
    DECLARE INTEGER EnableWindow IN user32 AS xmbEnablewindow INTEGER HWNDINTEGER fEnable
    RETURN xmbEnableWindow(m.HWND, m.fEnable)
ENDFUNC

*********************************************************************
FUNCTION xmbSendMessage(hwindow, msg, wParam, LPARAM)
*********************************************************************
    * http://msdn.microsoft.com/en-us/library/bb760780(vs.85).aspx
    * http://www.news2news.com/vfp/?group=-1&function=312
    DECLARE INTEGER SendMessage IN user32 AS xmbsendmessage ;
        INTEGER hwindow, INTEGER msg, ;
        INTEGER wParam, INTEGER LPARAM
    RETURN xmbSendMessage(m.hwindow, m.msg, m.wParam, m.LPARAM)
ENDFUNC

*********************************************************************
FUNCTION xmbDeleteObject(hobject)
*********************************************************************
    DECLARE INTEGER DeleteObject IN gdi32 AS xmbdeleteobject INTEGER hobject
    RETURN xmbDeleteObject(m.hobject)
ENDFUNC

*********************************************************************
FUNCTION xmbCallWindowProc(lpPrevWndFunc, nhWnd, uMsg, wParam, LPARAM)
*********************************************************************
    DECLARE LONG CallWindowProc IN User32 ;
        AS xmbCallWindowProc ;
        LONG lpPrevWndFunc, LONG nhWnd, ;
        LONG uMsg, LONG wParam, LONG LPARAM

    RETURN xmbCallWindowProc(m.lpPrevWndFunc, m.nhWnd, m.uMsg, m.wParam, m.LPARAM)
ENDFUNC

*********************************************************************
FUNCTION xmbGetWindowLong(nhWnd, nIndex)
*********************************************************************
    DECLARE LONG GetWindowLong IN User32 ;
        AS xmbGetWindowLong ;
        LONG nhWnd, INTEGER nIndex
    RETURN xmbGetWindowLong(m.nhWnd, m.nIndex)
ENDFUNC

*!* *********************************************************************
*!* FUNCTION xmbTaskDialog(hWndParent, hInstance, pszWindowTitle, pszMainInstruction, pszContent, dwCommonButtons, pszIcon, pnButton)
*!* *********************************************************************
*!*     DECLARE SHORT TaskDialog IN comctl32 ;
*!*         AS xmbTaskDialog ;
*!*         INTEGER hWndParent, INTEGER hInstance, ;
*!*         STRING pszWindowTitle, STRING pszMainInstruction, ;
*!*         STRING pszContent, INTEGER dwCommonButtons, ;
*!*         INTEGER pszIcon, INTEGER @pnButton
*!*     RETURN xmbTaskDialog(m.hWndParent, m.hInstance, m.pszWindowTitle, m.pszMainInstruction, m.pszContent, m.dwCommonButtons, m.pszIcon, m.pnButton)

*********************************************************************
FUNCTION xmbGetWindow(HWND, wFlag)
*********************************************************************
    DECLARE INTEGER GetWindow IN user32 ;
        AS xmbGetWindow ;
        INTEGER HWNDINTEGER wFlag
    RETURN xmbGetWindow(m.HWND, m.wFlag)

*********************************************************************
FUNCTION xmbIsWindow(hWnd)
*********************************************************************
    DECLARE INTEGER IsWindow IN user32 ;
        AS xmbIsWindow ;
        INTEGER hwnd
    RETURN xmbIsWindow(hWnd)

*********************************************************************
FUNCTION GetWinText(hwindow)
*********************************************************************
    LOCAL cBuffer
    m.cBuffer = REPLICATE(CHR(0), 255)
    = xmbGetWindowText(m.hwindow, @m.cBuffer, LEN(m.cBuffer))
    RETURN STRTRAN(m.cBuffer, CHR(0), "")
ENDFUNC

*********************************************************************
FUNCTION xmbSetWindowText(HWND, lpString)
*********************************************************************
    DECLARE INTEGER SetWindowText IN user32 ;
        AS xmbSetWindowText ;
        INTEGER HWNDSTRING lpString
    RETURN xmbSetWindowText(m.HWND, m.lpString)
ENDFUNC

*********************************************************************
FUNCTION xmbSetWindowTextZ(HWND, lpString) && For Unicodes
*********************************************************************
    DECLARE INTEGER SetWindowTextW IN user32 ;
        AS xmbSetWindowTextZ ;
        INTEGER HWNDSTRING lpString
    RETURN xmbSetWindowTextZ(m.HWND, m.lpString)
ENDFUNC


*********************************************************************
FUNCTION SetWinText(hwindow, tcText)
*********************************************************************
    = xmbSetWindowText(m.hwindow, m.tcText + CHR(0))
    RETURN
ENDFUNC

*********************************************************************
FUNCTION xmbRealGetWindowClass(hwindow, pszType, cchType)
*********************************************************************
    DECLARE INTEGER RealGetWindowClass IN user32 ;
        AS xmbRealGetWindowClass ;
        INTEGER hWindow, STRING @ pszType, ;
        INTEGER cchType
    RETURN xmbRealGetWindowClass(m.hwindow, m.pszType, m.cchType)
ENDFUNC

*********************************************************************
FUNCTION GetWindowClass(lnWindow)
*********************************************************************
    LOCAL lnLength, lcText
    m.lcText = SPACE(250)
    m.lnLength = xmbRealGetWindowClass(m.lnWindow, ;
        @m.lcText, LEN(m.lcText))
    RETURN IIF(m.lnLength > 0, ;
        LEFT(m.lcText, m.lnLength), "#empty#")
ENDFUNC

*********************************************************************
FUNCTION xmbFindWindowEx(hWndParent, hwndChildAfter, lpszClass, lpszWindow)
*********************************************************************
    DECLARE INTEGER FindWindowEx IN user32 ;
        AS xmbFindWindowEx ;
        INTEGER hwndParent, INTEGER hwndChildAfter, ;
        STRING @lpszClass, STRING @lpszWindow
    RETURN xmbFindWindowEx(m.hWndParent, m.hwndChildAfter, m.lpszClass, m.lpszWindow)
ENDFUNC

*********************************************************************
FUNCTION xmbGetSystemMenu(HWnd, bRevert)
*********************************************************************
    DECLARE INTEGER GetSystemMenu In User32 ;
        AS xmbGetSystemMenu ;
        INTEGER HWndINTEGER bRevert
    RETURN xmbGetSystemMenu(HWnd, bRevert)
ENDFUNC

*********************************************************************
FUNCTION xmbEnableMenuItem(hMenu, wIDEnableItem, wEnable)
*********************************************************************
    DECLARE INTEGER EnableMenuItem IN User32 ;
        AS xmbEnableMenuItem ;
        LONG hMenu, LONG wIDEnableItem, LONG wEnable
    RETURN xmbEnableMenuItem(hMenu, wIDEnableItem, wEnable)
ENDFUNC


*********************************************************************
* The timer class controls the timeout parameter
DEFINE CLASS xmbTimer as Timer
    * Interval is in milliseconds.
    * To get 5 seconds -> 5 seconds * 1000
    Interval = 0
    Enabled = .F.
    nCurrentTimeout = 0
  lUpdatedIcon = .F.
    PROCEDURE Timer
        IF xmbIsWindow(This.Parent.hDialog) = 0
            * Possibly the dialog has been closed manually
            This.Parent.hDialog = 0
            This.Interval = 0  && stop the timer
        ELSE

      IF EMPTY(This.Parent.nIconBack) AND This.Parent.lFakeTimeout = .T.
        This.Interval = 0
      ENDIF

      IF NOT EMPTY(This.Parent.nIconBack) AND This.lUpdatedIcon = .F.
        This.lUpdatedIcon = .T.
        This.Parent.UpdateIcon()
        IF This.Parent.lFakeTimeout = .T.
          This.Interval = 0
        ELSE
          This.Interval = This.Parent.nDefaultInterval
        ENDIF
      ENDIF

            * The dialog is still around, checking timeout
            This.Parent.nXmbTimeout = This.Parent.nXmbTimeout - This.Interval

            IF This.Parent.nXmbTimeout <= 0
                This.Parent.CloseDialog()
            ENDIF

            * Update the header of the dialog if needed
            IF NOT EMPTY(This.Parent.cTimeoutCaption)
                LOCAL lnTimeout
                m.lnTimeout = ROUND(This.Parent.nXmbTimeout / 1000, 0)
                IF m.lnTimeout <> This.nCurrentTimeout
          m.lcNewText = STRTRAN(This.Parent.cHeading, "<SECS>""<UC>23f1</UC> " + TRANSFORM(m.lnTimeout)) && included the Unicode Watch
          m.lcNewText = TOUNICODE(m.lcNewText)
          * lcNewText = STRTRAN(This.Parent.cHeading, "<SECS>", TRANSFORM(lnTimeout))
          * = SetWinText(This.Parent.hDialog, lcNewText)
          =xmbSetWindowTextZ(This.Parent.hDialog, m.lcNewText)

          *!*  * Changing the captions after the dialog run
          *!*  loNewCaption = CREATEOBJECT("PChar", lcNewText)
          *!*  =xmbSendMessage(This.Parent.hDialog, TDM_SET_ELEMENT_TEXT, TDE_CONTENT, loNewCaption.GetAddr())
                ENDIF
            ENDIF
        ENDIF
    ENDPROC
ENDDEFINE


*********************************************************************
FUNCTION getTextSize
  * Author: Mike Lewis
  * https://www.tek-tips.com/viewthread.cfm?qid=1525491
    * Determines the width in pixels of a given text string,
    * based on a given font, font style and point size.

    * Parameters: text string, font name, size in points,
    * font style in format used by FONTMETRIC()
    * (e.g. "B" for bold, "BI" for bold italic;
    * defaults to normal).
    LPARAMETERS tcString, tcFont, tnSize, tcStyle
    LOCAL lnTextWidth, lnAvCharWidth
    IF EMPTY(m.tcStyle)
        m.tcStyle = ""
    ENDIF
    m.lnTextWidth = TXTWIDTH(m.tcString, m.tcFont, m.tnSize, m.tcStyle)
    m.lnAvCharWidth = FONTMETRIC(6, m.tcFont, m.tnSize, m.tcStyle)
    RETURN m.lnTextWidth * m.lnAvCharWidth
ENDFUNC



*********************************************************************
FUNCTION GetDialogFont(tcFontName, tnFontSize)
* Code derived from
* How to find which fonts Windows uses for drawing captions, menus and message boxes
* https://github.com/VFPX/Win32API/blob/master/samples/sample_556.md
* by VFPX / Anatolyi Mogylevets

    #DEFINE SPI_GETNONCLIENTMETRICS 0x0029
    #DEFINE NONCLIENTMETRICS_SIZE 0x0154
    #DEFINE LOGFONT_SIZE 0x003c
    #DEFINE LOGPIXELSY 0x005a

    LOCAL lfHeight, lcBuffer
    DECLARE INTEGER GetLastError IN kernel32
    DECLARE INTEGER GetWindowDC IN user32 INTEGER hWindow
    DECLARE INTEGER SystemParametersInfo IN user32;
        INTEGER uiAction, INTEGER uiParam,;
        STRING @pvParam, INTEGER fWinIni
    DECLARE INTEGER GetDeviceCaps IN gdi32;
        INTEGER hdc, INTEGER nIndex
    DECLARE INTEGER ReleaseDC IN user32;
        INTEGER hWindow, INTEGER hDC

    LOCAL lcNonClientMetrics
    * populating NONCLIENTMETRICS structure
    * the size of the structure occupies first 4 bytes
    m.lcNonClientMetrics=BINTOC(NONCLIENTMETRICS_SIZE,"4RS")

    * padding the structure to the required size
    m.lcNonClientMetrics=PADR(m.lcNonClientMetrics, NONCLIENTMETRICS_SIZE, CHR(0))

    * retrieving the metrics associated with the nonclient area
    * of nonminimized windows
    IF SystemParametersInfo(SPI_GETNONCLIENTMETRICS,;
            NONCLIENTMETRICS_SIZE, @m.lcNonClientMetrics, 0) = 0
        * ? "SystemParametersInfo call failed:", GetLastError()
        RETURN
    ENDIF

    * among other metrics, populated NONCLIENTMETRICS structure
    * contains data for 5 fonts used for drawing:
    * captions, small captions, menus, status bar and message boxes
    m.lcBuffer =   SUBSTR(m.lcNonClientMetrics, 281, LOGFONT_SIZE)
    m.tcFontName = STRTRAN(SUBSTR(m.lcBuffer,29,32), CHR(0),"")

    LOCAL lhwindow, lhdc, lnPxPerInchY
    m.lhwindow=_screen.HWnd
    m.lhdc=GetWindowDC(m.lhwindow)
    m.lnPxPerInchY = GetDeviceCaps(m.lhdc, LOGPIXELSY)
    =ReleaseDC(m.lhwindow, m.lhdc)
    m.lfHeight=CTOBIN(SUBSTR(m.lcBuffer,1,4),"4RS")

    m.tnFontSize = ROUND((ABS(m.lfHeight) * 72) / m.lnPxPerInchY, 0)

    RETURN


*********************************************************************
FUNCTION ToUnicode(tcStr)
*********************************************************************
LOCAL lnUnicodeCnt, lnPos, n, lcReturn, lnPos0, j, lnWidth
LOCAL laPos[1], lcText, lcUnicode, lnEnd, lnLen, lnStart, lnUnicodeIndex
m.lnUnicodeCnt = OCCURS("<UC>", m.tcStr)
m.lcReturn = ""

IF m.lnUnicodeCnt = 0
    RETURN STRCONV(m.tcStr + CHR(0), 5)
ENDIF

DIMENSION m.laPos(m.lnUnicodeCnt,4)
FOR m.n = 1 TO m.lnUnicodeCnt
  m.lcUnicode = STREXTRACT(m.tcStr, "<UC>""</UC>", m.n)
  m.lnStart = AT("<UC>", m.tcStr, m.n)
  m.lnEnd   = AT("</UC>", m.tcStr, m.n)
  m.laPos(m.n,1) = m.lnStart
  m.laPos(m.n,2) = m.lnEnd
  m.laPos(m.n,3) = m.lcUnicode
  m.laPos(m.n,4) = HEXTOUNICODE(m.lcUnicode)
ENDFOR

m.lnLen = LEN(m.tcStr)
m.lnUnicodeIndex = 1

FOR m.j = 1 TO m.lnLen
  IF (m.lnUnicodeIndex <= m.lnUnicodeCnt) AND (m.j = m.laPos(m.lnUnicodeIndex,1)) && Get Unicode
    m.lcReturn = m.lcReturn + m.laPos(m.lnUnicodeIndex,4)
    m.j = m.laPos(m.lnUnicodeIndex,2)
    m.lnUnicodeIndex = m.lnUnicodeIndex + 1
    LOOP
  ELSE
    m.lnStart = IIF(m.j = 1, 1, m.laPos(m.lnUnicodeIndex-1,2)+5)
    IF m.lnStart > m.lnLen
      EXIT
    ENDIF

    IF m.lnUnicodeIndex > m.lnUnicodeCnt
      m.j = m.lnLen && Finished
      m.lcText = SUBSTR(m.tcStr, m.lnStart)
    ELSE
      m.lnWidth = m.laPos(m.lnUnicodeIndex,1) - m.lnStart
      m.j = m.laPos(m.lnUnicodeIndex,1) - 1
      m.lcText = SUBSTR(m.tcStr, m.lnStart, m.lnWidth)
    ENDIF
    m.lcReturn = m.lcReturn + STRCONV(m.lcText, 5)
  ENDIF
ENDFOR

RETURN m.lcReturn + CHR(0)
ENDFUNC


*********************************************************************
FUNCTION HexToUnicode(tcHex)
*********************************************************************
    LOCAL lhHex, lhUnicode, i, lcHex
    lhUnicode = 0h
    FOR i = 1 TO GETWORDCOUNT(tcHex, SPACE(1))
    lcHex = GETWORDNUM(tcHex, i, SPACE(1))
    IF LEN(lcHex) = 8
          lhHex = EVALUATE("0h" + SUBSTR(lcHex,3,2) + LEFT(lcHex,2) + SUBSTR(lcHex,7,2) + SUBSTR(lcHex,5,2))
    ELSE
          lhHex = EVALUATE("0h" + SUBSTR(lcHex,3,2) + LEFT(lcHex,2))
    ENDIF
        lhUnicode = lhUnicode + lhHex
    ENDFOR
    RETURN lhUnicode
ENDFUNC



*********************************************************************
FUNCTION xmbLoadImage(hinst, lpszname, utype, cxdesired, cydesired, fuload)
*********************************************************************
        DECLARE INTEGER LoadImage IN user32 AS xmbloadimage;
            INTEGER hinst,;
            STRING lpszname,;
            INTEGER utype,;
            INTEGER cxdesired,;
            INTEGER cydesired,;
            INTEGER fuload
        RETURN xmbLoadImage(hinst, lpszname, uType, cxdesired, cydesired, fuload)
    ENDFUNC




DEFINE CLASS PChar As Session
PROTECTED hMem

PROCEDURE Init(lcString)
  THIS.hMem = 0
  THIS.setValue(lcString)

PROCEDURE Destroy
  THIS.ReleaseString

FUNCTION GetAddr
RETURN THIS.hMem

FUNCTION GetValue
  LOCAL lnSize, lcBuffer
  lnSize = THIS.getAllocSize()
  lcBuffer = SPACE(lnSize)

  IF THIS.hMem <> 0
    DECLARE RtlMoveMemory IN kernel32 As MemToStr;
      STRING @, INTEGERINTEGER
    = MemToStr(@lcBuffer, THIS.hMem, lnSize)
  ENDIF
RETURN lcBuffer

FUNCTION GetAllocSize
  DECLARE INTEGER GlobalSize IN kernel32 INTEGER hMem
RETURN Iif(THIS.hMem=0, 0, GlobalSize(THIS.hMem))

PROCEDURE SetValue(lcString)
#DEFINE GMEM_FIXED 0
#DEFINE GMEM_MOVEABLE 2
#DEFINE GMEM_ZEROINIT 0x0040

  THIS.ReleaseString

  DECLARE INTEGER GlobalAlloc IN kernel32 INTEGERINTEGER
  DECLARE RtlMoveMemory IN kernel32 As StrToMem;
    INTEGERSTRING @, INTEGER

  LOCAL lnSize
  lcString = lcString + Chr(0)
  lnSize = Len(lcString)
  THIS.hMem = GlobalAlloc(0x0040, lnSize)
  IF THIS.hMem <> 0
    = StrToMem(THIS.hMem, @lcString, lnSize)
  ENDIF

PROCEDURE ReleaseString
  IF THIS.hMem <> 0
    DECLARE INTEGER GlobalFree IN kernel32 INTEGER
    = GlobalFree (THIS.hMem)
    THIS.hMem = 0
  ENDIF
ENDDEFINE




Fichier MHT :
Mettre en plein écran


Commentaires
le 12/05/2020, jcriv a écrit :
Salut Mike
Merci, c'est sympa comme tout ! Par contre, pas possible de mettre un timeout ?
JC

le 12/05/2020, Mike Gagnon a écrit :
Pas pour l'instant, peut-etre plus tard dans l'évolution.
le 17/05/2020, Mike Gagnon a écrit :
Maintenant cette version supporte UNICODE. et un paramètre pour le timeout et bouton par défaut.
le 17/05/2020, Francis Faure a écrit :
Waow ! Bravo Mike !
le 17/05/2020, Mike Gagnon a écrit :
Merci Francis, j'ai ajouté aussi un demo pour le support de multilingue
le 17/05/2020, jcriv a écrit :
Merci Mike ! Maintenant, on peut adapter à partir des anciens messagebox de VFP utilisés dans les appli. Pour ma part, j'adopte !
le 17/05/2020, Mike Gagnon a écrit :
Un point à mentioner, version minimum de Windows est Vista.
le 24/05/2020, Mike Gagnon a écrit :
Quelques nouveautés ajoutées. 24/05/2020
le 24/05/2020, Cesar VfpImaging a écrit :
Bonjour mes amis,
Merci Mike d'avoir partagé ici.
Je travaille actuellement sur plusieurs améliorations de cette boîte de dialogue. Vous pouvez obtenir des informations plus détaillées et des échantillons directement depuis mon blog -
https://vfpimaging.blogspot.com/2020/05/messagebox-using-simple-vista-task.html

En fait, la prochaine étape est un projet beaucoup plus grand, beaucoup plus puissant, utilisant le plus grand frère de cette API, et j'espère publier très bientôt sur mon blog.
Meilleures salutations,
César

le 24/05/2020, Mike Gagnon a écrit :
Cesar je vais t'envoyer un courriel
le 24/05/2020, Cesar VfpImaging a écrit :
Salut Mke,
Je voudrais vous demander de modifier l'en-tête des codes et d'ajouter le billet de blog original
https://vfpimaging.blogspot.com/2020/05/messagebox-using-simple-vista-task.html
Merci davance
Salutations
Cesar

* File: NEWDIALOG
* Version 2.2 - 2020-05-24
* https://vfpimaging.blogspot.com/2020/05/messagebox-using-simple-vista-task.html
* Displays a Task dialog simple dialog, with custom captions and icons
* Based on the sample from Anatolyi Mogylevets and Tore Bleken from VFPX
* https://github.com/VFPX/Win32API/blob/master/samples/sample_557.md

le 24/05/2020, Mike Gagnon a écrit :
Je ne suis pas sur pourquoi cette ligne a disparue. Corrigé
le 24/05/2020, Cesar VfpImaging a écrit :
Merci beaucup

www.atoutfox.org - Site de la Communauté Francophone des Professionnels FoxPro - v3.4.0 - © 2004-2020.
Cette page est générée par un composant COM+ développé en Visual FoxPro 9.0-SP2-HF3