1732 lines
50 KiB
Plaintext
1732 lines
50 KiB
Plaintext
************************************************************************
|
|
* FUNCTION Utils
|
|
******************
|
|
*** Author: Rick Strahl
|
|
*** (c) West Wind Technologies, 1995-98
|
|
*** Contact: (541) 386-2087 / rstrahl@west-wind.com
|
|
*** Modified: 12/22/97
|
|
*** Function: A set of utility classes and functions used by
|
|
*** the various classes and processing code.
|
|
*************************************************************************
|
|
#INCLUDE FOXPRO.H
|
|
#INCLUDE WCONNECT.H
|
|
|
|
SET PROCEDURE TO wwUtils ADDITIVE
|
|
|
|
|
|
*************************************************************
|
|
DEFINE CLASS wwEnv AS Custom
|
|
*************************************************************
|
|
*** Function: Saves environment settings.
|
|
*************************************************************
|
|
|
|
*** Custom Properties
|
|
PROTECTED cSetting,vOldValue
|
|
|
|
|
|
************************************************************************
|
|
* wwEnv :: Init
|
|
*********************************
|
|
*** Function: Saves and restores environment settings
|
|
*** Assume: Limited to simple ON/OFF settings
|
|
*** Very limited!!! Test carefully.
|
|
*** Pass: tcSetting - SET value to set
|
|
*** tvNewValue - Value to set to
|
|
*** Return:
|
|
************************************************************************
|
|
FUNCTION Init
|
|
LPARAMETERS tcSetting,tvNewValue
|
|
THIS.Set(tcSetting, tvNewValue)
|
|
ENDFUNC
|
|
* Init
|
|
|
|
************************************************************************
|
|
* wwEnv :: Set
|
|
*********************************
|
|
FUNCTION Set
|
|
LPARAMETERS tcSetting,tvNewValue
|
|
THIS.cSetting=tcSetting
|
|
|
|
THIS.vOldValue=SET( tcSetting )
|
|
|
|
IF TYPE("tvNewValue")="C" AND ;
|
|
INLIST(UPPER(tvNewValue),"ON","OFF")
|
|
SET &tcSetting &tvNewValue
|
|
ELSE
|
|
SET &tcSetting TO (tvNewValue)
|
|
ENDIF
|
|
|
|
ENDFUNC
|
|
* Set
|
|
************************************************************************
|
|
* wwEnv :: Destroy
|
|
*********************************
|
|
FUNCTION Destroy
|
|
LOCAL lcSetting,lvValue
|
|
|
|
lcSetting=THIS.cSetting
|
|
lvValue=THIS.vOldValue
|
|
|
|
IF TYPE("lvValue")="C" AND ;
|
|
INLIST(UPPER(lvValue),"ON","OFF")
|
|
SET &lcSetting &lvValue
|
|
ELSE
|
|
SET &lcSetting TO (lvValue)
|
|
ENDIF
|
|
|
|
ENDFUNC
|
|
* Destroy
|
|
|
|
ENDDEFINE
|
|
*EOC wwEnv
|
|
|
|
|
|
#IF .F.
|
|
*DEFINE CLASS wwUtils as Custom
|
|
#ENDIF
|
|
|
|
|
|
*************************************************************************
|
|
****
|
|
**** STANDALONE FUNCTIONS
|
|
****
|
|
*************************************************************************
|
|
|
|
************************************************************************
|
|
FUNCTION OpenExclusive
|
|
**********************
|
|
*** Modified: 01/27/96
|
|
*** Function: Tries to open a table exclusively
|
|
*** Assume: Table name can't contain a file name.
|
|
*** Returns .F. for other reasons like file !found etc.
|
|
*** USES wwEVAL object to test for success
|
|
*** Parameters MUST NOT BE LPARAMETERS!!!
|
|
*** Pass: lcTable - Name of table to open exclusively
|
|
*** Return: .T. or .F.
|
|
************************************************************************
|
|
PARAMETERS lcTable, lcAlias
|
|
LOCAL lcOldError, llRetVal, loEval
|
|
|
|
lcTable=IIF(EMPTY(lcTable),"",lcTable)
|
|
lcAlias=IIF(EMPTY(lcAlias),JustStem(lcTable),lcAlias)
|
|
|
|
IF EMPTY(lcTable)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
loEval=CREATE([WWC_wwEval])
|
|
|
|
*** Use Exclusively to reindex and pack
|
|
IF !USED(lcAlias)
|
|
loEval.ExecuteCommand("USE (lcTable) EXCLUSIVE IN 0 ALIAS (lcAlias)")
|
|
ELSE
|
|
SELE (lcAlias)
|
|
loEval.ExecuteCommand("USE (lcTable) EXCLUSIVE ALIAS (lcAlias)")
|
|
ENDIF
|
|
|
|
llRetVal=!loEval.lError
|
|
|
|
*** Now try to re-open table as shared
|
|
IF !llRetVal
|
|
USE (lcTable) IN 0 ALIAS(lcAlias)
|
|
ELSE
|
|
SELE (lcAlias)
|
|
ENDIF
|
|
|
|
RETURN llRetVal
|
|
*EOP OpenExclusive
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION File2Var
|
|
******************
|
|
*** Function: Takes a file and returns the contents as a string or
|
|
*** Takes a string and stores it in a file if a second
|
|
*** string parameter is specified.
|
|
*** Pass: tcFilename - Name of the file
|
|
*** tcString - If specified the string is stored
|
|
*** in the file specified in tcFileName
|
|
*** Return: file contents as a string
|
|
************************************************************************
|
|
LPARAMETERS tcFileName, tcString
|
|
LOCAL lcRetVal, lnHandle, lnSize
|
|
|
|
tcFileName=IIF(EMPTY(tcFileName),"",tcFileName)
|
|
|
|
IF VARTYPE(tcString) # "C"
|
|
*** File to Text
|
|
lcRetVal=""
|
|
|
|
*** Make sure file exists and can be opened for READ operation
|
|
lnHandle=FOPEN(tcFileName,0)
|
|
IF lnHandle#-1
|
|
lnSize = FSEEK(lnHandle,0,2)
|
|
FSEEK(lnHandle,0,0)
|
|
lcRetVal=FREAD(lnHandle,lnSize)
|
|
=FCLOSE(lnHandle)
|
|
ENDIF
|
|
ELSE
|
|
tcString=IIF(EMPTY(tcString),"",tcString)
|
|
|
|
*** Text to File
|
|
lnHandle=FCREATE(tcFileName)
|
|
IF lnHandle=-1
|
|
RETURN .F.
|
|
ENDIF
|
|
=FWRITE(lnHandle,tcString)
|
|
=FCLOSE(lnHandle)
|
|
RETURN .T.
|
|
ENDIF
|
|
|
|
RETURN lcRetVal
|
|
*EOP File2Var
|
|
|
|
************************************************************************
|
|
FUNCTION Extract
|
|
******************
|
|
*** Function: Extracts a text value between two delimiters
|
|
*** Assume: Delimiters case insensitive
|
|
*** The first instance only is retrieved. Idea is
|
|
*** to translate the delims as you go...
|
|
*** Pass: lcString - Entire string
|
|
*** lcDelim1 - The starting delimiter
|
|
*** lcDelim2 - Ending delimiter
|
|
*** lcDelim3 - Alternate ending delimiter
|
|
*** llEndOk - End of line is OK
|
|
*** Return: Text between delimiters or ""
|
|
*************************************************************************
|
|
PARAMETERS lcString,lcDelim1,lcDelim2,lcDelim3, llEndOk
|
|
PRIVATE lnX,lnLocation,lcRetVal,lcChar,lnNewString,lnEnd
|
|
|
|
#IF wwVFPVersion > 6
|
|
IF EMPTY(lcDelim3)
|
|
RETURN STREXTRACT(lcString,lcDelim1,lcDelim2,1,1 + IIF(llendOk,2,0) )
|
|
ENDIF
|
|
#ENDIF
|
|
|
|
lcDelim1=IIF(LEN(lcDelim1)=0,",",lcDelim1)
|
|
lcDelim2=IIF(LEN(lcDelim2)=0,"z!x",lcDelim2)
|
|
lcDelim3=IIF(EMPTY(lcDelim3),"z!x",lcDelim3)
|
|
|
|
lnLocation=ATC(lcDelim1,lcString)
|
|
IF lnLocation=0
|
|
RETURN ""
|
|
ENDIF
|
|
|
|
lnLocation=lnlocation+len(lcDelim1)
|
|
|
|
*** Crate a new string of remaining text
|
|
lcNewString=SUBSTR(lcString,lnLocation)
|
|
|
|
lnEnd=ATC(lcDelim2,lcNewString)
|
|
IF lnEnd>0
|
|
RETURN SUBSTR(lcNewString,1,lnEnd-1)
|
|
ENDIF
|
|
*!* IF lnEnd = 0
|
|
*!* *** Empty Delimited string
|
|
*!* RETURN ""
|
|
*!* ENDIF
|
|
|
|
lnEnd=ATC(lcDelim3,lcNewString)
|
|
IF lnEnd>0
|
|
RETURN SUBSTR(lcNewString,1,lnEnd-1)
|
|
ENDIF
|
|
|
|
IF llEndOk
|
|
*** Return to the end of the line
|
|
RETURN SUBSTR(lcNewString,1)
|
|
ENDIF
|
|
|
|
RETURN ""
|
|
*EOP RetValue
|
|
|
|
************************************************************************
|
|
* wwUtils :: ReplaceDelimitedText
|
|
****************************************
|
|
*** Function: Replaces text between a set of delimiters with
|
|
*** a new string leaving the delimiters intact
|
|
*** Assume: The delimited block MUST have at least 1 character
|
|
*** in it even if it is blank or a CRLF
|
|
*** Pass: lcSource - Full Source String
|
|
*** lcStart - Start delimiter
|
|
*** lcEnd - End Delimiter
|
|
*** lcReplace - Text to replace between delimiters
|
|
*** Return: Updated String
|
|
************************************************************************
|
|
FUNCTION ReplaceText
|
|
LPARAMETERS lcSource, lcStart, lcEnd, lcReplace
|
|
|
|
lcExtract = Extract(lcSource,lcStart,lcEnd,,.T.)
|
|
|
|
RETURN STRTRAN(lcSource,lcStart + lcExtract + lcEnd,lcStart + lcReplace + lcEnd)
|
|
ENDFUNC
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION Path
|
|
******************
|
|
*** Function: Adds or deletes items from the path string
|
|
*** Pass: pcPathName - Filename
|
|
*** pcMethod - *"ADD","DELETE"
|
|
*** Return: New Path or ""
|
|
************************************************************************
|
|
PARAMETERS pcPath,pcMethod
|
|
LOCAL lcOldPath
|
|
|
|
IF VARTYPE(pcMethod) # "C"
|
|
pcMethod = "ADD"
|
|
ENDIF
|
|
|
|
IF EMPTY(pcPath)
|
|
RETURN
|
|
ENDIF
|
|
|
|
pcPath=ADDBS(LOWER(TRIM(pcPath)))
|
|
lcOldPath=LOWER(SET("PATH"))
|
|
|
|
IF pcMethod="ADD"
|
|
IF EMPTY(pcPath) .OR. ;
|
|
!Directory(pcPath)
|
|
RETURN ""
|
|
ENDIF
|
|
IF AT(";" + pcPath + ";" ,";" + lcOldPath + ";")>0
|
|
RETURN ""
|
|
ENDIF
|
|
lcOldPath=lcOldPath+";"+pcPath
|
|
ELSE
|
|
IF AT(";" + pcPath + ";" ,";" + lcOldPath + ";") < 1
|
|
RETURN ""
|
|
ENDIF
|
|
lcOldPath=STRTRAN(lcOldPath + ";" ,";" +pcPath+";",";")
|
|
lcOldPath = SUBSTR(lcOldPath,1,LEN(lcOldPath)-1)
|
|
ENDIF
|
|
|
|
SET PATH TO &lcOldPath
|
|
|
|
RETURN lcOldPath
|
|
*EOP PATH
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION DomainName
|
|
*******************
|
|
*** Modified: 04/13/96
|
|
*** Function: Retrieves a Domain name from an URL
|
|
*** Assume: URL starts with http:// - // required!
|
|
*** Pass: lcUrl - URL to retrieve name from
|
|
*** llNoStripWWW - Don't strip www.
|
|
*** Return: Domain Name or ""
|
|
*************************************************************************
|
|
LPARAMETER lcUrl, llNoStripWWW
|
|
lcText=STRTRAN(EXTRACT(lower(lcUrl),"//","/"," "),"/","")
|
|
IF !llNoStripWWW
|
|
lcText=STRTRAN(lcText,"www.","")
|
|
ENDIF
|
|
RETURN PADR(lcText,50)
|
|
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION ShowHTML
|
|
*****************
|
|
*** Function: Takes an HTML string and displays it in the default
|
|
*** browser.
|
|
*** Assume: Uses a file to store HTML temporarily.
|
|
*** For this reason there may be concurrency issues
|
|
*** unless you change the file for each use
|
|
*** Pass: lcHTML - HTML to display
|
|
*** lcFile - Temporary File to use (Optional)
|
|
*** loWebBrowser - Web Browser control ref (Optional)
|
|
************************************************************************
|
|
LPARAMETERS lcHTML, lcFile, loWebBrowser
|
|
|
|
lcHTML=IIF(EMPTY(lcHTML),"",lcHTML)
|
|
lcFile=IIF(EMPTY(lcFile),SYS(2023)+"\ww_HTMLView.htm",lcFile)
|
|
|
|
File2Var(lcFile,lcHTML)
|
|
|
|
IF TYPE("loWebBrowser") = "O"
|
|
loWebBrowser.Navigate(lcFile)
|
|
ELSE
|
|
IF TYPE("_oscreenx") = "O"
|
|
_oscreenx.Navigate(lcFile)
|
|
ENDIF
|
|
*!* IF lower(JUSTEXT(lcFile)) = "txt"
|
|
*!* MODI COMM (lcFile) IN MACDESKTOP
|
|
*!* ELSE
|
|
=GoUrl(lcFile)
|
|
*!* ENDIF
|
|
ENDIF
|
|
|
|
RETURN
|
|
*EOP ShowHTML
|
|
|
|
************************************************************************
|
|
FUNCTION ShowXML
|
|
*****************
|
|
*** Function: Takes an XML string and displays it in the default
|
|
*** browser.
|
|
*** Assume: Uses a file to store HTML temporarily.
|
|
*** For this reason there may be concurrency issues
|
|
*** unless you change the file for each use
|
|
*** Pass: lcHTML - HTML to display
|
|
*** lcFile - Temporary File to use (Optional)
|
|
*** loWebBrowser - Web Browser control ref (Optional)
|
|
************************************************************************
|
|
LPARAMETERS lcHTML, lcFile, loWebBrowser
|
|
IF EMPTY(lcFile)
|
|
lcFile=IIF(EMPTY(lcFile),SYS(2023)+"\ww_HTMLView.xml",lcFile)
|
|
ENDIF
|
|
ERASE (lcFile)
|
|
RETURN ShowHTML(lcHTML,lcFile,loWebBrowser)
|
|
|
|
************************************************************************
|
|
FUNCTION ShowText
|
|
*****************
|
|
*** Function: Takes an XML string and displays it in the default
|
|
*** browser.
|
|
*** Assume: Uses a file to store HTML temporarily.
|
|
*** For this reason there may be concurrency issues
|
|
*** unless you change the file for each use
|
|
*** Pass: lcHTML - HTML to display
|
|
*** lcFile - Temporary File to use (Optional)
|
|
*** loWebBrowser - Web Browser control ref (Optional)
|
|
************************************************************************
|
|
LPARAMETERS lcHTML, lcFile, loWebBrowser
|
|
IF EMPTY(lcFile)
|
|
lcFile=IIF(EMPTY(lcFile),SYS(2023)+"\ww_HTMLView.txt",lcFile)
|
|
ENDIF
|
|
|
|
IF VARTYPE(loWebBrowser) = "C" and loWebBrowser = "MODI"
|
|
FILE2VAR(lcFile,lcHTML)
|
|
MODIFY COMMAND (lcFile)
|
|
RETURN
|
|
ENDIF
|
|
|
|
RETURN ShowHTML(lcHTML,lcFile,loWebBrowser)
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION IsWinnt
|
|
*****************
|
|
*** Pass: llReturnVersionNumber
|
|
*** Return: .t. or .f. or Version Number or -1 if not NT
|
|
*************************************************************************
|
|
LPARAMETER llReturnVersionNumber
|
|
|
|
loAPI=CREATE("wwAPI")
|
|
lcVersion = loAPI.ReadRegistryString(HKEY_LOCAL_MACHINE,;
|
|
"SOFTWARE\Microsoft\Windows NT\CurrentVersion",;
|
|
"CurrentVersion")
|
|
|
|
IF !llReturnVersionNumber
|
|
IF ISNULL(lcVersion)
|
|
RETURN .F.
|
|
ELSE
|
|
RETURN .T.
|
|
ENDIF
|
|
ENDIF
|
|
|
|
IF ISNULL(lcVersion)
|
|
RETURN -1
|
|
ENDIF
|
|
|
|
RETURN VAL(lcVersion)
|
|
* IsWinNt
|
|
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION StripHTML
|
|
*******************
|
|
*** Function: Removes HTML tags from the passed text and converts
|
|
*** it to plain text. Note formatting is totally removed!
|
|
*** Assume: only <br> and <p> are translated
|
|
*** any < or > in the HTML besides tags will break this
|
|
*** function.
|
|
*** Pass: lcText - HTML Text to strip
|
|
*** lcLTag - Left Tag value ("<")
|
|
*** lcRTag - Right Tag Value (">")
|
|
*** Return: Stripped HTML text
|
|
*************************************************************************
|
|
LPARAMETER lcHTMLText, lcLTag, lcRTag
|
|
|
|
lcLTag=IIF(EMPTY(lcLTag),"<",lcLTag)
|
|
lcRTag=IIF(EMPTY(lcRTag),">",lcRTag)
|
|
|
|
IF ATC(lcLTag,lcHTMLText) = 0
|
|
RETURN lcHTMLText
|
|
ENDIF
|
|
|
|
*** Start by breaking line breaks
|
|
lcHTMLText = STRTRAN(lcHTMLText,lcLTag + "BR" + lcRTag,CRLF)
|
|
lcHTMLText = STRTRAN(lcHTMLText,lcLTag + "P" + lcRTag,CRLF+CRLF)
|
|
lcHTMLText = STRTRAN(lcHTMLText,lcLTag + "br" + lcRTag,CRLF)
|
|
lcHTMLText = STRTRAN(lcHTMLText,lcLTag + "p" + lcRTag,CRLF+CRLF)
|
|
lcHTMLText = STRTRAN(lcHTMLText," "," ")
|
|
|
|
lcExtract = "x"
|
|
DO WHILE !EMPTY(lcExtract)
|
|
lcExtract = Extract(lcHTMLText,lcLTag,lcRTag)
|
|
|
|
IF EMPTY(lcExtract)
|
|
EXIT
|
|
ENDIF
|
|
lcHTMLText = STRTRAN(lcHTMLText,lcLTag+lcExtract+lcRTag,"")
|
|
ENDDO
|
|
|
|
lcHTMLText = STRTRAN(lcHTMLText,"<","<")
|
|
lcHTMLText = STRTRAN(lcHTMLText,">",">")
|
|
|
|
RETURN lcHTMLText
|
|
|
|
************************************************************************
|
|
FUNCTION HTMLColor
|
|
*********************************
|
|
*** Function: Converts a FoxPro Color to an HTML Hex color value
|
|
*** Pass: lnRGBColor - FoxPro RGB color number - RGB(255,255,255)
|
|
*** llNoOutput
|
|
*** Return: Hex HTML Color String "#FFFFFF"
|
|
************************************************************************
|
|
LPARAMETER lnRGBColor
|
|
|
|
lcColor=RIGHT(TRANSFORM(lnRGBColor,"@0"),6)
|
|
|
|
*** Fox color is BBGGRR, HTML is RRGGBB
|
|
|
|
RETURN "#" + SUBSTR(lcColor,5,2) + SUBSTR(lcColor,3,2) + LEFT(lcColor,2)
|
|
* HTMLColor
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION CharToBin
|
|
******************
|
|
*** Function: Converts a DWORD value in binary string form back into
|
|
*** a numeric value
|
|
*** Pass: tcWord - Binary string value (from a structure?)
|
|
*** Return: numeric value of binary string
|
|
*************************************************************************
|
|
LPARAMETER tcWord
|
|
|
|
LOCAL i, lnWord
|
|
|
|
lnWord = 0
|
|
FOR i = 1 TO LEN(tcWord)
|
|
lnWord = lnWord + (ASC(SUBSTR(tcWord, i, 1)) * (2 ^ (8 * (i - 1))))
|
|
ENDFOR
|
|
|
|
RETURN lnWord
|
|
|
|
|
|
****************************************************
|
|
FUNCTION GoUrl
|
|
******************
|
|
*** Author: Rick Strahl
|
|
*** (c) West Wind Technologies, 1996
|
|
*** Contact: rstrahl@west-wind.com
|
|
*** Modified: 03/14/96
|
|
*** Function: Starts associated Web Browser
|
|
*** and goes to the specified URL.
|
|
*** If Browser is already open it
|
|
*** reloads the page.
|
|
*** Assume: Works only on Win95 and NT 4.0
|
|
*** Pass: tcUrl - The URL of the site or
|
|
*** HTML page to bring up
|
|
*** in the Browser
|
|
*** Return: 2 - Bad Association (invalid URL)
|
|
*** 31 - No application association
|
|
*** 29 - Failure to load application
|
|
*** 30 - Application is busy
|
|
***
|
|
*** Values over 32 indicate success
|
|
*** and return an instance handle for
|
|
*** the application started (the browser)
|
|
****************************************************
|
|
LPARAMETERS tcUrl, tcAction, tcDirectory
|
|
|
|
tcUrl=IIF(type("tcUrl")="C",tcUrl,;
|
|
"http://www.west-wind.com/")
|
|
|
|
tcAction=IIF(type("tcAction")="C",tcAction,"OPEN")
|
|
|
|
tcDirectory=IIF(EMPTY(tcDirectory),SYS(2023),tcDirectory)
|
|
|
|
DECLARE INTEGER ShellExecute ;
|
|
IN SHELL32.dll ;
|
|
INTEGER nWinHandle,;
|
|
STRING cOperation,;
|
|
STRING cFileName,;
|
|
STRING cParameters,;
|
|
STRING cDirectory,;
|
|
INTEGER nShowWindow
|
|
|
|
DECLARE INTEGER FindWindow ;
|
|
IN WIN32API ;
|
|
STRING cNull,STRING cWinName
|
|
|
|
RETURN ShellExecute(FindWindow(0,_SCREEN.caption),;
|
|
tcAction,tcUrl,;
|
|
"",tcDirectory,1)
|
|
|
|
************************************************************************
|
|
PROCEDURE StrTranC
|
|
******************
|
|
*** Function: Like Strtran but case insensitive
|
|
*** Pass: lcString - Entire string
|
|
*** lcDelim1 - String to replace
|
|
*** lcDelim2 - String to replace with
|
|
*** Return: translated string
|
|
*************************************************************************
|
|
LPARAMETER lcString, lcSource, lcReplace
|
|
|
|
#IF wwVFPVersion > 6
|
|
RETURN STRTRAN(lcString,lcSource,lcReplace,1,-1,1)
|
|
#ELSE
|
|
LOCAL lnAt
|
|
|
|
lnAt = 1
|
|
lnReplaceSize = LEN(lcSource)
|
|
DO while .T.
|
|
lnAt = ATC(lcSource,lcString)
|
|
IF lnAT = 0
|
|
RETURN lcString
|
|
ENDIF
|
|
|
|
lcString = STUFF(lcString,lnAt,lnReplaceSize,lcReplace)
|
|
ENDDO
|
|
|
|
RETURN lcString
|
|
#ENDIF
|
|
|
|
|
|
FUNCTION TimeToCStrict
|
|
LPARAMETER ltTime, llSQL
|
|
|
|
lcCentury = SET("CENTURY")
|
|
lcDateMode = SET("DATE")
|
|
SET CENTURY ON
|
|
SET DATE TO YMD
|
|
|
|
IF llSQL
|
|
lcDate = "'" + TTOC(ltTime) + "'"
|
|
ELSE
|
|
lcDate = "{^" + TTOC(ltTime) + "}"
|
|
ENDIF
|
|
|
|
SET DATE TO &lcDateMode
|
|
SET CENTURY &lcCentury
|
|
RETURN lcDate
|
|
|
|
************************************************************************
|
|
FUNCTION DateToC
|
|
******************
|
|
*** Function: Converts a date to string displaying empty dates as blanks
|
|
*** rather than displaying the empty date format
|
|
*** Pass: ldDate - Date to display
|
|
*** Return: Date String or "" if invalid date
|
|
*************************************************************************
|
|
LPARAMETER ldDate
|
|
|
|
IF EMPTY(ldDate)
|
|
RETURN ""
|
|
ENDIF
|
|
|
|
RETURN DTOC(ldDate)
|
|
* DateTOC
|
|
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION TimeToC
|
|
******************
|
|
*** Function: Converts a time to string displaying empty as blanks
|
|
*** and formatting the time string properly
|
|
*** Pass: ltTime - Date to display (Pass Time, Date or Char)
|
|
*** Return: Time String or "" if invalid date (Year is not returned)
|
|
*************************************************************************
|
|
LPARAMETER ltTime
|
|
|
|
IF EMPTY(ltTime)
|
|
RETURN ""
|
|
ENDIF
|
|
|
|
IF VARTYPE(ltTime) $ "DT"
|
|
lcTimestamp = TTOC(ltTime)
|
|
ELSE
|
|
lcTimeStamp = ltTime
|
|
ENDIF
|
|
|
|
RETURN Substr(lcTimeStamp,1,5)+"/" + Substr(lcTimeStamp,9,8)+lower(Substr(lcTimeStamp,21,2))
|
|
* DateTOC
|
|
|
|
************************************************************************
|
|
FUNCTION GetAppStartPath
|
|
*********************************
|
|
*** Function: Returns the FoxPro start path
|
|
*** of the *APPLICATION*
|
|
*** under all startmodes supported by VFP.
|
|
*** Returns the path of the starting EXE,
|
|
*** DLL, APP, PRG/FXP
|
|
*** Return: Path as a string with trailing "\"
|
|
************************************************************************
|
|
|
|
DO CASE
|
|
*** VFP 6 provides ServerName property for COM servers EXE/DLL/MTDLL
|
|
CASE INLIST(Application.StartMode,2,3,5)
|
|
lcPath = JustPath(Application.ServerName)
|
|
|
|
*!* *** Interactive
|
|
*!* CASE (Application.StartMode) = 0
|
|
*!* lcPath = SYS(5) + CURDIR()
|
|
|
|
*** Active Document
|
|
CASE ATC(".APP",SYS(16,0)) > 0
|
|
lcPath = JustPath(SYS(16,0))
|
|
|
|
*** Standalone EXE or VFP Development
|
|
OTHERWISE
|
|
lcPath = JustPath(SYS(16,0))
|
|
IF ATC("PROCEDURE",lcPath) > 0
|
|
lcPath = SUBSTR(lcPath,RAT(":",lcPath)-1)
|
|
ENDIF
|
|
ENDCASE
|
|
|
|
RETURN AddBs(lcPath)
|
|
* EOF GetAppStartPath
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION ShortPath
|
|
******************
|
|
*** Function: Converts a Long Windows filename into a short
|
|
*** 8.3 compliant path/filename
|
|
*** Pass: lcPath - Path to check
|
|
*** Return: lcShortFileName
|
|
*************************************************************************
|
|
LPARAMETER lcPath
|
|
|
|
DECLARE INTEGER GetShortPathName IN Win32API;
|
|
STRING @lpszLongPath, STRING @lpszShortPath,;
|
|
INTEGER cchBuffer
|
|
|
|
lcPath = lcPath
|
|
lcshortname = SPACE(260)
|
|
lnlength = LEN(lcshortname)
|
|
lnresult = GetShortPathName(@lcPath, @lcshortname, lnlength)
|
|
IF lnResult = 0
|
|
RETURN ""
|
|
ENDIF
|
|
RETURN LEFT(lcShortName,lnResult)
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION DeleteFiles
|
|
********************
|
|
*** Function: Returns the size of a file
|
|
*** Pass: lcFileName - Wildcard File Spec (d:\temp\*.pdf)
|
|
*** lnTimeout - Timeout in seconds
|
|
*** Return: the size of the file or -1 on error
|
|
************************************************************************
|
|
PARAMETERS lcFileSpec, lnTimeout
|
|
PRIVATE lnX,lnFiles, loAPI
|
|
|
|
lnTimeout=IIF(EMPTY(lnTimeout),300,lnTimeout)
|
|
|
|
lnFiles = aDir(laFiles,lcFileSpec)
|
|
*loEval = CREATE([WWC_wwEval])
|
|
FOR lnX=1 to lnFiles
|
|
ldtime = CTOT( DTOC(laFiles[lnX,3]) + " " + laFiles[lnX,4] )
|
|
IF ldTime + lnTimeout < DateTime()
|
|
* loEval.ExecuteCommand( " ERASE (ADDBS(justpath(lcFileSpec)) + laFiles[lnX,1]) " )
|
|
ERASE (ADDBS(justpath(lcFileSpec)) + laFiles[lnX,1])
|
|
ENDIF
|
|
ENDFOR
|
|
|
|
RETURN .T.
|
|
ENDFUNC
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION IsDir
|
|
******************
|
|
*** Modified: 10/09/97
|
|
*** Function: Checks to see whether a directory exists
|
|
*** Pass: lcPath - Path to check
|
|
*** Return: .T. or .F.
|
|
*************************************************************************
|
|
LPARAMETER lcPath
|
|
DIMENSION laTemp[1]
|
|
IF ADIR(laTemp,lcPath,"DH") < 1
|
|
RETURN .F.
|
|
ENDIF
|
|
RETURN .T.
|
|
|
|
************************************************************************
|
|
FUNCTION FileSize
|
|
******************
|
|
*** Function: Returns the size of a file
|
|
*** Pass: lcFileName
|
|
*** Return: the size of the file or -1 on error
|
|
************************************************************************
|
|
LPARAMETERS lcFileName
|
|
LOCAL lh, lnSize
|
|
|
|
lh = FOPEN(lcFileName)
|
|
IF lh = -1
|
|
RETURN -1
|
|
ENDIF
|
|
|
|
lnSize = FSEEK(lh, 0, 2)
|
|
|
|
FCLOSE(lh)
|
|
|
|
RETURN lnSize
|
|
*EOP FileSize
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION Slash
|
|
******************
|
|
*** Function: Converts slashes from DOS -> Web and vice versa
|
|
*** Pass: lcPath - Path to convert
|
|
*** lcStyle - "WEB" or "DOS"
|
|
*** Return: update path
|
|
************************************************************************
|
|
LPARAMETER lcPath, lcStyle
|
|
lcStyle=IIF(type("lcStyle")="C",UPPER(lcStyle),"")
|
|
IF lcStyle="WEB"
|
|
lcPath=CHRTRAN(lcPath,"\","/")
|
|
ELSE
|
|
lcPath=CHRTRAN(lcPath,"/","\")
|
|
ENDIF
|
|
RETURN lcPath
|
|
*EOP LPARAMETER
|
|
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION ProgLevel
|
|
******************
|
|
*** Function: Returns the current Calling Stack level. Used to check
|
|
*** recursive Error calls in Error methods.
|
|
*************************************************************************
|
|
|
|
FOR lnX=1 to 128
|
|
IF EMPTY(SYS(16,lnX))
|
|
exit
|
|
ENDIF
|
|
ENDFOR && lnX=1 to 128
|
|
|
|
*** -1 for lnX count - -1 for ProgLevel Call
|
|
RETURN lnX - 2
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION AParseString
|
|
**********************
|
|
*** Modified: 07/03/97
|
|
*** Function: Parses a delimited string into an array
|
|
*** Pass: laResult - Array containing the result strings (@)
|
|
*** lcString - The full string
|
|
*** lcDelimiter - The delimiter string
|
|
*** Return: Count of strings or 0 if null string is passed
|
|
*************************************************************************
|
|
LPARAMETER laResult, lcString, lcDelimiter
|
|
LOCAL lnLastPos, lnItemCount, i
|
|
|
|
lnItemCount = OCCURS(lcDelimiter,lcString) + 1
|
|
DIMENSION laResult[lnItemCount]
|
|
|
|
lnLastPos=1
|
|
|
|
FOR i=1 to lnItemCount
|
|
IF i < lnItemCount
|
|
laResult[i] = SUBSTR(lcString,lnLastPos, ;
|
|
ATC(lcDelimiter,lcString,i) - lnLastPos )
|
|
ELSE
|
|
laResult[i] = SUBSTR(lcString,lnLastPos)
|
|
ENDIF
|
|
lnLastPos = ATC(lcDelimiter,lcString,i) + LEN(lcDelimiter)
|
|
ENDFOR
|
|
|
|
RETURN lnItemCount
|
|
|
|
************************************************************************
|
|
FUNCTION URLDecode
|
|
******************
|
|
*** Function: URLDecodes a text string to normal text.
|
|
*** Assume: Uses wwIPStuff.dll
|
|
*** Pass: lcText - Text string to decode
|
|
*** Return: Decoded string or ""
|
|
************************************************************************
|
|
LPARAMETERS lcText
|
|
LOCAL lnSize, lnLoc, lcHex, lcRetval
|
|
|
|
*** Use wwIPStuff for large buffers
|
|
IF LEN(lcText) > 255
|
|
DECLARE INTEGER URLDecode ;
|
|
IN WWIPSTUFF AS API_URLDecode ;
|
|
STRING @cText
|
|
|
|
lnSize=API_URLDecode(@lcText)
|
|
|
|
IF lnSize > 0
|
|
lcText = SUBSTR(lcText,1,lnSize)
|
|
ELSE
|
|
lcText = ""
|
|
ENDIF
|
|
|
|
RETURN lcText
|
|
ENDIF
|
|
|
|
*** First convert + to spaces
|
|
lcText=STRTRAN(lcText,"+"," ")
|
|
|
|
*** Handle Hex Encoded Control chars
|
|
|
|
lcRetval = ""
|
|
DO WHILE .T.
|
|
*** Format: %0A ( CHR(10) )
|
|
lnLoc = AT('%',lcText)
|
|
|
|
*** No Hex chars
|
|
IF lnLoc > LEN(lcText) - 2 OR lnLoc < 1
|
|
lcRetval = lcRetval + lcText
|
|
EXIT
|
|
ENDIF
|
|
|
|
*** Now read the next 2 characters
|
|
*** Check for digits - at this point we must have hex pair!
|
|
lcHex=SUBSTR(lcText,lnLoc+1,2)
|
|
|
|
*** Now concat the string plus the evaled hex code
|
|
lcRetval = lcRetval + LEFT(lcText,lnLoc-1) + ;
|
|
CHR( EVAL("0x"+lcHex) )
|
|
|
|
*** Trim out the input string
|
|
IF LEN(lcText) > lnLoc + 2
|
|
lcText = SUBSTR(lcText,lnLoc+3)
|
|
ELSE
|
|
EXIT
|
|
ENDIF
|
|
ENDDO
|
|
|
|
RETURN lcRetval
|
|
ENDFUNC
|
|
* EOF URLDecode
|
|
|
|
************************************************************************
|
|
FUNCTION GetURLEncodedKey
|
|
*********************************
|
|
*** Function: Retrieves a 'parameter' from the query string that
|
|
*** is encoded with standard CGI/ISAPI URL encoding.
|
|
*** Typical URL encoding looks like this:
|
|
***
|
|
*** "User=Rick+Strahl&ID=0011&Address=400+Morton%0A%0DHood+River"
|
|
***
|
|
*** Pass: lcVal - Form Variable to retrieve
|
|
*** Return: Value or ""
|
|
************************************************************************
|
|
LPARAMETERS tcURLString, lcKey
|
|
LOCAL lnLoc,c2, cStr, lcURLString, lcRetval
|
|
|
|
lcURLString=IIF(EMPTY(tcURLString),"","&"+tcURLString)
|
|
lcKey=IIF(EMPTY(lcKey)," ",lcKey)
|
|
lcKey=STRTRAN(lcKey," ","+")
|
|
|
|
#IF wwVFPVersion > 6
|
|
lcRetval = STREXTRACT(lcUrlString,"&"+lcKey+"=","&",1,3)
|
|
#ELSE
|
|
lcRetval=Extract(@lcUrlString,"&"+lcKey+"=","&",,.T.)
|
|
#ENDIF
|
|
|
|
RETURN URLDecode(lcRetval)
|
|
ENDFUNC
|
|
|
|
|
|
********************************************************
|
|
FUNCTION URLEncode
|
|
*******************
|
|
*** Function: Encodes a string in URL encoded format
|
|
*** for use on URL strings or when passing a
|
|
*** POST buffer to wwIPStuff::HTTPGetEx
|
|
*** Pass: tcValue - String to encode
|
|
*** Return: URLEncoded string or ""
|
|
********************************************************
|
|
LPARAMETER tcValue
|
|
LOCAL lcResult, lcChar, lnSize, lnX
|
|
|
|
*** Large Buffers use the wwIPStuff function
|
|
*** for quicker response
|
|
if LEN(tcValue) > 255
|
|
lnSize=LEN(tcValue)
|
|
tcValue=PADR(tcValue,lnSize * 3)
|
|
|
|
DECLARE INTEGER VFPURLEncode ;
|
|
IN WWIPSTUFF ;
|
|
STRING @cText,;
|
|
INTEGER cInputTextSize
|
|
|
|
lnSize=VFPUrlEncode(@tcValue,lnSize)
|
|
|
|
IF lnSize > 0
|
|
RETURN SUBSTR(TRIM(tcValue),1,lnSize)
|
|
ENDIF
|
|
RETURN ""
|
|
ENDIF
|
|
|
|
*** Do it in VFP Code
|
|
lcResult=""
|
|
|
|
FOR lnX=1 to len(tcValue)
|
|
lcChar = SUBSTR(tcValue,lnX,1)
|
|
IF ATC(lcChar,"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") > 0
|
|
lcResult=lcResult + lcChar
|
|
LOOP
|
|
ENDIF
|
|
IF lcChar=" "
|
|
lcResult = lcResult + "+"
|
|
LOOP
|
|
ENDIF
|
|
*** Convert others to Hex equivalents
|
|
lcResult = lcResult + "%" + RIGHT(transform(ASC(lcChar),"@0"),2)
|
|
ENDFOR && lnX=1 to len(tcValue)
|
|
|
|
RETURN lcResult
|
|
* EOF URLEncode
|
|
|
|
#IF WWC_COMPATIBILITY
|
|
************************************************************************
|
|
FUNCTION WCSCompile
|
|
*******************
|
|
*** Modified: 12/31/97
|
|
*** Function: Compiles WCS script files
|
|
*** Assume: Requires Runtime version
|
|
*** Called by wwMaint using VisualFoxpro.Application
|
|
*** Automation object if Runtime is installed.
|
|
*** Pass: lcFileSpec - Filespec of files to compile
|
|
*** llSilent - No error display
|
|
*** Return: "" on success or Error String
|
|
*************************************************************************
|
|
LPARAMETER lcFileSpec, llSilent
|
|
lcFileSpec=IIF(type("lcFileSpec")="C",lcFileSpec,CURDIR() + "*.wcs")
|
|
|
|
lcPath = justpath(lcFileSpec)
|
|
lcFile = justfname(lcFileSpec)
|
|
|
|
IF EMPTY(lcPath)
|
|
lcPath = CURDIR()
|
|
ENDIF
|
|
IF EMPTY(lcFile)
|
|
lcFile = "*.WCS"
|
|
ENDIF
|
|
lcPath = ADDBS(lcPath)
|
|
|
|
lcFileSpec = lcPath + lcFile
|
|
|
|
|
|
DIMENSION laFiles[1]
|
|
lnFiles = ADIR(laFiles,lcFileSpec)
|
|
IF lnFiles < 1
|
|
RETURN "No files to compile..."
|
|
ENDIF
|
|
oScript = CREATE("wwVFPScript",laFiles[1])
|
|
IF TYPE("oScript") <> "O"
|
|
Return "Error: Couldn't create wwVFPScriptObject"
|
|
ENDIF
|
|
oScript.lDeleteGeneratedCode = .F. && Erase WCT files
|
|
|
|
FOR lnX = 1 to lnFiles
|
|
lcFileName = lcPath+laFiles[lnX,1]
|
|
wait window nowait "Compiling "+lcFileName
|
|
|
|
*** WCS - Script Text WCX - Compiled WCT - Intermediate
|
|
oScript.cFileName = lcFileName
|
|
oScript.ConvertPage()
|
|
oScript.CompilePage()
|
|
ENDFOR
|
|
|
|
wait window nowait LTRIM(STR(lnFiles))+ " Web Connection Script file(s) compiled."
|
|
|
|
lcErrors = ""
|
|
IF !EMPTY(oScript.cCompileErrors)
|
|
File2Var(lcPath + "WCS_Script.err",oScript.cCompileErrors)
|
|
IF !llSilent
|
|
MODI COMM (lcPath + "WCS_Script.err")
|
|
ENDIF
|
|
lcErrors = File2Var(lcPath + "WCS_Script.err")
|
|
ENDIF
|
|
|
|
RETURN lcErrors
|
|
* EOF WCSCompile
|
|
#ENDIF
|
|
|
|
|
|
|
|
|
|
* Pass lnX/YFactor by reference
|
|
FUNCTION TwipsFactor(lnXFactor, lnYFactor)
|
|
LOCAL ln_x_pixels, ln_y_pixels, ln_twips, ln_partial_x, ln_partial_y, ;
|
|
ln_hwnd, ln_hdc
|
|
|
|
*** Calculate the factor to be used in the HitTest method...
|
|
ln_x_pixels = 88
|
|
ln_y_pixels = 90
|
|
ln_twips = 1440
|
|
|
|
DECLARE INTEGER GetActiveWindow IN win32api
|
|
DECLARE INTEGER GetActiveWindow IN win32api
|
|
DECLARE INTEGER GetDC IN win32api INTEGER iHDC
|
|
DECLARE INTEGER GetDeviceCaps IN win32api INTEGER iHDC, INTEGER iIndex
|
|
|
|
ln_hwnd = GetActiveWindow()
|
|
ln_hdc = GetDC(ln_hwnd)
|
|
|
|
ln_partial_x = GetDeviceCaps(ln_hdc, ln_x_pixels)
|
|
ln_partial_y = GetDeviceCaps(ln_hdc, ln_x_pixels)
|
|
|
|
lnXFactor = ln_twips/ln_partial_x
|
|
lnYFactor = ln_twips/ln_partial_y
|
|
RETURN
|
|
|
|
|
|
************************************************************************
|
|
FUNCTION InputForm
|
|
******************
|
|
*** Function: Creates a simple Input form that returns a value
|
|
*** Assume: Consists of this function and Form Class
|
|
*** Pass: lcValue - Initial value to retrieve
|
|
*** lcMessage - The request message
|
|
*** lcCaption - Form Caption (_Screen.Caption)
|
|
*** lnFormWidth Width of the form
|
|
*** lnFieldWidth Widht of the input field
|
|
*** lcFormat Format string for the input field
|
|
*** lcCancelValue Value returned on a Cancel operation
|
|
*** Return: Value or ("" or -1)
|
|
************************************************************************
|
|
LPARAMETER lcValue, lcMessage, lcCaption, lnFormWidth, lnFieldWidth, lcFormat,lcCancelValue
|
|
PRIVATE pcResult
|
|
LOCAL o
|
|
|
|
IF PCOUNT() > 6
|
|
pcCancelValue = lcCancelValue
|
|
ELSE
|
|
pcCancelValue = NULL
|
|
ENDIF
|
|
|
|
lcValue=IIF(EMPTY(lcValue),"",lcValue)
|
|
lcMessage=IIF(EMPTY(lcMessage),"Please enter",lcMessage)
|
|
lcCaption=IIF(EMPTY(lcCaption),_SCREEN.Caption,lcCaption)
|
|
lnFormWidth=IIF(EMPTY(lnFormWidth),300,lnFormWidth)
|
|
lnFieldWidth=IIF(EMPTY(lnFieldWidth),lnFormWidth - 20,lnFieldWidth)
|
|
lcFormat=IIF(EMPTY(lcFormat),"@K",lcFormat)
|
|
|
|
|
|
lcType = VARTYPE(lcCancelValue)
|
|
pcResult = lcValue
|
|
|
|
o=CREATE("frmInput")
|
|
o.Width = lnFormWidth
|
|
o.nFieldWidth = lnFieldWidth
|
|
o.Caption = lcCaption
|
|
o.cMessage = lcMessage
|
|
o.cFormat = lcFormat
|
|
|
|
IF lcFormat = "PASSWORD"
|
|
o.cFormat = "@K"
|
|
o.txtInput.PasswordChar = "*"
|
|
ENDIF
|
|
|
|
|
|
o.Show()
|
|
|
|
IF TYPE("pcResult")="C"
|
|
lcValue = TRIM(pcResult)
|
|
ELSE
|
|
lcValue = pcResult
|
|
ENDIF
|
|
RETURN lcValue
|
|
|
|
|
|
**************************************************
|
|
*-- Form: frminput
|
|
*-- ParentClass: form
|
|
*-- BaseClass: form
|
|
DEFINE CLASS frminput AS form
|
|
nFieldWidth = 250
|
|
cMessage = "Please enter:"
|
|
cFormat = ""
|
|
|
|
Top = 0
|
|
Left = 0
|
|
Height = 90
|
|
Width = 300
|
|
ControlBox = .F.
|
|
Name = "frmInput"
|
|
WindowType = 1
|
|
AutoCenter = .t.
|
|
Showwindow = 1
|
|
BorderStyle = 2
|
|
MinButton = .f.
|
|
ShowWindow = 1
|
|
MaxButton = .f.
|
|
|
|
ADD OBJECT lblMessage AS label WITH ;
|
|
AutoSize = .T., ;
|
|
Caption = "Message Text:", ;
|
|
Height = 17, ;
|
|
Left = 7, ;
|
|
Top = 11, ;
|
|
Width = 81, ;
|
|
Name = "lblMessage",;
|
|
Font = "Tahoma" ,;
|
|
FontSize = 8
|
|
|
|
ADD OBJECT txtinput AS textbox WITH ;
|
|
ControlSource = "pcResult", ;
|
|
Height = 22, ;
|
|
Left = 5, ;
|
|
Top = 28, ;
|
|
Width = 373, ;
|
|
Name = "txtInput",;
|
|
Font = "Tahoma" ,;
|
|
Default = .T.,;
|
|
FontSize = 8
|
|
ADD OBJECT cmdOk AS commandbutton WITH ;
|
|
Top = 55, ;
|
|
Left = THISFORM.width - 150, ;
|
|
Height = 25, ;
|
|
Width = 70, ;
|
|
Caption = "OK", ;
|
|
Default = .T., ;
|
|
Fontname="Tahoma",;
|
|
Fontsize = 8,;
|
|
Cancel = .F.,;
|
|
Name = "cmdOK"
|
|
|
|
ADD OBJECT cmdCancel AS commandbutton WITH ;
|
|
Top = 55, ;
|
|
Left = THISFORM.Width - 75, ;
|
|
Height = 25, ;
|
|
Width = 70, ;
|
|
Caption = "\<Cancel", ;
|
|
Fontname="Tahoma",;
|
|
Fontsize = 8,;
|
|
Cancel = .T.,;
|
|
Name = "cmdCancel"
|
|
|
|
PROCEDURE Show
|
|
THIS.Icon = _Screen.icon
|
|
THIS.txtInput.Width = THIS.nFieldWidth
|
|
THIS.lblMessage.Caption = THIS.cMessage
|
|
THIS.cmdCancel.Left = THISFORM.Width - 85
|
|
THIS.cmdOk.Left = THISFORM.Width - 157
|
|
IF !EMPTY(THIS.cFormat)
|
|
IF ATC("@",THIS.cFormat) > 0
|
|
THIS.txtInput.Format = THIS.cFormat
|
|
ELSE
|
|
THIS.txtInput.InputMask = THIS.cFormat
|
|
ENDIF
|
|
ENDIF
|
|
ENDPROC
|
|
PROCEDURE cmdOk.Click
|
|
RELEASE THISFORM
|
|
ENDPROC
|
|
PROCEDURE cmdCancel.Click
|
|
LOCAL lcType
|
|
|
|
IF ISNULL(pcCancelValue)
|
|
lcType = TYPE("pcResult")
|
|
DO CASE
|
|
CASE lcType $ "CM"
|
|
pcResult = ""
|
|
CASE lcType $ "NIBY"
|
|
pcResult = -99999999
|
|
CASE lcType $ "DT"
|
|
pcResult = {}
|
|
CASE lcType = "L"
|
|
pcResult = .f.
|
|
ENDCASE
|
|
ELSE
|
|
pcResult = pcCancelValue
|
|
ENDIF
|
|
RELEASE THISFORM
|
|
ENDPROC
|
|
ENDDEFINE
|
|
*
|
|
*-- EndDefine: frminput
|
|
**************************************************
|
|
|
|
|
|
**************************************************
|
|
FUNCTION IsCOMObject
|
|
*********************
|
|
*** Function: Checks to see if a COM object
|
|
*** or ActiveX control exists
|
|
*** Assume: Uses wwAPI
|
|
*** Pass: lcProgId - Prog Id of the Class
|
|
*** lcClassId - (Optional) If passed in
|
|
*** by reference gets ClassId
|
|
*** lcClassDescript - (Optional) by ref
|
|
*** Return: .T. or .F.
|
|
*****************************************************
|
|
LPARAMETER lcProgId,lcClassId, lcClassDescript
|
|
|
|
IF EMPTY(lcProgId)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
loAPI = CREATE("wwAPI")
|
|
|
|
*** Retrieve ClassId and Server Name
|
|
lcClassId = ;
|
|
loAPI.ReadRegistryString(HKEY_CLASSES_ROOT,;
|
|
lcProgId + "\CLSID",;
|
|
"")
|
|
IF ISNULL(lcClassId)
|
|
lcClassId = ""
|
|
lcClassDescription = ""
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
lcClassDescript = ;
|
|
loAPI.ReadRegistryString(HKEY_CLASSES_ROOT,;
|
|
lcProgId,"")
|
|
|
|
IF ISNULL(lcClassDescript)
|
|
lcClassDescript = ""
|
|
ENDIF
|
|
|
|
RETURN .T.
|
|
*
|
|
FUNCTION CopyObject
|
|
LPARAMETERS loinput
|
|
LOCAL loobject, lafields[1], lnx, lcfield, lctype, llclass, lncount, z, lnlength
|
|
IF TYPE("loInput.Class") = "C"
|
|
loobject = CREATEOBJECT(loinput.CLASS)
|
|
ELSE
|
|
loobject = CREATEOBJECT("EMPTY")
|
|
ENDIF
|
|
lncount = AMEMBERS(lafields, loinput)
|
|
FOR lnx = 1 TO lncount
|
|
lcfield = LOWER(lafields(lnx))
|
|
IF AT("," + lcfield + ",", "'" + ",activecontrol,classlibrary,baseclass,comment,controls,objects,controlcount," + "class,name,parent,parentalias,parentclass,helpcontextid,whatsthishelpid," + "width,height,top,left,tag,picture,onetomany,childalias,childorder,relationalexpr,timestamp_column,") > 0
|
|
LOOP
|
|
ENDIF
|
|
lctype = TYPE("loInput." + lcfield)
|
|
DO CASE
|
|
CASE TYPE('ALEN(loInput.' + lcfield + ')') = "N"
|
|
IF TYPE("loObject." + lcfield) = "U"
|
|
*!_err=0x1A0A_!(loobject, lcfield + "[1]")
|
|
ENDIF
|
|
lnlength = ALEN(loinput.&lcfield)
|
|
DIMENSION loobject.&lcfield[lnLength]
|
|
FOR z = 1 TO lnlength
|
|
IF TYPE("loInput." + lcfield + "[z]") = "O"
|
|
loobject.&lcfield[z] = CopyObject(EVAL( "loInput." + lcfield + "[z]"))
|
|
ELSE
|
|
loobject.&lcfield[z] = EVAL("loInput." + lcfield)
|
|
ENDIF
|
|
ENDFOR
|
|
CASE lctype = "O"
|
|
IF TYPE("loObject." + lcfield) = "U"
|
|
*!_err=0x1A0A_!(loobject, lcfield)
|
|
ENDIF
|
|
loobject.&lcfield = CopyObject(EVAL("loInput."+lcfield))
|
|
OTHERWISE
|
|
IF TYPE("loObject." + lcfield) = "U"
|
|
*!_err=0x1A0A_!(loobject, lcfield)
|
|
ENDIF
|
|
loobject.&lcfield = EVAL("loInput." + lcfield)
|
|
ENDCASE
|
|
ENDFOR
|
|
RETURN loobject
|
|
ENDFUNC
|
|
*
|
|
PROCEDURE CopyObjectProperties
|
|
LPARAMETERS loinput, loobject, lnobjectstructureobject
|
|
IF (EMPTY(lnobjectstructureobject))
|
|
lnobjectstructure = 1
|
|
ENDIF
|
|
IF lnobjectstructureobject = 1
|
|
lncount = AMEMBERS(lafields, loinput)
|
|
ELSE
|
|
lncount = AMEMBERS(lafields, loobject)
|
|
ENDIF
|
|
FOR lnx = 1 TO lncount
|
|
lcfield = LOWER(lafields(lnx))
|
|
IF AT("," + lcfield + ",", "'" + ",activecontrol,classlibrary,baseclass,comment,controls,objects,controlcount," + "class,name,parent,parentalias,parentclass,helpcontextid,whatsthishelpid," + "width,height,top,left,tag,picture,onetomany,childalias,childorder,relationalexpr,timestamp_column,") > 0
|
|
LOOP
|
|
ENDIF
|
|
lctype = TYPE("loInput." + lcfield)
|
|
IF lctype = "O" .OR. lctype = "U" .OR. TYPE('ALEN(loInput.' + lcfield + ')') = "N"
|
|
LOOP
|
|
ENDIF
|
|
IF lnobjectstructureobject = 1
|
|
IF TYPE("loObject." + lcfield) = "U"
|
|
LOOP
|
|
ENDIF
|
|
ELSE
|
|
IF TYPE("loInput." + lcfield) = "U"
|
|
LOOP
|
|
ENDIF
|
|
ENDIF
|
|
*_**BA=?? 730
|
|
loobject.&lcfield = EVAL("loInput." + lcfield)
|
|
*!_err=0xBB_! 738
|
|
*!_err=0xBE_!
|
|
DO CASE
|
|
CASE TYPE('ALEN(loInput.' + lcfield + ')') = "N"
|
|
CASE lctype = "O"
|
|
OTHERWISE
|
|
ENDCASE
|
|
ENDFOR
|
|
ENDPROC
|
|
|
|
FUNCTION CacheFile
|
|
LPARAMETER lcFilename, lnRefreshseconds
|
|
LOCAL lcOutput, lnHandle
|
|
lcAlias = ALIAS()
|
|
IF USED("wwFileCache")
|
|
SELECT wwFilecache
|
|
ELSE
|
|
CREATE CURSOR wwFileCache (fiLename C (120), tiMeread T, coNtent M)
|
|
ENDIF
|
|
LOCATE FOR fiLename=LOWER(lcFilename)
|
|
IF FOUND()
|
|
IF lnRefreshseconds>0 .AND. wwFilecache.tiMeread<DATETIME()- ;
|
|
lnRefreshseconds
|
|
REPLACE coNtent WITH fiLe2var(lcFilename), tiMeread WITH DATETIME()
|
|
ENDIF
|
|
lcOutput = coNtent
|
|
ELSE
|
|
lcOutput = fiLe2var(lcFilename)
|
|
INSERT INTO wwFileCache (fiLename, tiMeread, coNtent) VALUES ;
|
|
(LOWER(lcFilename), DATETIME(), lcOutput)
|
|
ENDIF
|
|
IF .NOT. EMPTY(lcAlias)
|
|
SELECT (lcAlias)
|
|
ENDIF
|
|
RETURN lcOutput
|
|
ENDFUNC
|
|
*
|
|
PROCEDURE WrCursor
|
|
PARAMETER pcNewname
|
|
PRIVATE lcOldalias
|
|
lcOldalias = ALIAS()
|
|
SELECT (lcOldalias)
|
|
lcDbf = DBF(lcOldalias)
|
|
IF USED(pcNewname)
|
|
USE IN (pcNewname)
|
|
ENDIF
|
|
USE (lcDbf) AGAIN ALIAS (pcNewname) IN 0
|
|
USE IN (lcOldalias)
|
|
SELECT (pcNewname)
|
|
RETURN
|
|
ENDPROC
|
|
|
|
FUNCTION CursorToObjectArray
|
|
LPARAMETER lcObjname
|
|
LOCAL lnX, laLitems[1]
|
|
IF .NOT. EMPTY(lcObjname)
|
|
loResult = CREATEOBJECT("lcObjName")
|
|
ELSE
|
|
loResult = CREATEOBJECT("RELATION")
|
|
loResult.adDproperty("nCount")
|
|
loResult.adDproperty("aRows(1)",1)
|
|
ENDIF
|
|
lnX = 0
|
|
SCAN
|
|
lnX = lnX+1
|
|
DIMENSION loResult.arOws[lnX]
|
|
SCATTER MEMO NAME loResult.arOws[lnX]
|
|
ENDSCAN
|
|
loResult.ncOunt = lnX
|
|
RETURN loResult
|
|
ENDFUNC
|
|
*
|
|
FUNCTION RegisterOleServer
|
|
LPARAMETER lcServerpath, llUnregister, llSilent
|
|
LOCAL llRetval, lcPath, lcOldpath
|
|
IF .NOT. FILE(lcServerpath)
|
|
RETURN .F.
|
|
ENDIF
|
|
llRetval = .F.
|
|
IF .NOT. llUnregister
|
|
lcOldpath = SYS(5)+CURDIR()
|
|
lcPath = JUSTPATH(lcServerpath)
|
|
CD (lcPath)
|
|
DECLARE INTEGER DllRegisterServer IN (lcServerpath)
|
|
IF dlLregisterserver()=0
|
|
IF .NOT. llSilent
|
|
WAIT WINDOW NOWAIT lcServerpath+" has been registered..."
|
|
ENDIF
|
|
llRetval = .T.
|
|
ELSE
|
|
WAIT WINDOW TIMEOUT 5 lcServerpath+" could not be registered..."
|
|
ENDIF
|
|
CD (lcOldpath)
|
|
ELSE
|
|
DECLARE INTEGER DllUnregisterServer IN (lcServerpath)
|
|
IF dlLunregisterserver()=0
|
|
IF .NOT. llSilent
|
|
WAIT WINDOW NOWAIT lcServerpath+" has been unregistered..."
|
|
ENDIF
|
|
llRetval = .T.
|
|
ENDIF
|
|
ENDIF
|
|
RETURN llRetval
|
|
ENDFUNC
|
|
*
|
|
FUNCTION DCOMCnfgServer
|
|
LPARAMETER lcProgid, lcRunas, lcPassword
|
|
LOCAL lcProgid, loApi, lcClassid, lcServername
|
|
lcRunas = IIF(TYPE("lcRunAs")="C", lcRunas, "Interactive User")
|
|
lcProgid = IIF(TYPE("lcProgId")="C", lcProgid, "")
|
|
lcPassword = IIF(EMPTY(lcPassword), "", lcPassword)
|
|
loApi = CREATEOBJECT("wwAPI")
|
|
lcClassid = loApi.reAdregistrystring(-2147483648,lcProgid+"\CLSID","")
|
|
lcServername = loApi.reAdregistrystring(-2147483648,lcProgid+"","")
|
|
IF ISNULL(lcClassid) .OR. ISNULL(lcServername)
|
|
WAIT WINDOW NOWAIT "Invalid Class Id..."
|
|
RETURN
|
|
ENDIF
|
|
WAIT WINDOW NOWAIT "Configuring server security for "+CHR(13)+CHR(10)+ ;
|
|
lcProgid+CHR(13)+CHR(10)+lcServername
|
|
IF .NOT. EMPTY(lcPassword)
|
|
IF .NOT. FILE("dcompermissions.exe")
|
|
WAIT WINDOW TIMEOUT 5 "Couldn't find dcompermissions.exe..."
|
|
RETURN
|
|
ENDIF
|
|
lcPath = FULLPATH("dcompermissions.exe")
|
|
lcPath = shOrtpath(lcPath)
|
|
lcCmd = "RUN "+lcPath+" -runas "+lcClassid+" "+lcRunas+" "+ ;
|
|
lcPassword+" > dcom.txt"
|
|
&lcCMD
|
|
lcResult = FILETOSTR("DCOM.TXT")
|
|
ERASE DCOM.TXT
|
|
IF .NOT. EMPTY(lcResult) .AND. ATC("ERROR:", lcResult)>0
|
|
MESSAGEBOX(lcProgid+CHR(13)+"Account: "+lcUsername+CHR(13)+ ;
|
|
CHR(13)+lcResult, 48, "DCOM Permissions")
|
|
RETURN .F.
|
|
ENDIF
|
|
ELSE
|
|
IF .NOT. loApi.wrIteregistrystring(-2147483646, ;
|
|
"SOFTWARE\Classes\CLSID\"+lcClassid,"AppId",lcClassid,.T.)
|
|
WAIT WINDOW NOWAIT "Unable to write AppID value..."
|
|
RETURN
|
|
ENDIF
|
|
IF .NOT. loApi.wrIteregistrystring(-2147483648,"AppID\"+lcClassid, ;
|
|
CHR(0),CHR(0),.T.)
|
|
WAIT WINDOW NOWAIT "Unable to write AppID key..."
|
|
RETURN
|
|
ENDIF
|
|
loApi.wrIteregistrystring(-2147483648,"AppID\"+lcClassid,"", ;
|
|
lcServername,.T.)
|
|
loApi.wrIteregistrystring(-2147483648,"AppID\"+lcClassid,"RunAs", ;
|
|
lcRunas,.T.)
|
|
ENDIF
|
|
WAIT WINDOW NOWAIT "DCOM security context set to: "+lcRunas
|
|
RETURN
|
|
ENDFUNC
|
|
*
|
|
FUNCTION DCOMLaunchPermissions
|
|
LPARAMETER lcProgid, lcUsername, lcErrormsg
|
|
IF .NOT. EMPTY(lcProgid)
|
|
lcClassid = ""
|
|
llResult = isComobject(lcProgid,@lcClassid)
|
|
IF EMPTY(lcClassid)
|
|
WAIT WINDOW "Invalid Prog ID"
|
|
RETURN .F.
|
|
ENDIF
|
|
ELSE
|
|
lcClassid = ""
|
|
ENDIF
|
|
lcPath = FULLPATH("dcompermissions.exe")
|
|
lcPath = shOrtpath(lcPath)
|
|
IF EMPTY(lcClassid)
|
|
lcCmd = "RUN "+lcPath+" -da "+lcClassid+" set "+lcUsername+ ;
|
|
" permit > dcom.txt"
|
|
_CLIPTEXT = lcCmd
|
|
ELSE
|
|
lcCmd = "RUN "+lcPath+" -aa "+lcClassid+" set "+lcUsername+ ;
|
|
" permit > dcom.txt"
|
|
_CLIPTEXT = lcCmd
|
|
ENDIF
|
|
&lcCMD
|
|
lcResult = FILETOSTR("DCOM.TXT")
|
|
ERASE DCOM.TXT
|
|
IF .NOT. EMPTY(lcResult) .AND. ATC("ERROR:", lcResult)>0
|
|
MESSAGEBOX(lcProgid+CHR(13)+"Account: "+lcUsername+CHR(13)+CHR(13)+ ;
|
|
lcResult, 48, "DCOM Permissions")
|
|
RETURN .F.
|
|
ENDIF
|
|
IF EMPTY(lcClassid)
|
|
lcCmd = "RUN "+lcPath+" -dl "+lcClassid+" set "+lcUsername+ ;
|
|
" permit > dcom.txt"
|
|
_CLIPTEXT = lcCmd
|
|
ELSE
|
|
lcCmd = "RUN "+lcPath+" -al "+lcClassid+" set "+lcUsername+ ;
|
|
" permit > dcom.txt"
|
|
_CLIPTEXT = lcCmd
|
|
ENDIF
|
|
&lcCMD
|
|
lcResult = FILETOSTR("DCOM.TXT")
|
|
ERASE DCOM.TXT
|
|
IF .NOT. EMPTY(lcResult) .AND. ATC("ERROR:", lcResult)>0
|
|
MESSAGEBOX(lcProgid+CHR(13)+"Account: "+lcUsername+CHR(13)+CHR(13)+ ;
|
|
lcResult, 48, "DCOM Permissions")
|
|
RETURN .F.
|
|
ENDIF
|
|
RETURN
|
|
ENDFUNC
|
|
*
|
|
FUNCTION FixPreTags
|
|
LPARAMETER lcHtml, lnColwidth
|
|
LOCAL lcPre, lcFixed, lcPrecount, lnAt1, lnAt2
|
|
lnPrecount = 1
|
|
DO WHILE .T.
|
|
lnAt1 = ATC("<pre", lcHtml, lnPrecount)
|
|
lnAt2 = ATC("/pre>", lcHtml, lnPrecount)
|
|
IF lnAt1=0 .OR. lnAt2=0
|
|
EXIT
|
|
ENDIF
|
|
lcPre = SUBSTR(lcHtml, lnAt1, lnAt2-lnAt1)
|
|
lcFixed = STRTRAN(lcPre, "<p>", CHR(13)+CHR(10)+CHR(13)+CHR(10))
|
|
lcFixed = STRTRAN(lcFixed, "<br>", CHR(13)+CHR(10))
|
|
lcHtml = STRTRAN(lcHtml, lcPre, lcFixed)
|
|
lnPrecount = lnPrecount+1
|
|
ENDDO
|
|
RETURN lcHtml
|
|
ENDFUNC
|
|
*
|
|
FUNCTION FixHTMLForDisplay
|
|
LPARAMETER lcHtml
|
|
lcHTML = STRTRAN(lcHTML,"<","<")
|
|
lcHTML = STRTRAN(lcHTML,">",">")
|
|
lcHTML = STRTRAN(lcHTML,["],""")
|
|
RETURN lcHtml
|
|
ENDFUNC
|
|
*
|
|
FUNCTION DisplayMemo
|
|
LPARAMETER lcHtml
|
|
lcHtml = STRTRAN(lcHtml, CHR(13)+CHR(10), CHR(13))
|
|
lcHtml = STRTRAN(lcHtml, CHR(10), CHR(13))
|
|
lcHtml = STRTRAN(lcHtml, CHR(13)+CHR(13), "<p>")
|
|
RETURN STRTRAN(lcHtml, CHR(13), "<br>")
|
|
ENDFUNC
|
|
*
|
|
FUNCTION GetSystemPassword
|
|
LPARAMETER llUsername
|
|
loApi = NEWOBJECT("wwAPI", "wwapi.prg")
|
|
IF .NOT. llUsername
|
|
lcPass = loApi.reAdregistrystring("HKLM", ;
|
|
"SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", ;
|
|
"DefaultPassword")
|
|
ELSE
|
|
lcPass = loApi.reAdregistrystring("HKLM", ;
|
|
"SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", ;
|
|
"DefaultUserName")
|
|
ENDIF
|
|
IF ISNULL(lcPass)
|
|
RETURN ""
|
|
ENDIF
|
|
RETURN lcPass
|
|
ENDFUNC
|
|
*
|
|
FUNCTION GetPassword
|
|
LPARAMETER lcMessage
|
|
IF EMPTY(lcMessage)
|
|
lcMessage = "Please enter your password"
|
|
ENDIF
|
|
RETURN inPutform(SPACE(20),lcMessage,"Password Entry", , ,"PASSWORD")
|
|
ENDFUNC
|
|
*
|
|
FUNCTION IsDotNet
|
|
LPARAMETER lcFrameworkpath, lcVersion
|
|
LOCAL loApi, as, wwApi
|
|
lcVersion = ""
|
|
lcFrameworkpath = ""
|
|
loApi = CREATEOBJECT("wwAPI")
|
|
lcWindir = loApi.geTsystemdir(.T.)
|
|
lcVersion = loApi.reAdregistrystring(-2147483646, ;
|
|
"Software\Microsoft\ASP.Net","RootVer")
|
|
IF ISNULL(lcFrameworkpath)
|
|
RETURN .F.
|
|
ENDIF
|
|
lcFrameworkpath = ADDBS(loApi.reAdregistrystring(-2147483646, ;
|
|
"Software\Microsoft\ASP.Net\"+lcVersion,"Path"))
|
|
RETURN .T.
|
|
ENDFUNC
|
|
*
|
|
FUNCTION MergeText
|
|
LPARAMETER tcString, tcDelimiter, tcDelimiter2, llNoaspsyntax
|
|
LOCAL __Loeval
|
|
__Loeval = CREATEOBJECT('wwEval')
|
|
RETURN __Loeval.meRgetext(@tcString,tcDelimiter,tcDelimiter2,llNoaspsyntax)
|
|
ENDFUNC
|
|
*
|
|
FUNCTION MimeDateTime
|
|
LPARAMETER lvDatetime
|
|
LOCAL lcDays, lcMonths, lnCount, lcMonth, ltTime, lnOffset, lnOff, lnDiff
|
|
lcMonths = "JanFebMarAprMayJunJulAugSepOctNovDec"
|
|
IF VARTYPE(lvDatetime)="C"
|
|
DIMENSION laParts[1]
|
|
lnCount = apArsestring(@laParts,lvDatetime," ")
|
|
IF lnCount<5
|
|
RETURN {}
|
|
ENDIF
|
|
lcMonth = TRANSFORM((ATC(laParts(3), lcMonths)+2)/3)
|
|
ltTime = CTOT(lcMonth+"/"+laParts(2)+"/"+laParts(4)+" "+laParts(5))
|
|
IF lnCount<6
|
|
RETURN ltTime
|
|
ENDIF
|
|
lnOffset = geTtimezone()/60
|
|
lnOff = VAL(laParts(6))/100
|
|
lnDiff = (lnOffset+lnOff)*3600
|
|
RETURN ltTime-lnDiff
|
|
ELSE
|
|
IF EMPTY(lvDatetime)
|
|
lvDatetime = DATETIME()
|
|
ENDIF
|
|
lnDay = DOW(lvDatetime)
|
|
IF lnDay=0
|
|
RETURN ""
|
|
ENDIF
|
|
lcDays = "SunMonTueWedThuFriSat"
|
|
lcMime = SUBSTR(lcDays, ((lnDay-1)*3)+1, 3)+", "+ ;
|
|
TRANSFORM(DAY(lvDatetime))+" "
|
|
lcMime = lcMime+SUBSTR(lcMonths, ((MONTH(lvDatetime)-1)*3)+1, 3)+ ;
|
|
" "+TRANSFORM(YEAR(lvDatetime))+" "+PADL(HOUR(lvDatetime), ;
|
|
2, "0")+":"+PADL(MINUTE(lvDatetime), 2, "0")+":"+ ;
|
|
PADL(SEC(lvDatetime), 2, "0")
|
|
lnOffset = geTtimezone()/60
|
|
RETURN lcMime+IIF(lnOffset>0, " -", " +")+ ;
|
|
PADL(TRANSFORM(ABS(lnOffset)), 2, "0")+"00"
|
|
ENDIF
|
|
ENDFUNC
|
|
*
|
|
FUNCTION PropertyDump
|
|
LPARAMETER loObject
|
|
LOCAL lnX, lnCount, lcOutput
|
|
lnCount = AMEMBERS(laFields, loObject)
|
|
lcOutput = ""
|
|
FOR lnX = 1 TO lnCount
|
|
lcType = TYPE("loObject."+laFields(lnX))
|
|
IF ATC(lcType, "UO")=0
|
|
lvValue = EVALUATE("loObject."+laFields(lnX))
|
|
IF lcType="C" .AND. LEN(lvValue)>80
|
|
lvValue = LEFT(lvValue, 80)
|
|
ENDIF
|
|
lcOutput = lcOutput+CHR(13)+CHR(10)+LOWER(laFields(lnX))+" = "+ ;
|
|
ALLTRIM(TRANSFORM(lvValue, ""))
|
|
ELSE
|
|
lcOutput = lcOutput+CHR(13)+CHR(10)+LOWER(laFields(lnX))+" = "+ ;
|
|
IIF(TYPE("loObject."+laFields(lnX))="O", "Object", ;
|
|
"NULL")
|
|
ENDIF
|
|
ENDFOR
|
|
RETURN lcOutput
|
|
ENDFUNC
|
|
*
|