Last active
October 17, 2016 19:13
-
-
Save mattslay/b1502c58f2dd3167d667d98617e9b1de to your computer and use it in GitHub Desktop.
Matt Slay general FoxPro utils, aka msUtils
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| *======================================================================================= | |
| 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 = ' ' | |
| 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