************************************************** *-- Class: _hyperlinkbase *-- ParentClass: _hyperlink *-- BaseClass: hyperlink *-- Time Stamp: 04/05/03 10:44:14 PM *-- This class provides the functionality of an OLE Hyperlink and launches a Web Browser by executing the Follow method.. * DEFINE CLASS _hyperlinkbase AS _hyperlink Height = 27 Width = 25 *-- URL of the current document location. clocationurl = "" *-- Object reference to instance of Internet Explorer linked. oie = .NULL. *-- A character string expression representing the document or URL to jump to. ctarget = "" *-- A character string expression specifying the location within the URL specified in cTarget to jump to. If cLocation is not specified, the default document will be jumped to. clocation = "" *-- A character string expression specifying the frame within the URL specified in cTarget to jump to. If cFrameName is not specified, the default frame will be jumped to. cframe = "" *-- Class name used to create link for oIE. cieclass = "InternetExplorer.Application" cshellexecuteclass = "_ShellExecute" cshellexecuteclasslibrary = "_Environ.vcx" Name = "_hyperlinkbase" *-- Specifies if navigating to a URL will create a new window (.T.) or navigate in the current Internet Explorer link. lnewwindow = .F. PROTECTED PROCEDURE clocationurl_access IF TYPE("this.oIE.LocationURL")=="C" RETURN this.oIE.LocationURL ENDIF RETURN this.cLocationURL ENDPROC PROTECTED PROCEDURE clocationurl_assign LPARAMETERS m.vNewVal this.cTarget=m.vNewVal this.NavigateTo ENDPROC *-- Executes a hyperlink jump to the specified cTarget URL. PROCEDURE follow RETURN this.NavigateTo() ENDPROC *-- Returns a valid URL from the specified URL. PROCEDURE validurl LPARAMETERS tcURL *!* 04/05/03 17:31:43 nf 2: added lcScheme *!* LOCAL lcURL, lcScheme IF EMPTY(tcURL) RETURN "" ENDIF lcURL=ALLTRIM(tcURL) *!* 04/05/03 17:31:53 nf 1: Added lcScheme. Check for valid schemes as per RFC 1738 *!* (http://www.w3.org/Addressing/rfc1738.txt) *!* http://www.iana.org/assignments/uri-schemes lcScheme = LOWER(SUBSTR(lcURL,1,AT(":",lcURL))) *!* Examples of legitimate schemes: *!* INLIST(lcScheme,"","mailto:","file:","http:","https:","ftp:","news:","nntp:") *!* Don't assume http: as the original code did. New schemes can be added to the *!* URL specification *!* IF NOT LOWER(LEFT(lcURL,5))=="http:" AND NOT LOWER(LEFT(lcURL,5))=="file:" AND ; *!* NOT LOWER(LEFT(lcURL,4))=="ftp." AND (LOWER(LEFT(lcURL,4))=="www." OR ; *!* INLIST(LOWER(RIGHT(lcURL,4)),".com",".gov",".net") OR ; *!* (NOT SUBSTR(lcURL,2,1)==":" AND NOT LEFT(lcURL,2)=="\\")) *!* lcURL="http://"+lcURL *!* ENDIF *!* 04/05/03 17:31:06 nf 1: It should be safe to just strtran any scheme this way *!* IF SUBSTR(PADR(lcURL,5),5,1)==":" lcURL=STRTRAN(STRTRAN(lcURL,"\","/"),"///","//") *!* ELSE *!* IF NOT LOWER(LEFT(lcURL,4))=="ftp." *!* lcURL="file://"+STRTRAN(STRTRAN(STRTRAN(lcURL,"\","/"),"///","//"),"//","/") *!* ENDIF *!* ENDIF RETURN lcURL ENDPROC PROCEDURE getdefaultbrowser #DEFINE HKEY_CLASSES_ROOT -2147483648 #DEFINE HTTP_PATH "HTTP\shell\open\ddeexec\Application" #DEFINE ERROR_SUCCESS 0 #DEFINE REG_SZ 1 LOCAL nHKey,cSubKey,nResult,lpszValueName,dwReserved LOCAL lpdwType,lpbData,lpcbData,lnErrCode,lnGetKey DECLARE Integer RegOpenKey IN Win32API ; Integer nHKey, String @cSubKey, Integer @nResult DECLARE Integer RegQueryValueEx IN Win32API ; Integer nHKey, String lpszValueName, Integer dwReserved,; Integer @lpdwType, String @lpbData, Integer @lpcbData DECLARE Integer RegCloseKey IN Win32API ; Integer nHKey lnGetKey=0 lnErrCode=RegOpenKey(HKEY_CLASSES_ROOT,HTTP_PATH,@lnGetKey) IF lnErrCode#ERROR_SUCCESS RETURN "" ENDIF lpdwType=0 lpbData=SPACE(256) lpcbData=LEN(lpbData) lnErrCode=RegQueryValueEx(lnGetKey,"",0,@lpdwType,@lpbData,@lpcbData) IF lnErrCode#ERROR_SUCCESS OR lpdwType#REG_SZ RegCloseKey(nGetKey) RETURN "" ENDIF RegCloseKey(lnGetKey) RETURN ALLTRIM(LEFT(lpbData,lpcbData-1)) ENDPROC PROCEDURE GoForward IF TYPE("this.oIE.LocationURL")=="C" NODEFAULT this.oIE.GoForward RETURN ENDIF ENDPROC PROCEDURE GoBack IF TYPE("this.oIE.LocationURL")=="C" NODEFAULT this.oIE.GoBack RETURN ENDIF ENDPROC PROCEDURE NavigateTo LPARAMETERS cTarget, cLocation, cFrame LOCAL lcTarget,lcLocation,lcFrame,oShellExecute lcTarget=ALLTRIM(IIF(EMPTY(cTarget),THIS.cTarget,cTarget)) lcLocation=ALLTRIM(IIF(EMPTY(cLocation),THIS.cLocation,cLocation)) lcFrame=ALLTRIM(IIF(EMPTY(cFrame),THIS.cFrame,cFrame)) NODEFAULT IF EMPTY(lcTarget) RETURN .F. ENDIF *!* 04/05/03 19:02:19 nf 7: I don't see why we're going through all of this instead *!* of simply using ShellExecute. Unfortunately, Navigate2 for the mailto scheme tries to *!* open a browser instance, which isn't appropriate in this case. *!* *!* IF (this.lNewWindow OR TYPE("this.oIE.LocationURL")#"C") AND LOWER(this.GetDefaultBrowser())=="iexplore" *!* this.oIE=CREATEOBJECT(this.cIEClass) *!* ENDIF *!* IF TYPE("this.oIE.LocationURL")#"C" * THIS.SetObjectRef("oShellExecute",THIS.cShellExecuteClass,THIS.cShellExecuteClassLibrary) *IF VARTYPE(THIS.oShellExecute)=="O" *!* 04/05/03 19:04:34 nf 2: Just use ShellExcecute Open * THIS.oShellExecute.ShellExecute(lcTarget) *RETURN *ENDIF *RETURN DODEFAULT(lcTarget,lcLocation,lcFrame) *!* 04/05/03 19:02:19 nf 6: *!* ENDIF *!* IF EMPTY(THIS.oIE.LocationURL) *!* lcFrame="" *!* ENDIF *!* THIS.oIE.Navigate2(lcTarget,0,lcFrame) *!* THIS.oIE.VISIBLE=.T. DECLARE INTEGER ShellExecute IN shell32.DLL ; INTEGER hndWin, STRING cAction, STRING cFileName, ; STRING cParams, STRING cDir, INTEGER nShowWin ShellExecute(0,"open",lcTarget,"","",1) ENDPROC PROCEDURE Error LPARAMETERS nError, cMethod, nLine IF nError=1733 AND LOWER(cMethod)=="navigateto" RETURN ENDIF RETURN DODEFAULT(nError,cMethod,nLine) ENDPROC ENDDEFINE * *-- EndDefine: _hyperlinkbase **************************************************