#DIM ALL
#COMPILE EXE
#OPTION VERSION4
#INCLUDE "WIN32API.INC"
#INCLUDE "COMMCTRL.INC"
#INCLUDE "IEWB2.INC"GLOBAL HtmlResult AS LONG
TYPE SAFEARRAYBOUND
cElements AS DWORD
lLbound AS LONG
END TYPE
DECLARE FUNCTION SafeArrayCreate LIB "OLEAUT32.DLL" ALIAS "SafeArrayCreate" (BYVAL vt AS WORD, BYVAL cDims AS DWORD, BYREF rgsabound AS SAFEARRAYBOUND) AS DWORD
DECLARE FUNCTION SafeArrayDestroy LIB "OLEAUT32.DLL" ALIAS "SafeArrayDestroy" (BYVAL psa AS DWORD) AS DWORD
DECLARE FUNCTION SafeArrayPutElement LIB "OLEAUT32.DLL" ALIAS "SafeArrayPutElement" (BYVAL psa AS DWORD, BYVAL rgIndices AS DWORD, BYVAL pv AS DWORD) AS DWORD
' ********************************************************************************************
' QueryInterface method
' ********************************************************************************************
' Returns a pointer to a specified interface on an object to which a client currently holds an
' interface pointer. You must release the returned interface, when no longer needed, with a call
' to the Release method.
' ********************************************************************************************
DECLARE FUNCTION Proto_HtmlQueryInterface (BYVAL pthis AS DWORD PTR, BYREF riid AS GUID, BYREF ppvObj AS DWORD) AS LONG
' ********************************************************************************************
FUNCTION HtmlQueryInterface (BYVAL pthis AS DWORD PTR, BYREF riid AS GUID) AS DWORD
LOCAL ppvObj AS DWORD
IF pthis = 0 THEN HtmlResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[0] USING Proto_WbQueryInterface(pthis, riid, ppvObj) TO HtmlResult
FUNCTION = ppvObj
END FUNCTION
' ********************************************************************************************
' ********************************************************************************************
' AddRef method
' ********************************************************************************************
' The AddRef method increments the reference count for an interface on an object. It should be
' called for every new copy of a pointer to an interface on a given object.
' ********************************************************************************************
FUNCTION HtmlAddRef (BYVAL pthis AS DWORD PTR) AS DWORD
LOCAL DWRESULT AS LONG
IF pthis = 0 THEN WbResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[1] USING HtmlAddRef(pthis) TO DWRESULT
FUNCTION = DWRESULT
END FUNCTION
' ********************************************************************************************
' ********************************************************************************************
' Release method
' ********************************************************************************************
' Decrements the reference count for the calling interface on a object. If the reference count
' on the object falls to 0, the object is freed from memory.
' ********************************************************************************************
FUNCTION HtmlRelease (BYVAL pthis AS DWORD PTR) AS DWORD
LOCAL DWRESULT AS DWORD
IF pthis = 0 THEN WbResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[2] USING HtmlRelease(pthis) TO DWRESULT
FUNCTION = DWRESULT
END FUNCTION
' ********************************************************************************************
' ****************************************************************************************
' write method
' Writes one or more HTML expressions to a document in the specified window.
' Parameter:
' psarray
' [in] BSTR that specifies the text and HTML tags to write.
' Note: This function expects that you pass an unicode string in a safearray of variants.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLDocument2_write ( _
BYVAL pthis AS DWORD PTR _ ' %VT_DISPATCH <dispinterface>
, ByVal psarray AS DWORD _ ' %VT_SAFEARRAY [in]
) AS LONG ' %VT_HRESULT <LONG>
' ****************************************************************************************
SUB IHTMLDocument2_write (BYVAL pthis AS DWORD PTR, ByVal strScript AS STRING)
LOCAL psarray AS DWORD, ix AS LONG, vScript AS VARIANT, rgsabound AS SAFEARRAYBOUND
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
' Create a safearray of variants of one element
rgsabound.lLBound = 0 : rgsabound.cElements = 1
psarray = SafeArrayCreate(%VT_VARIANT, 1, rgsabound)
IF ISFALSE psarray THEN HtmlResult = %E_POINTER : EXIT SUB
' Fill the safearray with the script
vScript = strScript : ix = 0
SafeArrayPutElement(psarray, BYVAL VARPTR(ix), BYVAL VARPTR(vScript))
' Do the call
CALL DWORD @@pthis[59] USING Proto_IHTMLDocument2_write(pthis, psarray) TO HtmlResult
' Destroy the safearray
SafeArrayDestroy psarray
END SUB
' ****************************************************************************************
' ****************************************************************************************
' writeln method
' Writes one or more HTML expressions, followed by a carriage return, to a document in the
' specified window.
' Parameters
' psarray
' [in] BSTR that specifies the text and HTML tags to write.
' Return Value
' Returns %S_OK if successful, or an error value otherwise.
' Remarks
' In HTML, the carriage return is ignored unless it occurs within preformatted text.
' Note: This function expects that you pass an unicode string in a safearray of variants.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLDocument2_writeln ( _
BYVAL pthis AS DWORD PTR _ ' %VT_DISPATCH <dispinterface>
, ByVal psarray AS DWORD _ ' %VT_SAFEARRAY [in]
) AS LONG ' %VT_HRESULT <LONG>
' ****************************************************************************************
SUB IHTMLDocument2_writeln (BYVAL pthis AS DWORD PTR, ByVal strScript AS STRING)
LOCAL psarray AS DWORD, ix AS LONG, vScript AS VARIANT, rgsabound AS SAFEARRAYBOUND
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
' Create a safearray of variants of one element
rgsabound.lLBound = 0 : rgsabound.cElements = 1
psarray = SafeArrayCreate(%VT_VARIANT, 1, rgsabound)
IF ISFALSE psarray THEN HtmlResult = %E_POINTER : EXIT SUB
' Fill the safearray with the script
vScript = strScript : ix = 0
SafeArrayPutElement(psarray, BYVAL VARPTR(ix), BYVAL VARPTR(vScript))
' Do the call
CALL DWORD @@pthis[60] USING Proto_IHTMLDocument2_writeln(pthis, psarray) TO HtmlResult
' Destroy the safearray
SafeArrayDestroy psarray
END SUB
' ****************************************************************************************
' ****************************************************************************************
' close method
' Closes an output stream and forces the sent data to display.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLDocument2_close (BYVAL pthis AS DWORD PTR) AS LONG
' ****************************************************************************************
SUB IHTMLDocument2_close (BYVAL pthis AS DWORD PTR)
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
CALL DWORD @@pthis[62] USING Proto_IHTMLDocument2_close (pthis) TO HtmlResult
END SUB
' ****************************************************************************************
' ****************************************************************************************
' [get_]innerHTML property
' Retrieves the HTML between the start and end tags of the object.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement_get_innerHTML (BYVAL pthis AS DWORD PTR, ByRef p AS STRING) AS LONG
' ****************************************************************************************
FUNCTION IHTMLElement_get_innerHTML (BYVAL pthis AS DWORD PTR) AS STRING
LOCAL p AS STRING
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[58] USING Proto_IHTMLElement_get_innerHTML(pthis, p) TO HtmlResult
FUNCTION = ACODE$(p)
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' [put_]innerHTML property
' Interface name = IHTMLElement
' VTable offset = 228
' DispID = -2147417086 [&H80010402]
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement_put_innerHTML (BYVAL pthis AS DWORD PTR, ByVal p AS DWORD) AS LONG
' ****************************************************************************************
SUB IHTMLElement_put_innerHTML (BYVAL pthis AS DWORD PTR, ByVal p AS STRING)
p = UCODE$(p)
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
CALL DWORD @@pthis[57] USING Proto_IHTMLElement_put_innerHTML(pthis, STRPTR(p)) TO HtmlResult
END SUB
' ****************************************************************************************
' ****************************************************************************************
' [get_]id property
' Retrieves the string identifying the object.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement_get_id (BYVAL pthis AS DWORD PTR, ByRef p AS STRING) AS LONG
' ****************************************************************************************
FUNCTION IHTMLElement_get_id (BYVAL pthis AS DWORD PTR) AS STRING
LOCAL p AS STRING
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[13] USING Proto_IHTMLElement_get_id(pthis, p) TO HtmlResult
FUNCTION = ACODE$(p)
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' [put_]id property
' Sets the string identifying the object.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement_put_id (BYVAL pthis AS DWORD PTR, BYVAL p AS DWORD) AS LONG
' ****************************************************************************************
SUB IHTMLElement_put_id (BYVAL pthis AS DWORD PTR, BYVAL p AS STRING)
p = UCODE$(p)
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
CALL DWORD @@pthis[12] USING Proto_IHTMLElement_put_id(pthis, STRPTR(p)) TO HtmlResult
END SUB
' ****************************************************************************************
' ****************************************************************************************
' getElementById method
' Returns a reference to the first object with the specified value of the ID attribute.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLDocument3_getElementById (BYVAL pthis AS DWORD PTR, ByVal v AS STRING PTR, ByRef pel AS DWORD) AS LONG
' ****************************************************************************************
FUNCTION IHTMLDocument3_getElementById (BYVAL pthis AS DWORD PTR, ByVal v AS STRING) AS DWORD
LOCAL pel AS DWORD
v = UCODE$(v)
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT FUNCTION
LOCAL HRESULT AS LONG
CALL DWORD @@pthis[46] USING Proto_IHTMLDocument3_getElementById(pthis, STRPTR(v), pel) TO HtmlResult
FUNCTION = pel
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' getAttribute method
' Retrieves the value of the specified attribute.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement_getAttribute (BYVAL pthis AS DWORD PTR, ByVal strAttributeName AS STRING PTR, ByVal lFlags AS LONG, ByRef AttributeValue AS VARIANT) AS LONG
' ****************************************************************************************
SUB IHTMLElement_getAttribute (BYVAL pthis AS DWORD PTR, ByVal strAttributeName AS STRING, ByVal lFlags AS LONG, ByRef AttributeValue AS VARIANT)
strAttributeName = UCODE$(strAttributeName)
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
CALL DWORD @@pthis[8] USING Proto_IHTMLElement_getAttribute(pthis, STRPTR(strAttributeName), lFlags, AttributeValue) TO HtmlResult
END SUB
' ****************************************************************************************
' ****************************************************************************************
' setAttribute method
' Sets the value of the specified attribute.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement_setAttribute (BYVAL pthis AS DWORD PTR, BYVAL strAttributeName AS DWORD, BYVAL AttributeValue AS VARIANT, BYVAL lFlags AS LONG) AS LONG
' ****************************************************************************************
SUB IHTMLElement_setAttribute (BYVAL pthis AS DWORD PTR, BYVAL strAttributeName AS STRING, BYVAL AttributeValue AS VARIANT, OPTIONAL ByRef lFlags AS LONG)
LOCAL Flags AS LONG
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
strAttributeName = UCODE$(strAttributeName)
IF VARPTR(lFlags) THEN Flags = lFlags ELSE Flags = 1
CALL DWORD @@pthis[7] USING Proto_IHTMLElement_setAttribute(pthis, STRPTR(strAttributeName), AttributeValue, Flags) TO HtmlResult
END SUB
' ****************************************************************************************
' ****************************************************************************************
' removeAttribute method
' Removes the given attribute from the object.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement_removeAttribute (BYVAL pthis AS DWORD PTR, BYVAL strAttributeName AS DWORD, BYVAL lFlags AS LONG, ByRef pfSuccess AS INTEGER) AS LONG
' ****************************************************************************************
FUNCTION IHTMLElement_removeAttribute (BYVAL pthis AS DWORD PTR, BYVAL strAttributeName AS STRING, OPTIONAL BYREF lFlags AS LONG) AS INTEGER
LOCAL pfSuccess AS INTEGER
LOCAL Flags AS LONG
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT FUNCTION
strAttributeName = UCODE$(strAttributeName)
IF VARPTR(lFlags) THEN Flags = lFlags ELSE Flags = 1
CALL DWORD @@pthis[9] USING Proto_IHTMLElement_removeAttribute(pthis, STRPTR(strAttributeName), Flags, pfSuccess) TO HtmlResult
FUNCTION = pfSuccess
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' HTMLDocument_GetElementValueById
' Parameters:
' - pthis = Reference to the IHTMLDocument interface
' - strId = The value of the ID attribute
' Return Value:
' An string containing the value as ddefined by the attribute.
' This method performs a case insensitive property search.
' If two or more attributes have the same name (differing only in uppercase and lowercase
' letters) this function retrieves values only for the last attribute created with this
' name, and ignores all other attributes with the same name.
' When retrieving the CLASS attribute using this method, set the strAttributeName to be
' "className", which is the corresponding Dynamic HTML (DHTML) property.
' This function is used only by events created from HTML Components.
' HtmlResult will be filled with %S_OK if successful, or an error value otherwise.
' ****************************************************************************************
FUNCTION HTMLDocument_GetElementValueById (BYVAL pthis AS DWORD, BYVAL strId AS STRING) AS STRING
LOCAL ppDoc3 AS DWORD ' // Reference to the IHTMLDocument3 interface
LOCAL ppElement AS DWORD ' // Reference to the element
LOCAL IID_IHTMLDocument3 AS GUID ' // IHTMLDocument3 interface identifier
LOCAL pvar AS VARIANT ' // General purpose variant
IID_IHTMLDocument3 = GUID$("{3050F485-98B5-11CF-BB82-00AA00BDCE0B}")
' // Get a reference to the IHTMLDocument3 interface
ppDoc3 = HtmlQueryInterface(pthis, IID_IHTMLDocument3)
IF ppDoc3 THEN
' // Get a reference to the input element
ppElement = IHTMLDocument3_getElementById(ppDoc3, strId)
IF ppElement THEN
' // Get the value
IHTMLElement_getAttribute ppElement, "value", 0, pvar
' // Release the element interface
HtmlRelease ppElement
END IF
' // Release the IHTMLDocument3 interface
HtmlRelease ppDoc3
END IF
IF VARIANTVT(pvar) = %VT_BOOL THEN
FUNCTION = LTRIM$(STR$(CINT(VARIANT#(pvar))))
ELSEIF VARIANTVT(pvar) = %VT_BSTR THEN
FUNCTION = VARIANT$(pvar)
ELSE
FUNCTION = LTRIM$(STR$(VARIANT#(pvar)))
END IF
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' HTMLDocument_SetElementValueById
' Parameters:
' - pthis = Reference to the IHTMLDocument interface
' - strId = The value of the ID attribute
' - varValue = Variant that specifies the string, number, or Boolean to assign to the attribute.
' HtmlResult will be filled with %S_OK if successful, or an error value otherwise.
' ****************************************************************************************
SUB HTMLDocument_SetElementValueById (BYVAL pthis AS DWORD, BYVAL strId AS STRING, BYVAL varValue AS VARIANT)
LOCAL ppDoc3 AS DWORD ' // Reference to the IHTMLDocument3 interface
LOCAL ppElement AS DWORD ' // Reference to the element
LOCAL IID_IHTMLDocument3 AS GUID ' // IHTMLDocument3 interface identifier
IID_IHTMLDocument3 = GUID$("{3050F485-98B5-11CF-BB82-00AA00BDCE0B}")
' // Get a reference to the IHTMLDocument3 interface
ppDoc3 = HtmlQueryInterface(pthis, IID_IHTMLDocument3)
IF ppDoc3 THEN
' // Get a reference to the input element
ppElement = IHTMLDocument3_getElementById(ppDoc3, strId)
IF ppElement THEN
' // Set the value
IHTMLElement_setAttribute ppElement, "value", varValue, 0
' // Release the element interface
HtmlRelease ppElement
END IF
' // Release the IHTMLDocument3 interface
HtmlRelease ppDoc3
END IF
END SUB
' ****************************************************************************************
' ****************************************************************************************
' HTMLDocument_GetElementInnerHtmlById
' Parameters:
' - pthis = Reference to the IHTMLDocument interface
' - strId = The value of the ID attribute
' HtmlResult will be filled with %S_OK if successful, or an error value otherwise.
' ****************************************************************************************
FUNCTION HTMLDocument_GetElementInnerHtmlById (BYVAL pthis AS DWORD, BYVAL strId AS STRING) AS STRING
LOCAL ppDoc3 AS DWORD ' // Reference to the IHTMLDocument3 interface
LOCAL ppElement AS DWORD ' // Reference to the element
LOCAL IID_IHTMLDocument3 AS GUID ' // IHTMLDocument3 interface identifier
LOCAL strHtml AS STRING ' // General purpose variable
IID_IHTMLDocument3 = GUID$("{3050F485-98B5-11CF-BB82-00AA00BDCE0B}")
' // Get a reference to the IHTMLDocument3 interface
ppDoc3 = HtmlQueryInterface(pthis, IID_IHTMLDocument3)
IF ppDoc3 THEN
' // Get a reference to the input element
ppElement = IHTMLDocument3_getElementById(ppDoc3, strId)
IF ppElement THEN
' // Get the inner html text
strHtml = IHTMLElement_get_innerHTML(ppElement)
FUNCTION = strHtml
' // Release the element interface
HtmlRelease ppElement
END IF
' // Release the IHTMLDocument3 interface
HtmlRelease ppDoc3
END IF
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' HTMLDocument_SetElementInnerHtmlById
' Parameters:
' - pthis = Reference to the IHTMLDocument interface
' - strId = The value of the ID attribute
' HtmlResult will be filled with %S_OK if successful, or an error value otherwise.
' ****************************************************************************************
SUB HTMLDocument_SetElementInnerHtmlById (BYVAL pthis AS DWORD, BYVAL strId AS STRING, BYVAL strHtml AS STRING)
LOCAL ppDoc3 AS DWORD ' // Reference to the IHTMLDocument3 interface
LOCAL ppElement AS DWORD ' // Reference to the element
LOCAL IID_IHTMLDocument3 AS GUID ' // IHTMLDocument3 interface identifier
LOCAL pvar AS VARIANT ' // General purpose variant
IID_IHTMLDocument3 = GUID$("{3050F485-98B5-11CF-BB82-00AA00BDCE0B}")
' // Get a reference to the IHTMLDocument3 interface
ppDoc3 = HtmlQueryInterface(pthis, IID_IHTMLDocument3)
IF ppDoc3 THEN
' // Get a reference to the input element
ppElement = IHTMLDocument3_getElementById(ppDoc3, strId)
IF ppElement THEN
' // Set the inner html text
IHTMLElement_put_innerHTML ppElement, strHtml
' // Release the element interface
HtmlRelease ppElement
END IF
' // Release the IHTMLDocument3 interface
HtmlRelease ppDoc3
END IF
END SUB
' ****************************************************************************************
' ****************************************************************************************
' [get_]activeElement property
' Retrieves the object that has the focus when the parent document has focus.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLDocument2_get_activeElement (BYVAL pthis AS DWORD PTR, ByRef p AS DWORD) AS LONG
' ****************************************************************************************
FUNCTION IHTMLDocument2_get_activeElement (BYVAL pthis AS DWORD PTR) AS DWORD
LOCAL p AS DWORD
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[10] USING Proto_IHTMLDocument2_get_activeElement(pthis, p) TO HtmlResult
FUNCTION = p
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' Retrieves the ID of the active element (the object that has the focus when the parent
' document has focus).
' pthis = Reference to the IHTMLDocument interface.
' ****************************************************************************************
FUNCTION HTMLDocument_GetActiveElementId (BYVAL pthis AS DWORD PTR) AS STRING
LOCAL ppElement AS DWORD
ppElement = IHTMLDocument2_get_activeElement(pthis)
FUNCTION = IHTMLElement_get_id(ppElement)
HtmlRelease ppElement
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' [get_]readyState property
' Retrieves a value that indicates the current state of the object.
' Possible values:
' uninitialized Object is not initialized with data.
' loading Object is loading its data.
' loaded Object has finished loading its data.
' interactive User can interact with the object even though it is not fully loaded.
' complete Object is completely initialized.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLDocument2_get_readyState (BYVAL pthis AS DWORD PTR, ByRef p AS STRING) AS LONG
' ****************************************************************************************
FUNCTION IHTMLDocument2_get_readyState (BYVAL pthis AS DWORD PTR) AS STRING
LOCAL p AS STRING
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[22] USING Proto_IHTMLDocument2_get_readyState(pthis, p) TO HtmlResult
FUNCTION = ACODE$(p)
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' click method
' Simulates a click by causing the onclick event to fire.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement_click (BYVAL pthis AS DWORD PTR) AS LONG
' ****************************************************************************************
SUB IHTMLElement_click (BYVAL pthis AS DWORD PTR)
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
CALL DWORD @@pthis[69] USING Proto_IHTMLElement_click (pthis) TO HtmlResult
END SUB
' ****************************************************************************************
' ****************************************************************************************
' elementFromPoint method
' Returns the element for the specified x and y coordinates.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLDocument2_elementFromPoint (BYVAL pthis AS DWORD PTR, ByVal x AS LONG, ByVal y AS LONG, ByRef elementHit AS DWORD) AS LONG
' ****************************************************************************************
FUNCTION IHTMLDocument2_elementFromPoint (BYVAL pthis AS DWORD PTR, ByVal x AS LONG, ByVal y AS LONG) AS DWORD
LOCAL elementHit AS DWORD
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[107] USING Proto_IHTMLDocument2_elementFromPoint(pthis, x, y, elementHit) TO HtmlResult
FUNCTION = elementHit
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' focus method
' Causes the element to receive the focus and executes the code specified by the onfocus event.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLElement2_focus (BYVAL pthis AS DWORD PTR) AS LONG
' ****************************************************************************************
SUB IHTMLElement2_focus (BYVAL pthis AS DWORD PTR)
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT SUB
CALL DWORD @@pthis[50] USING Proto_IHTMLElement2_focus (pthis) TO HtmlResult
END SUB
' ****************************************************************************************
' ****************************************************************************************
' Sets the focus in the specified element.
' pthis = Reference to the IHTMLDocument interface.
' strId = Udentifier of the element.
' ****************************************************************************************
SUB HTMLDocument_SetElementFocusById (BYVAL pthis AS DWORD, BYVAL strId AS STRING)
LOCAL ppDoc3 AS DWORD ' // Reference to the IHTMLDocument3 interface
LOCAL ppElement AS DWORD ' // Reference to the element
LOCAL ppElement2 AS DWORD ' // Reference to the element
LOCAL IID_IHTMLDocument3 AS GUID ' // IHTMLDocument3 interface identifier
LOCAL IID_IHTMLElement2 AS GUID ' // IHTMLElement2 interface identifier
IID_IHTMLDocument3 = GUID$("{3050F485-98B5-11CF-BB82-00AA00BDCE0B}")
IID_IHTMLElement2 = GUID$("{3050F434-98B5-11CF-BB82-00AA00BDCE0B}")
' // Get a reference to the IHTMLDocument3 interface
ppDoc3 = HtmlQueryInterface(pthis, IID_IHTMLDocument3)
IF ppDoc3 THEN
' // Get a reference to the input element
ppElement = IHTMLDocument3_getElementById(ppDoc3, strId)
IF ppElement THEN
' // Get a reference to the IHTMLElement2 interface
ppElement2 = HtmlQueryInterface(ppElement, IID_IHTMLElement2)
IF ppElement2 THEN
' // Set the focus in the element
IHTMLElement2_focus ppElement2
' // Release the element interface
HtmlRelease ppElement2
END IF
' // Release the element interface
HtmlRelease ppElement
END IF
' // Release the IHTMLDocument3 interface
HtmlRelease ppDoc3
END IF
END SUB
' ****************************************************************************************
' ****************************************************************************************
' [get_]parentWindow property
' Retrieves a reference to the container object of the window.
' ****************************************************************************************
DECLARE FUNCTION Proto_IHTMLDocument2_get_parentWindow (BYVAL pthis AS DWORD PTR, ByRef p AS DWORD) AS LONG
' ****************************************************************************************
FUNCTION IHTMLDocument2_get_parentWindow (BYVAL pthis AS DWORD PTR) EXPORT AS DWORD
LOCAL p AS DWORD
IF ISFALSE pthis THEN HtmlResult = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[108] USING Proto_IHTMLDocument2_get_parentWindow(pthis, p) TO HtmlResult
FUNCTION = p
END FUNCTION
' ****************************************************************************************
' ========================================================================================
' Identifiers
' ========================================================================================
' Form1
%IDD_FORM1 = 100
%IDC_FORM1_STATUSBAR1 = 101
%IDC_FORM1_REBAR1 = 102
%IDC_FORM1_WEBBROWSER1 = 103
%IDC_FORM1_TOOLBAR1 = 104
%IDC_FORM1_EDITURL = 105
%IDC_FORM1_GOBTN = 106
' Rebar1
%IDS_STRING0 = 32770
%IDS_STRING1 = 32771
%IDS_STRING2 = 32772
' Command
%IDM_GOBACK = 28000
%IDM_GOFORWARD = 28001
%IDM_FIND = 28002
%IDM_PRINTPREVIEW = 28003
%IDM_PRINT = 28004
%IDM_PROPERTIES = 28005
%IDM_FILE_SAVE = 28006
%IDM_PAGESETUP = 28007
' ========================================================================================
' Globals
' ========================================================================================
GLOBAL ghInstance AS DWORD ' handle of the application instance
GLOBAL gdwADM_ALIGNCONTROLS AS DWORD ' identifier of registered message
' Purpose: sent to a form or panel to reposition controls with alignment
' styles after the form or panel has been resized or scrolled.
' wParam: N/A
' lParam: the low-order word is the width, and the high-order word the height of the client area
' Return: N/A
GLOBAL gdwADM_REALIGNPARTS AS DWORD ' identifier of registered message
' Purpose: posted by the parent of a status bar control to realign
' the status bar panels.
' wParam: handle of parent of statusbar
' lParam: handle of statusbar
' Return: N/A
GLOBAL gdwCookie AS DWORD ' events cookie
' ========================================================================================
' ========================================================================================
' PROCEDURE: phnxAdjustWindowRect
' PURPOSE: Adjusts the bounding rectangle of a nonresizeable window, based
' on the desired size of the client area, when a system parameter
' changes.
' ========================================================================================
FUNCTION phnxAdjustWindowRect _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL cxClient AS LONG, _ ' desired width of client area in pixels
BYVAL cyClient AS LONG _ ' desired height of client area in pixels
) AS LONG
LOCAL trc AS RECT
LOCAL trcTemp AS RECT
LOCAL hMenu AS DWORD
LOCAL dwStyle AS DWORD
LOCAL cx AS LONG
LOCAL cy AS LONG
' Calculate the height of the window taking menu wrap into account
trc.nLeft = 0
trc.nTop = 0
trc.nRight = cxClient
trc.nBottom = cyClient
hMenu = GetMenu(hWnd)
dwStyle = GetWindowLong(hWnd, %GWL_STYLE)
AdjustWindowRectEx trc, dwStyle, (hMenu <> %NULL), GetWindowLong(hWnd, %GWL_EXSTYLE)
' If there is a menu, check how much wrapping occurs when we set the window
' to the width specified by AdjustWindowRect and an infinite amount of height.
' An infinite height allows us to see every single menu wrap.
IF ISTRUE hMenu THEN
trcTemp = trc
trcTemp.nBottom = &H7FFF ' "Infinite" height
SendMessage hWnd, %WM_NCCALCSIZE, %FALSE, BYVAL VARPTR(trcTemp)
' Adjust our previous calculation to compensate for menu wrapping.
trc.nBottom = trc.nBottom + trcTemp.nTop
END IF
' AdjustWindowRectEx does not take the standard scrollbars into account
IF (dwStyle AND %WS_HSCROLL) = %WS_HSCROLL THEN
trc.nBottom = trc.nBottom + GetSystemMetrics(%SM_CYHSCROLL)
END IF
IF (dwStyle AND %WS_VSCROLL) = %WS_VSCROLL THEN
trc.nRight = trc.nRight + GetSystemMetrics(%SM_CXVSCROLL)
END IF
cx = trc.nRight - trc.nLeft
cy = trc.nBottom - trc.nTop
SetWindowPos hWnd, %NULL, 0, 0, cx, cy, %SWP_NOZORDER OR %SWP_NOMOVE OR %SWP_NOACTIVATE
END FUNCTION
' ========================================================================================
' PROCEDURE: phnxCenterWindow
' PURPOSE: Centers one window over another. It also ensures that the
' placement is within the 'working area', meaning that it is
' both within the display limits of the screen, -and- not
' obscured by the tray or other frameing elements of the
' desktop.
' ========================================================================================
FUNCTION phnxCenterWindow _
( _
BYVAL hWndChild AS DWORD, _ ' handle of window to center
BYVAL hWndParent AS DWORD _ ' handle of reference window or NULL if window is the screen
) AS LONG
LOCAL trcChild AS RECT ' Child window dimensions
LOCAL trcParent AS RECT ' Parent window dimensions
LOCAL trcWorkArea AS RECT ' Work area dimensions
LOCAL tpt AS POINTAPI ' x and y coordinate of centered window
LOCAL cxChild AS LONG ' Width of child window
LOCAL cyChild AS LONG ' Height of child window
LOCAL cxParent AS LONG ' Width of parent window
LOCAL cyParent AS LONG ' Height of parent window
LOCAL fResult AS LONG ' Return flag for SystemParametersInfo()
' Get the Height and Width of the child window
GetWindowRect hWndChild, trcChild
cxChild = trcChild.nRight - trcChild.nLeft
cyChild = trcChild.nBottom - trcChild.nTop
' Get the limits of the 'workarea'
fResult = SystemParametersInfo(%SPI_GETWORKAREA, SIZEOF(trcWorkArea), BYVAL VARPTR(trcWorkArea), 0)
IF ISFALSE(fResult) THEN
trcWorkArea.nLeft = 0
trcWorkArea.nTop = 0
trcWorkArea.nRight = GetSystemMetrics(%SM_CXSCREEN)
trcWorkArea.nBottom = GetSystemMetrics(%SM_CYSCREEN)
END IF
' Get the Height and Width of the parent window
IF ISTRUE hWndParent THEN
GetWindowRect hWndParent, trcParent
ELSE
trcParent.nLeft = trcWorkArea.nLeft
trcParent.nTop = trcWorkArea.nTop
trcParent.nRight = trcWorkArea.nRight
trcParent.nBottom = trcWorkArea.nBottom
END IF
cxParent = trcParent.nRight - trcParent.nLeft
cyParent = trcParent.nBottom - trcParent.nTop
' Calculate new X position, then adjust for workarea
tpt.x = trcParent.nLeft + ((cxParent - cxChild) \ 2)
IF (tpt.x < trcWorkArea.nLeft) THEN
tpt.x = trcWorkArea.nLeft
ELSEIF ((tpt.x + cxChild) > trcWorkArea.nRight) THEN
tpt.x = trcWorkArea.nRight - cxChild
END IF
' Calculate new Y position, then adjust for workarea
tpt.y = trcParent.nTop + ((cyParent - cyChild) \ 2)
IF (tpt.y < trcWorkArea.nTop) THEN
tpt.y = trcWorkArea.nTop
ELSEIF ((tpt.y + cyChild) > trcWorkArea.nBottom) THEN
tpt.y = trcWorkArea.nBottom - cyChild
END IF
IF (GetWindowLong(hWndChild, %GWL_STYLE) AND %WS_CHILD) = %WS_CHILD THEN
ScreenToClient hWndParent, tpt
END IF
' Reposition the window
FUNCTION = SetWindowPos(hWndChild, %NULL, tpt.x, tpt.y, 0, 0, %SWP_NOSIZE OR %SWP_NOZORDER)
END FUNCTION
' ========================================================================================
' FUNCTION: phnxGetFormHandle
' PURPOSE: Finds the handle of the top-level window or MDI child
' window that is the ancestor of the specified window. The
' reference handle is the handle of any control on the form.
' RETURNS: The handle of the form.
' ========================================================================================
FUNCTION phnxGetFormHandle _
( _
BYVAL hWnd AS DWORD _ ' reference handle
) AS DWORD
WHILE ISTRUE (GetWindowLong(hWnd, %GWL_STYLE) AND %WS_CHILD)
IF ISTRUE (GetWindowLong(hWnd, %GWL_EXSTYLE) AND %WS_EX_MDICHILD) THEN EXIT LOOP
hWnd = GetParent(hWnd)
WEND
FUNCTION = hWnd
END FUNCTION
' ========================================================================================
' PROCEDURE: RealignStatusPanels
' PURPOSE: Realigns the panels and embedded controls of the specified
' statusbar when the control is resized.
' ========================================================================================
FUNCTION RealignStatusPanels _
( _
BYVAL hWndParent AS DWORD, _ ' handle of original parent
BYVAL hWndStatus AS DWORD, _ ' handle of statusbar
BYVAL lOffsetPart AS LONG _ ' TRUE = offset last panel from size grip
) AS LONG
LOCAL trc AS RECT
LOCAL plEdge AS LONG PTR ' address of array of right edges
LOCAL plInfo AS LONG PTR
LOCAL hWndChild AS DWORD ' handle of child window
LOCAL lNumParts AS LONG
LOCAL lPartIdx AS LONG
LOCAL dx AS LONG
DIM cxBorder(2) AS LONG
' Allocate memory for the coordinate of the right edge of each panel
plEdge = HeapAlloc(GetProcessHeap(), %HEAP_ZERO_MEMORY, 256 * 4)
IF ISTRUE plEdge THEN
lNumParts = SendMessage(hWndStatus, %SB_GETPARTS, 0, BYVAL 0)
IF lNumParts > 0 THEN
' Get the right edge of each panel
SendMessage hWndStatus, %SB_GETPARTS, lNumParts, BYVAL plEdge
' Get the spacing between panel
' The inter-panel spacing is in cxBorder(2)
SendMessage hWndStatus, %SB_GETBORDERS, 0, BYVAL VARPTR(cxBorder(0))
' Calculate the change in the position of the right edges
GetClientRect hWndStatus, trc
dx = trc.nRight - cxBorder(2) - @plEdge[lNumParts - 1]
IF ISTRUE lOffsetPart THEN
IF (GetWindowLong(hWndStatus, %GWL_STYLE) AND %SBARS_SIZEGRIP) = %SBARS_SIZEGRIP THEN
IF ISFALSE IsZoomed(hWndParent) THEN dx = dx - GetSystemMetrics(%SM_CXVSCROLL)
END IF
END IF
lPartIdx = 0
DO UNTIL lPartIdx >= lNumParts
@plEdge[lPartIdx] = @plEdge[lPartIdx] + dx
INCR lPartIdx
LOOP
SendMessage hWndStatus, %SB_SETPARTS, lNumParts, BYVAL plEdge
' Realign embedded controls
@plEdge[0] = hWndStatus
@plEdge[1] = dx
EnumChildWindows hWndStatus, CODEPTR(RealignStatus_ChildEnumProc), plEdge
END IF
' Free memory that was allocated for the edge info
HeapFree GetProcessHeap(), 0, BYVAL plEdge
END IF
END FUNCTION
' ========================================================================================
' TITLE: StatusBar_SetText
' DESC: Sets the text in the specified part of a status window.
' SYNTAX: StatusBar_SetText hStatus, iPart, sText
' Parameters:
' hStatus - The handle of the Status Bar control.
' iPart - Zero-based index of the part to set. If this value is 255,
' the status window is assumed to be a simple window having
' only one part.
' sText - String that specifies the text to set.
' uType - Type of drawing operation. This parameter can be one of the
' following:
'
' Value Meaning
' -------------- ----------------------------------------------------------
' 0 The text is drawn with a border to appear lower than the plane of the window.
' SBT_NOBORDERS The text is drawn without borders.
' SBT_POPOUT The text is drawn with a border to appear higher than the plane of the window.
' SBT_RTLREADING Displays text using right-to-left reading order on Hebrew or Arabic systems.
'
' Return Values:
' If the operation succeeds, the return value is TRUE.
' If the operation fails, the return value is FALSE.
'
' Remarks:
' The message invalidates the portion of the window that has changed, causing
' it to display the new text when the window next receives the WM_PAINT message.
' ========================================================================================
FUNCTION StatusBar_SetText (BYVAL hStatus AS DWORD, BYVAL iPart AS DWORD, BYVAL strText AS STRING, OPT BYVAL uType AS DWORD) AS LONG
FUNCTION = SendMessage (hStatus, %SB_SETTEXT, iPart OR uType, BYVAL STRPTR(strText))
END FUNCTION
' ========================================================================================
' IOleCommandTarget_Exec method
' Executes a specified command or displays help for a command.
' ========================================================================================
FUNCTION IOleCommandTarget_Exec (BYVAL pthis AS DWORD PTR, BYREF pguidCmdGroup AS GUID, BYVAL nCmdID AS DWORD, BYVAL nCmdexecopt AS DWORD, BYREF pvaIn AS VARIANT, BYREF pvaOut AS VARIANT) AS LONG
LOCAL HRESULT AS LONG
IF pthis = 0 THEN FUNCTION = %E_POINTER : EXIT FUNCTION
CALL DWORD @@pthis[4] USING IOleCommandTarget_Exec(pthis, pguidCmdGroup, nCmdID, nCmdexecopt, pvaIn, pvaOut) TO HRESULT
FUNCTION = HRESULT
END FUNCTION
' ========================================================================================
' ========================================================================================
' Events code iclude file
' ========================================================================================
#INCLUDE "IHTMLEventObj.inc" ' IHTMLEventObj interface
#INCLUDE "HTMLDocumentEvents2.inc" ' HTMLDocument events
#INCLUDE "DWebBrowserEvents2.inc" ' WebBrowser events
' ========================================================================================
' ========================================================================================
' FUNCTION: RealignStatus_ChildEnumProc
' PURPOSE: Enumerates all embedded controls in a statusbar.
' ========================================================================================
FUNCTION RealignStatus_ChildEnumProc _
( _
BYVAL hWnd AS DWORD, _ ' handle of child window
BYVAL lParam AS LONG _ ' address of realignment info
) AS LONG
LOCAL trc AS RECT
LOCAL plEdge AS LONG PTR
LOCAL hWndStatus AS DWORD
LOCAL dx AS LONG
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL cy AS LONG
plEdge = lParam
hWndStatus = @plEdge[0]
dx = @plEdge[1]
IF GetParent(hWnd) = hWndStatus THEN
' Get the bounding rectangle of the embedded control
GetWindowRect hWnd, trc
MapWindowPoints %NULL, hWndStatus, BYVAL VARPTR(trc), 2
x = trc.nLeft + dx
cy = trc.nBottom - trc.nTop
' Get the bounding rectangle of any panel
SendMessage hWndStatus, %SB_GETRECT, 0, BYVAL VARPTR(trc)
y = (trc.nTop + trc.nBottom - cy) \ 2
SetWindowPos hWnd, %NULL, x, y, 0, 0, %SWP_NOZORDER OR %SWP_NOSIZE OR %SWP_DRAWFRAME
END IF
FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_InitWindow
' PURPOSE: Initializes main window of this application instance.
' RETURN: FALSE if initialization was successful, TRUE to close the window on
' failure.
' ========================================================================================
FUNCTION Form1_InitWindow _
( _
BYVAL hWnd AS DWORD, _ ' handle of main window
BYVAL lParam AS LONG _ ' address of command line
) AS LONG
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_TranslateMessage
' PURPOSE: Preprocesses messages.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_TranslateMessage _
( _
BYVAL hWnd AS DWORD, _ ' handle of window
tmsg AS tagMsg _ ' message information
) AS LONG
' Retrieve the handle of the window that hosts the WebBrowser control
LOCAL hCtrl AS DWORD
hCtrl = GetDlgItem(hWnd, %IDC_FORM1_WEBBROWSER1)
' Retrieve the ancestor of the control that has the focus
LOCAL hWndCtrl AS DWORD
hWndCtrl = GetFocus
DO
IF ISFALSE GetParent(hWndCtrl) OR GetParent(hWndCtrl) = hWnd THEN EXIT DO
hWndCtrl = GetParent(hWndCtrl)
LOOP
' %WM_FORWARDMSG = &H37F
' If the focus is in the WebBrowser, forward the message to it
' IF hCtrl = GetParent(GetParent(GetParent(GetFocus))) THEN
IF hCtrl = hWndCtrl THEN
IF ISTRUE SendMessage(hCtrl, &H37F, 0, VARPTR(tmsg)) THEN FUNCTION = %TRUE
END IF
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnClose
' PURPOSE: Form1 WM_CLOSE message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnClose _
( _
BYVAL hWnd AS DWORD _ ' window handle
) AS LONG
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnCreate
' PURPOSE: Form1 WM_CREATE message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnCreate _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL lptcs AS DWORD, _ ' address of CREATESTRUCT structure
lMsgResult AS LONG _ ' value returned to message
) AS LONG
LOCAL hr AS LONG
LOCAL hCtrl AS DWORD
LOCAL ppvObj AS DWORD
LOCAL dwCookie AS DWORD
LOCAL ppDoc AS DWORD
LOCAL vUrl AS VARIANT
LOCAL vScript AS STRING
LOCAL s AS STRING
' Get the handle of the window that hosts the webbrowser
hCtrl = GetDlgItem(hWnd, %IDC_FORM1_WEBBROWSER1)
IF ISFALSE hCtrl THEN EXIT FUNCTION
' Get the IDispatch of the control
ppvObj = WbGetInterfacePointer(hCtrl)
IF ISFALSE ppvObj THEN EXIT FUNCTION
' Connect to the events fired by the control
hr = DWebBrowserEvents2_ConnectEvents(ppvObj, dwCookie)
' Store the cookie in the control properties
SetProp hCtrl, "COOKIE", dwCookie
' ' Call the GoHome method
' IWebBrowser2_GoHome ppvObj
' Call the Navigate2 method
vUrl = "about:blank"
IWebBrowser2_Navigate2 ppvObj, vUrl
' Make an Html form
s = "<html>" & $CRLF
s = s & "<head>" & $CRLF
s = s & " <title>WebGui</title>" & $CRLF
s = s & "" & $CRLF
s = s & "<style type=""text/css"">" & $CRLF
s = s & "<!--" & $CRLF
s = s & "" & $CRLF
s = s & "#output" & $CRLF
s = s & "{" & $CRLF
s = s & "background: #FFFFCC;" & $CRLF
s = s & "border: thin solid black;" & $CRLF
s = s & "text-align: center;" & $CRLF
s = s & "width: 300px;" & $CRLF
s = s & "}" & $CRLF
s = s & "-->" & $CRLF
s = s & "</style>" & $CRLF
s = s & "" & $CRLF
s = s & "</head>" & $CRLF
s = s & "<body>" & $CRLF
s = s & "<input type =""Button"" id=""Button_1"" name=""Button_1"" value=""Button 1""><br />" & $CRLF
s = s & "<input type =""Button"" id=""Button_2"" name=""Button_2"" value=""Button 2""><br />" & $CRLF
s = s & "<input type =""Button"" id=""Button_3"" name=""Button_3"" value=""Button 3""><br />" & $CRLF
s = s & "<input type =""Button"" id=""Button_4"" name=""Button_4"" value=""Button 4""><br />" & $CRLF
s = s & "<br />" & $CRLF
s = s & "<div id=""output"">" & $CRLF
s = s & "Click a button" & $CRLF
s = s & "</div>" & $CRLF
s = s & "<br />" & $CRLF
s = s & "<br />" & $CRLF
s = s & "<input type=""Text"" id=""Input_Text"" name=""Input_Text"" value="""" size=40><br />" & $CRLF
s = s & "<br />" & $CRLF
s = s & "<input type =""Button"" id=""Button_GetText"" name=""Button_GetTex"" value=""Get text""><br />" & $CRLF
s = s & "</body>" & $CRLF
s = s & "</html>" & $CRLF
ppDoc = IWebBrowser2_GetDocument(ppvObj)
IF ppDoc THEN
IHTMLDocument2_write ppDoc, s
IHtmlDocument2_close ppDoc
WbRelease ppDoc
END IF
' Release the interface
WbRelease ppvObj
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnDestroy
' PURPOSE: Form1 WM_DESTROY message handler.
' ========================================================================================
SUB Form1_OnDestroy _
( _
BYVAL hWnd AS DWORD, _ ' window handle
lMsgResult AS LONG _ ' value returned to message
)
LOCAL hr AS LONG
LOCAL hCtrl AS DWORD
LOCAL ppvObj AS DWORD
LOCAL dwCookie AS DWORD
' Get the handle of the window that hosts the webbrowser
hCtrl = GetDlgItem(hWnd, %IDC_FORM1_WEBBROWSER1)
IF ISFALSE hCtrl THEN EXIT SUB
' Get the IDispatch of the control
ppvObj = WbGetInterfacePointer(hCtrl)
IF ISFALSE ppvObj THEN EXIT SUB
' Retrieve the events cookie
dwCookie = GetProp(hCtrl, "COOKIE")
' Disconnect events
IF dwCookie THEN hr = DWebBrowserEvents2_DisconnectEvents(ppvObj, dwCookie)
' Remove the cookie from the control
RemoveProp hCtrl, "COOKIE"
' Release the interface
WbRelease ppvObj
END SUB
' ========================================================================================
' PROCEDURE: Form1_OnQueryEndSession
' PURPOSE: Form1 WM_QUERYENDSESSION message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnQueryEndSession _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL lSource AS LONG, _ ' source of end-session request
BYVAL fLogOff AS LONG, _ ' logoff flag
lMsgResult AS LONG _ ' value returned to message
) AS LONG
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnSize
' PURPOSE: Form1 WM_SIZE message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnSize _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL lState AS LONG, _ ' resizing state
BYVAL cxClient AS LONG, _ ' width of client area
BYVAL cyClient AS LONG _ ' height of client area
) AS LONG
LOCAL hCtrl AS DWORD
LOCAL rc AS RECT
LOCAL sbh AS LONG
' Height of the statusbar
hCtrl = GetDlgItem(hWnd, %IDC_FORM1_STATUSBAR1)
GetClientRect hCtrl, rc
sbh = rc.nBottom - rc.nTop
hCtrl = GetDlgItem(hWnd, %IDC_FORM1_WEBBROWSER1)
MoveWindow hCtrl, 0, 0, cxClient, cyClient - sbh, %TRUE
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnPaint
' PURPOSE: Form1 WM_PAINT message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnPaint _
( _
BYVAL hWnd AS DWORD _ ' window handle
) AS LONG
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnCommand
' PURPOSE: Form1 WM_COMMAND message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnCommand _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL lCtrlId AS LONG, _ ' identifier of menu item, control, or accelerator
BYVAL hWndCtrl AS DWORD, _ ' handle of control
BYVAL lNotifyCode AS LONG _ ' notification code
) AS LONG
SELECT CASE lCtrlId
' CASE %IDCANCEL
' ' Send a message to close the application
' SendMessage hWnd, %WM_CLOSE, 0, 0
' FUNCTION = %TRUE
' CASE %IDOK
END SELECT
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnNotify
' PURPOSE: Form1 WM_NOTIFY message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnNotify _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL lCtrlId AS LONG, _ ' control identifier
BYVAL lptnmhdr AS DWORD, _ ' address of NMHDR structure
lMsgResult AS LONG _ ' value returned to message
) AS LONG
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnKillFocus
' PURPOSE: Form1 WM_KILLFOCUS message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnKillFocus _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL hWndNewFocus AS DWORD _ ' handle of window receiving focus
) AS LONG
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnSetFocus
' PURPOSE: Form1 WM_SETFOCUS message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnSetFocus _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL hWndOldFocus AS DWORD _ ' handle of window losing focus
) AS LONG
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnActivate
' PURPOSE: Form1 WM_ACTIVATE message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnActivate _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL lState AS LONG, _ ' activation state
BYVAL hWndActDeact AS DWORD, _ ' handle of window being activated/deactivated
BYVAL fMinimized AS LONG _ ' minimized flag
) AS LONG
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_OnSysCommand
' PURPOSE: Form1 WM_SYSCOMMAND message handler.
' RETURN: TRUE if message was processed, FALSE if it was not.
' ========================================================================================
FUNCTION Form1_OnSysCommand _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL lCmdType AS LONG, _ ' type of system command requested
BYVAL x AS LONG, _ ' horizontal postion of cursor
BYVAL y AS LONG _ ' vertical position of cursor
) AS LONG
' If user has clicked the x button, send a WM_CLOSE message
IF (lCmdType AND &HFFF0) = %SC_CLOSE THEN
SendMessage hWnd, %WM_CLOSE, 0, 0
FUNCTION = %TRUE
END IF
END FUNCTION
' ========================================================================================
' PROCEDURE: Project1_InitApplication
' PURPOSE: Registers window classes and loads dynamic link libraries.
' RETURN: FALSE if initialization was successful, TRUE if it was not.
' ========================================================================================
FUNCTION Project1_InitApplication _
( _
BYVAL hInstance AS DWORD, _ ' handle of current instance
BYVAL pszCmdLine AS DWORD _ ' address of command line
) AS LONG
' Initializes ATL
AtlAxWinInit
END FUNCTION
' ========================================================================================
' PROCEDURE: Project1_UnloadInstance
' PURPOSE: Unloads dynamic link libraries and frees memory associated with
' this instance.
' ========================================================================================
SUB Project1_UnloadInstance _
( _
BYVAL hInstance AS DWORD _ ' handle of current instance
)
END SUB
' ========================================================================================
' PROCEDURE: WinMain
' PURPOSE: Program entry point, calls initialization function, processes
' message loop.
' ========================================================================================
FUNCTION WinMain _
( _
BYVAL hInstance AS DWORD, _ ' handle of current instance
BYVAL hPrevInstance AS DWORD, _ ' handle of previous instance(not used in Win32)
BYVAL pszCmdLine AS ASCIIZ PTR, _ ' address of command line
BYVAL nCmdShow AS LONG _ ' show state of window
) AS LONG
LOCAL szClassName AS ASCIIZ * %MAX_PATH ' class name
LOCAL twcx AS WNDCLASSEX ' class information
LOCAL tmsg AS tagMsg ' message information
LOCAL ticc AS INIT_COMMON_CONTROLSEX ' specifies common control classes to register
LOCAL hWnd AS DWORD ' handle of main window
LOCAL hWndModeless AS DWORD ' handle of the current active window
' Save the handle of the application instance
ghInstance = hInstance
' Register the Form1 window
szClassName = "Form1_Class"
twcx.cbSize = SIZEOF(twcx) ' size of WNDCLASSEX structure
twcx.style = %CS_DBLCLKS ' class styles
twcx.lpfnWndProc = CODEPTR(Form1_WndProc) ' address of window procedure used by class
twcx.cbClsExtra = 0 ' extra class bytes
twcx.cbWndExtra = 0 ' extra window bytes
twcx.hInstance = ghInstance ' instance of the process that is registering the window
twcx.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION) ' handle of class icon
twcx.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW) ' handle of class cursor
twcx.hbrBackground = %COLOR_BTNFACE + 1 ' brush used to fill background of window's client area
twcx.lpszMenuName = %NULL ' resource identifier of the class menu
twcx.lpszClassName = VARPTR(szClassName) ' class name
twcx.hIconSm = %NULL ' handle of small icon shown in caption/system Taskbar
IF ISFALSE RegisterClassEx(twcx) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
' Load the common controls library and
' specify the classes to register.
ticc.dwSize = SIZEOF(ticc)
ticc.dwICC = %ICC_BAR_CLASSES OR %ICC_COOL_CLASSES
InitCommonControlsEx ticc
' Register custom messages
gdwADM_ALIGNCONTROLS = RegisterWindowMessage("ADM_ALIGNCONTROLS")
gdwADM_REALIGNPARTS = RegisterWindowMessage("ADM_REALIGNPARTS")
' Perform extra application initialization
IF ISTRUE Project1_InitApplication(hInstance, BYVAL pszCmdLine) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
' Create the Form1 window
hWnd = CreateWindowEx(%WS_EX_WINDOWEDGE, _ ' extended styles
"Form1_Class", _ ' class name
"WebGui example", _ ' caption
%WS_OVERLAPPEDWINDOW OR %WS_VISIBLE, _ ' window styles
1, 100, _ ' left, top
500, 350, _ ' width, height
%NULL, %NULL, _ ' handle of owner, menu handle
ghInstance, BYVAL %NULL) ' handle of instance, creation parameters
' If window could not be created, return "failure"
IF ISFALSE hWnd THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
' Adjust the size of the window so that it conforms
' to the specified size of the client area
phnxAdjustWindowRect hWnd, 500, 350
' Initialize this instance of the window
IF ISTRUE Form1_InitWindow(hWnd, BYVAL pszCmdLine) THEN
SendMessage hWnd, %WM_CLOSE, 0, 0
FUNCTION = %FALSE
EXIT FUNCTION
END IF
' Center the window relative to the screen
phnxCenterWindow hWnd, %NULL
' Make the window visible; update its client area
ShowWindow hWnd, nCmdShow
UpdateWindow hWnd
' Main message loop of program.
' Acquire and dispatch messages until a WM_QUIT message is received.
WHILE ISTRUE GetMessage(tmsg, BYVAL %NULL, 0, 0)
IF ISFALSE Form1_TranslateMessage(hWnd, tmsg) THEN
hWndModeless = phnxGetFormHandle(GetFocus())
IF (ISFALSE hWndModeless) OR (ISFALSE IsDialogMessage(hWndModeless, tmsg)) THEN
TranslateMessage tmsg
DispatchMessage tmsg
END IF
END IF
WEND
' Free memory and unload dlls associated with this instance
Project1_UnloadInstance hInstance
FUNCTION = tmsg.wParam
END FUNCTION
' ========================================================================================
' PROCEDURE: Form1_WndProc
' PURPOSE: Processes messages for the Form1 window.
' ========================================================================================
FUNCTION Form1_WndProc _
( _
BYVAL hWnd AS DWORD, _ ' window handle
BYVAL uMsg AS DWORD, _ ' type of message
BYVAL wParam AS DWORD, _ ' first message parameter
BYVAL lParam AS LONG _ ' second message parameter
) EXPORT AS LONG
LOCAL szItem AS ASCIIZ * %MAX_PATH ' working variable
LOCAL trbi AS REBARINFO ' specifies attributes(imagelist) of the rebar control
LOCAL trbbi AS REBARBANDINFO ' specifies or receives the attributes of a rebar band
LOCAL ttbb AS TBBUTTON ' specifies or receives the attributes of a toolbar button
LOCAL ttbab AS TBADDBITMAP ' specifies the images to add to a toolbar
LOCAL ptnmhdr AS NMHDR PTR ' information about a notification message
LOCAL ptttdi AS NMTTDISPINFO PTR ' tooltip notification message information
LOCAL pttbb AS TBBUTTON PTR ' address of array of toolbar button info
LOCAL plEdge AS LONG PTR ' address of array of right edges
LOCAL hWndChild AS DWORD ' handle of child window
LOCAL hWndRebar AS DWORD ' handle of rebar control
LOCAL hFont AS DWORD ' handle of font used by form
LOCAL lMsgResult AS LONG ' value returned to message after message is processed
SELECT CASE uMsg
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE ELSE
' If the message was processed
IF ISTRUE Form1_OnCommand(hWnd, LOWRD(wParam), lParam, HIWRD(wParam)) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
END SELECT
CASE %WM_SYSCOLORCHANGE
' Forward this message to common controls so that they will
' be properly updated when the user changes the color settings.
SendMessage GetDlgItem(hWnd, %IDC_FORM1_STATUSBAR1), %WM_SYSCOLORCHANGE, wParam, lParam
SendMessage GetDlgItem(hWndRebar, %IDC_FORM1_TOOLBAR1), %WM_SYSCOLORCHANGE, wParam, lParam
CASE %WM_ACTIVATE
' If the message was processed
IF ISTRUE Form1_OnActivate(hWnd, LOWRD(wParam), lParam, HIWRD(wParam)) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
FUNCTION = %FALSE
EXIT FUNCTION
CASE %WM_SETFOCUS
' If the message was processed
IF ISTRUE Form1_OnSetFocus(hWnd, wParam) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
' Set the keyboard focus to the first control that is
' visible, not disabled, and has the WS_TABSTOP style
SetFocus GetNextDlgTabItem(hWnd, %NULL, %FALSE)
CASE %WM_KILLFOCUS
' If the message was processed
IF ISTRUE Form1_OnKillFocus(hWnd, wParam) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
CASE %WM_CLOSE
' If the message was processed
IF ISTRUE Form1_OnClose(hWnd) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
CASE %WM_QUERYENDSESSION
' If the message was processed
IF ISTRUE Form1_OnQueryEndSession(hWnd, wParam, lParam, lMsgResult) THEN
FUNCTION = lMsgResult
EXIT FUNCTION
END IF
CASE %WM_DESTROY
Form1_OnDestroy hWnd, lMsgResult
PostQuitMessage lMsgResult
FUNCTION = %FALSE
EXIT FUNCTION
CASE %WM_SIZE
IF wParam <> %SIZE_MINIMIZED THEN
' Update the size and position of aligned controls
SendMessage hWnd, gdwADM_ALIGNCONTROLS, wParam, lParam
' Realign statusbar panels
PostMessage hWnd, gdwADM_REALIGNPARTS, hWnd, GetDlgItem(hWnd, %IDC_FORM1_STATUSBAR1)
' If the message was processed
IF ISTRUE Form1_OnSize(hWnd, wParam, LOWRD(lParam), HIWRD(lParam)) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
FUNCTION = %FALSE
EXIT FUNCTION
END IF
CASE gdwADM_ALIGNCONTROLS
' Update the size and position of aligned controls
hWndChild = GetDlgItem(hWnd, %IDC_FORM1_STATUSBAR1)
SendMessage hWndChild, %WM_SIZE, wParam, lParam
InvalidateRect hWndChild, BYVAL %NULL, %TRUE
SendMessage GetDlgItem(hWnd, %IDC_FORM1_REBAR1), %WM_SIZE, wParam, lParam
FUNCTION = %FALSE
EXIT FUNCTION
CASE gdwADM_REALIGNPARTS
' Realign the panels of statusbars
RealignStatusPanels wParam, lParam, %TRUE
InvalidateRect lParam, BYVAL %NULL, %TRUE
FUNCTION = %FALSE
EXIT FUNCTION
CASE %WM_PAINT
' If the message was processed
IF ISTRUE Form1_OnPaint(hWnd) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
CASE %WM_SYSCOMMAND
' If the message was processed
IF ISTRUE Form1_OnSysCommand(hWnd, wParam, LOINT(lParam), HIINT(lParam)) THEN
FUNCTION = %FALSE
EXIT FUNCTION
END IF
CASE %WM_CREATE
' Create font used by container
hFont = GetStockObject(%DEFAULT_GUI_FONT)
' Create the Statusbar1 statusbar control
hWndChild = CreateWindowEx(%NULL, _ ' extended styles
"msctls_statusbar32", _ ' class name
"", _ ' caption
%WS_CHILD OR %WS_VISIBLE OR _ ' window styles
%CCS_BOTTOM OR %SBARS_SIZEGRIP, _ ' class styles
0, 347, _ ' left, top
535, 23, _ ' width, height
hWnd, %IDC_FORM1_STATUSBAR1, _ ' handle of parent, control ID
ghInstance, BYVAL %NULL) ' handle of instance, creation parameters
SendMessage hWndChild, %WM_SETFONT, hFont, %TRUE
' Allocate memory for the coordinate of the right edge of each part
plEdge = HeapAlloc(GetProcessHeap(), %HEAP_ZERO_MEMORY, 1 * 4)
IF ISTRUE plEdge THEN
@plEdge[0] = 96
SendMessage hWndChild, %SB_SETPARTS, 1, BYVAL plEdge
' Free memory that was allocated for the edge info
HeapFree GetProcessHeap(), 0, BYVAL plEdge
END IF
' Update the size of the statusbar
SendMessage hWndChild, %WM_SIZE, 0, 0
' Create the WebBrowser control
hWndChild = CreateWindowEx(%NULL, _ ' extended styles
"AtlAxWin", _ ' class name
"Shell.Explorer", _ ' caption
%WS_CHILD OR %WS_VISIBLE OR %WS_CLIPSIBLINGS OR _ ' window styles
%WS_TABSTOP, _
0, 0, _ ' left, top
0, 0, _ ' width, height
hWnd, %IDC_FORM1_WEBBROWSER1, _ ' handle of parent, control ID
ghInstance, BYVAL %NULL) ' handle of instance, creation parameters
' If the message was processed
IF ISTRUE Form1_OnCreate(hWnd, lParam, lMsgResult) THEN
FUNCTION = lMsgResult
EXIT FUNCTION
END IF
FUNCTION = %FALSE
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hWnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
PowerBASIC Forums
UBBFriend: Email This Page to Someone! 
posted April 09, 2005 11:58 PM
