Skip to content

Instantly share code, notes, and snippets.

@mattslay

mattslay/msUtils.prg

Last active Oct 17, 2016
Embed
What would you like to do?
Matt Slay general FoxPro utils, aka msUtils
*=======================================================================================
Functions:
AddCR
AddSpace
AddWorkingDays
BuildHtmlPage
cd
CloseCursor
ConvertTimeStringToDecmalHours
ConveretoDate
CreateCursorFromObject
CreaeeDaceTime
CurrenttimelnDecimal
CursorToHTML
DateSering
Displaypach
EvlOrNvl
Exist
GetRestoreWorkAreaObject
GW_CHILD
GW_HWNDNEXT
IsInteger
IsObject
IsString
IsWholeNumber
ListProcesses
NumberOfDecimals
OutputToConsole
RestoreWorkArea AS Cuscom
SetBorder
StringOf
TimeIn24HourCloclcFormac
TimeinClockFormae
WM_CLOSE
WorkinoDaysBetweentwoDates
_classlib
_dir
_path
_procedure
*=======================================================================================
Function Exists(tcExpression)
Try
luValue = Evaluate(tcExpression)
llReturn = .t.
Catch
llReturn = .f.
EndTry
Endfunc
Function SetBorder(toContainer, tnBorderWidth, tnBorderColor)
toContainer.BorderWidth = Evl(tnBorderWidth, 0)
If !Empty(tnBorderColor)
toContainer.BorderColor = tnBorderColor
Endif
Endfunc
*----------------------------------------------------------------------------------
*-- 2008-09-04 M. Slay
*-- Adds a space to the end of a String
*-- Can Handle .null. values
*----------------------------------------------------------------------------------
Function AddSpace(PassedValue)
If Isnull(PassedValue) Or Empty(PassedValue)
Return ''
Else
Return Alltrim(PassedValue) + ' '
Endif
Endfunc
*----------------------------------------------------------------------------------
*-- 2008-12-01 M. Slay
*-- Adds a Carriage Return to the end of a string
*-- Can Handle .null. values
*----------------------------------------------------------------------------------
Function AddCR(PassedValue)
If Isnull(PassedValue) Or Empty(PassedValue)
Return ''
Else
Return Alltrim(PassedValue) + Chr(13)
Endif
Endfunc
*=======================================================================================
Function EvlOrNvl(tuValue, tuDefault)
If Empty(tuValue) or IsNull(tuValue)
Return tuDefault
Else
Return tuValue
Endif
Endfunc
*===============================================================================================
Function CurrentTimeInDecimal
*---Determine current time in decimal format -----
Local lcTime, lnCurrentTime, lnDecimalHrs, lnHrs
lcTime = Time()
*-- Want this as in integer with no decimals. It the whole number of the current Hour.
lnHrs = Val(Substr(lcTime, 1, 2))
lnHrs = Cast(lnHrs as I)
*-- Want this as 2 place decimal -----------------
lnDecimalHrs = Val(Substr(lcTime, 4, 2)) / 60.0
lnDecimalHrs = Cast(lnDecimalHrs as F(5,2))
lnCurrentTime = lnHrs + lnDecimalHrs
Return lnCurrentTime
Endproc
*---------------------------------------------------------------------------------------
*-- Accepts a string in "XX:XX" in 24-hour format.
*-- Returns a number in decimal hours.
*-- Ex: "14:30" returns 14.50
*-- Ex: "14:30:11" returns 14.50 (Seconds are ignored)
Function ConvertTimeStringToDecimalHours(tcTimeString)
Local lnHours, lnMinutes, lnTimeInDecimalFormat
If Empty(tcTimeString)
Return 0
Endif
If Vartype(tcTimeString) = "C" and ":" $ tcTimeString
lnHours = Val(GetWordNum(tcTimeString, 1, ":"))
lnMinutes = Val(GetWordNum(tcTimeString, 2, ":")) / 60
lnTimeInDecimalFormat = lnHours + lnMinutes
Else
Return -1
EndIf
Return lnTimeInDecimalFormat
Endfunc
*----------------------------------------------------------------------------------
*-- Expects a time in XX.XX decimal number format or a string in "XX:XX" in 24-hour format.
*-- Converts to "XX:XX a.m." or "XX:XX p.m." 12 hour formatted string
Function TimeInClockFormat(tnTimeInDecimalFormat)
Local lcTimeInClockFormat, lcHour, lcMin, lcAmPm
*-- Convert "XX:XX" 24 hour string to a decimal hour
If Vartype(tnTimeInDecimalFormat) = "C" and ":" $ tnTimeInDecimalFormat
tnTimeInDecimalFormat = ConvertTimeStringToDecimalHours(tnTimeInDecimalFormat)
Endif
*-- Start time in clock format ----
If tnTimeInDecimalFormat >= 13
lcHour = Alltrim(Str(Int(tnTimeInDecimalFormat - 12)))
Else
lcHour = Alltrim(Str(Int(tnTimeInDecimalFormat)))
Endif
lcMin = Alltrim(Str((tnTimeInDecimalFormat - Int(tnTimeInDecimalFormat)) * 60))
If Len(lcMin) = 1
lcMin = '0' + lcMin
Endif
lcTimeInClockFormat = Padl(lcHour + ':' + lcMin, 5)
lcAmPm = Iif(tnTimeInDecimalFormat < 12, " a.m.", " p.m.")
lcTimeInClockFormat = lcTimeInClockFormat + lcAmPm
Return lcTimeInClockFormat
EndFunc
*----------------------------------------------------------------------------------
*-- Expects a time in XX.XX decimal number format or a string in "XX:XX" in 24-hour format.
*-- Converts to "XX:XX a.m." or "XX:XX p.m." 12 hour formatted string
Function TimeIn24HourClockFormat(tnTimeInDecimalFormat)
Local lcTimeInClockFormat, lcHour, lcMin, lcAmPm
*-- Convert "XX:XX" 24 hour string to a decimal hour
If Vartype(tnTimeInDecimalFormat) = "C" and ":" $ tnTimeInDecimalFormat
tnTimeInDecimalFormat = ConvertTimeStringToDecimalHours(tnTimeInDecimalFormat)
Endif
*-- Get Decimal number of time
lcHour = Alltrim(Str(Int(tnTimeInDecimalFormat)))
lcMin = Alltrim(Str((tnTimeInDecimalFormat - Int(tnTimeInDecimalFormat)) * 60))
lcMin = Padl(lcMin, 2, '0')
lcTimeInClockFormat = Padl(lcHour + ':' + lcMin, 5)
Return lcTimeInClockFormat
Endfunc
*------------------------------------------------------------------------------------------
Procedure Displaypath
Local lcPath, crlf
crlf = Chr(13)
lcPath = Strtran(Set('PATH'), ';', crlf + ' ', 1)
lcPath = Strtran(lcPath, ',', crlf + ' ', 1)
?Alltrim(lcPath)
Messagebox(lcPath)
Endproc
*--------------------------------------------------------------------------------------
Procedure StringOf(tuInput)
Return Iif(!Empty(tuInput), tuInput, '')
Endproc
*-----------------------------------------------------------------------------------------
Function CursorToHTML(tcAlias, tcTableId, tcTableClass, tcZeroString)
* Generates an HTML table from a Foxpro table or cursor.
* The resulting string is a formatted HTML table which can be inserted into a web page. Each column represents
* a field from the cursor. The first row contains the field names (in proper case, with underscores converted to spaces).
*
* Original code from : http://www.ml-consult.co.uk/foxst-13.htm
* Modifications by Matt Slay, 2011
* Check the parameters (these two lines require SET ASSERT ON)
Local lcCell, lcColHead, lcHtml, lnI, lnRecno, lnSelect
lcCRLF = Chr(13) + Chr(10)
Assert Pcount() > 0 Message "Parameter required"
Assert Used(tcAlias) Message "Alias " + tcAlias + " not found"
lnSelect = Select()
Select (tcAlias)
lnRecno = Recno()
tcTableId = Evl(tcTableId, '')
tcTableClass = Evl(tcTableClass, '')
If Vartype(tcZeroString) = 'C' and Empty(tcZeroString)
tcZeroString = '&nbsp;'
Else
tcZeroString = '0'
Endif
*-- Define the table -------------
lcHtml = lcCRLF
lcHtml = lcHtml + '<TABLE id = "' + tcTableId + '" class="' + tcTableClass + '">'
*-- Create <th> column headings from field names ---
lcHtml = lcHtml + "<TR>"
For lnI = 1 To Fcount()
lcColHead = Proper(Strtran(Field(lnI), "_", " "))
lcHtml = lcHtml + "<TH>" + lcColHead + "</TH>"
Endfor
lcHtml = lcHtml + "</TR>"
lcHtml = lcHtml + lcCRLF
*-- Scan the cursor, creating a row for each record
Scan
lcHtml = lcHtml + "<TR>"
For lnI = 1 To Fcount()
lcCell = Alltrim(Transform(Evaluate(Fields(lnI))))
If lcCell == '0'
lcCell = tcZeroString
Endif
lcHtml = lcHtml + "<TD>" + lcCell + "</TD>"
Endfor
lcHtml = lcHtml + "</TR>"
lcHtml = lcHtml + lcCRLF
EndScan
lcHtml = lcHtml + "</TABLE>" && End the table
Try
Goto lnRecno
Catch
EndTry
Select(lnSelect)
*lcHtml = Chrtran(lcHtml, Chr(13)+Chr(10), Chr(13))
*lcHtml = Chrtran(lcHtml, Chr(13), Chr(13)+Chr(10))
Return lcHtml
Endfunc
*-----------------------------------------------------------------------------------------
* tcCss and tcJavascript parameters can be file references or actual css/javascript code
Procedure BuildHtmlPage(tcBody, tcCss, tcJavascript)
Local lcBody, lcCss, lcHtml, lcJavascript, lcJquery, lcScriptToReferencejQuery
lcScriptToReferencejQuery = "script_to_load_jquery.html"
lcCss = ""
lcJquery = ""
lcJavascript = ""
*-- Css -------------------------------
If !Empty(tcCss)
If File(tcCss)
lcCss = FileToStr(tcCss)
Else
lcCss = tcCss
Endif
Endif
*-- Pull in a script to reference the main jQuery library -----------------
If File(lcScriptToReferencejQuery)
lcJquery = FileToStr(lcScriptToReferencejQuery)
Else
lcJquery = ""
EndIf
*-- Body -----------------------------------------
If File(tcBody)
lcBody = FileToStr(tcBody)
Else
lcBody = tcBody
Endif
*-- Any additional javasctipt (follows after body) -----------------------------------------
If !Empty(tcJavascript)
If File(tcJavascript)
lcJavascript = FileToStr(tcJavascript)
Else
lcJavascript = tcJavascript
Endif
Endif
Text To lcHtml TextMerge NoShow PreText 7
<head>
<<lcCss>>
<<lcJquery>>
</head>
<body>
<<lcBody>>
<<lcJavascript>>
</body>
EndText
Return lcHtml
Endproc
*===============================================================================================
Procedure GetRestoreWorkAreaObject
Local loRestoreWorkArea As 'RestoreWorkArea'
loRestoreWorkArea = Createobject('RestoreWorkArea')
Return loRestoreWorkArea
Endproc
*=============================================================================
*-- Using an instance of this object at the top of any method will cause the current work
*-- area to be restored when the method goes out of scope. This prevents you from havinf to
*-- manage restoring the work area yourself when the method exits
*---------------------------------------------------------------------------------------
Define Class RestoreWorkArea As Custom
nWorkArea = 0
*---------------------------------------------------------------------------------------
Procedure Init
This.nWorkArea = Select()
Endproc
*---------------------------------------------------------------------------------------
Procedure Destroy
Select (This.nWorkArea)
Endproc
EndDefine
*!* *=======================================================================================
*!* *-- Creates and returns a PrivateDataSession object, which stores the current DataSessionID, which can
*!* *-- be restored later with the RetoreDataSession() function.
*!* Procedure GetPrivateDataSession()
*!* Local loPrivateDataSession as 'PrivateDataSession'
*!* lnOriginalDataSession = Set("DataSession")
*!* loPrivateDataSession = CreateObject('PrivateDataSession', lnOriginalDataSession)
*!*
*!* Set DataSession to (loPrivateDataSession.DataSessionID)
*!*
*!* Return loPrivateDataSession
*!*
*!* Endproc
*!* *=======================================================================================
*!* *-- A function which will change the current DataSession back to toPrivateDataSession.nOriginalDataSession.
*!* *-- Designed to work with the GetPrivateDataSession() function.
*!* Procedure RetoreDataSession(toPrivateDataSession)
*!* Set DataSession to (toPrivateDataSession.nOriginalDataSession)
*!* Endproc
*!* *=======================================================================================
*!* Define Class PrivateDataSession as Session
*!* nOriginalDataSession = 0
*!*
*!* *---------------------------------------------------------------------------------------
*!* Procedure Init(tnOriginalDataSession)
*!*
*!* This.nOriginalDataSession = tnOriginalDataSession
*!*
*!* EndProc
*!*
*!* *---------------------------------------------------------------------------------------
*!* Procedure Release
*!*
*!* Set DataSession To (This.nOriginalDataSession)
*!* EndProc
*!* *---------------------------------------------------------------------------------------
*!* Procedure Destroy
*!*
*!* Set DataSession To (This.nOriginalDataSession)
*!* Endproc
*!*
*!* EndDefine
*==========================================================================================
Procedure CloseCursor(tcCursor)
Try
Use In &tcCursor
Catch
Endtry
Endproc
*===============================================================================================
*!* Procedure CloseCursor(tcCursorName)
*!* If !Empty(tcCursorName) And Used(tcCursorName)
*!* Use In (tcCursorName)
*!* Endif
*!* Endproc
*==========================================================================================
Procedure CreateCursorFromObject(toObject, tcCursor)
*!* Forum: Visual FoxPro
*!* Category: Object Oriented Programming
*!* Thread ID: 1532019
*!* Message ID: 1532318
*!* From: Chi Ony
*!* To: Matt Slay
*!* Date: January 6th, 2012
*!* A very simple cursor from object function
*!* not contain field width handler and error checker
LOCAL ARRAY laFields[1]
LOCAL i, lcFields, lcField, lvValue, lcType, lcTemp, lnPos, lnLen, lnDec
lcFields = ""
FOR i = 1 TO AMEMBERS(laFields, m.toObject)
lcField = m.laFields[m.i]
lvValue = EVALUATE("m.toObject." + m.lcField)
lcType = VARTYPE(m.lvValue)
lcFields = m.lcFields + "," + m.lcField + " " + m.lcType
DO CASE
CASE m.lcType == "C"
lnLen = Min(LEN(m.lvValue), 254)
lcFields = m.lcFields + "(" + LTRIM(STR(lnLen)) + ")"
CASE m.lcType $ "NY"
lcTemp = TRANSFORM(m.lvValue)
lnLen = LEN(m.lcTemp)
lnPos = AT(".", m.lcTemp)
IF m.lnPos > 0
lnDec = m.lnLen - m.lnPos - 1
lnLen = m.lnLen - m.lnDec - 1
lcFields = m.lcFields + "(" + LTRIM(STR(m.lnLen)) + "," + LTRIM(STR(m.lnDec)) + ")"
ELSE
lcFields = m.lcFields + "(" + LTRIM(STR(m.lnLen)) + ")"
ENDIF
CASE m.lcType $ "DT"
ENDCASE
ENDFOR
IF !EMPTY(m.lcFields)
m.lcFields = TRIM(SUBSTR(m.lcFields, 2))
CREATE CURSOR (m.tcCursor) (&lcFields.)
APPEND BLANK
GATHER NAME m.toObject
ENDIF
RETURN USED(m.tcCursor)
Endproc
*---------------------------------------------------------------------------------------
Procedure _dir
Local la[1], lcDir, lnX
adir(la)
lcDir = 'Directory for: ' + Curdir() + Chr(13)
lcDir = lcDir + Replicate('-', 100) + Chr(13)
For lnX = 1 to (Alen(la)/5)
lcDir = lcDir + Padr(la[lnX, 1], 60)
lcDir = lcDir + Padl(Transform(la[lnX, 2]), 15)
lcDir = lcDir + Padl(Transform(la[lnX, 3]), 15)
lcDir = lcDir + Padl(la[lnX, 4], 13)
lcDir = lcDir + Padl(la[lnX, 5], 10)
lcDir = lcDir + Chr(13)
Endfor
OutputToConsole(lcDir)
Endproc
*---------------------------------------------------------------------------------------
Procedure _path
Local lcPath, lnHandle
lcPath = Set('Path')
lcPath = Strtran(lcPath, ';', Chr(13))
OutputToConsole(lcPath)
EndProc
*---------------------------------------------------------------------------------------
Procedure _classlib
Local lcPath, lnHandle
lcPath = Set('Classlib')
lcPath = Strtran(lcPath, ', ', Chr(13))
OutputToConsole(lcPath)
EndProc
*---------------------------------------------------------------------------------------
Procedure _procedure
Local lcPath, lnHandle
lcPath = Set('Procedure')
lcPath = Strtran(lcPath, ', ', Chr(13))
OutputToConsole(lcPath)
EndProc
*---------------------------------------------------------------------------------------
Procedure cd
Local lcCD
lcCD = Lower(Set('Default')+Sys(2003))
OutputToConsole(lcCD)
Endproc
*---------------------------------------------------------------------------------------
Procedure OutputToConsole(tcOutput)
tcOutput = tcOutput + Chr(13)
SET LIBRARY TO FoxTools ADDITIVE
lnHandle = _WonTop()
? _EdInsert(lnHandle, tcOutput, Len(tcOutput))
Keyboard '{CTRL+PGDN}'
Endproc
*---------------------------------------------------------------------------------------
Procedure DateString(tdDate, tcFormat)
Local lcCentury, lcDate, lcMark, lcReturn
tcFormat = Evl(tcFormat, "YYYY-MM-DD")
lcMark = Set("Mark")
lcCentury = Set("Century")
lcDate = Set("Date")
Do Case
Case Upper(tcFormat) = "YYYY-MM-DD"
Set Mark To "-"
Set Century On
Set Date to YMD
lcReturn = Transform(tdDate)
Otherwise
Endcase
Set Mark to &lcMark
Set Century &lcCentury
Set Date to &lcDate
Return lcReturn
EndProc
*---------------------------------------------------------------------------------------
Procedure CreateDateTime(tdDate, tcTime)
Local ldDateTime, lnDay, lnHours, lnMinutes, lnMonth, lnSeconds, lnYear
lnYear = Year(tdDate)
lnMonth = Month(tdDate)
lnDay = Day(tdDate)
lnHours = Val(GetWordNum(tcTime, 1, ":"))
lnMinutes = Val(GetWordNum(tcTime, 2, ":"))
lnSeconds = Val(GetWordNum(tcTime, 3, ":"))
ldDateTime = Datetime(lnYear, lnMonth, lnDay, lnHours,lnMinutes, lnSeconds)
Return ldDateTime
EndProc
*---------------------------------------------------------------------------------------
Procedure ConvertToDate(tuInput)
lcDataType = Vartype(tuInput)
Do Case
Case lcDataType = 'T'
Return Ttod(tuInput)
Otherwise
Return tuInput
Endcase
*---------------------------------------------------------------------------------------
*-- Source: https://www.berezniker.com/content/pages/visual-foxpro/how-check-if-variable-integer
Procedure NumberOfDecimals(tnNumber)
Return -AT(SET("Point"), PADL(tnNumber, 20)) % 20
Endproc
*---------------------------------------------------------------------------------------
*-- Source: https://www.berezniker.com/content/pages/visual-foxpro/how-check-if-variable-integer
Procedure IsInteger(tnNumber)
Return NOT ( SET("Point") $ PADL(tnNumber, 20) )
Endproc
*---------------------------------------------------------------------------------------
*-- Source: https://www.berezniker.com/content/pages/visual-foxpro/how-check-if-variable-integer
Procedure IsWholeNumber(tnValue)
Return (tnValue% 1) = 0
Endproc
*-------------------------------------------------------
Procedure IsString(tuReference)
Return Vartype(tuReference) = 'C'
Endproc
*-------------------------------------------------------
Procedure IsObject(tuReference)
If Vartype(tuReference) = 'C'
If Type(tuReference) = 'O' and !IsNull(Evaluate(tuReference))
Return .t.
Else
Return .f.
EndIf
Else
If Vartype(tuReference) = 'O' and !IsNull(tuReference)
Return .t.
Else
Return .f.
Endif
EndIf
Endproc
*---------------------------------------------------------------------------------------
Function AddWorkingDays(tnStartingDate, tnWorkingDays)
Local lnFutureDate, lnWorkingDays
If Empty(tnWorkingDays)
Return tnStartingDate
EndIf
tnStartingDate = Cast(tnStartingDate as Date)
lnFutureDate = tnStartingDate + tnWorkingDays - 1
lnWorkingDays = 0
Do While lnWorkingDays < tnWorkingDays
lnFutureDate= lnFutureDate + 1
lnWorkingDays = WorkingDaysBetweenTwoDates(tnStartingDate, lnFutureDate)
Enddo
Return lnFutureDate
Endfunc
*---------------------------------------------------------------------------------------
*-- http://www.tek-tips.com/faqs.cfm?fid=307
*---------------------------------------------------------------------------------------
Function WorkingDaysBetweenTwoDates(dStart, dEnd)
If Empty(dStart) or Empty(dEnd)
Return 0
Endif
dStart = Cast(dStart as Date)
dEnd = Cast(dEnd as Date)
*Check for year Span (Determines size of holiday array)
nSpan = YEAR(dEnd) - YEAR(dStart)
If nSpan < 0
dTemp = dEnd
dEnd = dStart
dStart = dTemp
nSpan = YEAR(dEnd)-YEAR(dStart)
ENDIF
nCounter = 0
nStandardHolidays = 3 && Holidays dates that do not change
Dimension gSHolidays(nStandardHolidays)
gSHolidays(1) = {^2000-01-01} && New Years Day
gSHolidays(2) = {^2000-07-04} && July 4th
gSHolidays(3) = {^2000-12-25} && Christmas
nFloatingHolidays = 3 && Holidays dates that change
Dimension gFHolidays(nFloatingHolidays, 4)
* Labor Day
gFHolidays(1,1) = 9 && Month
gFHolidays(1,2) = 2 && Day of the week Sunday = 1
gFHolidays(1,3) = 1 && Occurence IE (11,5,4,0) = 4th Thursday in Novemeber
gFHolidays(1,4) = 0 && Offset plus this many days
* Thanksgiving
gFHolidays(2,1) = 11
gFHolidays(2,2) = 5
gFHolidays(2,3) = 4
gFHolidays(2,4) = 0
* Day After Thanksgiving
gFHolidays(3,1) = 11
gFHolidays(3,2) = 5
gFHolidays(3,3) = 4
gFHolidays(3,4) = 1 && IE (11,5,4,1) = Friday after the 4th Thursday in Novemeber
nHolidayCount = (nFloatingHolidays + nStandardHolidays) * (nSpan + 1)
DIMENSION gHolidays(nHolidayCount)
nHC = 1
DO WHILE nCounter <= nSpan
nYear = YEAR(dStart)+nCounter
* Add Standard Holidays
FOR x = 1 TO ALEN(gSHolidays)
nMonth = MONTH(gSHolidays(x))
nDay = DAY(gSHolidays(x))
cDate = "{^"+ALLTRIM(STR(nYear))+"-"+ALLTRIM(STR(nMonth))+"-"+ALLTRIM(STR(nDay))+"}"
gHolidays(nHC)= &cDate
nHC = nHC + 1
NEXT
* Add Floating Holidays
FOR x = 1 TO ALEN(gFHolidays) / 4
nMonth = gFHolidays(x,1)
nFindDay = gFHolidays(x,2)
nOccur = gFHolidays(x,3)
nOffset = gFHolidays(x,4)
cDate = "{^" + ALLTRIM(STR(nYear)) + "-" + ALLTRIM(STR(nMonth)) + "-01}"
dTemp = &cDate && 1st day of Holiday's Month
nCheckM = nMonth
nCheckD = 1
DO WHILE nCheckM = nMonth && Scan the month for nOccurence of the Day
IF DOW(dTemp) = nFindDay THEN
IF nCheckD = nOccur THEN
EXIT
ELSE
nCheckD = nCheckD + 1
ENDIF
ENDIF
dTemp = dTemp + 1
nCheckM = MONTH(dTemp)
ENDDO
dTemp = dTemp + nOffset
gHolidays(nHC)= dTemp
nHC = nHC + 1
NEXT
nCounter = nCounter + 1
EndDo
RELEASE gFHolidays, gSHolidays
=ASORT(gHolidays) &¼ really needed
* Count work days between dates
nCalenderDays = dEnd - dStart
nCountHolidays = 0
nWorkDays = 0
dTemp = dStart + 1
FOR x = 1 TO nCalenderDays
nDOW = DOW(dTemp)
nHoliday = ASCAN(gHolidays,dTemp)
IF (nDOW = 1 OR nDOW = 7) or nHoliday > 0
nCountHolidays = nCountHolidays + 1
ENDIF
dTemp = dTemp + 1
Next
nWorkDays = nCalenderDays - nCountHolidays
RETURN nWorkDays
ENDFUNC
*=======================================================================================
FUNCTION ListProcesses(tcCursor)
*==============================================================================
* Program: Adapted from KillApp.PRG by Tamar E. Granor
* Purpose: Close any invisible instances of a specified program
* Parameters: tcClassName - the classname of the app to close
* Returns: Number of instances closed; -1, if parameter problems
* Environment in:
* Environment out: Several API functions declared
*==============================================================================
#DEFINE GW_CHILD 5
#DEFINE GW_HWNDNEXT 2
#DEFINE WM_CLOSE 0x10
DECLARE LONG GetDesktopWindow IN WIN32API
DECLARE LONG GetWindow IN WIN32API LONG hWnd, LONG wCmd
DECLARE LONG IsWindowVisible IN WIN32API LONG hWnd
DECLARE LONG GetClassName IN WIN32API LONG hWnd, STRING lpClassName, LONG nMaxCount
DECLARE LONG PostMessage IN WIN32API LONG hwnd, LONG wMsg, LONG wParam, LONG lParam
LOCAL lnDesktopHWnd, lnHWnd, lnOldHWnd, lcClass, lnLen, nClosedCount
lnDesktopHWnd = GetDesktopWindow()
lnHWnd = GetWindow( lnDesktopHWnd, GW_CHILD)
lnClosedCount = 0
loProcesses = CreateObject("Collection")
lcCursor = Evl(tcCursor, "Query")
If !Used(lcCursor)
Create Cursor (lcCursor) (ProcessName C(80))
Else
Select ProcessName From (lcCursor) Where 0 = 1 Into Cursor (lcCursor) ReadWrite Order by 1 Group by ProcessName
EndIf
Select (lcCursor)
DO WHILE lnHWnd <> 0
lcClass = SPACE(256)
lnLen = GetClassName( lnHWnd, @lcClass, 256)
lnOldHWnd = lnHWnd
lnHWnd = GetWindow(lnOldHWnd, GW_HWNDNEXT)
loProcesses.Add(lcClass)
Append Blank
Replace ProcessName with lcClass
EndDo
Select Max(ProcessName) as ProcessName, Count(*) as Count from (lcCursor) Into Cursor (lcCursor) ReadWrite Order by 1 Group by ProcessName
Return loProcesses
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.