! * ! ******************************************************************************** ! * INTEL CORPORATION * ! * Copyright (C) 2024 Intel Corporation. All Rights Reserved. * ! * * ! * Portions Copyright (C)1992-2002, Hewlett-Packard Corporation. All Rights * ! * Reserved. * ! * * ! * The source code contained or described herein and all documents related to * ! * the source code ("Material") are owned by Intel Corporation or its suppliers * ! * or licensors. Title to the Material remains with Intel Corporation or its * ! * suppliers and licensors. The Material contains trade secrets and proprietary * ! * and confidential information of Intel or its suppliers and licensors. The * ! * Material is protected by worldwide copyright and trade secret laws and * ! * treaty provisions. No part of the Material may be used, copied, reproduced, * ! * modified, published, uploaded, posted, transmitted, distributed, or * ! * disclosed in any way without Intel's prior express written permission. * ! * * ! * No license under any patent, copyright, trade secret or other intellectual * ! * property right is granted to or conferred upon you by disclosure or delivery * ! * of the Materials, either expressly, by implication, inducement, estoppel or * ! * otherwise. Any license under such intellectual property rights must be * ! * express and approved by Intel in writing. * ! ******************************************************************************** ! * ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! iflogm.f90 !! !! This is the source code for the dialog procedures. !! Provides a procedural interface to Windows dialogs. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module iflogmt use ifwinty ! all character strings should be this size integer, parameter :: STRSZ = 256 type ControlType sequence integer control ! ctrl_[] :identifies the control type integer(INT_PTR) :: id ! the associated Windows control id logical dirty ! true if a control value is modified ! and needs to be written to the dialog logical duplicate ! Controls that have duplicate ids are read-only ! arrays of each data type. This allows us to create a ! union-like structure integer intsize integer(INT_PTR), pointer, dimension(:) :: intvalue integer logsize logical(INT_PTR), pointer, dimension(:) :: logvalue ! 02-Apr-202; Make like Windows integer charsize character*(STRSZ), pointer, dimension(:) :: charvalue ! we would like to make this an array of externals but that is not ! allowed in F90 integer callbacksize integer(UINT_PTR), pointer, dimension(:) :: callbackvalue ! pointer to varying length text string used for the window "text" integer(UINT_PTR) vartextptr integer doptions ! the previous arrays are used as follows depending on the value of control ! ctrl_StaticText ! intsize = 0 ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 0 ! vartextptr = dlg_title ! ctrl_GroupBox ! intsize = 0 ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 0 ! vartextptr = dlg_title ! ctrl_PushButton ! intsize = 0 ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 1 ! callbackvalue(1) = dlg_clicked ! vartextptr = dlg_title ! ctrl_CheckBox ! intsize = 0 ! logsize = 2 ! logvalue(1) = dlg_enable ! logvalue(2) = dlg_state (default) ! charsize = 0 ! callbacksize = 1 ! callbackvalue(1) = dlg_clicked ! vartextptr = dlg_title ! ctrl_RadioButton ! intsize = 2 ! intvalue(1) = index of first button in group ! intvalue(2) = index of last button in group ! logsize = 2 ! logvalue(1) = dlg_enable ! logvalue(2) = dlg_state (default) ! charsize = 0 ! callbacksize = 1 ! callbackvalue(1) = dlg_clicked ! vartextptr = dlg_title ! ctrl_Edit ! intsize = 2 ! intvalue(1) = dlg_textlength ! intvalue(2) = dlg_position ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 4 ! callbackvalue(1) = dlg_change (default) ! callbackvalue(2) = dlg_update ! callbackvalue(3) = dlg_gainfocus ! callbackvalue(4) = dlg_losefocus ! vartextptr = dlg_state ! ctrl_ScrollBar ! intsize = 5 ! intvalue(1) = dlg_position (default) ! intvalue(2) = dlg_rangemax ! intvalue(3) = dlg_smallstep ! intvalue(4) = dlg_bigstep ! intvalue(5) = dlg_rangemin ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 1 ! callbackvalue(1) = dlg_change ! vartextptr - NOT USED ! ctrl_ListBox ! IMPLEMENTATION ! note: n is the number of elements in the listbox ! intsize = n+2 ! intvalue(1) = number of items in listbox ! intvalue(2...n+2) = index of selected entry (1 based) ! list is terminated with 0 ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = n+1 ! charvalue(1) = selected value ! charvalue(2...n+1) = text ! callbacksize = 2 ! callbackvalue(1) = dlg_selchange ! callbackvalue(2) = dlg_dblclick ! vartextptr - NOT USED ! USER ! intvalue(dlg_numitems) = number of items in listbox ! intvalue(1...n) = index of selected entry (1 based, 0 terminated) ! charvalue(x) = selected value ! charvalue(1..n) = indexed value ! ctrl_ComboBox ! IMPLEMENTATION ! note: n is the number of elements in the combo box ! intsize = 1 ! intvalue(1) = number of items in combo box ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = n+1 ! charvalue(1) = selected value ! charvalue(2...n+1) = text ! callbacksize = 6 ! callbackvalue(1) = dlg_selchange ! callbackvalue(2) = dlg_dblclick ! callbackvalue(3) = dlg_update ! callbackvalue(4) = dlg_change ! callbackvalue(5) = dlg_gainfocus ! callbackvalue(6) = dlg_losefocus ! vartextptr - NOT USED ! USER ! intvalue(dlg_numitems) = number of items in combo box ! charvalue(dlg_state) = selected value ! charvalue(1..n) = indexed value ! ctrl_DropList ! IMPLEMENTATION ! note: n is the number of elements in the combo box ! intsize = 2 ! intvalue(1) = number of items in combo box ! intvalue(2) = current selected item (may be 0) ! logsize = 2 ! logvalue(1) = dlg_enable ! logvalue(2) = if .true., use charvalue(1) to set current selection ! charsize = n+1 ! charvalue(1) = selected value ! charvalue(2...n+1) = text ! callbacksize = 2 ! callbackvalue(1) = dlg_selchange ! callbackvalue(2) = dlg_dblclick ! vartextptr - NOT USED ! USER ! intvalue(dlg_numitems) = number of items in combo box ! intvalue(dlg_state) = index of selected value ! charvalue(dlg_state) = selected value ! charvalue(1..n) = indexed value ! ctrl_Spinner ! intsize = 5 ! intvalue(1) = dlg_position (default) ! intvalue(2) = dlg_rangemax ! intvalue(3) = NOT USED - to match scroll bar indexes ! intvalue(4) = NOT USED - to match scroll bar indexes ! intvalue(5) = dlg_rangemin ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 1 ! callbackvalue(1) = dlg_change ! vartextptr - NOT USED ! ctrl_Slider ! intsize = 6 ! intvalue(1) = dlg_position (default) ! intvalue(2) = dlg_rangemax ! intvalue(3) = dlg_smallstep ! intvalue(4) = dlg_bigstep ! intvalue(5) = dlg_rangemin ! intvalue(6) = dlg_tickfreq ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 1 ! callbackvalue(1) = dlg_change ! vartextptr - NOT USED ! ctrl_Progress ! intsize = 3 ! intvalue(1) = dlg_position (default) ! intvalue(2) = dlg_rangemax ! intvalue(3) = dlg_rangemin ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 0 ! vartextptr - NOT USED ! ctrl_Tab ! note: n is the number of tabs ! intsize = n+2 ! intvalue(1) = dlg_numitems - number of tabs (default) ! intvalue(2) = dlg_state - currently selected tab ! intvalue(3...n+2) = tab child dialog id ! logsize = 2 ! logvalue(1) = dlg_enable (default) ! logvalue(2) = if .true., use charvalue(1) to set current selection ! charsize = n+1 ! charvalue(1) = dlg_state - currently selected tab (default) ! charvalue(2...n+1) = tab text ! callbacksize = 2 ! callbackvalue(1) = dlg_selchange (default) ! callbackvalue(2) = dlg_selchanging ! vartextptr - NOT USED ! ctrl_ActiveX ! intsize = 1 ! intvalue(1) = dlg_idispatch (default) ! logsize = 1 ! logvalue(1) = dlg_enable ! charsize = 0 ! callbacksize = 1 - contains pointer to event handler list ! vartextptr - NOT USED end type ! data types returned from resource parsing functions ! type DialogHeader sequence integer Style integer ExtendedStyle integer NumberOfItems integer x integer y integer cx integer cy integer MenuId character*(STRSZ) MenuName integer ClassId character*(STRSZ) ClassName character*(STRSZ) Caption integer PointSize character*(STRSZ) FontName logical DialogEX end type ! WARNING! This structure is shared with dlglow.cpp. ! If you change it here, you must change it ! there. Look for "struct ControlData". ! type ControlHeader sequence integer Style integer ExtendedStyle integer x integer y integer cx integer cy integer(INT_PTR) id integer ClassId character*(STRSZ) ClassName integer TextId character*(STRSZ) TextName integer ExtraStuff end type type DialogResource sequence integer(UINT_PTR) ptr end type ! WARNING: Must match dlgglow.cpp's "struct DialogBoxExtraBytes. ! type DialogExtraBytes sequence integer*4 Length ! Length of this structure integer*4 Signature ! Identifies this structure integer(UINT_PTR) DSServer ! IDlgServer interface pointer integer(UINT_PTR) DSDlg ! IDSDialog interface pointer integer(UINT_PTR) Dlg ! Pointer to dialog integer*4 DlgModal ! TRUE if modal; FALSE is modeless end type !DEC$ OPTIONS /WARN=NOALIGN type strpos sequence integer i character*(STRSZ), pointer :: s character c end type !DEC$ END OPTIONS ! WARNING! This structure is shared with dlglow.cpp. ! If you change it here, you must change it ! there. Look for "struct dialogType". ! type, public :: Dialog sequence integer(INT_PTR) dlgid integer(HANDLE) hwnd ! 0 if dialog is not displayed !private integer retval logical dirty ! prevents unwanted callbacks when dlg values are changed logical mutexflush logical comboupdate integer(UINT_PTR) dlginitcallback integer NumControls type (ControlType), pointer, dimension(:) :: list end type end module iflogmt module iflogm !make sure we link with the correct libraries !DEC$ OBJCOMMENT lib: "iflogm.lib" !DEC$ OBJCOMMENT lib: "user32.lib" !DEC$ OBJCOMMENT lib: "comctl32.lib" ! windows ids and constants !! use ifwinty use ifwinty, NULL_rename => NULL use iflogmt, NULLPTR => NULL implicit none private ! everything that is not explicitly declared public is private ! defined in ifwinty public idok public idcancel public idabort public idretry public idignore public idyes public idno public idclose public idhelp public dialog ! this global should only be referenced by DlgModalWithParent type (dialog), pointer :: g_dlgmodal => NULL() ! this global should only be referenced by DlgModelessProc ! and DlgIsDlgMessage type (dialog), pointer :: g_dlgmodeless => NULL() ! this global should only be referenced by DlgCommonProc, ! DlgModalWithParent, DlgModeless and DlgSet* routines type (dialog), pointer :: g_dlgcurrentmsg => NULL() ! Global variable to store 'latest' handle. Used in DlgModelessProc ! and DlgIsDlgMessage. ! integer(HANDLE) :: g_dlghwnd = 0_HANDLE ! predefined index values for Get/Set functions integer, parameter, public :: dlg_init = 0 integer, parameter, public :: dlg_default = -1 integer, parameter, public :: dlg_title = -2 integer, parameter, public :: dlg_enable = -3 integer, parameter, public :: dlg_clicked = -4 integer, parameter, public :: dlg_state = -5 integer, parameter, public :: dlg_change = -6 integer, parameter, public :: dlg_update = -7 integer, parameter, public :: dlg_range = -8 integer, parameter, public :: dlg_rangemax = -8 integer, parameter, public :: dlg_position = -9 integer, parameter, public :: dlg_selchange = -10 integer, parameter, public :: dlg_bigstep = -11 integer, parameter, public :: dlg_smallstep = -12 integer, parameter, public :: dlg_numitems = -13 integer, parameter, public :: dlg_dblclick = -14 integer, parameter, public :: dlg_destroy = -15 integer, parameter, public :: dlg_rangemin = -16 integer, parameter, public :: dlg_tickfreq = -17 integer, parameter, public :: dlg_gainfocus = -18 integer, parameter, public :: dlg_losefocus = -19 integer, parameter, public :: dlg_selchanging = -20 integer, parameter, public :: dlg_addstring = -21 integer, parameter, public :: dlg_textlength = -22 integer, parameter, public :: dlg_idispatch = -23 integer, parameter, public :: dlg_sizechange = -24 ! OK and Cancel IDs integer, parameter, public :: IDC_BUTTON_OK = 1 integer, parameter, public :: IDC_BUTTON_CANCEL = 2 ! values of dialog's options integer, parameter, public :: DLG_CLOSE = #00000001 ! control classes (not Windows constants but should be) integer, parameter :: CLS_BUTTON = Z"80" integer, parameter :: CLS_EDIT = Z"81" integer, parameter :: CLS_STATIC = Z"82" integer, parameter :: CLS_LISTBOX = Z"83" integer, parameter :: CLS_SCROLLBAR = Z"84" integer, parameter :: CLS_COMBOBOX = Z"85" ! internal constants for each supported control type integer, parameter :: ctrl_error = 0 integer, parameter :: ctrl_statictext = 1 integer, parameter :: ctrl_groupbox = 2 integer, parameter :: ctrl_pushbutton = 3 integer, parameter :: ctrl_checkbox = 4 integer, parameter :: ctrl_radiobutton = 5 integer, parameter :: ctrl_edit = 6 integer, parameter :: ctrl_scrollbar = 7 integer, parameter :: ctrl_listbox = 8 integer, parameter :: ctrl_combobox = 9 integer, parameter :: ctrl_droplist = 10 integer, parameter :: ctrl_spinner = 11 integer, parameter :: ctrl_slider = 12 integer, parameter :: ctrl_progress = 13 integer, parameter :: ctrl_tab = 14 integer, parameter :: ctrl_activex = 15 integer, parameter :: TotalControls = 15 ! interfaces for routines implemented in C (dlglow.cpp) interface function DlgCastFunc2Int( func ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgCastFunc2Int external func integer r end function DlgCastFunc2Int subroutine DlgDoCallBack( subr, dlg, id, code ) !DEC$ ATTRIBUTES DEFAULT :: DlgDoCallBack use iflogmt integer(UINT_PTR), intent(in) :: subr type (dialog), intent(in) :: dlg integer(INT_PTR), intent(in) :: id integer(INT_PTR), intent(in) :: code end subroutine DlgDoCallback function DlgGetRes ( id, hinst, res ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgGetRes use iflogmt integer(INT_PTR), intent(in) :: id integer(HANDLE), intent(in) :: hinst type (DialogResource), intent(out) :: res logical r end function DlgGetRes subroutine DlgParseRes ( res, dlgheader ) !DEC$ ATTRIBUTES DEFAULT :: DlgParseRes use iflogmt type (DialogResource), intent(in) :: res type (DialogHeader), intent(out) :: dlgheader end subroutine DlgParseRes subroutine DlgParseResControl ( res, dialogEx, ctrlheader ) !DEC$ ATTRIBUTES DEFAULT :: DlgParseResControl use iflogmt type (DialogResource), intent(in) :: res logical, intent(in) :: dialogEx type (ControlHeader), intent(out) :: ctrlheader end subroutine DlgParseResControl function DlgDoModal ( dlg, dlgid, hinst, hwndParent, dlgproc, & isactivex ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgDoModal use iflogmt type (dialog), intent(in) :: dlg integer(INT_PTR), intent(in) :: dlgid integer(HANDLE), intent(in) :: hinst integer(HANDLE), intent(in) :: hwndParent integer(UINT_PTR),external :: dlgproc logical, intent(in) :: isactivex integer(INT_PTR) :: r end function DlgDoModal function DlgDoModeless ( dlg, dlgid, hinst, hwndParent, nCmdShow, & dlgproc, isactivex ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgDoModeless use iflogmt type (dialog), intent(in) :: dlg integer(INT_PTR), intent(in) :: dlgid integer(HANDLE), intent(in) :: hinst integer(HANDLE), intent(in) :: hwndParent integer, intent(in) :: nCmdShow integer(UINT_PTR), external :: dlgproc logical, intent(in) :: isactivex integer(INT_PTR) r end function DlgDoModeless subroutine DlgExecuteDLGINIT( dlg, dlgid, hinst ) !DEC$ ATTRIBUTES DEFAULT :: DlgExecuteDLGINIT use iflogmt type (dialog), intent(in) :: dlg integer(INT_PTR), intent(in) :: dlgid integer(HANDLE), intent(in) :: hinst end subroutine DlgExecuteDLGINIT subroutine DlgEndDialog ( hwnd, retval ) !DEC$ ATTRIBUTES DEFAULT :: DlgEndDialog use ifwinty integer(HANDLE), intent(in) :: hwnd integer, intent(in) :: retval end subroutine DlgEndDialog function DlgSendMessage( hwnd, msg, wparam, lparam ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgSendMessage use ifwinty integer(HANDLE), intent(in) :: hwnd integer(UINT), intent(in) :: msg integer(fWPARAM), intent(in) :: wparam integer(fLPARAM), intent(in) :: lparam integer r end function DlgSendMessage function DlgHwnd2Id( hwnd ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgHwnd2Id use ifwinty integer(HANDLE), intent(in) :: hwnd integer r end function DlgHwnd2Id function DlgId2Hwnd( hwndDlg, id ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgId2Hwnd use ifwinty integer(HANDLE), intent(in) :: hwndDlg integer(INT_PTR), intent(in) :: id integer r end function DlgId2Hwnd function DlgEnableWindow( hwnd, enabled ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgEnableWindow use ifwinty integer(HANDLE), intent(in) :: hwnd logical(UINT_PTR), intent(in) :: enabled logical r end function DlgEnableWindow function DlgIsWindowEnabled( hwnd ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgIsWindowEnabled use ifwinty integer(HANDLE), intent(in) :: hwnd logical r end function DlgIsWindowEnabled function DlgIsDialogMessage( hwnd, lpMsg ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgIsDialogMessage use ifwinty integer(HANDLE), intent(in) :: hwnd type (T_MSG), intent(in) :: lpMsg logical r end function DlgIsDialogMessage subroutine DlgIssueError ( severity, errno, hinst, paramno, & param1, param2 ) !DEC$ ATTRIBUTES DEFAULT, C :: DlgIssueError use ifwinty integer(UINT_PTR), intent(in) :: severity !DEC$ ATTRIBUTES REFERENCE :: severity integer, intent(in) :: errno !DEC$ ATTRIBUTES REFERENCE :: errno integer(HANDLE), intent(in) :: hinst !DEC$ ATTRIBUTES REFERENCE :: hinst integer(UINT_PTR), intent(in), optional :: paramno !DEC$ ATTRIBUTES REFERENCE :: paramno character, intent(in), optional :: param1 !DEC$ ATTRIBUTES REFERENCE :: param1 character, intent(in), optional :: param2 !DEC$ ATTRIBUTES REFERENCE :: param2 end subroutine DlgIssueError function DlgGetControlIDispatch( hwnd, id ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgGetControlIDispatch use ifwinty integer(HANDLE), intent(in) :: hwnd integer(INT_PTR), intent(in) :: id integer(HANDLE) r end function DlgGetControlIDispatch function DlgAllocateEventHandlerList( id ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgAllocateEventHandlerList use ifwinty integer(INT_PTR), intent(in) :: id integer(UINT_PTR) r end function DlgAllocateEventHandlerList function DlgAddEventHandler( hwnd, ctrlid, list, iid, dispid, & handler ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgAddEventHandler use ifwinty integer(HANDLE), intent(in) :: hwnd integer(INT_PTR), intent(in) :: ctrlid integer(UINT_PTR), intent(in) :: list type(T_GUID), intent(in) :: iid integer(INT_PTR), intent(in) :: dispid integer(UINT_PTR), intent(in) :: handler integer r end function DlgAddEventHandler subroutine DlgSetAXControlInfo( hwnd, ctrlid, list ) !DEC$ ATTRIBUTES DEFAULT :: DlgSetAXControlInfo use ifwinty integer(HANDLE), intent(in) :: hwnd integer(INT_PTR), intent(in) :: ctrlid integer(UINT_PTR), intent(in) :: list end subroutine DlgSetAXControlInfo subroutine DlgDeallocateEventHandlerList( list ) !DEC$ ATTRIBUTES DEFAULT :: DlgDeallocateEventHandlerList use ifwinty integer(UINT_PTR), intent(in) :: list end subroutine DlgDeallocateEventHandlerList function VarTextSet( vartext, str, newlen ) result (r) !DEC$ ATTRIBUTES DEFAULT :: VarTextSet use ifwinty integer(UINT_PTR), intent(in) :: vartext !DEC$ ATTRIBUTES VALUE :: vartext character*(*), intent(in) :: str integer, intent(out) :: newlen integer(UINT_PTR) r end function VarTextSet function VarTextGet( vartext, str ) result (r) !DEC$ ATTRIBUTES DEFAULT :: VarTextGet use ifwinty integer(UINT_PTR), intent(in) :: vartext !DEC$ ATTRIBUTES VALUE :: vartext character*(*), intent(out) :: str integer r end function VarTextGet subroutine VarTextFree( vartext ) !DEC$ ATTRIBUTES DEFAULT :: VarTextFree use ifwinty integer(UINT_PTR), intent(in) :: vartext !DEC$ ATTRIBUTES VALUE :: vartext end subroutine VarTextFree subroutine VarTextSendSetMessage( hwnd, vartext ) !DEC$ ATTRIBUTES DEFAULT :: VarTextSendSetMessage use ifwinty integer(HANDLE), intent(in) :: hwnd integer(UINT_PTR), intent(in) :: vartext !DEC$ ATTRIBUTES VALUE :: vartext end subroutine VarTextSendSetMessage function VarTextSendGetMessage( hwnd, vartext, newlen ) result (r) !DEC$ ATTRIBUTES DEFAULT :: VarTextSendGetMessage use ifwinty integer(HANDLE), intent(in) :: hwnd integer(UINT_PTR), intent(in) :: vartext !DEC$ ATTRIBUTES VALUE :: vartext integer, intent(out) :: newlen integer(UINT_PTR) r end function VarTextSendGetMessage function VarTextSetLength( vartext, newlen ) result (r) !DEC$ ATTRIBUTES DEFAULT :: VarTextSetLength use ifwinty integer(UINT_PTR), intent(in) :: vartext !DEC$ ATTRIBUTES VALUE :: vartext integer, intent(in) :: newlen integer(UINT_PTR) r end function VarTextSetLength end interface ! overload the dialog modal routine using F90 generics interface DlgModal module procedure DlgModal module procedure DlgModalWithParent end interface ! overload the dialog get and set routines using F90 generics interface DlgSet module procedure DlgSetInt module procedure DlgSetLog module procedure DlgSetChar end interface interface DlgGet module procedure DlgGetInt !#if defined( _M_IA64) || defined( _M_AMD64) module procedure DlgGetInt64 !#endif module procedure DlgGetLog module procedure DlgGetChar end interface ! overload the dialog initialization routine using F90 generics interface DlgInit module procedure DlgInit module procedure DlgInitWithResourceHandle end interface ! overload the DlgIsDlgMessage routine using F90 generics interface DlgIsDlgMessage module procedure DlgIsDlgMessage module procedure DlgIsDlgMessageWithDlg end interface ! overload DlgSetCtrlEventHandler to deal with inconsistent ! declaration/documentation of its iid argument interface DlgSetCtrlEventHandler module procedure DlgSetCtrlEventHandler recursive function DlgSetCtrlEventHandler1( dlg, controlid, & handler, dispid, iid ) result (r) !DEC$ ATTRIBUTES DEFAULT, DECORATE, ALIAS:"IFLOGM_mp_DLGSETCTRLEVENTHANDLER" :: DlgSetCtrlEventHandler1 import type (dialog), intent(inout) :: dlg integer, intent(in) :: controlid external handler integer(INT_PTR), intent(in) :: dispid type(GUID), intent(in) :: iid ! Don't make this OPTIONAL! integer r end function DlgSetCtrlEventHandler1 end interface ! all public module functions are listed here public DlgInit public DlgInitWithResourceHandle public DlgModal public DlgModalWithParent public DlgModeless public DlgIsDlgMessage public DlgIsDlgMessageWithDlg public DlgSetReturn public DlgExit public DlgUninit !DEC$ IF defined(DEBUG) public DlgDump !DEC$ ENDIF public DlgSetInt public DlgSetLog public DlgSetChar public DlgSetSub public DlgSet public DlgSetTitle public DlgSetCtrlEventHandler public DlgGetInt !SS #if defined( _M_IA64) || defined( _M_AMD64) public DlgGetInt64 !SS #endif public DlgGetLog public DlgGetChar public DlgGet public DlgSendCtrlMessage public DlgFlush contains ! helper functions recursive function log2int( lvalue ) result (ivalue) !DEC$ ATTRIBUTES DEFAULT :: log2int logical(UINT_PTR), intent(in) :: lvalue integer(INT_PTR) :: ivalue if ( lvalue ) then ivalue = 1 else ivalue = 0 end if end function log2int !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! StrFor2C !! !! Null terminates a blank padded string and saves string !! information in a strpos structure. (F90 string to C string) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine StrFor2C( str, pos ) !DEC$ ATTRIBUTES DEFAULT :: StrFor2C character*(*), target, intent(inout) :: str type (strpos), intent(out) :: pos integer iEnd iEnd = len_trim(str)+1 if (iEnd .eq. len(str)+1) iEnd = len(str) pos%s => str pos%c = str(iEnd:iEnd) pos%i = iEnd str(iEnd:iEnd) = char(0) end subroutine StrFor2C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! StrC2For !! !! Restores a previously null terminated string into its !! original blank padded state !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine StrC2For( pos ) !DEC$ ATTRIBUTES DEFAULT :: StrC2For type (strpos), intent(inout) :: pos pos%s(pos%i:pos%i) = pos%c end subroutine StrC2For !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! PadStrFor !! !! Pads out a null terminated string (C string to F90 string) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine PadStrFor( str ) !DEC$ ATTRIBUTES DEFAULT :: PadStrFor character*(*), intent(inout) :: str integer i ! scan up to the terminating null i = 1 do while( i .le. len(str) .and. str(i:i) .ne. char(0) ) i = i + 1 end do ! pad the rest with blanks do while( i .le. len(str) ) str(i:i) = ' ' i = i + 1 end do end subroutine PadStrFor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DefaultCallback !! !! This is the initial callback for the messages of all !! controls except pushbuttons. No action is performed !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DefaultCallback( dlg, id, code ) !DEC$ ATTRIBUTES DEFAULT :: DefaultCallback type (dialog) dlg integer id integer code ! supress compiler warnings type (dialog) local_dlg integer local_i local_dlg = dlg local_i = id local_i = code end subroutine DefaultCallback !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DefaultPushbuttonCallback !! !! This is the initial callback for the dlg_click message !! for pushbutton controls. The dialog is terminated, !! returning the control id of the pushbutton. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DefaultPushbuttonCallback( dlg, id, code ) !DEC$ ATTRIBUTES DEFAULT :: DefaultPushbuttonCallback type (dialog) dlg integer id integer code ! supress compiler warnings integer local_i local_i = code call DlgSetReturn( dlg, id ) call DlgExit( dlg ) end subroutine DefaultPushbuttonCallback !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgBadStyle !! !! Halts the program displaying the incorrect style and id !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgBadStyle ( cid, str, hinst ) !DEC$ ATTRIBUTES DEFAULT :: DlgBadStyle integer(INT_PTR), intent(IN) :: cid character*(*) str integer(HANDLE), intent(in) :: hinst integer, parameter :: IDS_ERROR_INVSTYLE = 50007 integer, parameter :: SEVERITY_SEVERE = 1 character*20 text write (text,*) cid call DlgIssueError ( SEVERITY_SEVERE, IDS_ERROR_INVSTYLE, & hinst, 2, & trim(str) // ""C, & adjustl(text) // ""C ) stop end subroutine DlgBadStyle !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgInitWithResourceHandle !! PUBLIC ROUTINE !! !! Given a dialog's resource id, scans the resource for !! supported controls and initializes the dialog structure !! appropriately !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgInitWithResourceHandle ( id, hinst, dlg, dlgoptions ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgInitWithResourceHandle integer, intent(in) :: id integer(HANDLE), intent(in) :: hinst type (dialog), intent(out) :: dlg integer, intent(in), optional :: dlgoptions logical r integer i, i2 integer(INT_PTR) long_id type (DialogHeader) dlgheader type (ControlHeader) ctrlheader integer class, style, textlen type (DialogResource) dlgres, dlgres2 integer idxFirstRadio, idLastRadio character(80) envval !what we need to get to the VC++ routine getenv !char * __cdecl getenv(const char *); INTERFACE integer(INT_PTR_KIND()) function getenv(varname) !DEC$ ATTRIBUTES C, DECORATE, ALIAS: "getenv" :: getenv integer(INT_PTR_KIND()) varname end function getenv END INTERFACE character*50 varname character*300 varvalue integer(INT_PTR_KIND()) vvPtr pointer(vvPtr,varvalue) interface integer function OleInitialize( reserved ) !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS : "OleInitialize" :: OleInitialize integer, intent(in) :: reserved !DEC$ ATTRIBUTES VALUE :: reserved end function OleInitialize end interface POINTER(OleInitialize_PTR, OleInitialize) ! routine pointer integer(HANDLE) dllhInst logical lret, lenabled logical cancelcontrol, sysmenu, dirty integer ioptions if (present(dlgoptions)) then ioptions = dlgoptions else ioptions = 0 end if r = .true. ! Initialize 'dialog' object 'dlg'. ! idxFirstRadio = 0 dlg % dlgid = id dlg % hwnd = 0 dlg % retval = 1 dlg % dirty = .true. dlg % mutexflush = .false. dlg % comboupdate = .true. dlg % dlginitcallback = loc(DefaultCallback) dlg % NumControls = 0 long_id = id ! Call-by-reference mismatch between our arg and the callee's arg. if ( .not. DlgGetRes( long_id, hinst, dlgres ) ) then r = .false. return end if call DlgParseRes( dlgres, dlgheader ) ! note 1: this may be larger than necessary since we only ! need an entry for each supported control while we allocate ! an entry for each control in the dialog ! note 2: we allocate an additional entry to hold additional ! information about the dialog box. This information would ! logically be in the DIALOG type except for binary upward ! compatibility considerations ! note 3: if needed we allocate an additional entry for control ! IDCANCEL for "Close" button of system menu. ! if ((dlgheader % Style .AND. WS_SYSMENU) /= 0) then ! There is system menu and must be used. sysmenu = .true. allocate( dlg % list( dlgheader % NumberOfItems + 2 ) ) else ! There isn't system menu. sysmenu = .false. allocate( dlg % list( dlgheader % NumberOfItems + 1 ) ) end if dirty = .false. cancelcontrol = .false. do i = 1, dlgheader % NumberOfItems call DlgParseResControl( dlgres, dlgheader % DialogEX, ctrlheader ) class = ctrlheader % ClassId style = ctrlheader % Style lenabled = .TRUE. if (ctrlheader % id == IDCANCEL) then ! There is user's IDCANCEL control cancelcontrol = .true. end if if ( (style .AND. WS_DISABLED) /= 0 ) then lenabled = .FALSE. endif ! Check for duplicate ids ! dlg%NumControls = dlg%NumControls + 1 dlg % list(dlg%NumControls) % doptions = 0 dlg % list(dlg%NumControls) % duplicate = .false. do i2 = 1, i-1 if (dlg % list(i2) % id .eq. ctrlheader % id ) then dlg % list(i2) % duplicate = .true. dlg % list(dlg%NumControls) % duplicate = .true. exit end if end do ! if the control matches one of the controls that we support then add it if ( class .eq. CLS_BUTTON ) then ! is it a button? style = iand( style, 15 ) ! just keep the low 4 bits if (style .eq. BS_PUSHBUTTON .or. style .eq. BS_DEFPUSHBUTTON) then dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_pushbutton dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 0 dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 1 allocate( dlg % list(dlg%NumControls) % callbackvalue(1) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultPushbuttonCallback) dlg % list(dlg%NumControls) % vartextptr = & VarTextSet(0, ctrlheader % textname, textlen) ! dlg_title else if (style .eq. BS_AUTOCHECKBOX) then dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_checkbox dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 0 dlg % list(dlg%NumControls) % logsize = 2 allocate( dlg % list(dlg%NumControls) % logvalue(2) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % logvalue(2) = .true. ! dlg_state dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 1 allocate( dlg % list(dlg%NumControls) % callbackvalue(1) ) dlg % list(dlg%NumControls) % callbackvalue(1) = loc(DefaultCallback) dlg % list(dlg%NumControls) % vartextptr = & VarTextSet(0, ctrlheader % textname, textlen) ! dlg_title else if (style .eq. BS_AUTORADIOBUTTON .or. style .eq. BS_RADIOBUTTON .or. & style .eq. BS_AUTO3STATE .or. style .eq. BS_3STATE ) then dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_radiobutton dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 2 allocate( dlg % list(dlg%NumControls) % intvalue(2) ) ! do int initialization later dlg % list(dlg%NumControls) % logsize = 2 allocate( dlg % list(dlg%NumControls) % logvalue(2) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled ! do dlg_state later dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 1 allocate( dlg % list(dlg%NumControls) % callbackvalue(1) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % vartextptr = & VarTextSet(0, ctrlheader % textname, textlen) ! dlg_title if ( idxFirstRadio .eq. 0) then ! scan ahead counting radio buttons to next group control ! or last control idxFirstRadio = i idLastRadio = ctrlheader % id dlgres2 = dlgres do i2 = i, dlgheader % NumberOfItems call DlgParseResControl( dlgres2, dlgheader % DialogEX, ctrlheader ) if (iand(ctrlheader%Style,Z"00020000") .eq. Z"00020000") exit if (ctrlheader%ClassId .eq. CLS_BUTTON .and. & iand(ctrlheader%Style,15) .eq. BS_AUTORADIOBUTTON) & idLastRadio = ctrlheader % id end do dlg % list(dlg%NumControls) % logvalue(2) = .true. ! dlg_state else dlg % list(dlg%NumControls) % logvalue(2) = .false. ! dlg_state end if if ( idLastRadio .eq. dlg % list(dlg%NumControls) % id ) then ! fill whole radio group with first and last index value do i2 = idxFirstRadio, i if (dlg % list(i2) % control .eq. ctrl_radiobutton) then dlg % list(i2) % intvalue(1) = idxFirstRadio dlg % list(i2) % intvalue(2) = i end if end do idxFirstRadio = 0 end if else if (style .eq. BS_GROUPBOX ) then dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_groupbox dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 0 dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 0 dlg % list(dlg%NumControls) % vartextptr = & VarTextSet(0, ctrlheader % textname, textlen) ! dlg_title else if ( style .eq. BS_OWNERDRAW ) then call DlgBadStyle( ctrlheader%id, "BS_OWNERDRAW", hinst) else if ( style .eq. BS_USERBUTTON ) then call DlgBadStyle( ctrlheader%id, "BS_USERBUTTON", hinst) else call DlgBadStyle( ctrlheader%id, "", hinst) end if else if ( class .eq. CLS_STATIC ) then ! is it a static control? dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_statictext dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 0 dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 0 dlg % list(dlg%NumControls) % vartextptr = & VarTextSet(0, ctrlheader % textname, textlen) ! dlg_title else if ( class .eq. CLS_EDIT ) then ! is it an edit control? dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_edit dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 2 allocate( dlg % list(dlg%NumControls) % intvalue(2) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 ! dlg_textlength dlg % list(dlg%NumControls) % intvalue(2) = 0 ! dlg_position dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 4 allocate( dlg % list(dlg%NumControls) % callbackvalue(4) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(2) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(3) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(4) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % vartextptr = & VarTextSet(0, ctrlheader % textname, textlen) ! dlg_state else if ( class .eq. CLS_LISTBOX) then ! is it a list box control? if ( iand(ctrlheader%Style,LBS_OWNERDRAWFIXED) .eq. LBS_OWNERDRAWFIXED ) then call DlgBadStyle( ctrlheader%id, "LBS_OWNERDRAWFIXED", hinst) else if ( iand(ctrlheader%Style,LBS_OWNERDRAWVARIABLE) .eq. LBS_OWNERDRAWVARIABLE ) then call DlgBadStyle( ctrlheader%id, "LBS_OWNERDRAWVARIABLE", hinst) end if dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_listbox dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 2 allocate( dlg % list(dlg%NumControls) % intvalue(2) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 !listbox is 0 length dlg % list(dlg%NumControls) % intvalue(2) = 0 !no items are selected dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 1 allocate( dlg % list(dlg%NumControls) % charvalue(1) ) dlg % list(dlg%NumControls) % charvalue(1) = "" dlg % list(dlg%NumControls) % callbacksize = 2 allocate( dlg % list(dlg%NumControls) % callbackvalue(2) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(2) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % vartextptr = 0 else if ( class .eq. CLS_COMBOBOX ) then ! is it a combo box control? if ( iand(ctrlheader%Style,CBS_OWNERDRAWFIXED) .ne. 0 ) then call DlgBadStyle( ctrlheader%id, "CBS_OWNERDRAWFIXED", hinst) else if ( iand(ctrlheader%Style,CBS_OWNERDRAWVARIABLE) .ne. 0 ) then call DlgBadStyle( ctrlheader%id, "CBS_OWNERDRAWVARIABLE", hinst) end if if ( iand(ctrlheader%Style,3) .eq. CBS_DROPDOWNLIST) then ! droplist combo dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_droplist dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 2 allocate( dlg % list(dlg%NumControls) % intvalue(2) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 !combo box is 0 length dlg % list(dlg%NumControls) % intvalue(2) = 0 dlg % list(dlg%NumControls) % logsize = 2 allocate( dlg % list(dlg%NumControls) % logvalue(2) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % logvalue(2) = .false. ! Use text for selection dlg % list(dlg%NumControls) % charsize = 1 allocate( dlg % list(dlg%NumControls) % charvalue(1) ) dlg % list(dlg%NumControls) % charvalue(1) = "" dlg % list(dlg%NumControls) % callbacksize = 2 allocate( dlg % list(dlg%NumControls) % callbackvalue(2) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(2) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % vartextptr = 0 else ! simple combo or dropdown combo dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_combobox dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 1 allocate( dlg % list(dlg%NumControls) % intvalue(1) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 !combo box is 0 length dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 1 allocate( dlg % list(dlg%NumControls) % charvalue(1) ) dlg % list(dlg%NumControls) % charvalue(1) = "" dlg % list(dlg%NumControls) % callbacksize = 6 allocate( dlg % list(dlg%NumControls) % callbackvalue(6) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(2) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(3) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(4) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(5) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % callbackvalue(6) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % vartextptr = 0 end if else if ( class .eq. CLS_SCROLLBAR ) then ! is it a scroll bar control? dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_scrollbar dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 5 allocate( dlg % list(dlg%NumControls) % intvalue(5) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 ! dlg_position dlg % list(dlg%NumControls) % intvalue(2) = 100 ! dlg_rangemax dlg % list(dlg%NumControls) % intvalue(3) = 1 ! dlg_smallstep dlg % list(dlg%NumControls) % intvalue(4) = 10 ! dlg_bigstep dlg % list(dlg%NumControls) % intvalue(5) = 1 ! dlg_rangemin dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 1 allocate( dlg % list(dlg%NumControls) % callbackvalue(1) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % vartextptr = 0 else ! Check for the Common Controls that we support if (ctrlheader % ClassName .eq. UD_CLASS_NAME(1:15)) then dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_spinner dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 5 allocate( dlg % list(dlg%NumControls) % intvalue(5) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 ! dlg_position dlg % list(dlg%NumControls) % intvalue(2) = 100 ! dlg_rangemax dlg % list(dlg%NumControls) % intvalue(3) = 1 dlg % list(dlg%NumControls) % intvalue(4) = 1 dlg % list(dlg%NumControls) % intvalue(5) = 0 ! dlg_rangemin dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 1 allocate( dlg % list(dlg%NumControls) % callbackvalue(1) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) ! dlg_changed dlg % list(dlg%NumControls) % vartextptr = 0 else if (ctrlheader % ClassName .eq. TB_CLASS_NAME(1:17)) then dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_slider dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 6 allocate( dlg % list(dlg%NumControls) % intvalue(6) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 ! dlg_position dlg % list(dlg%NumControls) % intvalue(2) = 100 ! dlg_rangemax dlg % list(dlg%NumControls) % intvalue(3) = 1 ! dlg_smallstep dlg % list(dlg%NumControls) % intvalue(4) = 10 ! dlg_bigstep dlg % list(dlg%NumControls) % intvalue(5) = 0 ! dlg_rangemin dlg % list(dlg%NumControls) % intvalue(6) = 1 ! dlg_tickfreq dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 1 allocate( dlg % list(dlg%NumControls) % callbackvalue(1) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) dlg % list(dlg%NumControls) % vartextptr = 0 else if (ctrlheader % ClassName .eq. PB_CLASS_NAME(1:17)) then dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_progress dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 3 allocate( dlg % list(dlg%NumControls) % intvalue(3) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 ! dlg_position dlg % list(dlg%NumControls) % intvalue(2) = 100 ! dlg_rangemax dlg % list(dlg%NumControls) % intvalue(3) = 0 ! dlg_rangemin dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 0 dlg % list(dlg%NumControls) % vartextptr = 0 else if (ctrlheader % ClassName .eq. TAB_CLASS_NAME(1:15)) then dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_tab dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 2 allocate( dlg % list(dlg%NumControls) % intvalue(2) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 ! dlg_numitems dlg % list(dlg%NumControls) % intvalue(2) = 0 ! dlg_state dlg % list(dlg%NumControls) % logsize = 2 allocate( dlg % list(dlg%NumControls) % logvalue(2) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % logvalue(2) = .false. ! Use text for selection dlg % list(dlg%NumControls) % charsize = 1 allocate( dlg % list(dlg%NumControls) % charvalue(1) ) dlg % list(dlg%NumControls) % charvalue(1) = "" ! dlg_state dlg % list(dlg%NumControls) % callbacksize = 2 allocate( dlg % list(dlg%NumControls) % callbackvalue(2) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultCallback) ! dlg_selchange dlg % list(dlg%NumControls) % callbackvalue(2) & = loc(DefaultCallback) ! dlg_selchanging dlg % list(dlg%NumControls) % vartextptr = 0 ! Check for an ActiveX Control else if (ctrlheader % ClassName(1:1) .eq. "{") then dirty = .true. dlg % list(dlg%NumControls) % id = ctrlheader % id dlg % list(dlg%NumControls) % control = ctrl_activex dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 1 allocate( dlg % list(dlg%NumControls) % intvalue(1) ) dlg % list(dlg%NumControls) % intvalue(1) = 0 ! dlg_idispatch dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 1 allocate( dlg % list(dlg%NumControls) % callbackvalue(1) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = DlgAllocateEventHandlerList(ctrlheader % id) dlg % list(dlg%NumControls) % vartextptr = 0 else ! Not a recognized control, zero out the sizes so that we don't ! try to deallocate them in DlgUninit, set other values to safe ones. ! dlg % list(dlg%NumControls) % intsize = 0 dlg % list(dlg%NumControls) % logsize = 0 dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 0 dlg % list(dlg%NumControls) % vartextptr = 0 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = .FALSE. dlg % list(dlg%NumControls) % control = ctrl_error ! Zero dlg % list(dlg%NumControls) % id = 0 end if end if end do if (sysmenu) then ! To add the control IDCANCEL for processing pushing of "Close" button of system menu. dlg % NumControls = dlg % NumControls + 1 dlg % list(dlg%NumControls) % id = IDCANCEL dlg % list(dlg%NumControls) % control = ctrl_pushbutton dlg % list(dlg%NumControls) % duplicate = .false. if (cancelcontrol) then dlg % list(dlg%NumControls) % duplicate = .true. end if dlg % list(dlg%NumControls) % dirty = .true. dlg % list(dlg%NumControls) % intsize = 0 dlg % list(dlg%NumControls) % logsize = 1 allocate( dlg % list(dlg%NumControls) % logvalue(1) ) dlg % list(dlg%NumControls) % logvalue(1) = lenabled ! dlg_enabled dlg % list(dlg%NumControls) % charsize = 0 dlg % list(dlg%NumControls) % callbacksize = 1 allocate( dlg % list(dlg%NumControls) % callbackvalue(1) ) dlg % list(dlg%NumControls) % callbackvalue(1) & = loc(DefaultPushbuttonCallback) dlg % list(dlg%NumControls) % vartextptr = 0 dlg % list(dlg%NumControls) % doptions = 1 end if ! Initialize the extra entry for the dialog box dlg % list(dlg%NumControls+1) % control = 0 ! 'id' is the index in 'intvalue' pointer storing ! the instance handle for for the dialog resource template dlg % list(dlg%NumControls+1) % id = 1 ! dlg % list(dlg%NumControls+1) % dirty = dirty ! this field gets set to TRUE if the ! dialog box contains ActiveX controls dlg % list(dlg%NumControls+1) % duplicate = .false. ! this field gets set to TRUE if ! we need to call OleUninitialize dlg % list(dlg%NumControls+1) % intsize = 1 allocate( dlg % list(dlg%NumControls+1) % intvalue(1) ) dlg % list(dlg%NumControls+1) % intvalue(1) = hinst ! this holds ! the instance handle for dialog resource template dlg % list(dlg%NumControls+1) % logsize = 0 dlg % list(dlg%NumControls+1) % charsize = 0 dlg % list(dlg%NumControls+1) % callbacksize = 1 allocate( dlg % list(dlg%NumControls+1) % callbackvalue(1) ) dlg % list(dlg%NumControls+1) % callbackvalue(1) & = loc(DefaultCallback) dlg % list(dlg%NumControls+1) % vartextptr = 0 ! this field gets set by DlgSetTitle dlg % list(dlg%NumControls+1) % doptions = 0 ! The presence of the FOR_DLG_ACTIVEX environment variable forces the use ! of the ActiveX implementation. We call OleInitialize in case the ! application hasn't !avoid using GETENVQQ - wrc 02/11/2003 ! i = GETENVQQ ("FOR_DLG_ACTIVEX", envval) ! if (i > 0) then varname = "FOR_DLG_ACTIVEX"C vvPtr = GETENV(loc(varname)) !fix this for 64-bit architecture systems if(vvPtr .ne. 0) then dlg % list(dlg%NumControls+1) % dirty = .true. ! this field gets set to TRUE if the ! dialog box contains ActiveX controls !DEC$ IF defined(DEBUG) dllhInst = LoadLibrary("ole32.dll"C) if (dllhInst .ne. NULLPTR) then OleInitialize_PTR = GetProcAddress(dllhInst, "OleInitialize"C) if (OleInitialize_PTR .ne. NULLPTR) then !call COMINITIALIZE(i) i = OleInitialize(NULLPTR) if (i >= 0) then ! this field gets set to TRUE if we need to call OleUninitialize dlg % list(dlg%NumControls+1) % duplicate = .true. end if end if lret = FreeLibrary(dllhInst) end if !DEC$ ENDIF end if end function DlgInitWithResourceHandle !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgInit !! PUBLIC ROUTINE !! !! Given a dialog's resource id, scans the resource for !! supported controls and initializes the dialog structure !! appropriately. The resource handle defaults to the !! main application. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgInit ( id, dlg, dlgoptions ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgInit integer, intent(in) :: id type (dialog), intent(out) :: dlg integer, intent(in), optional :: dlgoptions logical r integer ioptions if (present(dlgoptions)) then ioptions = dlgoptions else ioptions = 0 end if r = DlgInitWithResourceHandle( id, 0, dlg, ioptions ) end function DlgInit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Id2Index !! !! Given the control id of a dialog, returns the index of !! that control in our dialog structure !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function Id2Index( dlg, id ) result (index) !DEC$ ATTRIBUTES DEFAULT :: Id2Index type (dialog), intent(in) :: dlg integer(INT_PTR), intent(in) :: id integer(INT_PTR) :: index integer i ! TODO: binary search instead of linear do i = 1, dlg % NumControls if ( dlg % list(i) % id .eq. id ) then index = i return end if end do index = 0 end function Id2Index !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Data2Dialog !! !! Sets all values for a single control in the dialog box !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine Data2Dialog( dlg, index ) !DEC$ ATTRIBUTES DEFAULT :: Data2Dialog use user32 type (dialog), intent(inout) :: dlg integer index logical dummyL logical(INT_PTR) :: logvalue integer :: dummyi, numItems, ior_arg1, ior_arg2 integer(INT_PTR) :: i, i2, selItem ! Because passed to DlgSendMessage integer(HANDLE) hwndControl type (strpos) pos type (T_SCROLLINFO) scrollInfo type (T_TCITEM) item integer tabid integer(UINT_PTR) ior_val ! controls with duplicate ids are inaccessable if (dlg % list(index) % duplicate) return ! Handle to the control "Close" button of system menu is absent if (.NOT.((dlg % list(index) % doptions == 1) .AND. & (dlg % list(index) % control == ctrl_pushbutton))) then hwndControl = DlgID2Hwnd( dlg%hwnd, dlg % list(index) % id ) end if select case (dlg % list(index) % control) case (ctrl_statictext) call VarTextSendSetMessage( hwndControl, dlg % list(index) % vartextptr ) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) case (ctrl_groupbox) call VarTextSendSetMessage( hwndControl, dlg % list(index) % vartextptr ) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) case (ctrl_pushbutton) logvalue = dlg % list(index) % logvalue(1) if (dlg % list(index) % doptions /= 1) then call VarTextSendSetMessage( hwndControl, dlg % list(index) % vartextptr ) dummyL = DlgEnableWindow( hwndControl, logvalue ) end if if (dlg % list(index) % id == IDCANCEL) then ! To enable or to disable the "Close" of system menu if needed hwndControl = GetSystemMenu( dlg%hwnd, FALSE ) if (hwndControl /= 0) then if (logvalue) then dummyL = EnableMenuItem( hwndControl, SC_CLOSE, ior(MF_ENABLED,MF_BYCOMMAND)) else dummyL = EnableMenuItem( hwndControl, SC_CLOSE, ior(MF_DISABLED,MF_BYCOMMAND)) end if end if end if case (ctrl_checkbox) call VarTextSendSetMessage( hwndControl, dlg % list(index) % vartextptr ) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) dummyi = DlgSendMessage( hwndControl, BM_SETCHECK, & log2int( dlg % list(index) % logvalue(2) ), 0 ) case (ctrl_radiobutton) call VarTextSendSetMessage( hwndControl, dlg % list(index) % vartextptr ) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) dummyi = DlgSendMessage( hwndControl, BM_SETCHECK, & log2int( dlg % list(index) % logvalue(2) ), 0 ) case (ctrl_edit) call VarTextSendSetMessage( hwndControl, dlg % list(index) % vartextptr ) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) dummyi = DlgSendMessage( hwndControl, EM_SETSEL, & dlg % list(index) % intvalue(2), dlg % list(index) % intvalue(2) ) case (ctrl_scrollbar) scrollInfo % Size = SIZEOF(scrollInfo) scrollInfo % Mask = SIF_ALL scrollInfo % Min = dlg % list(index) % intvalue(5) scrollInfo % Max = dlg % list(index) % intvalue(2) scrollInfo % Pos = dlg % list(index) % intvalue(1) scrollInfo % Page = dlg % list(index) % intvalue(4) dummyi = DlgSendMessage( hwndControl, SBM_SETSCROLLINFO, & 1, loc(scrollInfo)) ! Note: EnableScrollBar is called after SBM_SETSCROLLINFO ! Otherwise disabling does not work. if (dlg % list(index) % logvalue(1)) then dummyL = EnableScrollBar( hwndControl, SB_CTL, ESB_ENABLE_BOTH) else dummyL = EnableScrollBar( hwndControl, SB_CTL, ESB_DISABLE_BOTH) end if case (ctrl_listbox) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) dummyi = DlgSendMessage( hwndControl, LB_RESETCONTENT, 0, 0 ) do i = 2, dlg % list(index) % intvalue(1) + 1 call StrFor2C( dlg % list(index) % charvalue(i), pos ) dummyi = DlgSendMessage( hwndControl, LB_ADDSTRING, & 0, loc(dlg % list(index) % charvalue(i)) ) call StrC2For( pos ) end do do i = 2, dlg % list(index) % intvalue(1) + 1 if (dlg % list(index) % intvalue(i) .eq. 0) then exit end if ! The list box selection message is different depending upon ! whether the box is single or multi selection dummyi = GetWindowLongPtr( hwndControl, GWL_STYLE ) if ( (dummyi .AND. LBS_MULTIPLESEL) /= 0 .OR. (dummyi .AND. LBS_EXTENDEDSEL) /= 0 ) then dummyi = DlgSendMessage( hwndControl, LB_SETSEL, & 1, dlg % list(index) % intvalue(i) - 1 ) else dummyi = DlgSendMessage( hwndControl, LB_SETCURSEL, & dlg % list(index) % intvalue(i) - 1, 0 ) end if end do case (ctrl_combobox) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) dummyi = DlgSendMessage( hwndControl, CB_RESETCONTENT, 0, 0 ) do i = 2, dlg % list(index) % intvalue(1) + 1 call StrFor2C( dlg % list(index) % charvalue(i), pos ) dummyi = DlgSendMessage( hwndControl, CB_ADDSTRING, & 0, loc(dlg % list(index) % charvalue(i)) ) call StrC2For( pos ) end do call StrFor2C( dlg % list(index) % charvalue(1), pos ) dummyi = DlgSendMessage( hwndControl, WM_SETTEXT, & 0, loc(dlg % list(index) % charvalue(1)) ) call StrC2For( pos ) case (ctrl_droplist) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) dummyi = DlgSendMessage( hwndControl, CB_RESETCONTENT, 0, 0 ) do i = 2, dlg % list(index) % intvalue(1) + 1 call StrFor2C( dlg % list(index) % charvalue(i), pos ) dummyi = DlgSendMessage( hwndControl, CB_ADDSTRING, & 0, loc(dlg % list(index) % charvalue(i)) ) call StrC2For( pos ) end do if (dlg % list(index) % logvalue(2)) then dlg % list(index) % logvalue(2) = .false. call StrFor2C( dlg % list(index) % charvalue(1), pos ) dummyi = DlgSendMessage( hwndControl, CB_SELECTSTRING, & -1, loc(dlg % list(index) % charvalue(1)) ) else dummyi = DlgSendMessage( hwndControl, CB_SETCURSEL, & dlg % list(index) % intvalue(2) - 1, 0 ) end if case (ctrl_spinner) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) ior_arg1 = ishft(dlg % list(index) % intvalue(5),16) ior_arg2 = iand(dlg % list(index) % intvalue(2), Z"ffff") ior_val = ior( ior_arg1, ior_arg2 ) dummyi = DlgSendMessage( hwndControl, UDM_SETRANGE, 0, ior_val ) dummyi = DlgSendMessage( hwndControl, UDM_SETPOS, & 0, dlg % list(index) % intvalue(1)) case (ctrl_slider) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) ior_arg1 = ishft(dlg % list(index) % intvalue(2),16) ior_arg2 = iand(dlg % list(index) % intvalue(5), Z"ffff") ! dummyi = DlgSendMessage( hwndControl, TBM_SETRANGE, 1, ior(ishft(dlg % list(index) % intvalue(2),16), iand(dlg % list(index) % intvalue(5), Z"ffff") ) ) ior_val = ior( ior_arg1, ior_arg2 ) dummyi = DlgSendMessage( hwndControl, TBM_SETRANGE, 1, ior_val ) dummyi = DlgSendMessage( hwndControl, TBM_SETPOS, 1, & dlg % list(index) % intvalue(1)) dummyi = DlgSendMessage( hwndControl, TBM_SETLINESIZE, 0, & dlg % list(index) % intvalue(3)) dummyi = DlgSendMessage( hwndControl, TBM_SETPAGESIZE, 0, & dlg % list(index) % intvalue(4)) dummyi = DlgSendMessage( hwndControl, TBM_SETTICFREQ, & dlg % list(index) % intvalue(6), 0 ) case (ctrl_progress) ior_arg1 = ishft(dlg % list(index) % intvalue(2),16) ior_arg2 = iand(dlg % list(index) % intvalue(3), Z"ffff") dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) ! dummyi = DlgSendMessage( hwndControl, PBM_SETRANGE, 0, ior(ishft(dlg % list(index) % intvalue(2),16), iand(dlg % list(index) % intvalue(3), Z"FFFF") ) ) ior_val = ior( ior_arg1, ior_arg2 ) dummyi = DlgSendMessage( hwndControl, PBM_SETRANGE, 0, ior_val) dummyi = DlgSendMessage( hwndControl, PBM_SETPOS, & dlg % list(index) % intvalue(1), 0) case (ctrl_tab) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) selItem = -1 numItems = DlgSendMessage( hwndControl, TCM_GETITEMCOUNT, 0, 0) do i = 2, dlg % list(index) % intvalue(1) + 1 call StrFor2C( dlg % list(index) % charvalue(i), pos ) item % mask = TCIF_TEXT item % pszText = loc(dlg % list(index) % charvalue(i)) ! If the tab already exists, use TCM_SETITEM, else TCM_INSERTITEM if (i-1 <= numItems) then dummyi = DlgSendMessage( hwndControl, TCM_SETITEM, & i-2, loc(item) ) else dummyi = DlgSendMessage( hwndControl, TCM_INSERTITEM, & i-2, loc(item) ) end if call StrC2For( pos ) if (dlg % list(index) % charvalue(i) .eq. dlg % list(index) % charvalue(1)) then selItem = i-1 end if end do ! Delete any extra tabs... i = dlg % list(index) % intvalue(1) i2 = i do while (i < numItems) dummyi = DlgSendMessage( hwndControl, TCM_DELETEITEM, i2, 0 ) i = i + 1 end do if (dlg % list(index) % logvalue(2)) then dlg % list(index) % logvalue(2) = .false. if (selItem > 0) then dlg % list(index) % intvalue(2) = selItem end if end if selItem = dlg % list(index) % intvalue(2) if (selItem > 0) then i = DlgSendMessage( hwndControl, TCM_GETCURSEL, 0, 0 ) if ( i /= (selItem - 1)) then tabid = dlg % list(index) % intvalue(i+3) if (tabid /= 0) then call DlgTabShow( hwndControl, tabid, .FALSE. ) end if dummyi = DlgSendMessage( hwndControl, TCM_SETCURSEL, & selItem - 1, 0 ) end if ! Ensure that the selected box is visible if ( dlg % list(index) % intvalue(1) > 0) then tabid = dlg % list(index) % intvalue(selItem+2) if (tabid /= 0) then call DlgTabShow( hwndControl, tabid, .TRUE. ) end if end if end if case (ctrl_activex) dummyL = DlgEnableWindow( hwndControl, dlg % list(index) % logvalue(1) ) case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select end subroutine Data2Dialog !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Dialog2Data !! !! Gets all values of a single control from the dialog box !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine Dialog2Data( dlg, index ) !DEC$ ATTRIBUTES DEFAULT :: Dialog2Data type (dialog), intent(inout) :: dlg integer index integer dummyi, newlen integer(INT_PTR) :: i, i2 integer(HANDLE) hwndControl integer*2 ishort type (T_SCROLLINFO) scrollInfo type (T_TCITEM) item ! controls with duplicate ids are inaccessable if (dlg % list(index) % duplicate) return ! Handle to the control "Close" of system menu is absent if (dlg % list(index) % doptions == 1) return hwndControl = DlgID2Hwnd( dlg%hwnd, dlg % list(index) % id ) select case (dlg % list(index) % control) case (ctrl_statictext) dlg % list(index) % vartextptr = & VarTextSendGetMessage( hwndControl, dlg % list(index) % vartextptr, newlen ) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) case (ctrl_groupbox) dlg % list(index) % vartextptr = & VarTextSendGetMessage( hwndControl, dlg % list(index) % vartextptr, newlen ) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) case (ctrl_pushbutton) dlg % list(index) % vartextptr = & VarTextSendGetMessage( hwndControl, dlg % list(index) % vartextptr, newlen ) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) case (ctrl_checkbox) dlg % list(index) % vartextptr = & VarTextSendGetMessage( hwndControl, dlg % list(index) % vartextptr, newlen ) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) if ( DlgSendMessage( hwndControl, BM_GETCHECK, 0, 0 ) .eq. 0 ) then dlg % list(index) % logvalue(2) = .false. else dlg % list(index) % logvalue(2) = .true. end if case (ctrl_radiobutton) dlg % list(index) % vartextptr = & VarTextSendGetMessage( hwndControl, dlg % list(index) % vartextptr, newlen ) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) if ( DlgSendMessage( hwndControl, BM_GETCHECK, 0, 0 ) .eq. 0 ) then dlg % list(index) % logvalue(2) = .false. else dlg % list(index) % logvalue(2) = .true. end if case (ctrl_edit) dlg % list(index) % vartextptr = & VarTextSendGetMessage( hwndControl, dlg % list(index) % vartextptr, newlen ) dlg % list(index) % intvalue(1) = newlen dummyi = DlgSendMessage( hwndControl, EM_GETSEL, & 0, loc(dlg % list(index) % intvalue(2)) ) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) case (ctrl_scrollbar) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) scrollInfo % Size = SIZEOF(scrollInfo) scrollInfo % Mask = SIF_ALL dummyi = DlgSendMessage( hwndControl, SBM_GETSCROLLINFO, & 0, loc(scrollInfo)) dlg % list(index) % intvalue(5) = scrollInfo % Min dlg % list(index) % intvalue(2) = scrollInfo % Max dlg % list(index) % intvalue(1) = scrollInfo % Pos dlg % list(index) % intvalue(4) = scrollInfo % Page case (ctrl_listbox) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) do i = 2, dlg % list(index) % intvalue(1) + 1 dummyi = DlgSendMessage( hwndControl, LB_GETTEXT, & i-2, loc(dlg % list(index) % charvalue(i)) ) call PadStrFor(dlg % list(index) % charvalue(i)) end do i2 = 2 do i = 0, dlg % list(index) % intvalue(1) - 1 dummyi = DlgSendMessage( hwndControl, LB_GETSEL, i, 0 ) if (dummyi .gt. 0) then dlg % list(index) % intvalue(i2) = i+1 i2 = i2 + 1 end if end do do i = i2, dlg % list(index) % intvalue(1) + 1 dlg % list(index) % intvalue(i) = 0 end do if (dlg % list(index) % intvalue(2) .eq. 0) then dlg % list(index) % charvalue(1) = "" else dummyi = DlgSendMessage( hwndControl, LB_GETTEXT, & dlg % list(index) % intvalue(2) - 1, & loc(dlg % list(index) % charvalue(1)) ) call PadStrFor(dlg % list(index) % charvalue(1)) end if case (ctrl_combobox) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) do i = 2, dlg % list(index) % intvalue(1) + 1 dummyi = DlgSendMessage( hwndControl, CB_GETLBTEXT, & i-2, loc(dlg % list(index) % charvalue(i)) ) call PadStrFor(dlg % list(index) % charvalue(i)) end do if ( dlg % comboupdate ) then dummyi = DlgSendMessage( hwndControl, WM_GETTEXT, & STRSZ, loc(dlg % list(index) % charvalue(1)) ) call PadStrFor(dlg % list(index) % charvalue(1)) else i = DlgSendMessage( hwndControl, CB_GETCURSEL, 0, 0 ) if ( i .eq. -1 ) i=0 if ( dlg % list(index) % intvalue(1) .eq. 0 ) then dlg % list(index) % charvalue(1) = "" else dlg % list(index) % charvalue(1) = dlg % list(index) % charvalue(i+2) end if end if case (ctrl_droplist) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) do i = 2, dlg % list(index) % intvalue(1) + 1 dummyi = DlgSendMessage( hwndControl, CB_GETLBTEXT, & i-2, loc(dlg % list(index) % charvalue(i)) ) call PadStrFor(dlg % list(index) % charvalue(i)) end do i = DlgSendMessage( hwndControl, CB_GETCURSEL, 0, 0 ) if ( i .eq. -1 ) i=0 if ( dlg % list(index) % intvalue(1) .eq. 0 ) then dlg % list(index) % charvalue(1) = "" else dlg % list(index) % charvalue(1) = dlg % list(index) % charvalue(i+2) end if dlg % list(index) % intvalue(2) = i+1 case (ctrl_spinner) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) i = DlgSendMessage( hwndControl, UDM_GETPOS, 0, 0 ) ishort = int2(i) dlg % list(index) % intvalue(1) = ishort i = DlgSendMessage( hwndControl, UDM_GETRANGE, 0, 0 ) ishort = int2(i) dlg % list(index) % intvalue(2) = ishort ishort = int2(ishft(i,-16)) dlg % list(index) % intvalue(5) = ishort case (ctrl_slider) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) dlg % list(index) % intvalue(1) = DlgSendMessage( hwndControl, TBM_GETPOS, 0, 0 ) dlg % list(index) % intvalue(2) = DlgSendMessage( hwndControl, TBM_GETRANGEMAX, 0, 0 ) dlg % list(index) % intvalue(5) = DlgSendMessage( hwndControl, TBM_GETRANGEMIN, 0, 0 ) dlg % list(index) % intvalue(3) = DlgSendMessage( hwndControl, TBM_GETLINESIZE, 0, 0 ) dlg % list(index) % intvalue(4) = DlgSendMessage( hwndControl, TBM_GETPAGESIZE, 0, 0 ) ! There is no TBM_GETTICFREQ case (ctrl_progress) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) ! NOTE: The PBM_GETPOS & PBM_GETRANGE messages require a version of ! Internet Explorer which is post Win95 and Win NT 4.0 !dlg % list(index) % intvalue(1) = DlgSendMessage( hwndControl, PBM_GETPOS, 0, 0 ) !dlg % list(index) % intvalue(3) = DlgSendMessage( hwndControl, PBM_GETRANGE, 1, 0 ) !dlg % list(index) % intvalue(2) = DlgSendMessage( hwndControl, PBM_GETRANGE, 0, 0 ) case (ctrl_tab) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) dlg % list(index) % intvalue(1) = DlgSendMessage( hwndControl, TCM_GETITEMCOUNT, 0, 0) do i = 2, dlg % list(index) % intvalue(1) + 1 item % Mask = TCIF_TEXT item % pszText = loc(dlg % list(index) % charvalue(i)) item % cchTextMax = STRSZ dummyi = DlgSendMessage( hwndControl, TCM_GETITEM, & i-2, loc(item) ) call PadStrFor(dlg % list(index) % charvalue(i)) end do i = DlgSendMessage( hwndControl, TCM_GETCURSEL, 0, 0 ) if ( i .eq. -1 ) i=0 if ( dlg % list(index) % intvalue(1) .eq. 0 ) then dlg % list(index) % charvalue(1) = "" else dlg % list(index) % charvalue(1) = dlg % list(index) % charvalue(i+2) end if dlg % list(index) % intvalue(2) = i+1 case (ctrl_activex) dlg % list(index) % logvalue(1) = DlgIsWindowEnabled( hwndControl ) if (dlg % hwnd .eq. 0) then dlg % list(index) % intvalue(1) = 0 ! dlg_idispatch else dlg % list(index) % intvalue(1) = & DlgGetControlIDispatch( dlg % hwnd, dlg % list(index) % id ); end if case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select end subroutine Dialog2Data !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgFlush !! PUBLIC ROUTINE !! !! Sets controls with any unwritten control data. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgFlush( dlg, flushall ) !DEC$ ATTRIBUTES DEFAULT :: DlgFlush type (dialog), intent(inout) :: dlg logical, intent(in), optional :: flushall integer i logical all ! ignore if the dialog box does not have a window if (dlg % hwnd .eq. 0) then return end if if (present(flushall)) then all = flushall else all = .false. end if ! ignore callbacks caused by internal writes dlg % mutexflush = .true. if (dlg % dirty .or. all) then dlg % dirty = .false. do i = 1, dlg % NumControls if (dlg % list(i) % dirty .or. all) then dlg % list(i) % dirty = .false. call Data2Dialog( dlg, i ) end if end do end if dlg % mutexflush = .false. end subroutine DlgFlush !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgWmCommand !! !! Turns WM_COMMAND messages into appropriate callback calls !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgWmCommand ( dlg, id, code, hwndControl ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgWmCommand type (dialog), intent(inout) :: dlg integer(INT_PTR), intent(in) :: id integer, intent(in) :: code integer(HANDLE), intent(in) :: hwndControl integer r integer(INT_PTR) :: i, j integer tabid ! supress compiler warning i = hwndControl i = id2index( dlg, id ) r = 0 ! ignore unsupported controls if (i .eq. 0 .and. id .eq. IDCANCEL .and. hwndControl .eq. 0) then call DefaultPushbuttonCallback(dlg,IDCANCEL,0) return ! Update SS 03-05-2025 else if(i.eq.0) then return ! End of Update end if ! if id == IDCANCEL, we treat it as if close button was pushed. ! Don't ignore it even if handle is 0. 09-16-2024 if (hwndControl .eq. 0_HANDLE .and. id .ne. IDCANCEL) then return endif ! ignore disabled scrollbar controls wrc 10-13-97 if(dlg % list(i) % control .eq. ctrl_scrollbar) then if(.not. dlg % list(i) % logvalue(1)) then return endif end if ! if the dialog is not running or if the message ! was caused by our own write then don't call the ! callback if ( id .eq. 0 .or. dlg % mutexflush ) then return endif select case (dlg % list(i) % control) case (ctrl_statictext) ! no callbacks case (ctrl_groupbox) ! no callbacks case (ctrl_pushbutton) ! 3 if (( code .eq. BN_CLICKED ) .and. dlg % list(i) % logvalue(1)) then call DlgDoCallback( dlg % list(i) % callbackvalue(1), & dlg, id, dlg_clicked ) r = 1 end if case (ctrl_checkbox) if ( code .eq. BN_CLICKED ) then call DlgDoCallback( dlg % list(i) % callbackvalue(1), & dlg, id, dlg_clicked ) r = 1 end if case (ctrl_radiobutton) if ( code .eq. BN_CLICKED ) then call DlgDoCallback( dlg % list(i) % callbackvalue(1), & dlg, id, dlg_clicked ) r = 1 end if case (ctrl_edit) if ( code .eq. EN_CHANGE ) then call DlgDoCallback( dlg % list(i) % callbackvalue(1), & dlg, id, dlg_change ) r = 1 else if (code .eq. EN_UPDATE ) then call DlgDoCallback( dlg % list(i) % callbackvalue(2), & dlg, id, dlg_update ) r = 1 else if (code .eq. EN_SETFOCUS ) then call DlgDoCallback( dlg % list(i) % callbackvalue(3), & dlg, id, dlg_gainfocus ) r = 1 else if (code .eq. EN_KILLFOCUS ) then call DlgDoCallback( dlg % list(i) % callbackvalue(4), & dlg, id, dlg_losefocus ) r = 1 end if case (ctrl_listbox) if ( code .eq. LBN_SELCHANGE ) then call DlgDoCallback( dlg % list(i) % callbackvalue(1), & dlg, id, dlg_selchange ) r = 1 else if (code .eq. LBN_DBLCLK ) then call DlgDoCallback( dlg % list(i) % callbackvalue(2), & dlg, id, dlg_dblclick ) r = 1 end if case (ctrl_combobox) if ( code .eq. CBN_SELCHANGE ) then dlg % comboupdate = .false. call DlgDoCallback( dlg % list(i) % callbackvalue(1), & dlg, id, dlg_selchange ) dlg % comboupdate = .true. r = 1 else if (code .eq. CBN_DBLCLK ) then call DlgDoCallback( dlg % list(i) % callbackvalue(2), & dlg, id, dlg_dblclick ) r = 1 else if (code .eq. CBN_EDITUPDATE ) then call DlgDoCallback( dlg % list(i) % callbackvalue(3), & dlg, id, dlg_update ) r = 1 else if (code .eq. CBN_EDITCHANGE ) then call DlgDoCallback( dlg % list(i) % callbackvalue(4), & dlg, id, dlg_change ) r = 1 else if (code .eq. CBN_SETFOCUS ) then call DlgDoCallback( dlg % list(i) % callbackvalue(5), & dlg, id, dlg_gainfocus ) r = 1 else if (code .eq. CBN_KILLFOCUS ) then call DlgDoCallback( dlg % list(i) % callbackvalue(6), & dlg, id, dlg_losefocus ) r = 1 end if case (ctrl_droplist) if ( code .eq. CBN_SELCHANGE ) then call DlgDoCallback( dlg % list(i) % callbackvalue(1), & dlg, id, dlg_selchange ) r = 1 else if (code .eq. CBN_DBLCLK ) then call DlgDoCallback( dlg % list(i) % callbackvalue(2), & dlg, id, dlg_dblclick ) r = 1 end if case (ctrl_tab) if ( code .eq. TCN_SELCHANGING ) then j = DlgSendMessage( hwndControl, TCM_GETCURSEL, 0, 0 ) if ( j .eq. -1 ) j=0 dlg % list(i) % charvalue(1) = dlg % list(i) % charvalue(j+2) dlg % list(i) % intvalue(2) = j+1 call DlgDoCallback( dlg % list(i) % callbackvalue(2), & dlg, id, dlg_selchanging ) ! Unmap the child dialog tabid = dlg % list(i) % intvalue(j+3) if (tabid /= 0) then call DlgTabShow( hwndControl, tabid, .FALSE. ) end if r = 0 ! 0 return value allows the selection to change... else if ( code .eq. TCN_SELCHANGE ) then j = DlgSendMessage( hwndControl, TCM_GETCURSEL, 0, 0 ) if ( j .eq. -1 ) j=0 dlg % list(i) % charvalue(1) = dlg % list(i) % charvalue(j+2) dlg % list(i) % intvalue(2) = j+1 ! Map the new child dialog tabid = dlg % list(i) % intvalue(j+3) if (tabid /= 0) then call DlgTabShow( hwndControl, tabid, .TRUE. ) end if call DlgDoCallback( dlg % list(i) % callbackvalue(1), & dlg, id, dlg_selchange ) r = 1 end if case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select if (r .eq. 1) call DlgFlush( dlg ) end function DlgWmCommand !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgWmScroll !! !! Turn scrolling messages into appropriate callbacks !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgWmScroll( dlg, hwndScroll, code, pos ) !DEC$ ATTRIBUTES DEFAULT :: DlgWmScroll type (dialog), intent(inout) :: dlg integer(INT_PTR), intent(in) :: code integer, intent(in) :: pos integer(HANDLE), intent(in) :: hwndScroll integer(INT_PTR) i, id, dummyi id = DlgHwnd2Id(hwndScroll) i = Id2Index( dlg, id ) ! ignore unsupported controls if (i .eq. 0) return ! ignore disabled controls wrc 10-13-97 if(.not. dlg % list(i) % logvalue(1)) return if ( dlg % mutexflush ) return select case(code) case (SB_LINEUP) dlg % list(i) % intvalue(1) & = dlg % list(i) % intvalue(1) - dlg % list(i) % intvalue(3) case (SB_LINEDOWN) dlg % list(i) % intvalue(1) & = dlg % list(i) % intvalue(1) + dlg % list(i) % intvalue(3) case (SB_PAGEUP) dlg % list(i) % intvalue(1) & = dlg % list(i) % intvalue(1) - dlg % list(i) % intvalue(4) case (SB_PAGEDOWN) dlg % list(i) % intvalue(1) & = dlg % list(i) % intvalue(1) + dlg % list(i) % intvalue(4) case (SB_THUMBPOSITION) dlg % list(i) % intvalue(1) = pos case (SB_THUMBTRACK) dlg % list(i) % intvalue(1) = pos case (SB_TOP) dlg % list(i) % intvalue(1) = 1 case (SB_BOTTOM) dlg % list(i) % intvalue(1) = dlg % list(i) % intvalue(2) case default return end select ! position can never slide below the minimum range if ( dlg % list(i) % intvalue(1) < dlg % list(i) % intvalue(5) ) then dlg % list(i) % intvalue(1) = dlg % list(i) % intvalue(5) end if ! position can never slide above maximum range if ( dlg % list(i) % intvalue(1) > dlg % list(i) % intvalue(2) ) then dlg % list(i) % intvalue(1) = dlg % list(i) % intvalue(2) end if if(dlg % list(i) % control .eq. ctrl_scrollbar) then dummyi = DlgSendMessage( hwndScroll, SBM_SETPOS, dlg % list(i) % intvalue(1), 1 ) end if call DlgDoCallback( dlg % list(i) % callbackvalue(1), dlg, id, dlg_change ) call DlgFlush( dlg ) end subroutine DlgWmScroll !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgModalProc !! !! This is the main dialog procedure for modal dialog boxes. !! Modal dialog messages are handled here. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgModalProc( hwnd, msg, wparam, lparam ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgModalProc !DEC$ ATTRIBUTES STDCALL, DECORATE, ALIAS:"IFLOGM_mp_DLGMODALPROC" :: DlgModalProc use user32 integer(HANDLE), intent(in) :: hwnd integer(UINT), intent(in) :: msg integer(fWPARAM), intent(in) :: wparam integer(fLPARAM), intent(in) :: lparam integer(INT_PTR) :: r integer(LRESULT) :: status type (DialogExtraBytes) :: dlgextrabytes POINTER (pex, dlgextrabytes) type (dialog), target :: dlg POINTER (p, dlg) pex = GetWindowLongPtr( hwnd, DWLP_USER ) ! WM_INITDIALOG: if ( msg .eq. WM_INITDIALOG ) then pex = lparam status = SetWindowLongPtr( hwnd, DWLP_USER, pex ) endif ! WM_NOTIFYFORMAT: if (msg .eq. WM_NOTIFYFORMAT) then status = SetWindowLongPtr( hwnd, DWLP_MSGRESULT, NFR_ANSI ) r = 1 return end if ! If this message is before WM_INITDIALOG, don't process it. ! NOTE: This ignores some messages which may be of interest to the user. ! For example, the initial WM_SIZE message, or the EN_CHANGED ! message when a spin button sets its Edit control "buddy" ! to its initial value. if ( pex .eq. NULLPTR ) then r = FALSE return end if r = -11 if ( pex .ne. NULLPTR ) then p = dlgextrabytes % Dlg r = DlgCommonProc( dlg, .TRUE., hwnd, msg, wparam, lparam ) endif end function DlgModalProc !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgModelessProc !! !! This is the main dialog proc for modeless dialog boxes. !! All modeless dialog messages are handled here. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgModelessProc ( hwnd, msg, wparam, lparam ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgModelessProc !DEC$ ATTRIBUTES STDCALL, DECORATE, ALIAS:"IFLOGM_mp_DLGMODLESSPROC" :: DlgModelessProc use user32 integer(HANDLE), intent(in) :: hwnd integer(UINT), intent(in) :: msg integer(fWPARAM), intent(in) :: wparam integer(fLPARAM), intent(in) :: lparam integer(INT_PTR) :: r integer(LRESULT) status type (DialogExtraBytes) :: dlgextrabytes type (dialog) :: dlg POINTER (p, dlg) POINTER (pex, dlgextrabytes) pex = GetWindowLongPtr( hwnd, DWLP_USER ) ! WM_INITDIALOG: if (msg .eq. WM_INITDIALOG) then pex = lparam status = SetWindowLongPtr( hwnd, DWLP_USER, pex ) ! WM_NOTIFYFORMAT: else if (msg .eq. WM_NOTIFYFORMAT) then status = SetWindowLongPtr( hwnd, DWLP_MSGRESULT, NFR_ANSI ) r = 1 return end if ! If this message is before WM_INITDIALOG, don't process it. ! NOTE: This ignores some messages which may be of interest to the user. ! For example, the initial WM_SIZE message, or the EN_CHANGED ! message when a spin button sets its Edit control "buddy" ! to its initial value. if (pex .eq. NULLPTR) then r = FALSE return end if p = dlgextrabytes % Dlg if (msg .eq. WM_ACTIVATE) then ! Keep track of the active modeless dialog window handle for DlgIsDlgMessage if (wparam .eq. 0) then g_dlghwnd = 0_HANDLE else g_dlghwnd = dlg % hwnd end if end if r = DlgCommonProc( dlg, .FALSE., hwnd, msg, wparam, lparam ) end function DlgModelessProc !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgCommonProc !! !! This is the common dialog proc. All dialog messages !! which are not modal/modeless specific are handled here. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgCommonProc ( dlg, modal, hwnd, msg, wparam, lparam ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgCommonProc type (dialog), intent(inout), target :: dlg logical, intent(in) :: modal[VALUE] integer(HANDLE), intent(in) :: hwnd[VALUE] integer(UINT), intent(in) :: msg[VALUE] integer(fWPARAM), intent(in) :: wparam[VALUE] integer(fLPARAM), intent(in) :: lparam[VALUE] integer i integer r integer*2 int_2 type (dialog), pointer :: dlgSave type (T_NMHDR) nmhdr POINTER (p_nmhdr, nmhdr) ! save pointer to allow single thread re-entrancy dlgSave => g_dlgcurrentmsg g_dlgcurrentmsg => dlg ! WM_INITDIALOG: if (msg .eq. WM_INITDIALOG) then dlg % hwnd = hwnd ! If the dialog box contains an ActiveX control, apply ! any event handlers which have been added. if ( dlg % list(dlg%NumControls+1) % dirty) then do i = 1, dlg % NumControls if ( dlg % list(i) % control .eq. ctrl_activex ) then CALL DlgSetAXControlInfo( dlg % hwnd, & dlg % list(i) % id, & dlg % list(i) % callbackvalue(1) ) end if end do end if ! Call DlgExecuteDLGINIT to process the RT_DLGINIT ! resource. This handles initial data in combo and list boxes call DlgExecuteDLGINIT( & dlg, & dlg % dlgid, & dlg % list(dlg%NumControls+1) % intvalue( & dlg % list(dlg%NumControls+1) % id)) ! If the program called DlgSetTitle, set the title if ( dlg % list(dlg%NumControls+1) % vartextptr .ne. 0) then call VarTextSendSetMessage( dlg % hwnd, & dlg % list(dlg%NumControls+1) % vartextptr ) end if ! Write all of the data values to the dialog box call DlgFlush( dlg, .true. ) call DlgDoCallback( dlg % dlginitcallback, dlg, dlg % dlgid, dlg_init ) call DlgFlush( dlg ) r = 1 ! WM_COMMAND: else if (msg .eq. WM_COMMAND) then ! wparam is 64 bits. Bottom 32 is id of control ! Shift left to get operation as 16 bit integer int_2 = iand(ishft(wparam,-16), Z"ffff") r = DlgWmCommand( dlg, iand(wparam, Z"ffff"), zext(int_2), lparam ) ! WM_NOTIFY: else if (msg .eq. WM_NOTIFY) then p_nmhdr = lparam r = DlgWmCommand( dlg, nmhdr % idFrom, nmhdr % code, nmhdr % hwndFrom) ! WM_?SCROLL: else if (msg .eq. WM_HSCROLL .or. msg .eq. WM_VSCROLL) then int_2 = iand(ishft(wparam,-16), Z"ffff") call DlgWmScroll( dlg, lparam, iand(wparam, Z"ffff"), zext(int_2) ) r = 1 ! WM_DESTROY: else if (msg .eq. WM_DESTROY) then if (.NOT. modal) then ! save data from controls do i = 1, dlg % NumControls call Dialog2Data( dlg, i ) end do end if call DlgDoCallback( dlg % dlginitcallback, dlg, dlg % dlgid, dlg_destroy ) if (.NOT. modal) then dlg % hwnd = 0 end if r = 1 ! WM_SIZE: else if (msg .eq. WM_SIZE .and. & (wparam .eq. SIZE_RESTORED .or. & wparam .eq. SIZE_MAXIMIZED .or. & wparam .eq. SIZE_MINIMIZED)) then call DlgDoCallback( dlg % list(dlg%NumControls+1) % callbackvalue(1), & dlg, dlg % dlgid, dlg_sizechange ) r = 1 else r = 0 end if g_dlgcurrentmsg => dlgSave end function DlgCommonProc !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgModal !! PUBLIC ROUTINE !! !! Bring up a modal dialog !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgModal ( dlg ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgModal type (dialog), intent(inout) :: dlg integer r integer(HANDLE) hwndParent hwndParent = NULLPTR r = DlgModalWithParent( dlg, hwndParent ) end function DlgModal !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgModalWithParent !! PUBLIC ROUTINE !! !! Bring up a modal dialog !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgModalWithParent ( dlg, hwndParent ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgModalWithParent !from ifqwin.f90, code is in libifcoremt.lib INTEGER(UINT_PTR), PARAMETER :: QWIN$FRAMEWINDOW = Z"80000000" INTERFACE FUNCTION GETHWNDQQ(IUNIT) use iflogmt !use compiler default calling method !DEC$ ATTRIBUTES DEFAULT, REFERENCE, DECORATE, ALIAS:"GETHWNDQQ" :: GETHWNDQQ INTEGER(HANDLE) GETHWNDQQ, IUNIT END FUNCTION END INTERFACE type (dialog), target, intent(inout) :: dlg integer(HANDLE) hwndParent integer r type (dialog), pointer :: dlgSave ! save pointer to allow single thread re-entrancy dlgSave => g_dlgmodal g_dlgmodal => dlg ! make dlg global for DlgProc ! choose the parent window if not specified if ( hwndParent .eq. NULLPTR) then if ( associated(dlgSave) ) then ! we are in a nested modal dialog so the parent is the previous dialog hwndParent = dlgSave % hwnd else if ( associated(g_dlgcurrentmsg) ) then ! we are in a nested dialog so the parent is the previous dialog hwndParent = g_dlgcurrentmsg % hwnd else hwndParent = GetHwndQQ(QWIN$FRAMEWINDOW) end if end if if ( DlgDoModal ( & dlg, & dlg % dlgid, & dlg % list(dlg%NumControls+1) % intvalue( & dlg % list(dlg%NumControls+1) % id), & hwndParent, & DlgModalProc, & dlg % list(dlg%NumControls+1) % dirty ) & .eq. -1 ) then r = -1 else r = dlg % retval end if g_dlgmodal => dlgSave end function DlgModalWithParent !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgSetReturn !! PUBLIC ROUTINE !! !! Change the return value of a dialog (usually called from !! within callbacks) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgSetReturn ( dlg, retval ) !DEC$ ATTRIBUTES DEFAULT :: DlgSetReturn type (dialog), intent(inout) :: dlg integer retval dlg % retval = retval end subroutine DlgSetReturn !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgExit !! PUBLIC ROUTINE !! !! Terminate the dialog. For a modal dialog, this should !! only be called from within a callback. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgExit( dlg ) !DEC$ ATTRIBUTES DEFAULT :: DlgExit use user32 type (dialog), intent(inout) :: dlg integer i type (DialogExtraBytes) :: dlgextrabytes POINTER (pex, dlgextrabytes) if (dlg % hwnd .eq. 0) then return end if pex = GetWindowLongPtr( dlg % hwnd, DWLP_USER ) if (pex .ne. NULLPTR) then if ( dlgextrabytes % DlgModal ) then ! save data from controls do i = 1, dlg % NumControls call Dialog2Data( dlg, i ) end do end if end if g_dlghwnd = 0_HANDLE call DlgEndDialog ( dlg % hwnd, dlg % retval ) dlg % hwnd = 0 end subroutine DlgExit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgModeless !! PUBLIC ROUTINE !! !! Bring up a modeless dialog !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgModeless ( dlg, nCmdShow, hwndParent ) result (log) !DEC$ ATTRIBUTES DEFAULT :: DlgModeless !from ifqwin.f90 - code is from libifcoremt.lib INTEGER(UINT_PTR), PARAMETER :: QWIN$FRAMEWINDOW = Z"80000000" INTERFACE FUNCTION GETHWNDQQ(IUNIT) !Use compiler default !DEC$ ATTRIBUTES DEFAULT, REFERENCE, DECORATE, ALIAS:"GETHWNDQQ" :: GETHWNDQQ use ifwinty INTEGER(HANDLE) GETHWNDQQ, IUNIT END FUNCTION END INTERFACE type (dialog), target, intent(inout) :: dlg integer, optional :: nCmdShow integer(HANDLE), optional :: hwndParent logical log integer cmdShow integer(HANDLE) hParent if ( .NOT. present(hwndParent) ) then if ( associated(g_dlgcurrentmsg) ) then ! we are in a nested dialog so the parent is the previous dialog hParent = g_dlgcurrentmsg % hwnd else hParent = GetHwndQQ(QWIN$FRAMEWINDOW) end if else hParent = hwndParent end if if ( .NOT. present(nCmdShow) ) then cmdShow = SW_NORMAL else cmdShow = nCmdShow end if if ( DlgDoModeless ( & dlg, & dlg % dlgid, & dlg % list(dlg%NumControls+1) % intvalue( & dlg % list(dlg%NumControls+1) % id), & hParent, cmdShow, DlgModelessProc, & dlg % list(dlg%NumControls+1) % dirty ) & .eq. -1 ) then log = .FALSE. else log = .TRUE. end if end function DlgModeless !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgIsDlgMessage !! PUBLIC ROUTINE !! !! Call IsDlgMessage for the active modeless dialog box !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgIsDlgMessage ( lpMsg ) result (log) !DEC$ ATTRIBUTES DEFAULT :: DlgIsDlgMessage type (T_MSG) lpMsg logical log if ( g_dlghwnd .ne. 0_HANDLE) then log = DlgIsDialogMessage(g_dlghwnd, lpMsg) else log = .FALSE. end if end function DlgIsDlgMessage !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgIsDlgMessageWithDlg !! PUBLIC ROUTINE !! !! Call IsDlgMessage for the specified modeless dialog box !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgIsDlgMessageWithDlg ( lpMsg, dlg ) result (l) !DEC$ ATTRIBUTES DEFAULT :: DlgIsDlgMessageWithDlg type (T_MSG) lpMsg type (DIALOG) dlg logical l l = DlgIsDialogMessage(dlg % hwnd, lpMsg) end function DlgIsDlgMessageWithDlg !DEC$ IF defined(DEBUG) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgDumpCtrl !! !! Displays the ControlType structure !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgDumpCtrl ( unit, ctrl ) !DEC$ ATTRIBUTES DEFAULT :: DlgDumpCtrl integer unit type (ControlType), intent(inout) :: ctrl integer i write (unit,*) 'Control =',ctrl % control write (unit,*) 'Id =',ctrl % id write (unit,*) 'Dirty =',ctrl % dirty write (unit,*) 'Duplicate =',ctrl % duplicate write (unit,*) 'IntSize =',ctrl % intsize write (unit,'(1X,A15,\)') 'intvalues: ' do i=1,ctrl % intsize write (unit,'(1X,I5,\)') ctrl % intvalue(i) end do write (unit,'(/)') write (unit,*) 'LogSize =',ctrl % logsize write (unit,'(1X,A15,\)') 'logvalues: ' do i=1,ctrl % logsize write (unit,'(1X,L5,\)') ctrl % logvalue(i) end do write (unit,'(/)') write (unit,*) 'CharSize =',ctrl % charsize write (unit,'(1X,A15,\)') 'charvalues: ' do i=1,ctrl % charsize write (unit,'(1X,A15,\)') ctrl % charvalue(i) end do write (unit,'(/)') write (unit,*) 'CallBackSize =',ctrl % callbacksize write (unit,'(1X,A15,\)') 'callbackvalues: ' do i=1,ctrl % callbacksize write (unit,'(1X,I10,\)') ctrl % callbackvalue(i) end do write (unit,'(/)') end subroutine DlgDumpCtrl !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgDump !! !! Displays the dialog structure !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgDump ( unit, dlg ) !DEC$ ATTRIBUTES DEFAULT :: DlgDump integer unit type (dialog), intent(inout) :: dlg integer i write (unit,*) '--- dlg begin dump ---' write (unit,*) 'DlgId =',dlg % dlgid write (unit,*) 'hwnd =',dlg % hwnd write (unit,*) 'retval =',dlg % retval write (unit,*) 'dirty =',dlg % dirty write (unit,*) 'mutexflush =',dlg % mutexflush write (unit,*) 'comboupdate =',dlg % comboupdate write (unit,*) 'numcontrols =',dlg % numcontrols do i=1,dlg % numcontrols call DlgDumpCtrl( unit, dlg % list(i) ) end do write (unit,*) '--- dlg end dump ---' end subroutine DlgDump !DEC$ ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgUninit !! PUBLIC ROUTINE !! !! Free any allocated dialog resources. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgUninit ( dlg ) !DEC$ ATTRIBUTES DEFAULT :: DlgUninit type (dialog), intent(inout) :: dlg interface subroutine OleUninitialize( ) !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS : "OleUninitialize" :: OleUninitialize end subroutine OleUninitialize end interface POINTER(OleUninitialize_PTR, OleUninitialize) ! routine pointer integer dllhInst logical lret integer i ! Free Control resources do i = 1, dlg % NumControls if ( .not. dlg % list(i) % intsize .eq. 0 ) then deallocate( dlg % list(i) % intvalue ) end if if ( .not. dlg % list(i) % logsize .eq. 0 ) then deallocate( dlg % list(i) % logvalue ) end if if ( .not. dlg % list(i) % charsize .eq. 0 ) then deallocate( dlg % list(i) % charvalue ) end if if ( .not. dlg % list(i) % callbacksize .eq. 0 ) then if ( dlg % list(i) % control .eq. ctrl_activex ) then CALL DlgDeallocateEventHandlerList( & dlg % list(i) % callbackvalue(1) ) end if deallocate( dlg % list(i) % callbackvalue ) end if if ( .not. dlg % list(i) % vartextptr .eq. 0 ) then call VarTextFree( dlg % list(i) % vartextptr ) end if end do ! Free the Dialog entry resources i = dlg%NumControls+1 if ( .not. dlg % list(i) % callbacksize .eq. 0 ) then deallocate( dlg % list(i) % callbackvalue ) end if if ( .not. dlg % list(i) % vartextptr .eq. 0 ) then call VarTextFree( dlg % list(i) % vartextptr ) end if !DEC$ IF defined(DEBUG) ! Do we need to call OleUninitialize? ! NOTE: This causes a problem if the application does not call ! ComInitialize and DlgUninit is called from a callback. ! In that case, IFDLGnnn.DLL gets unmapped and the ! program aborts when it unwinds to code that is no longer ! there. if (dlg % list(i) % duplicate) then dllhInst = LoadLibrary("ole32.dll"C) if (dllhInst .ne. NULLPTR) then OleUninitialize_PTR = GetProcAddress(dllhInst, "OleUninitialize"C) if (OleUninitialize_PTR .ne. NULLPTR) then !call COMUNINITIALIZE() call OleUninitialize() end if lret = FreeLibrary(dllhInst) end if end if !DEC$ ENDIF ! Free the entire control list deallocate( dlg % list ) end subroutine DlgUninit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! ChangeNumItems !! !! Change the elements in a listbox, combobox, or tab control !! to reflect the new size. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine ChangeNumItems( control, newsize ) !DEC$ ATTRIBUTES DEFAULT :: ChangeNumItems type (ControlType), intent(inout) :: control integer, intent(in) :: newsize !number of elements in new listbox character*(STRSZ), pointer, dimension(:) :: charvalue integer(UINT_PTR), pointer, dimension(:) :: intvalue integer i, lesser ! assert that control is of type listbox, combobox, droplist, or tab !DEC$ IF defined(DEBUG) if (control%control .ne. ctrl_listbox .and. & control%control .ne. ctrl_combobox .and. & control%control .ne. ctrl_droplist .and. & control%control .ne. ctrl_tab) then stop "assert in module dialogm" end if !DEC$ ENDIF allocate( charvalue(newsize+1) ) lesser = min( newsize+1, control%charsize ) do i = 1, lesser charvalue(i) = control % charvalue(i) enddo do i = lesser+1, newsize+1 charvalue(i) = "" end do deallocate( control%charvalue ) allocate( control%charvalue(newsize+1) ) control % charsize = newsize+1 do i = 1, control % charsize control % charvalue(i) = charvalue(i) end do deallocate( charvalue ) end subroutine ChangeNumItems !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! ChangeListboxItems !! !! Changes the size of a listbox. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine ChangeListboxItems( control, newsize ) !DEC$ ATTRIBUTES DEFAULT :: ChangeListboxItems type (ControlType), intent(inout) :: control integer, intent(in) :: newsize !number of elements in new listbox integer i ! assert that control is of type listbox !DEC$ IF defined(DEBUG) if (control%control .ne. ctrl_listbox) then stop "assert in module dialogm" end if !DEC$ ENDIF call ChangeNumItems( control, newsize ) control%charvalue(1) = "" ! Reset the selection deallocate( control%intvalue ) control%intsize = newsize+2 allocate( control%intvalue(newsize+2) ) control%intvalue(1) = newsize ! control%intvalue(2) = 0 ! Terminate the selection list do i = 1, newsize+2 control%intvalue(i) = 0 end do end subroutine ChangeListboxItems !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! ChangeTabItems !! !! Changes the size of a tab control. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine ChangeTabItems( dlg, control, newsize ) !DEC$ ATTRIBUTES DEFAULT :: ChangeTabItems type (dialog), intent(inout), target :: dlg type (ControlType), intent(inout) :: control integer, intent(in) :: newsize !number of elements in new listbox integer, pointer, dimension(:) :: intvalue integer i, lesser, state, tabid integer(HANDLE) hwndControl ! assert that control is of type tab !DEC$ IF defined(DEBUG) if (control%control .ne. ctrl_tab) then stop "assert in module dialogm" end if !DEC$ ENDIF ! save the current dlg_state state = control % intvalue(2) if (state > newsize) then state = 1 end if ! handle the tab text call ChangeNumItems( control, newsize ) ! handle the child dialog ids allocate( intvalue(newsize+2) ) lesser = min( newsize+2, control%intsize ) intvalue(1) = newsize intvalue(2) = state do i = 3, lesser intvalue(i) = control % intvalue(i) enddo do i = lesser+1, newsize+2 intvalue(i) = 0 end do ! Ensure that any deleted tab dialogs are unmapped if ( dlg%hwnd /= 0 ) then hwndControl = DlgID2Hwnd( dlg%hwnd, control%id ) if ( hwndControl /= 0 ) then do i = newsize+2, control%intsize tabid = control % intvalue(i) if (tabid /= 0) then call DlgTabShow( hwndControl, tabid, .FALSE. ) end if end do end if end if deallocate( control%intvalue ) allocate( control%intvalue(newsize+2) ) control % intsize = newsize+2 do i = 1, control % intsize control % intvalue(i) = intvalue(i) end do if (control % intvalue(1) .eq. 0) then control % charvalue(1) = "" else control % charvalue(1) = control % charvalue(state + 1) end if deallocate( intvalue ) end subroutine ChangeTabItems !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgGetTabChild !! !! Find the DIALOG structure of a child window given !! the Dialog ID !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgGetTabChild ( hwndTab, childID, childDlg ) result (l) !DEC$ ATTRIBUTES DEFAULT :: DlgGetTabChild use user32 integer(HANDLE), intent(in) :: hwndTab integer, intent(in) :: childID integer(UINT_PTR), intent(out) :: childDlg ! Pointer to DIALOG type logical l integer(HANDLE) hwndChild type (DialogExtraBytes) :: dlgextrabytes POINTER (pex, dlgextrabytes) type (dialog) :: dlg POINTER (p, dlg) l = .FALSE. hwndChild = GetWindow (hwndTab, GW_CHILD) do while (hwndChild /= 0) pex = GetWindowLongPtr( hwndChild, DWLP_USER ) if (pex /= NULLPTR) then p = dlgextrabytes % Dlg if (childID == dlg % dlgid) then childDlg = p l = .TRUE. return end if end if hwndChild = GetWindow (hwndChild, GW_HWNDNEXT) end do end function DlgGetTabChild !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgTabShow !! !! Show or hide a child dialog box of a Tab Control !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine DlgTabShow ( hwndTab, tabid, bShow ) !DEC$ ATTRIBUTES DEFAULT :: DlgTabShow use user32 integer(HANDLE), intent(in) :: hwndTab integer, intent(in) :: tabid logical, intent(in) :: bShow type (dialog) :: tabdlg POINTER (ptab, tabdlg) logical status type (T_RECT) :: rect integer i status = DlgGetTabChild ( hwndTab, tabid, pTab ) if (status) then if (bShow) then if ( IsWindowVisible ( tabdlg % hwnd ) == 0 ) then ! Ask the tab control for the position and size of its ! children status = GetClientRect( hwndTab, rect ) i = DlgSendMessage( hwndTab, TCM_ADJUSTRECT, 0, loc(rect) ) status = SetWindowPos( tabdlg % hwnd, HWND_TOP, & rect % left, rect % top, & rect % right - rect % left, rect % bottom - rect % top, & 0 ) status = ShowWindow( tabdlg % hwnd, SW_NORMAL ) end if else if ( IsWindowVisible ( tabdlg % hwnd ) /= 0 ) then status = ShowWindow( tabdlg % hwnd, SW_HIDE ) end if end if end if end subroutine DlgTabShow !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! ControlAddString !! !! Add a new string to a listbox or combobox !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine ControlAddString( control, newstr ) !DEC$ ATTRIBUTES DEFAULT :: ControlAddString type (ControlType), intent(inout) :: control character*(*), intent(in) :: newstr character*(STRSZ), pointer, dimension(:) :: charvalue integer i, newsize ! assert that control is of type listbox, combobox or droplist !DEC$ IF defined(DEBUG) if (control%control .ne. ctrl_listbox .and. & control%control .ne. ctrl_combobox .and. & control%control .ne. ctrl_droplist) then stop "assert in module dialogm" end if !DEC$ ENDIF newsize = control%charsize+1 allocate( charvalue(newsize) ) ! copy the current values do i = 1, control%charsize charvalue(i) = control % charvalue(i) end do charvalue(newsize) = newstr deallocate( control%charvalue ) control % charsize = newsize allocate( control%charvalue(newsize) ) do i = 1, control % charsize control % charvalue(i) = charvalue(i) end do deallocate( charvalue ) ! update the dlg_numItems count control % intvalue(1) = newsize - 1 end subroutine ControlAddString !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! ListAddString !! !! Add a new string to a listbox !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive subroutine ListAddString( control, newstr ) !DEC$ ATTRIBUTES DEFAULT :: ListAddString type (ControlType), intent(inout) :: control character*(*), intent(in) :: newstr integer(UINT_PTR), pointer, dimension(:) :: intvalue integer i, newsize ! assert that control is of type listbox !DEC$ IF defined(DEBUG) if (control%control .ne. ctrl_listbox) then stop "assert in module dialogm" end if !DEC$ ENDIF call ControlAddString( control, newstr ) newsize = control%intvalue(1) + 2 allocate( intvalue(newsize) ) ! copy the current values do i = 1, control%intsize intvalue(i) = control % intvalue(i) end do intvalue(newsize) = 0 deallocate( control%intvalue ) control % intsize = newsize allocate( control%intvalue(newsize) ) do i = 1, control % intsize control % intvalue(i) = intvalue(i) end do deallocate( intvalue ) end subroutine ListAddString !!! Control routines !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgSetInt !! PUBLIC ROUTINE !! !! Sets integer values of dialog controls. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgSetInt( dlg, controlid, value, index ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgSetInt type (dialog), intent(inout), target :: dlg integer, intent(in) :: controlid integer, intent(in) :: value integer, optional, intent(in) :: index logical r integer i, idx, i2 integer(INT_PTR) :: longcontrolid longcontrolid = controlid if ( present(index) ) then idx = index else idx = dlg_default end if i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then r = .false. return end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = .false. return end if if (.not. (dlg % hwnd .eq. 0) .and. .not. dlg % list(i) % dirty) then call Dialog2Data( dlg, i ) end if select case (dlg % list(i) % control) case (ctrl_statictext) r = .false. case (ctrl_groupbox) r = .false. case (ctrl_pushbutton) r = .false. case (ctrl_checkbox) r = .false. case (ctrl_radiobutton) r = .false. case (ctrl_edit) if ( idx .eq. dlg_textlength .or. idx .eq. dlg_default) then dlg % list(i) % intvalue(1) = value dlg % list(i) % vartextptr = & VarTextSetLength( dlg % list(i) % vartextptr, value ) if ( value < dlg % list(i) % intvalue(2)) then dlg % list(i) % intvalue(2) = value end if r = .true. else if ( idx .eq. dlg_position ) then dlg % list(i) % intvalue(2) = value r = .true. else r = .false. end if case (ctrl_scrollbar) if ( idx .eq. dlg_position .or. idx .eq. dlg_default) then dlg % list(i) % intvalue(1) = value r = .true. else if ( idx .eq. dlg_range ) then dlg % list(i) % intvalue(2) = value r = .true. else if ( idx .eq. dlg_smallstep ) then ! Ignore this, since there is no !dlg % list(i) % intvalue(3) = value ! way to change the value r = .true. ! It is always 1 else if ( idx .eq. dlg_bigstep ) then dlg % list(i) % intvalue(4) = value r = .true. else if ( idx .eq. dlg_rangemin ) then dlg % list(i) % intvalue(5) = value r = .true. else r = .false. end if case (ctrl_listbox) if (idx .eq. dlg_numitems .or. idx .eq. dlg_default) then call ChangeListboxItems( dlg % list(i), value) dlg % list(i) % intvalue(1) = value r = .true. else if (idx>0 .and. idx <= dlg % list(i) % intvalue(1)) then dlg % list(i) % intvalue(idx+1) = value r = .true. else r = .false. end if case (ctrl_combobox) if (idx .eq. dlg_numitems .or. idx .eq. dlg_default) then i2 = dlg % list(i) % intvalue(1) ! Current DLG_NUMITEMS call ChangeNumItems( dlg % list(i), value) if (value < i2) then ! If there are fewer new items, dlg % list(i) % charvalue(1) = "" ! clear the selection endif dlg % list(i) % intvalue(1) = value r = .true. else r = .false. end if case (ctrl_droplist) if (idx .eq. dlg_numitems .or. idx .eq. dlg_default) then i2 = dlg % list(i) % intvalue(1) ! Current DLG_NUMITEMS call ChangeNumItems( dlg % list(i), value) if (value < i2) then ! If there are fewer new items, dlg % list(i) % charvalue(1) = "" ! clear the selection else dlg % list(i) % logvalue(2) = .true.! Use string to set selection endif dlg % list(i) % intvalue(1) = value r = .true. else if (idx .eq. dlg_state) then dlg % list(i) % intvalue(2) = value dlg % list(i) % logvalue(2) = .false. if ( value > 0 .and. value <= dlg % list(i) % intvalue(1) ) then dlg % list(i) % charvalue(1) = dlg % list(i) % charvalue(value+1) else dlg % list(i) % charvalue(1) = "" end if r = .true. else r = .false. end if case (ctrl_spinner) if ( idx .eq. dlg_position .or. idx .eq. dlg_default) then dlg % list(i) % intvalue(1) = value r = .true. else if ( idx .eq. dlg_rangemax ) then dlg % list(i) % intvalue(2) = value r = .true. else if ( idx .eq. dlg_rangemin ) then dlg % list(i) % intvalue(5) = value r = .true. else r = .false. end if case (ctrl_slider) if ( idx .eq. dlg_position .or. idx .eq. dlg_default) then dlg % list(i) % intvalue(1) = value r = .true. else if ( idx .eq. dlg_range ) then dlg % list(i) % intvalue(2) = value r = .true. else if ( idx .eq. dlg_smallstep ) then dlg % list(i) % intvalue(3) = value r = .true. else if ( idx .eq. dlg_bigstep ) then dlg % list(i) % intvalue(4) = value r = .true. else if ( idx .eq. dlg_rangemin ) then dlg % list(i) % intvalue(5) = value r = .true. else if ( idx .eq. dlg_tickfreq ) then dlg % list(i) % intvalue(6) = value r = .true. else r = .false. end if case (ctrl_progress) if ( idx .eq. dlg_position .or. idx .eq. dlg_default) then dlg % list(i) % intvalue(1) = value r = .true. else if ( idx .eq. dlg_rangemax ) then dlg % list(i) % intvalue(2) = value r = .true. else if ( idx .eq. dlg_rangemin ) then dlg % list(i) % intvalue(3) = value r = .true. else r = .false. end if case (ctrl_tab) if (idx .eq. dlg_numitems .or. idx .eq. dlg_default) then call ChangeTabItems( dlg, dlg % list(i), value) dlg % list(i) % intvalue(1) = value r = .true. else if (idx .eq. dlg_state) then dlg % list(i) % intvalue(2) = value dlg % list(i) % logvalue(2) = .false. r = .true. else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then dlg % list(i) % intvalue(idx+2) = value r = .true. else r = .false. end if case (ctrl_activex) r = .false. case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select ! Note that the dialog needs to be updated dlg % dirty = .true. dlg % list(i) % dirty = .true. ! If this is not the currently active ! dialog box, update the dialog box fields if (.not. (dlg % hwnd .eq. 0) .and. & .not. (ASSOCIATED(g_dlgcurrentmsg, dlg)) ) then call DlgFlush( dlg ) end if end function DlgSetInt !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgSetLog !! PUBLIC ROUTINE !! !! Sets logical values of dialog controls. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgSetLog( dlg, controlid, in_value, index ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgSetLog type (dialog), intent(inout), target :: dlg integer, intent(in) :: controlid logical, intent(in) :: in_value integer, optional, intent(in) :: index logical r integer i, i2, idx logical value integer(INT_PTR) :: longcontrolid longcontrolid = controlid i = in_value i = i .and. 1 value = .true. if (i .eq. 0) value = .false. if ( present(index) ) then idx = index else idx = dlg_default end if i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then r = .false. return end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = .false. return end if if (.not. (dlg % hwnd .eq. 0) .and. .not. dlg % list(i) % dirty) then call Dialog2Data( dlg, i ) end if select case (dlg % list(i) % control) case (ctrl_statictext) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_groupbox) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_pushbutton) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_checkbox) if ( idx .eq. dlg_state .or. idx .eq. dlg_default) then dlg % list(i) % logvalue(2) = value r = .true. else if ( idx .eq. dlg_enable ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_radiobutton) if ( idx .eq. dlg_state .or. idx .eq. dlg_default) then ! set all buttons in the group to false do i2 = dlg % list(i) % intvalue(1), dlg % list(i) % intvalue(2) if ( dlg % list(i2) % control .eq. ctrl_radiobutton ) then dlg % list(i2) % logvalue(2) = .false. dlg % list(i2) % dirty = .true. end if end do if ( value ) then dlg % list(i) % logvalue(2) = .true. else dlg % list(dlg % list(i) % intvalue(1)) % logvalue(2) = .true. end if r = .true. else if ( idx .eq. dlg_enable ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_edit) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_scrollbar) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_listbox) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_combobox) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_droplist) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_spinner) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_slider) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_progress) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_tab) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case (ctrl_activex) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then dlg % list(i) % logvalue(1) = value r = .true. else r = .false. end if case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select ! Note that the dialog needs to be updated dlg % dirty = .true. dlg % list(i) % dirty = .true. ! If this is not the currently active ! dialog box, update the dialog box fields if (.not. (dlg % hwnd .eq. 0) .and. & .not. (ASSOCIATED(g_dlgcurrentmsg, dlg)) ) then call DlgFlush( dlg ) end if end function DlgSetLog !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgSetChar !! PUBLIC ROUTINE !! !! Sets character values of dialog controls. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgSetChar( dlg, controlid, value, index ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgSetChar type (dialog), intent(inout), target :: dlg integer, intent(in) :: controlid character*(*), intent(in) :: value integer, optional, intent(in) :: index logical r integer i, idx, j, textlen logical l integer(INT_PTR) :: longcontrolid longcontrolid = controlid if ( present(index) ) then idx = index else idx = dlg_default end if i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then r = .false. return end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = .false. return end if if (.not. (dlg % hwnd .eq. 0) .and. .not. dlg % list(i) % dirty) then call Dialog2Data( dlg, i ) end if select case (dlg % list(i) % control) case (ctrl_statictext) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then dlg % list(i) % vartextptr = & VarTextSet(dlg % list(i) % vartextptr, value, textlen) r = .true. else r = .false. end if case (ctrl_groupbox) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then dlg % list(i) % vartextptr = & VarTextSet(dlg % list(i) % vartextptr, value, textlen) r = .true. else r = .false. end if case (ctrl_pushbutton) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then dlg % list(i) % vartextptr = & VarTextSet(dlg % list(i) % vartextptr, value, textlen) r = .true. else r = .false. end if case (ctrl_checkbox) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then dlg % list(i) % vartextptr = & VarTextSet(dlg % list(i) % vartextptr, value, textlen) r = .true. else r = .false. end if case (ctrl_radiobutton) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then dlg % list(i) % vartextptr = & VarTextSet(dlg % list(i) % vartextptr, value, textlen) r = .true. else r = .false. end if case (ctrl_edit) if ( idx .eq. dlg_state .or. idx .eq. dlg_default ) then dlg % list(i) % vartextptr = & VarTextSet(dlg % list(i) % vartextptr, value, textlen) dlg % list(i) % intvalue(1) = textlen if ( textlen < dlg % list(i) % intvalue(2)) then dlg % list(i) % intvalue(2) = textlen end if r = .true. else r = .false. end if case (ctrl_scrollbar) r = .false. case (ctrl_listbox) if ( idx .eq. dlg_addstring ) then call ListAddString( dlg % list(i), value ) r = .true. else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then dlg % list(i) % charvalue(idx+1) = value r = .true. else r = .false. end if case (ctrl_combobox) if ( idx .eq. dlg_default .or. idx .eq. dlg_state) then dlg % list(i) % charvalue(1) = value r = .true. else if ( idx .eq. dlg_addstring ) then call ControlAddString( dlg % list(i), value ) r = .true. else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then dlg % list(i) % charvalue(idx+1) = value r = .true. else r = .false. end if case (ctrl_droplist) if ( idx .eq. dlg_default .or. idx .eq. dlg_state) then ! Determine if the string is one of the entries in the list l = .false. do j = 2, dlg % list(i) % intvalue(1) + 1 if (dlg % list(i) % charvalue(j) == value) then l = .true. exit end if end do if (l) then dlg % list(i) % charvalue(1) = value dlg % list(i) % logvalue(2) = .true. dlg % list(i) % intvalue(2) = j - 1 r = .true. else r = .false. end if else if ( idx .eq. dlg_addstring ) then call ControlAddString( dlg % list(i), value ) r = .true. else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then dlg % list(i) % charvalue(idx+1) = value r = .true. else r = .false. end if case (ctrl_spinner) r = .false. case (ctrl_slider) r = .false. case (ctrl_progress) r = .false. case (ctrl_tab) if ( idx .eq. dlg_default .or. idx .eq. dlg_state) then ! Determine if the string is one of the existing tabs l = .false. do j = 2, dlg % list(i) % intvalue(1) + 1 if (dlg % list(i) % charvalue(j) == value) then l = .true. exit end if end do if (l) then dlg % list(i) % charvalue(1) = value dlg % list(i) % logvalue(2) = .true. dlg % list(i) % intvalue(2) = j - 1 r = .true. else r = .false. end if else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then dlg % list(i) % charvalue(idx+1) = value r = .true. else r = .false. end if case (ctrl_activex) r = .false. case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select ! Note that the dialog needs to be updated dlg % dirty = .true. dlg % list(i) % dirty = .true. ! If this is not the currently active ! dialog box, update the dialog box fields if (.not. (dlg % hwnd .eq. 0) .and. & .not. (ASSOCIATED(g_dlgcurrentmsg, dlg)) ) then call DlgFlush( dlg ) end if end function DlgSetChar !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgSetSub !! PUBLIC ROUTINE !! !! Sets callback values of dialog controls. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgSetSub( dlg, controlid, value, index ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgSetSub type (dialog), intent(inout) :: dlg integer, intent(in) :: controlid external value integer, optional, intent(in) :: index logical r integer i, idx integer(INT_PTR) :: longcontrolid longcontrolid = controlid if ( present(index) ) then idx = index else idx = dlg_default end if i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then if (longcontrolid .eq. dlg % dlgid) then ! this is one of the callbacks supported by the dialog box if ( idx .eq. dlg_sizechange ) then i = dlg%NumControls+1 dlg % list(i) % callbackvalue(1) = loc(value) else dlg % dlginitcallback = loc(value) end if r = .true. return else r = .false. return end if end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = .false. return end if r = .false. ! don't let the user change these from within a dlgproc ! LPT - I don't see any need for this restriction !if (.not. dlg % hwnd .eq. 0) then ! return !end if select case (dlg % list(i) % control) case (ctrl_statictext) case (ctrl_groupbox) case (ctrl_pushbutton) if ( idx .eq. dlg_clicked .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. end if case (ctrl_checkbox) if ( idx .eq. dlg_clicked .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. end if case (ctrl_radiobutton) if ( idx .eq. dlg_clicked .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. end if case (ctrl_edit) if ( idx .eq. dlg_change .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. else if (idx .eq. dlg_update) then dlg % list(i) % callbackvalue(2) = loc(value) r = .true. else if (idx .eq. dlg_gainfocus) then dlg % list(i) % callbackvalue(3) = loc(value) r = .true. else if (idx .eq. dlg_losefocus) then dlg % list(i) % callbackvalue(4) = loc(value) r = .true. end if case (ctrl_scrollbar) if ( idx .eq. dlg_change .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. end if case (ctrl_listbox) if ( idx .eq. dlg_selchange .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. else if (idx .eq. dlg_dblclick) then dlg % list(i) % callbackvalue(2) = loc(value) r = .true. end if case (ctrl_combobox) if ( idx .eq. dlg_selchange .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. else if (idx .eq. dlg_dblclick) then dlg % list(i) % callbackvalue(2) = loc(value) r = .true. else if (idx .eq. dlg_update) then dlg % list(i) % callbackvalue(3) = loc(value) r = .true. else if (idx .eq. dlg_change) then dlg % list(i) % callbackvalue(4) = loc(value) r = .true. else if (idx .eq. dlg_gainfocus) then dlg % list(i) % callbackvalue(5) = loc(value) r = .true. else if (idx .eq. dlg_losefocus) then dlg % list(i) % callbackvalue(6) = loc(value) r = .true. end if case (ctrl_droplist) if ( idx .eq. dlg_selchange .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. else if (idx .eq. dlg_dblclick) then dlg % list(i) % callbackvalue(2) = loc(value) r = .true. end if case (ctrl_spinner) if ( idx .eq. dlg_change .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. end if case (ctrl_slider) if ( idx .eq. dlg_change .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. end if case (ctrl_tab) if ( idx .eq. dlg_selchange .or. idx .eq. dlg_default ) then dlg % list(i) % callbackvalue(1) = loc(value) r = .true. else if ( idx .eq. dlg_selchanging ) then dlg % list(i) % callbackvalue(2) = loc(value) r = .true. end if case (ctrl_activex) case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select end function DlgSetSub !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgSetTitle !! PUBLIC ROUTINE !! !! Sets the title of the dialog box !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine DlgSetTitle( dlg, title ) !DEC$ ATTRIBUTES DEFAULT :: DlgSetTitle type (dialog), intent(inout), target :: dlg character*(*), intent(in) :: title integer len dlg % list(dlg%NumControls+1) % vartextptr = & VarTextSet(dlg % list(dlg%NumControls+1) % vartextptr, title, len) if ( dlg % hwnd .ne. 0) then call VarTextSendSetMessage( dlg % hwnd, & dlg % list(dlg%NumControls+1) % vartextptr ) end if end subroutine DlgSetTitle !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgSetCtrlEventHandler !! PUBLIC ROUTINE !! !! Sets an event handler for an ActiveX control. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgSetCtrlEventHandler( dlg, controlid, & handler, dispid, iid ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgSetCtrlEventHandler type (dialog), intent(inout) :: dlg integer, intent(in) :: controlid external handler integer(INT_PTR), intent(in) :: dispid type(T_GUID), optional, intent(in) :: iid integer r integer, parameter :: ERROR_INVALID_PARAMETER = Z"80070057" integer i integer(INT_PTR) :: longcontrolid longcontrolid = controlid i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then r = ERROR_INVALID_PARAMETER return end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = ERROR_INVALID_PARAMETER return end if select case (dlg % list(i) % control) case (ctrl_activex) r = DlgAddEventHandler( dlg % hwnd, longcontrolid, & dlg % list(i) % callbackvalue(1), & iid, dispid, loc(handler) ) case default r = ERROR_INVALID_PARAMETER end select end function DlgSetCtrlEventHandler !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgGetInt !! PUBLIC ROUTINE !! !! Gets an integer value from a dialog control !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgGetInt( dlg, controlid, value, index ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgGetInt type (dialog), intent(inout) :: dlg integer, intent(in) :: controlid integer, intent(out) :: value integer, optional, intent(in) :: index logical r integer i, idx integer(INT_PTR) :: longcontrolid longcontrolid = controlid if ( present(index) ) then idx = index else idx = dlg_default end if i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then r = .false. return end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = .false. return end if if (.not. (dlg % hwnd .eq. 0) .and. .not. dlg % list(i) % dirty) then call Dialog2Data( dlg, i ) end if r = .false. select case (dlg % list(i) % control) case (ctrl_statictext) case (ctrl_groupbox) case (ctrl_pushbutton) case (ctrl_checkbox) case (ctrl_radiobutton) case (ctrl_edit) if ( idx .eq. dlg_textlength .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_position ) then value = dlg % list(i) % intvalue(2) r = .true. else r = .false. end if case (ctrl_scrollbar) if ( idx .eq. dlg_position .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_range ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx .eq. dlg_smallstep ) then value = dlg % list(i) % intvalue(3) r = .true. else if ( idx .eq. dlg_bigstep ) then value = dlg % list(i) % intvalue(4) r = .true. else if ( idx .eq. dlg_rangemin ) then value = dlg % list(i) % intvalue(5) r = .true. end if case (ctrl_listbox) if ( idx .eq. dlg_numitems .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then value = dlg % list(i) % intvalue(idx+1) r = .true. else if ( idx >= 1 ) then value = 0 r = .true. else r = .false. end if case (ctrl_combobox) if ( idx .eq. dlg_numitems .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else r = .false. end if case (ctrl_droplist) if ( idx .eq. dlg_numitems .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_state ) then value = dlg % list(i) % intvalue(2) r = .true. else r = .false. end if case (ctrl_spinner) if ( idx .eq. dlg_position .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_range ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx .eq. dlg_rangemin ) then value = dlg % list(i) % intvalue(5) r = .true. end if case (ctrl_slider) if ( idx .eq. dlg_position .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_range ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx .eq. dlg_smallstep ) then value = dlg % list(i) % intvalue(3) r = .true. else if ( idx .eq. dlg_bigstep ) then value = dlg % list(i) % intvalue(4) r = .true. else if ( idx .eq. dlg_rangemin ) then value = dlg % list(i) % intvalue(5) r = .true. else if ( idx .eq. dlg_tickfreq ) then value = dlg % list(i) % intvalue(6) r = .true. end if case (ctrl_progress) if ( idx .eq. dlg_position .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_range ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx .eq. dlg_rangemin ) then value = dlg % list(i) % intvalue(3) r = .true. end if case (ctrl_tab) if ( idx .eq. dlg_numitems .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_state ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then value = dlg % list(i) % intvalue(idx+2) r = .true. else r = .false. end if case (ctrl_activex) if ( idx .eq. dlg_idispatch .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. end if case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select end function DlgGetInt !SS #if defined( _M_IA64) || defined( _M_AMD64) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgGetInt64 !! PUBLIC ROUTINE !! !! Gets an integer value from a dialog control !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgGetInt64( dlg, controlid, value, index ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgGetInt64 type (dialog), intent(inout) :: dlg integer, intent(in) :: controlid integer(8), intent(out) :: value integer, optional, intent(in) :: index logical r integer i, idx integer(INT_PTR) :: longcontrolid longcontrolid = controlid if ( present(index) ) then idx = index else idx = dlg_default end if i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then r = .false. return end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = .false. return end if if (.not. (dlg % hwnd .eq. 0) .and. .not. dlg % list(i) % dirty) then call Dialog2Data( dlg, i ) end if r = .false. select case (dlg % list(i) % control) case (ctrl_statictext) case (ctrl_groupbox) case (ctrl_pushbutton) case (ctrl_checkbox) case (ctrl_radiobutton) case (ctrl_edit) if ( idx .eq. dlg_textlength .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_position ) then value = dlg % list(i) % intvalue(2) r = .true. else r = .false. end if case (ctrl_scrollbar) if ( idx .eq. dlg_position .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_range ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx .eq. dlg_smallstep ) then value = dlg % list(i) % intvalue(3) r = .true. else if ( idx .eq. dlg_bigstep ) then value = dlg % list(i) % intvalue(4) r = .true. else if ( idx .eq. dlg_rangemin ) then value = dlg % list(i) % intvalue(5) r = .true. end if case (ctrl_listbox) if ( idx .eq. dlg_numitems .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then value = dlg % list(i) % intvalue(idx+1) r = .true. else if ( idx >= 1 ) then value = 0 r = .true. else r = .false. end if case (ctrl_combobox) if ( idx .eq. dlg_numitems .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else r = .false. end if case (ctrl_droplist) if ( idx .eq. dlg_numitems .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_state ) then value = dlg % list(i) % intvalue(2) r = .true. else r = .false. end if case (ctrl_spinner) if ( idx .eq. dlg_position .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_range ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx .eq. dlg_rangemin ) then value = dlg % list(i) % intvalue(5) r = .true. end if case (ctrl_slider) if ( idx .eq. dlg_position .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_range ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx .eq. dlg_smallstep ) then value = dlg % list(i) % intvalue(3) r = .true. else if ( idx .eq. dlg_bigstep ) then value = dlg % list(i) % intvalue(4) r = .true. else if ( idx .eq. dlg_rangemin ) then value = dlg % list(i) % intvalue(5) r = .true. else if ( idx .eq. dlg_tickfreq ) then value = dlg % list(i) % intvalue(6) r = .true. end if case (ctrl_progress) if ( idx .eq. dlg_position .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_range ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx .eq. dlg_rangemin ) then value = dlg % list(i) % intvalue(3) r = .true. end if case (ctrl_tab) if ( idx .eq. dlg_numitems .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. else if ( idx .eq. dlg_state ) then value = dlg % list(i) % intvalue(2) r = .true. else if ( idx >= 1 .and. idx <= dlg % list(i) % intvalue(1) ) then value = dlg % list(i) % intvalue(idx+2) r = .true. else r = .false. end if case (ctrl_activex) if ( idx .eq. dlg_idispatch .or. idx .eq. dlg_default ) then value = dlg % list(i) % intvalue(1) r = .true. end if case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select end function DlgGetInt64 !SS #endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgGetLog !! PUBLIC ROUTINE !! !! Gets a logical value from a dialog control. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgGetLog( dlg, controlid, value, index ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgGetLog type (dialog), intent(inout) :: dlg integer, intent(in) :: controlid logical, intent(out) :: value integer, optional, intent(in) :: index logical r integer i, idx integer(INT_PTR) :: longcontrolid longcontrolid = controlid if ( present(index) ) then idx = index else idx = dlg_default end if i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then r = .false. return end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = .false. return end if if (.not. (dlg % hwnd .eq. 0) .and. .not. dlg % list(i) % dirty) then call Dialog2Data( dlg, i ) end if r = .false. select case (dlg % list(i) % control) case (ctrl_statictext) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_groupbox) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_pushbutton) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_checkbox) if ( idx .eq. dlg_state .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(2) r = .true. else if ( idx .eq. dlg_enable ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_radiobutton) if ( idx .eq. dlg_state .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(2) r = .true. else if ( idx .eq. dlg_enable ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_edit) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_scrollbar) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_listbox) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_combobox) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_droplist) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_spinner) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_slider) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_progress) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_tab) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case (ctrl_activex) if ( idx .eq. dlg_enable .or. idx .eq. dlg_default ) then value = dlg % list(i) % logvalue(1) r = .true. end if case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select end function DlgGetLog !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgGetChar !! PUBLIC ROUTINE !! !! Gets a character value from a dialog control. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgGetChar( dlg, controlid, value, index ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgGetChar type (dialog), intent(inout) :: dlg integer, intent(in) :: controlid character*(*), intent(out) :: value integer, optional, intent(in) :: index logical r integer i, idx, newlen integer(INT_PTR) :: longcontrolid longcontrolid = controlid if ( present(index) ) then idx = index else idx = dlg_default end if i = id2index( dlg, longcontrolid ) ! ignore unsupported controls if (i .eq. 0) then r = .false. return end if ! controls with duplicate ids are inaccessable if (dlg % list(i) % duplicate) then r = .false. return end if if (.not. (dlg % hwnd .eq. 0) .and. .not. dlg % list(i) % dirty) then call Dialog2Data( dlg, i ) end if r = .false. select case (dlg % list(i) % control) case (ctrl_statictext) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then newlen = VarTextGet(dlg % list(i) % vartextptr, value) r = .true. end if case (ctrl_groupbox) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then newlen = VarTextGet(dlg % list(i) % vartextptr, value) r = .true. end if r = .false. case (ctrl_pushbutton) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then newlen = VarTextGet(dlg % list(i) % vartextptr, value) r = .true. end if case (ctrl_checkbox) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then newlen = VarTextGet(dlg % list(i) % vartextptr, value) r = .true. end if case (ctrl_radiobutton) if ( idx .eq. dlg_title .or. idx .eq. dlg_default ) then newlen = VarTextGet(dlg % list(i) % vartextptr, value) r = .true. end if case (ctrl_edit) if ( idx .eq. dlg_state .or. idx .eq. dlg_default ) then newlen = VarTextGet(dlg % list(i) % vartextptr, value) r = .true. end if case (ctrl_scrollbar) r = .false. case (ctrl_listbox) if ( idx .eq. dlg_state .or. idx .eq. dlg_default ) then value = dlg % list(i) % charvalue(1) r = .true. else if ( idx>=1 .and. idx<= dlg % list(i) % intvalue(1) ) then value = dlg % list(i) % charvalue(idx+1) r = .true. end if case (ctrl_combobox) if ( idx .eq. dlg_state .or. idx .eq. dlg_default ) then value = dlg % list(i) % charvalue(1) r = .true. else if ( idx>=1 .and. idx<= dlg % list(i) % intvalue(1) ) then value = dlg % list(i) % charvalue(idx+1) r = .true. end if case (ctrl_droplist) if ( idx .eq. dlg_state .or. idx .eq. dlg_default ) then value = dlg % list(i) % charvalue(1) r = .true. else if ( idx>=1 .and. idx<= dlg % list(i) % intvalue(1) ) then value = dlg % list(i) % charvalue(idx+1) r = .true. end if case (ctrl_spinner) r = .false. case (ctrl_slider) r = .false. case (ctrl_progress) r = .false. case (ctrl_tab) if ( idx .eq. dlg_state .or. idx .eq. dlg_default ) then value = dlg % list(i) % charvalue(1) r = .true. else if ( idx>=1 .and. idx<= dlg % list(i) % intvalue(1) ) then value = dlg % list(i) % charvalue(idx+1) r = .true. end if case (ctrl_activex) r = .false. case default !DEC$ IF defined(DEBUG) stop "assert in module dialogm" !DEC$ ENDIF end select end function DlgGetChar ! NOTE: DlgGetSub does not make sense since an external value ! cannot be reassigned so this function is not implemented. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! DlgSendCtrlMessage !! PUBLIC ROUTINE !! !! Send a Windows message to a dialog control. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! recursive function DlgSendCtrlMessage( dlg, controlid, msg, wparam, lparam ) result (r) !DEC$ ATTRIBUTES DEFAULT :: DlgSendCtrlMessage type (dialog), intent(inout), target :: dlg integer, intent(in) :: controlid integer(UINT), intent(in) :: msg integer(fWPARAM), intent(in) :: wparam integer(fLPARAM), intent(in) :: lparam integer r integer(HANDLE) hwndControl integer(INT_PTR) :: longcontrolid longcontrolid = controlid r = .FALSE. if ( dlg%hwnd .eq. NULLPTR ) then return end if hwndControl = DlgID2Hwnd( dlg%hwnd, longcontrolid ) if ( hwndControl .eq. NULLPTR ) then return end if r = DlgSendMessage( hwndControl, msg, wparam, lparam ) end function DlgSendCtrlMessage end module iflogm