&& 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, NULL, NULL)
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, NULL, NULL)
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 hwnd, STRING @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 HWND, STRING @lpString, INTEGER nMaxCount
RETURN xmbGetWindowText(m.HWND, @m.lpString, m.nMaxCount)
ENDFUNC
*********************************************************************
FUNCTION xmbEnableWindow(HWND, fEnable)
*********************************************************************
DECLARE INTEGER EnableWindow IN user32 AS xmbEnablewindow INTEGER HWND, INTEGER 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 HWND, INTEGER 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 HWND, STRING lpString
RETURN xmbSetWindowText(m.HWND, m.lpString)
ENDFUNC
*********************************************************************
FUNCTION xmbSetWindowTextZ(HWND, lpString) && For Unicodes
*********************************************************************
DECLARE INTEGER SetWindowTextW IN user32 ;
AS xmbSetWindowTextZ ;
INTEGER HWND, STRING 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 HWnd, INTEGER 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 @, INTEGER, INTEGER
= 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 INTEGER, INTEGER
DECLARE RtlMoveMemory IN kernel32 As StrToMem;
INTEGER, STRING @, 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
|
Retour à la liste
Canada
Fiche personnelle
Note des membres
Mettre en plein écran
le 17/05/2020,
Salut Mike
Merci, c'est sympa comme tout ! Par contre, pas possible de mettre un timeout ?
JC