# ftsItem_content

c0Title: CiTextbox
c1Code:
INT	iDescAN = 33;
STRING	msTextBoxClass = "CiText.TextBox";

objDescText = DspAnCreateControlObject(iDescAN, msTextBoxClass, iDescWidth, - iDescHeight); _ObjectSetProperty(objDescText, "Text", sDesc); sDesc = _ObjectGetProperty(objDescText, "Text");


c0Title: Get Active Alarm Server Name
c1Code:
// Find the alarm server this client is connected to
// If there is no active connection, returns ""
// If this is an alarm server, will always return this alarm server' name
// Returned name will be <ClusterName>Alarm, e.g. CitectAlarm

//private
STRING
FUNCTION
GetActiveAlarmServerName()

	INT cActive = 0;
	INT cUsingStandby = 2;
	INT cConnected = 3;
	
	STRING sClusterPrimary;
	STRING sClusterStandby;	
	STRING sServer;
	
	ClusterGetName(sClusterPrimary, sClusterStandby, 0);
	
	IF (ServerInfo("Alarm", cActive) = "1") THEN
		sServer = sClusterPrimary + "Alarm";
	ELSE
		IF (ServerInfo("Alarm", cConnected) = "1") THEN
			IF (ServerInfo("Alarm", cUsingStandby) = "1") THEN
				sServer = sClusterStandby + "Alarm";
			ELSE
				sServer = sClusterPrimary + "Alarm";
			END
		ELSE
			sServer = "";
		END
	END
	
	RETURN sServer;
END


c0Title: Get Alarm Type From RID
c1Code:
// Filters the alarm page by the selected alarm type 
// 
// Arguments: nRecordID  Alarm record number
//            nVersion   Alarm instance number
//            nType      Alarm type to filter for
//                       0 = Digital
//                       1 = Analog
//                       2 = Advanced
//                       3 = Multi-digital
//                       6 = Time-stamped
//                       8 = Time-stamped digital
//                       9 = time-stamped analog
//
// Return: TRUE if the specified alarm should be displayed, else FALSE 
// 
// Source: AlarmSetQuery function / AlarmConfig page 
// 
// Notes: This function is called once per alarm by the alarm page 
//
//  Rev          Date        By            Comments
//	-----------------------------------------------------------------
//  0            02/2008     EB            Original
//
INT
FUNCTION
AlarmFilter(INT nRecordID, INT nVersion, INT nType)

	IF (nRecordID BITAND 0xF) = nType THEN	// The lowest byte of the record number represents the type
		RETURN TRUE;
	ELSE
		RETURN FALSE;
	END
END


c0Title: Display/Log Events in Alarm Summary
c1Code:
Create an alarm called "Event" with its own category. Use this function to create events when they happen:

FUNCTION MaakEvent(STRING Omschrijving , STRING EventNaam="Event")
	INT Handle;
	Handle = AlarmSumAppend( EventNaam );
	IF Handle <> -1 THEN
		AlarmSumSet( Handle, "Comment", Omschrijving);
		AlarmSumSet( Handle, "OnTime", TimeCurrent());
	END
END


c0Title: Binary Search
c1Code:
STRING msSearchArray[479];     // Array containing the list of items to be searched

// Search an ordered array for the first occurrence of the specified element 
// using the binary search algorithm. The element must match sFind exactly 
// to be successful (but case is ignored) 
//
// Arguments: sFind   Text to find
//            nFirst  First element to search (normally 0)
//            nLast   Last element to search (max 478 for strings)
//
// Returns the element number if successful, or -1 if the element was not found 
// 
// Note: 1. All elements in msSearchArray must be in alphabetical order
//       2. If nFirst or nLast are outside of the array's bounds, a hardware 
//          alarm is generated
//       3. If the array has any blank elements, they must be before nFirst or 
//          after nLast
//
INT
FUNCTION
BinarySearch(STRING sFind, INT nFirst, INT nLast)
	INT nMiddle;
	INT nHigh;
	INT nLow;
	
	nLow = nFirst - 1;
	nHigh = nLast + 1;

	WHILE (nHigh - nLow) > 1 DO
		
		nMiddle = nLow + ((nHigh - nLow) / 2);
		
		IF (msSearchArray[nMiddle] < sFind) THEN
			nLow = nMiddle;
		ELSE
			nHigh = nMiddle;
		END
	END

	IF (nHigh = nLast + 1) THEN
		RETURN -1;
	ELSE
		IF (msSearchArray[nHigh] <> sFind) THEN
			RETURN -1;
		ELSE
			RETURN nHigh;
		END
	END
END


c0Title: Execute DOS commands - XCOPY & DEL
c1Code:
// Use DOS XCopy command to copy files from the source path\filespec to the destination path including subfolders
//
// ARGUMENTS	sSource		Source path and filespec (e.g. c:\*.txt)
//				sDest		Destination path
//				bTodayOnly	TRUE	Only copy files modified today
//							FALSE	Copy all files (default)
//
// RETURN VALUE	0 for no errors (doesn't guarantee copy was successful), or a Cicode error
//
// XCopy options used:
//  D  Copies only those files whose source time is newer than the destination time.
//  S  Copies directories and subdirectories except empty ones.
//  C  Continues copying even if errors occur.
//  I  If destination does not exist and copying more than one file, assumes that destination must be a directory.
//  Y  Suppresses prompting to confirm you want to overwrite an existing destination file.
//  Z  Copies networked files in restartable mode.
//
PRIVATE
INT
FUNCTION
XCopy(STRING sSource, STRING sDest, INT bTodayOnly = FALSE)

	INT ShortDate = 2;
	STRING sCmd;
	STRING sDate;
	
	IF bTodayOnly = TRUE THEN
		sDate = ":" + Date(ShortDate);
	END
	
	sCmd = "XCopy ^"" + sSource + "^" ^"" + sDest + "^" /d" + sDate + "/s/c/i/y/z";
	
	IF (sSource <> "") AND (sDest <> "") THEN	
		RETURN DosCommand(sCmd);
	ELSE
		RETURN 274;	// blank source or destination
	END
END


// Use DOS Del command to delete the specified path\filespec including files in subfolders
PRIVATE
INT
FUNCTION
Del(STRING sFileSpec)

	STRING sCmd;
	
	IF sFileSpec <> "" THEN	
		sCmd = "del /s/q ^"" + sFileSpec + "^"";
		RETURN DosCommand(sCmd);
	ELSE
		RETURN 274;	// blank filespec
	END
END


// Execute the specified DOS command in a hidden window. Block until window closes
//
// Returns: 0		Success
//          274		Blank command string
//          1343	Command was too long to execute (ComSpec environment variable + sCommand must be 251 chars or less)
//
// NOTE:	If a DOS window is already open, the new window will be minimized but not
//			hidden and will execute asynchronously
PRIVATE
INT
FUNCTION
DosCommand(STRING sCommand)
	INT hWnd;
	INT bHide;
	INT iStart;
	STRING sComSpec;
	
	sComSpec = GetEnv("ComSpec");	// Get path/name of command interpreter

	IF sCommand = "" THEN
		RETURN 274;
	END

	IF (StrLength(sCommand) + StrLength(sComSpec) + 4) > 255 THEN
		RETURN 1343;
	END
	
	IF WndFind(sComSpec) = 0 THEN
		bHide = TRUE;
	ELSE
		bHide = FALSE;	// If a DOS window is already open, can't tell which to hide
	END

	sCommand = sComSpec + " /c " + sCommand;

	Exec(sCommand, 6);

	IF bHide = TRUE THEN
		hWnd = WndFind(sComSpec);
		iStart = TimeCurrent();
		
		WHILE hWnd = 0 DO	// Wait for window to open
			SleepMS(100);
			hWnd = WndFind(sComSpec);
		
			IF TimeCurrent() - iStart >= 3 THEN
				RETURN 0;	// Window never found (closed immediately?)
			END
		END
		
		WndShow(hWnd, 0);	// cmd.exe will still appear in Task Manager | Processes
		
		iStart = TimeCurrent();
		WHILE WndFind(sComSpec) <> 0 DO	// Wait for window to close
			Sleep(1);
			IF TimeCurrent() - iStart >= 60 THEN
				RETURN 290;	// Window never closed
			END
		END
	END
	
	RETURN 0;
END


c0Title: Constants
c1Code:
STRING	CRLF = "^0x0D^0x0A";		// Carriage Return & Line Feed characters

// Error Codes
INT		FAIL = -1;
INT		NO_ERR = 0;
INT		ERR_TIMEOUT = 21;
INT		ERR_FILE_NOT_EXIST = 261;
INT		ERR_CANNOT_WRITE_FILE = 264;
INT		ERR_OVERFLOW = 275;
INT		ERR_NO_PRIVILEGE = 276;
INT		ERR_NAME_NOT_EXIST = 289;

// File Constants
INT		COPY_ASYNC = 2;	// FileCopy

// Version constants
INT		VER_MAJOR = 0;
INT		VER_MINOR = 1;

// Plot constants
INT		TYPE_LINE = 3;
INT		SOLID = 0;
INT		NO_FILL = -1;
INT		NORMAL_MODE = 1;
INT		LEFT_TO_RIGHT = 0;
INT		FONT_HEIGHT = 6;
INT		FONT_WIDTH = 8;

// AN Constants
INT		AN_TYPE = 0;
INT		AN_TYPE_TREND = 6;

// Time/date constants
INT		LONG_TIME = 1;
INT		SHORT_DATE = 2;
INT		DATE_ORDER = 1;
STRING	MMDDYY_ORDER = "0";
STRING	DDMMYY_ORDER = "1";
STRING	YYMMDD_ORDER = "2";
INT		DATE_DELIMITER = 2;
INT		MONTH_SECS = 2628000;
INT		DAY_SECS = 86400;
INT		HOUR_SECS = 3600;

// Trend Constants
INT		CURRENT_PEN = 0;
INT		NO_SAMPLES = 1;
INT		TRN_VALID_VALUE = 0;		// TrnIsValidSample
INT		TRN_GATED_VALUE = 1;		// TrnIsValidSample
INT		TRN_NA_VALUE = 2;			// TrnIsValidSample
REAL		TREND_NA = TrnGetInvalidValue();
INT		TRN_NEW_TO_OLD = 2;		// TrnGetTable
INT		TRN_ALLOW_NA_GATED = 1;		// TrnGetTable

// Array Constants
INT		MAX_STRING_ARRAY_ELEMENTS = 479;

// Process Analyst Constants
INT PENTYPE_ANALOG = 4097;
INT PENNAMEMODE_CUSTOM = 3;
INT QUALITYTYPE_GOOD = 0;
INT QUALITYCOMPACTIONTYPE_SINGLE = 0;

// ServerInfo() Constants
INT SVI_RAT_PRIMARY_STANDBY = 2;	
INT SVI_RAT_CONNECTED = 3;

// Msg() constants
INT MSG_CONNECTED = 1;

// MessageBox constants
INT MSG_YES_NO_CANCEL = 3;
INT MSG_WARNING = 32;
INT MSG_YES = 6;
INT MSG_NO = 7;
INT MSG_CANCEL = 299;


c0Title: SQLite Sample Project, Cicode, DLL, and ActiveX
c2File: sqlite.ctz
c1Code:
http://www.sqlite.org

SQLite is a small C library that implements a self-contained, embeddable, zero-configuration SQL database engine. Features include:

Transactions are atomic, consistent, isolated, and durable (ACID) even after system crashes and power failures.
Zero-configuration - no setup or administration needed.
Implements most of SQL92. (Features not supported)
A complete database is stored in a single disk file.
Database files can be freely shared between machines with different byte orders.
Supports databases up to 2 terabytes (241 bytes) in size.
Sizes of strings and BLOBs limited only by available memory.
Small code footprint: less than 250KiB fully configured or less than 150KiB with optional features omitted.
Faster than popular client/server database engines for most common operations.
Simple, easy to use API.
TCL bindings included. Bindings for many other languages available separately.
Well-commented source code with over 95% test coverage.
Self-contained: no external dependencies.
Sources are in the public domain. Use for any purpose.

The SQLite distribution comes with a standalone command-line access program (sqlite) that can be used to administer an SQLite database and which serves as an example of how to use the SQLite library. 


c0Title: OLE Date Conversion Rounding Error Work-around
c1Code:
OLE Date Conversion Rounding Error Work-around

Citect 6.10 Bug 28731

REAL
FUNCTION
TimeToOLEDateFix(INT iTime, INT bLocal = FALSE)
     INT iBias;
	
     IF bLocal THEN
          iBias = TimeUTCOffset(iTime);
     ELSE
          iBias = 0;
     END
	
     RETURN 25569 + ((iTime + iBias) / 86400.0);
END


c0Title: Build date from separate day, month, and year values
c1Code:
STRING msDelimiter;
INT miDateOrder;

// Build a Citect time/date value from separate day, month, and year values.
// Takes into account local month/date/year order and separator character
//
// Returns the Citect date variable or -1 for invalid dates
//
INT
FUNCTION
PLUSBuildDate(INT iDay, INT iMonth, INT iYear)

INT DATE_DELIMITER = 2;
INT DATE_ORDER = 1;
INT MMDDYY_ORDER = 0;
INT DDMMYY_ORDER = 1;
INT YYMMDD_ORDER = 2;

STRING sDate;

IF msDelimiter = "" THEN
msDelimiter = DateInfo(DATE_DELIMITER, 0);
miDateOrder = DateInfo(DATE_ORDER, 0);
END

SELECT CASE miDateOrder
CASE MMDDYY_ORDER
sDate = iMonth:# + msDelimiter + iDay:# + msDelimiter + iYear:#;
RETURN StrToDate(sDate);
CASE DDMMYY_ORDER
sDate = iDay:# + msDelimiter + iMonth:# + msDelimiter + iYear:#;
RETURN StrToDate(sDate);
CASE YYMMDD_ORDER
sDate = iYear:# + msDelimiter + iMonth:# + msDelimiter + iDay:#;
RETURN StrToDate(sDate);
CASE ELSE
RETURN -1;
END SELECT
END


c0Title: Add dates, adjusting for DST
c1Code:
// Function:  PLUSDateAdd()
// Desc:      Adds separate time and date values, taking daylight savings time into account.
//            Also allows the repeated hour to be selected on the day DST ends.
//
// Arguments: iDate			Citect date value
//            iTime			Citect time of day value
//            bRepeatedHour =TRUE  The specified time is the repeated hour on 
//                                 the day DST ends
//                          =FALSE The specified time is not the repeated hour
//                                 (default)
//
// Returns: Citect time/date value for the specified time
//
INT
FUNCTION
PLUSDateAdd(INT iDate, INT iTime, INT bRepeatedHour = FALSE)
      INT CHANGE_TIME = 7199; // StrToTime("1:59:59 AM")
      INT REPEATED_HOUR = 3600; // StrToTime("1:00:00 AM")
      INT iDSTOffset;
      
      iDstOffset = PLUSDstChange(iDate);
 
      IF iDstOffset <> 0 THEN
 
            IF iTime > CHANGE_TIME THEN
                  iTime = iTime - iDstOffset;
            ELSE
                  IF (iDstOffset < 0) AND (bRepeatedHour = TRUE) AND (iTime >= REPEATED_HOUR) THEN
                        iTime = iTime + 3600;   //Operator is selecting the 2nd 1:00 hour on DST switch back
                  END
            END
      END
 
      RETURN DateAdd(iDate, iTime);
END
 
 
// Returns the amount of time the clock will change for DST on the specified date,
// (+1 hour, 0 hours, -1 hour, etc.) in seconds
INT
FUNCTION
PLUSDstChange(INT iInputTime)
 
      INT iTempTime;
      INT iTempDate;
      INT iTime;
      INT iTimeMidnight;
      
      iTempTime = StrToTime("12:00");
      iTempDate = StrToDate(TimeToStr(iInputTime, 2));
      iTime = DateAdd(iTempTime,iTempDate);
      iTimeMidNight = TimeMidNight(iTime);
 
      RETURN iTempDate - iTimeMidnight;
END


c0Title: Number of days in a month
c1Code:
INT
FUNCTION
PLUSDaysInMonth(INT iDate)
	
	SELECT CASE DateMonth(iDate)
	CASE 1, 3, 5, 7, 8, 10, 12

		RETURN 31;

	CASE 2

		IF PLUSIsLeapYear(iDate) = TRUE THEN
			RETURN 29;
		ELSE
			RETURN 28;
		END

	CASE 4, 6, 9, 11

		RETURN 30;

	CASE ELSE

		RETURN 0;

	END SELECT
END


INT
FUNCTION
PLUSIsLeapYear(INT iDate)
	INT iYear = DateYear(iDate, 1);
		
	IF ((iYear MOD 4) = 0) AND 
	   (((iYear MOD 100) <> 0) OR ((iYear MOD 1000) = 0)) THEN
		RETURN TRUE;
	ELSE
		RETURN FALSE;
	END
END


c0Title: Check if a date falls on a leap year
c1Code:
INT
FUNCTION
PLUSIsLeapYear(INT iDate)
	INT iYear = DateYear(iDate, 1);
		
	IF ((iYear MOD 4) = 0) AND 
	   (((iYear MOD 100) <> 0) OR ((iYear MOD 1000) = 0)) THEN
		RETURN TRUE;
	ELSE
		RETURN FALSE;
	END
END


c0Title: Easy Logging
c1Code:
FUNCTION
Log(STRING sText)
	INT	hLog = FileOpen("[DATA]:Log.txt", "a");
	FileWriteLn(hLog, sText);
	FileClose(hLog);
END


c0Title: Syslog Saver
c1Code:
// SaveSyslog()	v1.0	11/11/2004	Eric Black
//
// This function allows you to keep large amounts of syslog data. This is
// necessary if you need to keep more than the [Debug]SyslogSize parameter
// allows...such as when logging communications over a long period of time.
// This function just checks for a syslog.bak file, then renames that file with
// the current citect time and the extension .dat
// (e.g. syslog 2004-12-31 12 00 00.dat). The latest data will still be in 
// syslog.dat.
//
// It will stop renaming the files when the minimum free space is
// reached. When more space is available, it will continue renaming. Set the
// desired minimum by passing this value to the function (in KB)
// A message will display in the Kernel stating that SaveSyslog started and
// confirming the windows path and minimum disk space.

FUNCTION
SaveSyslog(INT iMinDiskSpaceKB = 100000)

	STRING sWinDir;
	STRING sTime;
	INT iTime;
	INT iDiskNo;

	ErrSet(1);
	
	sWinDir = StrLower(GetEnv("WINDIR"));
	iDiskNo = StrToChar(sWinDir) - 96;	// Convert disk letter (e.g. a:) to disk number (e.g. 1)

	TraceMsg("SaveSyslog using windir '" + sWinDir + "'. Minimum disk space " + iMinDiskSpaceKB:# + " KB");
	
	WHILE TRUE DO
		IF CitectInfo("disk", iDiskNo, 2) > iMinDiskSpaceKB THEN
			IF FileExist(sWinDir + "\syslog.bak") THEN
				Sleep(1);
				iTime = TimeCurrent();
				sTime = DateYear(iTime, 1):#0## + "-" + DateMonth(iTime):#0 + "-" + DateDay(iTime):#0 + " " +
						TimeHour(iTime):#0 + " " + TimeMin(iTime):#0 + " " + TimeSec(iTime):#0;
				
				FileReName(sWindir + "\syslog.bak", sWinDir + "\syslog " + sTime + ".dat");
			END
		END
		Sleep(1);
	END
END


c0Title: Get Filename from a Path\Filename
c1Code:
// Pass a path\filename or a path substitution like [Data]:File.ext
// Returns the filename and extension
STRING
FUNCTION
FileNameFromPath(STRING sPath)

	INT iChar;
	INT iLength;

	sPath = PathToStr(sPath);	
	iLength = StrLength(sPath);
	iChar = iLength - 1;

	WHILE TRUE DO 
		IF StrMid(sPath, iChar, 1) = "\" THEN
			RETURN StrRight(sPath, iLength - iChar - 1);
		ELSE
			iChar = iChar - 1;
		END
		IF iChar < 0 THEN
			RETURN "";
		END
	END
END


c0Title: Delete Files Older Than A Specified Date
c1Code:
FUNCTION
Test()

	INT cYearSec = 60 * 60 * 24 * 365;
	FileDeleteOld("c:\average\*.csv", TimeCurrent() - cYearSec);
END

// Deletes all files in the specified path/filespec older than the specified date/time
FUNCTION
FileDeleteOld(STRING sFileSpec, INT iOldDate)

	STRING sFile;
	INT hFile;
	INT iFileTime;
	
	ErrSet(1);
	
	sFile = FileFind(sFileSpec, 0);
	
	WHILE sFile <> "" DO
		hFile = FileOpen(sFile, "r");
		IF hFile <> -1 THEN
			iFileTime = FileGetTime(hFile);
			FileClose(hFile);
			
			IF iFileTime < iOldDate THEN
				FileDelete(sFile);
			END
		END
		
		sFile = FileFind("", 0);
		SleepMS(100);
	END
END


c0Title: Create Path
c1Code:
INT hCreatePath = -1;

// Creates all folders necessary for the specified path to be valid
// If the path includes a filename, the filename is ignored.
// Path substitution may be used.
//
// Returns TRUE if successful
INT
FUNCTION
CreatePath(STRING sPath)

	sPath = PathToStr(sPath);
	
	IF hCreatePath = -1 THEN
		hCreatePath = DLLOpen("dbghelp.dll", "MakeSureDirectoryPathExists", "AC");
	END
	
	RETURN DLLCallEx(hCreatePath, sPath);
END


c0Title: Get All Files in a Folder Recursively
c1Code:
// GetAllFiles.ci
//
// Function for finding files in nested folders



// Finds all files in the specified folder and all subfolders and stores them // in a table.
//
// Arguments: sPath      Path to search. May use path substitution.
//            sFileSpec  Which file names to find (default = "*.*")
//            bSort      TRUE   Alphabetize the list
//                       FALSE  File names are unsorted (default)
//
// Returns a handle for a table containing all the files in the specified 
// folder and all subfolders. Element numbers start at 1 
// 
// Notes: 1. You must call TableClose() when it is no longer needed
//        2. Requires the Table functions in Table.ci
//        3. Any path\filename over 255 characters will be truncated at 255 chars
//           and may cause a Citect runtime error
//
INT
FUNCTION
GetAllFiles(STRING sPath, STRING sFileSpec = "*.*", INT bSort = FALSE)
	INT		cFindFolders = 16;
	INT		cFindFiles = 0;
	INT		cFindNext = 0;
	INT		cTableQuickAppend = 1;
	INT		cErrDisableCheck = 1;

	INT		hFiles;
	INT		hFolders;
	INT		nCurrentFolder = 1;
	STRING	sCurrentFolder;
	INT		nNewFolder;
	STRING	sNewFolder;
	INT		nFile;
	STRING	sFile;

	ErrSet(cErrDisableCheck);

	hFolders = TableCreate("GetAllFiles:Folders");
	hFiles = TableCreate("GetAllFiles:Files");
	
	nNewFolder = nNewFolder + 1;
	sPath = PathAddSeparator(PathToStr(sPath));
	TableSet(hFolders, nNewFolder, sPath, cTableQuickAppend);

	WHILE (nCurrentFolder <= nNewFolder) DO
		
		sCurrentFolder = TableGet(hFolders, nCurrentFolder);
		sNewFolder = FileFind(sCurrentFolder + "*.*", cFindFolders);

		// FileFind may fail and return a blank string when called to find folders immediately 
		// after being called to find files. Sleeping and calling it again should work.
		IF sNewFolder = "" THEN		
			SleepMS(300);
			sNewFolder = FileFind(sCurrentFolder + "*.*", cFindFolders);
		END
		
		WHILE (sNewFolder <> "") DO
			IF (FolderIsValid(sNewFolder) = TRUE) THEN
				nNewFolder = nNewFolder + 1;
				TableSet(hFolders, nNewFolder, PathAddSeparator(sNewFolder), cTableQuickAppend);
			END
			sNewFolder = FileFind("", cFindNext);
		END
		
		sFile = FileFind(sCurrentFolder + sFileSpec, cFindFiles);
				
		WHILE (sFile <> "") DO
			nFile = nFile + 1;
			TableSet(hFiles, nFile, sFile, cTableQuickAppend);
			sFile = FileFind("", cFindNext);
		END
		
		nCurrentFolder = nCurrentFolder + 1;
	END

	TableClose(hFolders);
	
	IF (bSort = TRUE) THEN
		TableSortI(hFiles, 1, nFile);
	END

	RETURN hFiles;
END	


// Returns TRUE for a good folder name, FALSE for paths ending with \. or \..
PRIVATE
INT
FUNCTION
FolderIsValid(STRING sFolder)
	IF (StrRight(sFolder, 2) = "\.") OR (StrRight(sFolder, 3) = "\..") THEN
		RETURN FALSE;
	ELSE
		RETURN TRUE;
	END
END


// Adds a backslash separator to a path if it doesn't already have one PRIVATE STRING FUNCTION PathAddSeparator(STRING sPath)
    IF StrRight(sPath, 1) <> "\" THEN
    	sPath = sPath + "\";
    END
	RETURN sPath;
END


c0Title: Add Backslash to Paths
c1Code:
Add Backslash to Paths

// Adds a backslash separator to a path if it doesn't already have one STRING FUNCTION PathAddSeparator(STRING sPath)
    IF StrRight(sPath, 1) <> "\" THEN
    	sPath = sPath + "\";
    END
	RETURN sPath;
END


c0Title: No-Input Status Form
c1Code:
No-Input Status Form

// Display a no-input status form and return the handle so it can be closed later
PRIVATE
INT
FUNCTION
StatusForm(STRING sTitle, STRING sPrompt)

	INT hForm;
	INT iWidth = StrLength(sPrompt);
	INT iHeight = 1;
	INT iMode = 8+16;
	
	hForm = FormNew(sTitle, iWidth, iHeight, iMode);
	FormPrompt(0, 0, sPrompt);
	CSV_Form_Centre(iWidth, iHeight);
	FormRead(1);
	RETURN hForm;
END


c0Title: Custom Button with Push Effect
c1Code:
How to make a custom button object that will depress when the user clicks on it -- Copied from 6.10 CSV_Example project

Create a symbol set object with the 'up' button as the OFF symbol and the 'down' button as the ON symbol. (Can make bitmap symbols out of rectangle objects with raised and lowered effects).
Set ON Symbol When: DspGetMouseDown()

If the button needs to change colors or have a label, put those objects on top of the symbol set, but put the input command on the symbol set only (without the input property, it won't respond to clicking).

// MouseDown Functions
//
// React to mouse down event, determine if the mouse is down and return ask // if the mouse down is over a particular AN number.
//

INT fhHandlerChain = -1;
INT fnButtonDown = 0;
INT	mbMouseDownRegistered = FALSE;

FUNCTION DspRegisterMouseDown()
	mbMouseDownRegistered  = TRUE;
	fhHandlerChain = GetEvent(1);
	OnEvent(1,DspIsMouseDown);
END

INT
FUNCTION DspIsMouseDown()

	INT nKey;
	
	nKey = KeyPeek(0);
	
	IF nKey = KEY_LBUTTON_DN THEN
		fnButtonDown = KeyGetCursor();
	ELSE
		fnButtonDown = 0;
	END
	
	INT nChainReturn;
	IF fhHandlerChain <> -1 THEN
		nChainReturn = ChainEvent(fhHandlerChain);	
	END
	RETURN nChainReturn;
END

INT
FUNCTION DspGetMouseDown(INT hAN=0)

	IF mbMouseDownRegistered = FALSE THEN
		DspRegisterMouseDown();
	END

	IF hAN = 0 THEN 
		hAN = DspGetAnCur();
	END
	RETURN (hAN = fnButtonDown)
END


c0Title: SMTP Mail
c1Code:
// MailSend.ci -- functions for sending email
//
// Note: Binary attachments do not currently work
//
// Revisions:
//	?/?/??   1.00   Eric Black  Original
//	?/?/??   1.01   Eric Black  Improved Fix() function
//  5/7/04   1.10   Eric Black  Added 'sent date'
//	                            Improved documentation
//	                            Added status text
//  1/19/06  1.11   Eric Black  Fixed login sequence to use HELO command with a username (blank pwd)
//                              Added Getxxx functions to read lists of names or files
//	9/13/07  1.12   Eric Black	Added doco for servers that require a domain name. 
//								Changed end of message from CRLF.LF to CRLF.CRLF
//								Disabled debugging TraceMsg calls
//								All returned values are now shown by MailSendStatus as well
//								Status messages are no longer in multilanguage format as they may 
//								come from the mail server
//  3/10/08  1.13   Eric Black  Increased timeout in WaitForResponse function to allow for slow servers
//

/////////////////////////////////////////////////////////////////////////////////
//MODULE VARIABLES
/////////////////////////////////////////////////////////////////////////////////

STRING	msToList[479];			// List of addresses to send email To
INT		miNextTo;				// Next unused element in To List array
STRING	msCCList[479];
INT		miNextCC;
STRING	msBCCList[479];
INT		miNextBCC;
STRING	msAttachmentList[479];
INT		miNextAttachment;
INT		mhMailServer = -1;		// Handle for mail server socket connection
STRING	msSendStatus;			// Stores the current send progress message/error
INT		miLocal_1_1_1980;       // Local time for 1/1/80
STRING	msDecimalSeparator;		// Must be set to the local decimal separator


/////////////////////////////////////////////////////////////////////////////////
//MODULE CONSTANTS
/////////////////////////////////////////////////////////////////////////////////

STRING	MONTH_NAMES[13] = "", "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec";
STRING	DAY_NAMES[8] = "", "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat";
STRING  LF = "^0x0A";				// Line feed character
STRING	CRLF = "^0x0D^0x0A";		// Carriage Return & Line Feed characters
INT		MAX_ELEMENTS = 478;			// Max number of elements in any string array
INT		FAIL = -1;					// Operation has failed

STRING	UU_HEADER = "begin 666 ";	// Marks start of encoding
STRING	UU_FOOTER = "end";			// Marks end of encoding
INT		UU_CHUNK_SIZE = 45;			// # of bytes encoded per fixed line (common)
STRING	UU_TERMINATOR = "`";		// Marks the end of file
INT		UU_BASE = 32;				// Marks base encoding

// MailSendSMTP iMode parameter constants
INT		MAIL_NORMAL = 0;
INT		MAIL_MESSAGE_FILE = 1;
INT		MAIL_CLEAR_LISTS = 0;
INT		MAIL_PRESERVE_LISTS = 2;
INT		MAIL_NORMAL_IMPORTANCE = 0;
INT		MAIL_HIGH_IMPORTANCE = 4;
INT		MAIL_LOW_IMPORTANCE = 8;
INT		MAIL_NO_FOLLOWUP = 0;
INT		MAIL_FOLLOWUP = 16;

// FileOpen constants
STRING	FILE_READONLY = "r";

// Time/date constants
INT DAY_SECS = 86400;
INT HOUR_SECS = 3600;
INT GMT_1_1_1980 = 315532800;       // Citect time/date variable for 1/1/80



/////////////////////////////////////////////////////////////////////////////////
//PUBLIC FUNCTIONS
/////////////////////////////////////////////////////////////////////////////////


// Function:	MailSendSMTP
//
// Description:	Send e-mail through a POP3/SMTP server without needing a local MAPI client
//
// Arguments:	sFrom		Address of sender (e.g. name@domain.com)
//				sTo			Address of recipient. Multiple addresses may be used by calling AddTo()
//				sSubject	E-mail subject
//				sMessage	E-mail body text (default = "")
//				sUser		Login User name (only needed if server requires authentication)
//				sPassword	Login Password (only needed if server requires authentication)
//				iMode		0 Normal mode (default)
//							1 The sMessage argument is the name of a text file to send as the message body.
//
//							0 Clear To, CC, BCC, and attachment lists after sending (default)
//							2 Preserve To, CC, BCC, and attachment lists after sending
//
//							0 Set Normal importance (default)
//							4 Set High importance
//							8 Set Low importance
//							
//							0 No follow-up flag (default)
//							16 Flag for follow-up
//
// Return Value:	"OK" if successful. If unsuccessful, the SMTP error code and description are returned
//
// Notes:		1. You need to create a TCP/IP Board in your project if you don't already have one like this:
//						Board Name: <enter a name>
//						Board Type: TCPIP
//						Address: 0
//				2. You need to create a TCP/IP port for your mail server:
//						Port Name: MailServerPort
//						Board Name: <enter the board's name>
//						Special Opt: -i<ip address> -p25
//							For example: -i166.102.235.115 -p25
//							Change -p25 if your mail server uses a different port number
//				3. If you want to send to multiple recipients, use the functions AddTo(), AddCC(), AddBCC(), and 
//				   AddAttachment() to create lists before calling MailSendSMTP(). Use GetTo(), GetCC(), GetBCC, and
//                 GetAttachment() to read the items back.
//				4. If the server requires authentication to send mail, specify the username and password. Only SMTP
//				   AUTH LOGIN (Base64 encoded) authentication is supported.
//				5. Named addresses may be used for From, To, CC, or BCC in the form: "John Doe" <jdoe@headlight.com>
//				   Citect requires a ^ before each quote within the string. For example: 
//				   AddTo("^"John Doe^" <jdoe@headlight.com>")
//				6. If sMessage specifies a file to include in the message, it must be a plain text file.
//				7. The message text must not contain the sequence <CRLF>.<CRLF> as this signifies the end of the message body.
//				8. Each e-mail address, the subject, and the sMessage argument should not exceed 110 characters each.
//				9. Call MailSendStatus() to get the current status messages while a message is being sent.
//				10. If you get an error like "501 HELO requires domain", the mail server may only allow mail to be sent from
//                  Certain domains. Specify the domain in the sUser argument. For example, if the server is smtp.comporium.net
//					try entering "comporium.net" as the sUser value

STRING
FUNCTION
MailSendSMTP(STRING sFrom, STRING sTo = "", STRING sSubject = "", STRING sMessage="", STRING sUser = "", STRING sPassword = "", INT iMode = 0)

	INT		iCount;
	STRING	sText;
	STRING	sBuffer;
	INT		iLength;
	INT		iTime;
	INT 	bFailed = FALSE;
	STRING	sResponse;
	
	AccessCriticalSection("MailSendSMTP");

	msSendStatus = "Opening port 'MailServerPort'";
	
	mhMailServer = ComOpen("MailServerPort", 0);
	IF mhMailServer = FAIL THEN
		Cleanup(iMode);
		msSendStatus = "Cannot open port";
		RETURN msSendStatus;
	END
	
	msSendStatus = "Waiting for server response";
	
	sResponse = WaitForResponse("220");
	IF sResponse <> "" THEN
		Cleanup(iMode);
		msSendStatus = sResponse;
		RETURN msSendStatus;
	END
	
	IF (sUser <> "") AND (sPassword <> "") THEN	// Attempt user authentication

		msSendStatus = "Requesting Base64 authentication";

		sResponse = SendText("HELO " + sUser, "AUTH LOGIN");	// Should be EHLO <network Name of connecting machine>?

		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = "Login error: Base64 authentication not supported by server";
			RETURN msSendStatus;
		END

		msSendStatus = "Requesting AUTH login";

		sResponse = SendText("AUTH LOGIN", "334");
		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = sResponse;
			RETURN msSendStatus;
		END

		msSendStatus = "Sending username: " + sUser;
		
		sResponse = SendText(Base64Encode(sUser), "334");
		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = sResponse;
			RETURN msSendStatus;
		END
		
		msSendStatus = "Sending password: " + StrFill("�", StrLength(sPassword));
		
		sResponse = SendText(Base64Encode(sPassword), "235");
		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = sResponse;
			RETURN msSendStatus;
		END
		
	ELSE // No authentication
		IF sUser <> "" THEN
			sResponse = SendText("HELO " + sUser, "250");
		ELSE
			sResponse = SendText("HELO", "250");
		END
		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = sResponse;
			RETURN msSendStatus;
		END
	END
	
	msSendStatus = "Mail from: " + sFrom;

	sResponse = SendText("MAIL FROM: <" + GetAddress(sFrom) + ">", "250");
	IF sResponse <> "" THEN
		Cleanup(iMode);
		msSendStatus = sResponse;
		RETURN msSendStatus;
	END	
	
	msSendStatus = "Mail to: " + sTo;

	IF sTo <> "" THEN
		sResponse = SendText("RCPT TO: <" + GetAddress(sTo) + ">", "250");
		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = sResponse;
			RETURN msSendStatus;
		END
	END
		
	FOR iCount = 0 TO miNextTo - 1 DO
		sText = msToList[iCount];
		msSendStatus = "Mail to: " + sText;
		sResponse = SendText("RCPT TO: <" + GetAddress(sText) + ">", "250");
		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = sResponse;
			RETURN msSendStatus;
		END
	END

	FOR iCount = 0 TO miNextCC - 1 DO
		sText = msCCList[iCount];
		msSendStatus = "Mail CC: " + sText;
		sResponse = SendText("RCPT TO: <" + GetAddress(sText) + ">", "250");
		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = sResponse;
			RETURN msSendStatus;
		END
	END

	FOR iCount = 0 TO miNextBCC - 1 DO
		sText = msBCCList[iCount];
		msSendStatus = "Mail BCC: " + sText;
		sResponse = SendText("RCPT TO: <" + GetAddress(sText) + ">", "250");
		IF sResponse <> "" THEN
			Cleanup(iMode);
			msSendStatus = sResponse;
			RETURN msSendStatus;
		END
	END

	msSendStatus = "Message begin";

	sResponse = SendText("DATA", "354");	// Beginning of message
	IF sResponse <> "" THEN
		Cleanup(iMode);
		msSendStatus = sResponse;
		RETURN msSendStatus;
	END

	SendText("DATE: " + BuildSmtpDate(TimeCurrent()));
    SendText("FROM: " + sFrom);
	SendText("TO: " + sTo);
	
	FOR iCount = 0 TO miNextTo - 1 DO
		SendText("TO: " + msToList[iCount]);
	END

	msSendStatus = "CC";

	FOR iCount = 0 TO miNextCC - 1 DO
			SendText("CC: " + msCCList[iCount]);
	END

    IF (iMode BITAND MAIL_HIGH_IMPORTANCE) = MAIL_HIGH_IMPORTANCE THEN
		SendText("X-Priority: 1 (Highest)");
		SendText("X-MSMail-Priority: High");
		SendText("Importance: High");
	ELSE
		IF (iMode BITAND MAIL_LOW_IMPORTANCE) = MAIL_LOW_IMPORTANCE THEN
			SendText("X-Priority: 5 (Lowest)");
			SendText("X-MSMail-Priority: Low");
			SendText("Importance: Low");
		ELSE	// Normal importance
			SendText("X-Priority: 3 (Normal)");
			SendText("X-MSMail-Priority: Normal");
			SendText("Importance: Normal");
		END
	END

	IF (iMode BITAND MAIL_FOLLOWUP) = MAIL_FOLLOWUP THEN
		SendText("X-Message-Flag: Follow up");
	END

	SendText("X-Mailer: CitectSCADA " + Version(3) + " MailSendSMTP");

	SendText("SUBJECT: " + sSubject);
	SendText("");
	
	IF (iMode BITAND MAIL_MESSAGE_FILE) = MAIL_MESSAGE_FILE THEN
		// sMessage contains a filename. Include its contents in the message
		msSendStatus = "Including text file: " + sMessage;

		sText = IncludeTextFile(sMessage);	
		IF sText <> "" THEN 	// If not OK
			Cleanup(iMode);
			msSendStatus = sText;
			RETURN msSendStatus;
		END
	ELSE
		SendText(sMessage);
	END

	IF miNextAttachment > 0 THEN	// Attach files
		FOR iCount = 0 TO miNextAttachment - 1 DO
			UUEncodeFile(msAttachmentList[iCount]);
		END
	END

	msSendStatus = "End of message text";

	sResponse = SendText(CRLF + "." + CRLF, "250", FALSE);		// End of message text
	IF sResponse <> "" THEN
		Cleanup(iMode);
		msSendStatus = sResponse;
		RETURN msSendStatus;
	END
	
	msSendStatus = "Quitting";

	sResponse = SendText("QUIT", "221");
	IF sResponse <> "" THEN
		Cleanup(iMode);
		msSendStatus = sResponse;
		RETURN msSendStatus;
	END

	Cleanup(iMode);
	msSendStatus = "Message sent " + Time(1) + " " + Date(9);

	msSendStatus = "OK";
	RETURN msSendStatus;	// No errors
END


// Add an e-mail address to the To list
// Returns the number of addresses in the list (max 479) or -1 if the list is full
INT
FUNCTION
AddTo(STRING sAddress)
	IF sAddress <> "" THEN
		IF miNextTo < MAX_ELEMENTS THEN
			msSendStatus = "Added TO #" + MiNextTo:# + ": " + sAddress;
			msToList[miNextTo] = sAddress;
			miNextTo = miNextTo + 1;
			RETURN miNextTo;
		ELSE
			RETURN FAIL;
		END
	END
END


// Add an e-mail address to the CC list
// Returns the number of addresses in the list (max 479) or -1 if the list is full
INT
FUNCTION
AddCC(STRING sAddress)
	IF sAddress <> "" THEN
		IF miNextCC < MAX_ELEMENTS THEN
			msSendStatus = "Added CC #" + MiNextCC:# + ": " + sAddress;
			msCCList[miNextCC] = sAddress;
			miNextCC = miNextCC + 1;
			RETURN miNextCC;
		ELSE
			RETURN FAIL;
		END
	END
END


// Add an e-mail address to the BCC list
// Returns the number of addresses in the list (max 479) or -1 if the list is full
INT
FUNCTION
AddBCC(STRING sAddress)
	IF sAddress <> "" THEN
		IF miNextBCC < MAX_ELEMENTS THEN
			msSendStatus = "Added BCC #" + MiNextBCC:# + ": " + sAddress;
			msBCCList[miNextBCC] = sAddress;
			miNextBCC = miNextBCC + 1;
			RETURN miNextBCC;
		ELSE
			RETURN FAIL;
		END
	END
END


// Add an e-mail address to the Attachment list
// Returns the number of addresses in the list (max 479) or -1 if the list is full 
// or the file doesn't exist.
INT
FUNCTION
AddAttachment(STRING sFile)
	IF sFile <> "" THEN
		IF miNextAttachment < MAX_ELEMENTS THEN
			IF FileExist(sFile) THEN
				msSendStatus = "Added Attachment #" + MiNextAttachment:# + ": " + sFile;
				msAttachmentList[miNextAttachment] = sFile;
				miNextAttachment = miNextAttachment + 1;
				RETURN miNextAttachment;
			ELSE
				msSendStatus = "Attachment '" + sFile + "' doesn't exist'";
				RETURN FAIL;
			END
		ELSE
			RETURN FAIL;
		END
	END
END


// Get the current status and email lists
STRING FUNCTION MailSendStatus() RETURN msSendStatus; END
STRING FUNCTION GetTo(INT iIndex) IF iIndex < miNextTo THEN RETURN msToList[iIndex]; ELSE RETURN ""; END; END
STRING FUNCTION GetCC(INT iIndex) IF iIndex < miNextCC THEN RETURN msCCList[iIndex]; ELSE RETURN ""; END; END
STRING FUNCTION GetBCC(INT iIndex) IF iIndex < miNextBCC THEN RETURN msBCCList[iIndex]; ELSE RETURN ""; END; END
STRING FUNCTION GetAttachment(INT iIndex) IF iIndex < miNextAttachment THEN RETURN msAttachmentList[iIndex]; ELSE RETURN ""; END; END


/////////////////////////////////////////////////////////////////////////////////
//PRIVATE FUNCTIONS
/////////////////////////////////////////////////////////////////////////////////


//Add the contents of the specified text file to the message
//Returns "" if successful or an error message.
PRIVATE
STRING
FUNCTION
IncludeTextFile(STRING sFile)

	INT hFile;
	STRING sText;
	
	
	ErrSet(1);
	
	IF FileExist(sFile) = TRUE THEN
		hFile = FileOpen(sFile,"r");
		IF hFile = FAIL THEN
			ErrSet(0);
			RETURN "Unable to open file '" + sFile + "'";
		END
		
		WHILE FileEOF(hFile) = FALSE DO
			sText = FileRead(hFile, 127);
			StrReplace(sText, CRLF, LF);
			SendText(sText, "", 0);
		END			
	ELSE
		RETURN "File '" + sFile + "' does not exist";
	END
	
	FileClose(hFile);
	
	ErrSet(0);
END


// Take named address in the form:
// "John Doe" <jdoe@headlight.com>
// and return only the address part: jdoe@headlight.com
// If the quotes or <>s are missing, the entire address is returned.
// If it is invalid, the mail server should Report it.
PRIVATE
STRING
FUNCTION
GetAddress(STRING sAddress)

	INT iBeginQuote;
	INT iEndQuote;
	INT iBeginBracket;
	INT iEndBracket;
	
	iBeginQuote = StrSearch(0,sAddress, "^"");
	IF iBeginQuote <> FAIL THEN
		iEndQuote = StrSearch(iBeginQuote + 1, sAddress, "^"");
		IF iEndQuote <> FAIL THEN
			iBeginBracket = StrSearch(iEndQuote + 1, sAddress, "<");
			IF iBeginBracket <> FAIL THEN
				iEndBracket = StrSearch(iBeginBracket + 1, sAddress, ">");
				IF iEndBracket <> FAIL THEN
					sAddress = StrMid(sAddress, iBeginBracket + 1, iEndBracket - iBeginBracket - 1);
				END
			END
		END
	END
	RETURN sAddress;	
END


PRIVATE
FUNCTION
Cleanup(INT iMode)
	IF (iMode BITAND MAIL_PRESERVE_LISTS) <> MAIL_PRESERVE_LISTS THEN
		ClearMailLists();
	END
	Sleep(5);
	ClearBuffer();
	ComClose(mhMailServer);
	LeaveCriticalSection("MailSendSMTP");
END


PRIVATE
FUNCTION
ClearMailLists()
	INT iCount;

	miNextTo = 0;
	miNextCC = 0;
	miNextBCC = 0;
	miNextAttachment = 0;
END

// Send text to the mail server socket connection
// Automatically add LF to end of string unless bSendLF = FALSE
// 1/19/06 Modified to match standard to use LF instead of CRLF
PRIVATE
STRING
FUNCTION
SendText(STRING sText, STRING sResponse = "", INT bSendLF = TRUE)

	INT iLength;
	INT iWaitTime;
	
	INT NO_WAIT = 0;
	INT WAIT_FOREVER = -1;
	
	IF bSendLF = TRUE THEN
		sText = sText + LF;
	END
	
	iLength = StrLength(sText);
	ClearBuffer();
	
	IF sResponse = "" THEN
		iWaitTime = NO_WAIT;
	ELSE
		iWaitTime = 2;
	END
	
	ComWrite(mhMailServer, sText, iLength, iWaitTime);
	
	IF sResponse <> "" THEN
		RETURN WaitForResponse(sResponse);
	ELSE
		RETURN "";
	END	
END


PRIVATE
FUNCTION
ClearBuffer()
	STRING sBuffer;
	INT iLength = 128;
	
	WHILE iLength > 0 DO
		iLength = 128;
		ComRead(mhMailServer, sBuffer, iLength, 0);
!		IF sBuffer <> "" THEN TraceMsg(sBuffer); END
	END
END


// Checks port for specified response. Retries every 200ms (up to 4x)
// If response not found before timeout or > 128 characters received,
// returns response (should be an error message)
// Returns "" if expected response found
PRIVATE
STRING
FUNCTION
WaitForResponse(STRING sText)
	INT iLength;
	STRING sBuffer;
	STRING sResponse;
	INT iErr;
	INT iCount;

	INT WAIT_SEC = 4;
	INT DELAY_MS = 500;
	INT RETRIES = 12;	// Number of times to check for response
	INT ERR_TIMEOUT = 7;

	FOR iCount = 1 TO RETRIES DO

		SleepMS(DELAY_MS);
		
		iLength = 128;		
		
		iErr = ComRead(mhMailServer, sBuffer, iLength, 0);
!		IF sBuffer <> "" THEN TraceMsg(sBuffer); END

		IF (iErr <> 0) AND (iErr <> ERR_TIMEOUT) THEN
			RETURN "Read error: " + iErr:#;
		END
		
		IF StrLength(sResponse) + StrLength(sbuffer) > 255 THEN	// If buffer about to overflow, drop beginning
			iLength = StrLength(sText) - 1;
			sResponse = StrRight(sResponse, iLength);
		END
		sResponse = sResponse + sBuffer;
		
		IF StrSearch(0, sResponse, sText) <> FAIL THEN
			RETURN "";	// Response received
		ELSE
			IF StrLength(sResponse) > 128 THEN
				RETURN sResponse;
			END
		END
	END
	
	IF sResponse = "" THEN
		RETURN "No response from mail server";
	ELSE
		RETURN sResponse;	// Expected response not received
	END
END



// Pass a path\filename or a path substitution like [Data]:File.ext
// Returns the filename and extension
STRING
FUNCTION
FileNameFromPath(STRING sPath)

	INT iChar;
	INT iLength;

	sPath = PathToStr(sPath);	
	iLength = StrLength(sPath);
	iChar = iLength - 1;

	WHILE TRUE DO 
		IF StrMid(sPath, iChar, 1) = "\" THEN
			RETURN StrRight(sPath, iLength - iChar - 1);
		ELSE
			iChar = iChar - 1;
		END
		IF iChar < 0 THEN
			RETURN "";
		END
	END
END


// UU Encodes the specifid file
FUNCTION
UUEncodeFile(STRING sFilePath)
 
	INT hFile;				// file handler
	INT iLength;			// file size
	INT iFileSize;			// size of the file
	STRING sFileName;		// name of the file
	STRING sFileData;		// file data chunk
	INT nEncodedLines;		// number of encoded lines
	STRING sTempLine;		// temporary string
	INT i;					// loop counter
	INT j;					// loop counter
	INT iChar;				// Character being processed
	INT iChar1;				// Character being processed
	INT iChar2;				// Character being processed
	INT iCount;
	
	STRING sEncoded;		// Encoded text

	hFile = FileOpen(sFilePath, FILE_READONLY);
	
	sFileName = FileNameFromPath(sFilePath);
	
	SendText(UU_HEADER + sFileName);
	
	//Get file size
	iFileSize = FileSize(hFile);
	nEncodedLines = Fix(iFileSize / UU_CHUNK_SIZE) + 1;
	
	//Prepare buffer to retrieve data from
	//the file by 45 symbols chunks
	sFileData = StrFill(" ", UU_CHUNK_SIZE);
	
	FOR i = 1 TO nEncodedLines DO
	    //Read file data by 45-bytes cnunks
	    IF i = nEncodedLines THEN
	        //Last line of encoded data often is not
	        //equal to 45, therefore we need to change
	        //size of the buffer
	        sFileData = StrFill(" ", iFileSize MOD UU_CHUNK_SIZE);
	    END
	    //Retrieve data chunk from file to the buffer
		iLength = UU_CHUNK_SIZE;
		iLength = FileReadBlock(hFile, sFileData, iLength);
	    //Add first symbol to encoded string that informs
	    //about quantity of symbols in encoded string.
	    //More often "M" symbol is used.
		sTempLine = CharToStr(iLength + UU_BASE);

	    IF i = nEncodedLines AND (iLength MOD 3) THEN
	        //If the last line is processed and length of
	        //source data is not a number divisible by 3,
	        //add one or two blankspace symbols
	        FOR iCount = 1 TO 3 - (iLength MOD 3) DO
	        	StrSetChar(sFileData, iLength + iCount + 1, 32);
	        END
!	        sFileData = sFileData + StrFill(" ", 3 - (iLength MOD 3));
	    END
	
		j = 0;
	    WHILE j <= iLength - 1 DO
	        //Break each 3 (8-bits) bytes to 4 (6-bits) bytes

	        //1 byte
	        iChar1 = StrGetChar(sFileData, j);
	        iChar = Fix(iChar1 / 4) + UU_BASE;
	        IF iChar = 32 THEN
	        	iChar = 96;
	        END
	        sTempLine = sTempLine + CharToStr(iChar);

	        // 2 byte
	        iChar1 = StrGetChar(sFileData, j);
	        iChar2 = StrGetChar(sFileData, j + 1);
	        iChar = (iChar1 MOD 4) * 16 + Fix(iChar2 / 16) + UU_BASE;
	        IF iChar = 32 THEN
	        	iChar = 96;
	        END
	        sTempLine = sTempLine + CharToStr(iChar);

			// 3 byte
			iChar1 = StrGetChar(sFileData, j + 1);
			iChar2 = StrGetChar(sFileData, j + 2);
			iChar = (iChar1 MOD 16) * 4 + Fix(iChar2 / 64) + UU_BASE;
			IF iChar = 32 THEN
				iChar = 96;
			END
	        sTempLine = sTempLine + CharToStr(iChar);

			// 4 byte
			iChar1 = StrGetChar(sFileData, j + 2);
			iChar = iChar1 MOD 64 + UU_BASE;
			IF iChar = 32 THEN
				iChar = 96;
			END
	        sTempLine = sTempLine + CharToStr(iChar);
	        
			j = j + 3;
	    END
	    
	    //add encoded line to result buffer
	    SendText(sTempLine);
	    //reset line buffer
	    sTempLine = ""
	    
   		msSendStatus = "Sending Attachment: '" + sFilePath + "' " +(IntToReal(100 * i) / nEncodedLines):###.### + "% Complete";
        SleepMS(0);
	END

	FileClose(hFile);
	
	//add the end marker
	SendText(UU_TERMINATOR);
	SendText(UU_FOOTER);
	
END



PRIVATE
STRING
FUNCTION
Base64Encode(STRING sInput)

	INT InputByte1, InputByte2, InputByte3;
	INT OutputByte1, OutputByte2, OutputByte3, OutputByte4;
	INT iLength;
	INT iPos;
    STRING sOutput;
    
    ErrSet(1);
    
    iLength = StrLength(sInput);
    
    iPos = 0;
    WHILE iPos < iLength DO
		InputByte1 = StrToChar(StrMid(sInput, iPos, 1));
		InputByte2 = StrToChar(StrMid(sInput, iPos + 1, 1) + CharToStr(0));
		InputByte3 = StrToChar(StrMid(sInput, iPos + 2, 1) + CharToStr(0));
		OutputByte1 = Fix(InputByte1 / 4);
		OutputByte2 = (InputByte1 BITAND 3) * 16 + Fix(InputByte2 / 16);

		IF iLength >= iPos + 2 THEN
			OutputByte3 = (InputByte2 BITAND 15) * 4 + Fix(InputByte3 / 64);
		ELSE
			OutputByte3 = -1;
		END

		IF iLength >= iPos + 3 THEN
			OutputByte4 = InputByte3 BITAND 63;
		ELSE
			OutputByte4 = -1;
		END
		
		sOutput = sOutput + MimeEncode(OutputByte1) + MimeEncode(OutputByte2) + MimeEncode(OutputByte3) + MimeEncode(OutputByte4);
		
		iPos = iPos + 3;
	END
	
	ErrSet(0);
    
    RETURN sOutput;

END


// Mime-Encode an ascii value. Returns the encoded string
PRIVATE
STRING
FUNCTION
MimeEncode(INT iInput)
	STRING sBase64 = "=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";

    RETURN StrMid(sBase64, iInput + 1, 1);
END


// Emulates VB's Fix() function. Takes a REAL value and drops the decimals without rounding
INT
FUNCTION
Fix(REAL rValue)
	RETURN rValue - (rValue MOD 1);
END


//
// FUNCTION:	AccessCriticalSection
//
// DESC:		Replacement for EnterCriticalSection.
//
// REVISION:	15/8/01	Eric Black	Original
//
// ARGUMENTS:	sName	Section name (see EnterCriticalSection help)
//
// RETURN VALUE:	0 if successful. Otherwise Cicode error is returned (from SemWait)
//
// NOTES:		Fixes bug mentioned in Q3402
//
PRIVATE
INT 
FUNCTION 
AccessCriticalSection(STRING sName)
    INT hSem;
    INT iErr;

    hSem = SemOpen(sName, 2);
    iErr = SemWait(hSem, -1);

    WHILE iErr = 297 DO // Repeat if semaphore owner died 
          iErr = SemWait(hSem, -1);
    END

    RETURN iErr;
END 


// Returns the number of seconds between the current time zone and GMT
INT
FUNCTION
GmtBiasSec()
 
    INT iBiasStandardTime;  // Current time zone's bias from GMT when in standard time
    INT iBiasCurrentTime;   // Current time zone's bias from GMT. May or may not be daylight savings time
 
    IF miLocal_1_1_1980 = 0 THEN
        miLocal_1_1_1980 = BuildDate(1,1,1980);
    END
 
    iBiasStandardTime = GMT_1_1_1980 - miLocal_1_1_1980;
    iBiasCurrentTime = TimeMidNight(TimeCurrent()) MOD DAY_SECS;
 
    IF (iBiasStandardTime >= 0) AND (iBiasCurrentTime <> 0) THEN
        iBiasCurrentTime = DAY_SECS - iBiasCurrentTime;
    END
 
    IF iBiasStandardTime < 0 THEN
        iBiasCurrentTime = iBiasCurrentTime * (-1);
    END
 
    RETURN iBiasCurrentTime;
 
END
 
 
// Convert a separate day, month, and year into a Citect Time/Date variable
// Takes into account the local date format
PRIVATE
INT
FUNCTION
BuildDate(INT iDay, INT iMonth, INT iYear)
 
    // DateInfo Constants
    INT DATE_ORDER = 1;
    INT DATE_DELIMITER = 2;
    STRING MMDDYY_ORDER = "0";
    STRING DDMMYY_ORDER = "1";
    STRING YYMMDD_ORDER = "2";
 
    STRING sDelimiter;
    STRING sDate;
 
    sDelimiter = DateInfo(DATE_DELIMITER, 0);
    
    SELECT CASE DateInfo(DATE_ORDER, 0)
        CASE MMDDYY_ORDER
            sDate = iMonth:# + sDelimiter + iDay:# + sDelimiter + iYear:#;
            RETURN StrToDate(sDate);
        CASE DDMMYY_ORDER
            sDate = iDay:# + sDelimiter + iMonth:# + sDelimiter + iYear:#;
            RETURN StrToDate(sDate);
        CASE YYMMDD_ORDER
            sDate = iYear:# + sDelimiter + iMonth:# + sDelimiter + iDay:#;
            RETURN StrToDate(sDate);
        CASE ELSE
            RETURN 0;
    END SELECT
END


// Builds a time/date string in SMTP format from the specified Citect Time value
// Example: Fri, 07 May 2004 00:44:38 -0600
STRING
FUNCTION
BuildSmtpDate(INT iTime)
	STRING sTime;
	INT iGmtSecs;
	
	sTime = DAY_NAMES[DateWeekDay(iTime)] + ", ";
	sTime = sTime + DateDay(iTime):#0 + " ";
	sTime = sTime + MONTH_NAMES[DateMonth(iTime)] + " ";
	sTime = sTime + DateYear(iTime, 1):#000 + " ";
	sTime = sTime + TimeHour(iTime):#0 + ":";
	sTime = sTime + TimeMin(iTime):#0 + ":";
	sTime = sTime + TimeSec(iTime):#0 + " ";
	
	iGmtSecs = GmtBiasSec();
	IF iGmtSecs >= 0 THEN
		sTime = sTime + Fix(iGmtSecs / HOUR_SECS):#0;
	ELSE
		sTime = sTime + Fix(iGmtSecs / HOUR_SECS):#0#;
	END

	sTime = sTime + Abs(Fix((iGmtSecs MOD HOUR_SECS) / 60)):#0;
	RETURN sTime;
END


! USAGE :	StrReplace( Source, Original, Replace);
!		The StrReplace is used to replace the string 'Original' that is found in string
!		'Source' with the string 'Replace'.
!		_______________________________________________________________________________
!		EG 1:	sText = StrReplace( "The slow brown fox", "slow", "quick");
!		_______________________________________________________________________________
STRING
FUNCTION
StrReplace(STRING sSource, STRING sOrig, STRING sReplace = "")

	INT	iStart	= 0;
	INT	iPos	= 0;
	STRING	sResult	= sSource;

	IF (sOrig <> "") THEN

		sResult = "";
	
		WHILE (iPos > -1) DO
	
			iPos = StrSearch(iStart, sSource, sOrig);
	
			IF (iPos > -1) THEN
				sResult = sResult + StrMid(sSource, iStart, iPos - iStart);
				sResult = sResult + sReplace;
			ELSE
				sResult = sResult + StrRight(sSource, StrLength(sSource) - iStart);
			END
	
			iStart = iPos + StrLength(sOrig);
		END

	END

	RETURN (sResult);
END


c0Title: Internet Explorer Help Page Viewer
c1Code:
Uses a graphics page with an Microsoft Web Browser ActiveX control to display help pages. May be any kind of document IE can display. If no document is specified, a generic (user-defined) index page is displayed.

STRING msHelpFile;		// path/filename of the currently displayed help file (or the last file if none is currently displayed)

// Opens the HelpView page and displays the specified file
//
// Arguments:      sFile   Path and name of the file to display. Can be any file Internet Explorer can display 
//                         and may be a Citect path substitution, local path, UNC path, or URL. If no drive or 
//                         UNC name was specified, it defaults to the [Help] folder. Default: "index.htm"
//
// Source:          Called from help buttons on graphics pages.
//
// Example: Set a button's Up Command to: HelpView("AreaX\MachineX.pdf")
//
FUNCTION
HelpView(STRING sFile)

	IF sFile = "" THEN
		sFile = "index.htm";
	END
	
	sFile = PathToStr(sFile);	// expand any path substitutions
	
	// Default to [Help] path if the drive or UNC path was not specified
	IF (StrSearch(0, sFile, "\\") = -1) AND (StrSearch(0, sFile, ":") = -1) THEN
		sFile = PathToStr("[Help]:" + sFile);
	END
	
	msHelpFile = sFile;
	PageDisplay("HelpView");
END


// Display the selected help file on the HelpView graphics page.
//
// Arguments: sBrowserObjectName   The name of the IE object (properties | Access (Identification) tab | Object Name
//
// Source: Called from HelpView's "On Page Shown" Event.
//
// Notes: HelpView() must be called first to set the file name to display
//
FUNCTION
HelpShow(STRING sBrowserObjectName = "AN19")
	_ObjectCallMethod(ObjectByName(sBrowserObjectName), "Navigate", msHelpFile, 0, 0, 0, 0);
END


Index.htm looks like this:

<html>
<center><b>Select a Citect Help Page</b></center><br>
<A HREF="filename.ext">File Desc</A><br>
<A HREF="filename2.ext">File Desc 2</A><br>
</html>


HelpView Graphics page should have a Back button so users can browse back to the index page:

ErrSet(1);
_ObjectCallMethod(ObjectByName("AN19"),"GoBack")


c0Title: Scroll Microsoft Web Browser
c1Code:
Just call the below function from your scroll buttons with commands like these.

Scroll Up: Scroll(-30); 
Scroll Down: Scroll(30);


Make sure to replace �AN212� with the name of your ActiveX object (Citect Graphics Builder | Web Browser ActiveX object properties | Access tab | Identification subtab | Object Name).

FUNCTION
Scroll(INT nPixels)
      OBJECT hBrowser = ObjectByName("AN212");
      OBJECT hDocument = _ObjectGetproperty(hBrowser, "Document");
      OBJECT hBody = _ObjectGetproperty(hDocument, "Body");
      INT nCurrentPos = _ObjectGetProperty(hBody, "ScrollTop");
      INT nScrollPos = nCurrentPos + nPixels;
      _ObjectSetProperty(hBody, "ScrollTop", nScrollPos);
END


c0Title: Messenger
c1Code:
STRING msName[479];
STRING msDesc[479];
STRING msDescSelection;
STRING msMessage;


// Function:    Messenger
//
// Description: Prompts the user to select a name and enter a message, then sends
//              a popup text message to that user/PC
//
// Version:     1.0   EB  Original
//
// Arguments:   bSortNames    Set to TRUE to alphabetize the list of names (default = TRUE)
//                            or set to FALSE to use the order in MessengerNames.txt
//
// Notes:       1. You must create a list of names and descriptions in a text file named 
//                 MessengerNames.txt in the project's folder. Use this format:
//                   <Name><Tab>[Description]<Enter>
//                 For example:
//                   EricBlack	Eric
//                   OpsPC
//                   192.168.11.140	Citect Server
//              2. The names in MessengerNames.txt may be a PC name, Windows user name,
//                 or IP address 
//              3. The description is optional. If it is omitted, the name will be used instead
//              4. The user may enter a name that is not in the list
//              5. When the Messenger window opens it will display the name from the
//                 last message that was sent, even if it was not in the list
//              6. The Windows Messenger service (not related to MSN Messenger) must be running
//                 on the PC receiving the message. This is enabled by default in Windows
//              7. There is no confirmation that the message has been received
FUNCTION
Messenger(INT bSortNames = TRUE)

	INT hForm;
	INT iMode;

	hForm = FormNew("@(Messenger)", 40, 3, 8);

	msDescSelection = ParameterGet("Messenger", "LastSelection", "");
	IF bSortNames = FALSE THEN iMode = 1; END
	FormComboBox(0, 0, 40, 30, msDescSelection, iMode);
	AddNames();
	FormEdit(0, 1, msMessage, 40);
	FormButton(9, 2, "  @(&Send)  ", MessengerSendCB, 0);
	FormButton(19, 2, " @(&Close)  ", 0, 2);
	FormButton(30, 2, "  @(&Help)  ", MessengerHelpCB, 0);
	FormRead(0);

END


INT
FUNCTION
MessengerHelpCB()
	FormNew("@(Messenger Help)", 58, 3, 8);
	FormPrompt(0, 0, "@(Sends a popup text message to another PC.)");
	FormPrompt(0, 1, "@(Select a name^, type the text to send^, and press Enter or click Send.)");
	FormPrompt(0, 2, "@(The name may be a PC name^, Windows user name^, or IP address.)");
	FormRead(0);
	RETURN 0;
END


INT
FUNCTION
MessengerSendCB()

	INT hForm;
	INT hField;

	FormCurr(hForm, hField);
	FormGetData(hForm);

	Exec("net send " + FindName(msDescSelection) + " " + msMessage, 6);
	SleepMS(100);
	FormGoto(hForm);
	ParameterPut("Messenger", "LastSelection", msDescSelection);

	RETURN 0;
END


PRIVATE
FUNCTION
AddNames()

	STRING sLine;
	INT hFile;
	INT iElement;

	hFile = FileOpen("[RUN]:MessengerNames.txt", "r");

	ErrSet(1);

	sLine = FileReadLn(hFile);

	msName[iElement] = StrWord(sLine);

	WHILE msName[iElement] <> "" DO
		msDesc[iElement] = StrTrim(sLine);
		IF msDesc[iElement] = "" THEN
			msDesc[iElement] = msName[iElement];
		END

		FormAddList(msDesc[iElement]);

		iElement = iElement + 1;
		sLine = FileReadLn(hFile);
		msName[iElement] = StrWord(sLine);
	END

	ErrSet(0);

	FileClose(hFile);
END


STRING
FUNCTION
FindName(STRING sDesc)

	INT iCount;

	FOR iCount = 0 TO 478 DO
		IF sDesc = msDesc[iCount] THEN
			RETURN msName[iCount];
		END
	END

	RETURN sDesc;

END


c0Title: Check if a string contains only a numeric value
c1Code:
INT
FUNCTION
IsNumeric(STRING sStr)

	INT i, iLen, iPer, iMinus, nLength;
	INT iRet = TRUE;
	STRING sChar;
	
	sStr = StrClean(StrTrim(sStr));
	
	nLength = StrLength(sStr);
	WHILE i < nLength AND iRet = TRUE DO
		sChar = StrMid(sStr, i, 1);
		SELECT CASE sChar
			CASE "."
				IF (iPer = 0) THEN
					iPer = 1;
				ELSE
					iRet = FALSE;
				END
			CASE "-"
				IF iMinus = 0 AND i = 0 THEN
					iMinus = 1;
				ELSE
					iRet = FALSE;
				END
			CASE "0","1","2","3","4","5","6","7","8","9"
				;
			CASE ELSE
				iRet = FALSE;
		END SELECT
		i = i + 1;
	END
	RETURN iRet;
END


c0Title: Check if a string contains only an integer value
c1Code:
Check if a string contains only an integer value

// Check if a string contains only an integer value
INT
FUNCTION
IsInteger(STRING sText)
	RETURN (sText = IntToStr(StrToInt(sText)));
END


c0Title: Convert Value to a Comma-Delimited String
c1Code:
// ValToCDel function
//
// Converts an INT, UINT, LONG, or REAL value to a Comma-Separated-Value
// (a string with commas as thousands separators)
//
// Arguments: 	sInput	Input value
//		iMode	0 Value is INT, UINT, or LONG (Default)
//			1 Value is REAL
//
// Return Value: String with commas
//
// Example: String Expression (on a graphic page): ValToCSV(IntTag)
// If IntTag is -12345, then the string will display as: -12,345
//
// For a number with decimals, you have to use mode 1. Example: ValToCSV(AnalogTag, 1)
//
STRING
FUNCTION
ValToCDel(STRING sInput, INT iMode = 0)

	STRING sOutput;		// Output value
	STRING sPrefix;		// Holds "-" if needed
	STRING sSuffix;		// Holds decimal places if needed

	SELECT CASE iMode
		CASE 0	// Integer
			sInput = StrToInt(sInput);	// Strip off decimals (default format adds .00)
		CASE 1	// Real
			sSuffix = StrRight(sInput, StrLength(sInput) - StrSearch(0, sInput, "."));	// Copy decimals into separate string
			sInput = StrToInt(StrLeft(sInput, StrSearch(0, sInput, ".")));				// Strip decimals off input string
	END SELECT

	IF StrToInt(sInput) < 0 THEN		// If input string is negative, move "-" into separate string
		sPrefix = "-";
		sInput = StrRight(sInput, StrLength(sInput) - 1);
	END

	WHILE sInput <> "" DO
		sOutput = StrRight(sInput, 1) + sOutput;			// Copy 1 char from input string to output string
		sInput = StrLeft(sInput, StrLength(sInput) - 1);	// Delete last char from input string

		IF ((StrLength(sOutput) + 1) MOD 4 = 0) AND (StrLength(sInput) >= 1) THEN		// IF output string length is a multiple of 4 (3 digits + comma) and input string still has more chars THEN
			sOutput = "," + sOutput;							// Add comma
		END
	END

	sOutput = sPrefix + sOutput + sSuffix;		// Add "-" and decimal places if used

	RETURN sOutput;

END


c0Title: Equivalent to VB Fix() Function
c1Code:
// Function:         Fix()
//
// Description:      Emulates the VB Fix() function. Takes a REAL value and drops 
//                                 the decimals without rounding 
//
// Argument:         rValue Floating point value to convert 
//
// Return Value:     A long integer equal to the floating point value with no decimal 
//                                 places 
//
// Notes:            Pass 8.4 and it will return 8. Pass -8.4 and it will return -8.
//
INT
FUNCTION
Fix(REAL rValue)
    RETURN rValue - (rValue MOD 1);
END 


c0Title: Mersenne Twister Random Number Generator
c1Code:
// Mersenne.ci - MT19937ar Mersenne Twister Pseudo Random Number Generator Functions
//
// v1.0
//
// http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
// http://en.wikipedia.org/wiki/Mersenne_twister
//
// The built-in Cicode Rand() function only generates integer random numbers between 0 and 
// 32766 but the MT algorithm can generate integer random numbers from 0 to 4294967295 or 
// -2,147,483,648 to 2,147,483,647. It can also generate floating point (REAL) random 
// numbers between 0 and 1 (or a user specified maximum).
//
// Both the Rand() function and MT generate _pseudo_ random numbers. That means 
// they are actually a mathematically calculated sequence of numbers that will eventually
// repeat. Mersenne Twister won't repeat until after 2^19937 - 1 values (that's approximately 
// 4.315425 x 10^6001). MT also allows you to specify the starting point in that sequence
// by setting the 'seed'. This means you can test your project with a sequence of random 
// numbers, then repeat the test later with the same sequence of numbers by specifying the
// same seed value both times. Another option is to save all the values in the mt[] array
// and restore them later to continue the sequence where you left off (this has not been 
// implemented). It is recommended that you set the seed on startup. See MRandSeed() below.
// 
// Functions: MRand()          Return a REAL random number (0 to specified value)
//            MRandInt32()     Return a long INT random number (-2,147,483,648 to 2,147,483,647)
//            MRandInt32Real() Return an integer random number in a REAL variable (0 to 4294967295)
//            MRandSeed()      Sets the random number seed

INT mt[624];	// the array for the state vector
INT mti;

INT mag01[3];
INT mtb;

// Returns a floating point random number between 0 and rMax using the 
// Mersenne Twister Pseudo Random Number Generator
REAL
FUNCTION 
MRand(REAL rMax = 1)
	RETURN MRandInt32Real() * 2.3283064365387E-10 * rMax;
END


// Returns a value in the range 0 to 4294967295 using the
// Mersenne Twister Pseudo Random Number Generator
//
// Note: Since Cicode signed LONG variables only go to 2147483647, the 
// integer value is returned as a 64-bit REAL which can hold that range 
// without losing precision -- see Q2647.
REAL
FUNCTION 
MRandInt32Real()
	INT tmp;
	
	tmp = MRandInt32();
	
	IF tmp < 0 THEN
	    RETURN tmp + 4294967296.0;
	ELSE
	    RETURN tmp;
	END
END


// Returns a long integer random number between -2,147,483,648 and 2,147,483,647 using the 
// Mersenne Twister Pseudo Random Number Generator
INT
FUNCTION 
MRandInt32()
    
    INT y;
    INT kk;
    
    IF NOT mtb THEN
        mti = 625;
    END
    
    IF (mti >= 624) THEN  // generate 624 words at one time
        IF mti = 625 THEN 
        	MRandSeed(5489);	// use default seed
        END
        
        FOR kk = 0 TO (226) DO
            y = (mt[kk] BITAND 0x80000000) BITOR (mt[kk + 1] BITAND 0x7FFFFFFF);
            mt[kk] = (mt[kk + 397] BITXOR UDiv(y, 2)) BITXOR mag01[y BITAND 0x1];
        END
    
        FOR kk = kk TO 622 DO
            y = (mt[kk] BITAND 0x80000000) BITOR (mt[kk + 1] BITAND 0x7FFFFFFF);
            mt[kk] = (mt[kk + -227] BITXOR UDiv(y, 2)) BITXOR mag01[y BITAND 0x1];
        END
    
        y = (mt[623] BITAND 0x80000000) BITOR (mt[0] BITAND 0x7FFFFFFF);
        mt[623] = (mt[396] BITXOR UDiv(y, 2)) BITXOR mag01[y BITAND 0x1];
    
        mti = 0;
    END
    
    y = mt[mti];
    mti = mti + 1;
    
    y = (y BITXOR UDiv(y, 2048));
    INT i1 = UMult(y, 128);
    INT i2 = y BITXOR i1;
    INT i3 = i2 BITAND 0x9D2C5680;
    y = y BITXOR (UMult(y, 128) BITAND 0x9D2C5680);
    y = y BITXOR (UMult(y, 32768) BITAND 0xEFC60000);
    RETURN (y BITXOR UDiv(y, 262144));
END


// Seeds the Mersenne Twister random number generator
// Set nSeed to any long integer value to start that sequence.
// This is automatically called with a default seed the first time a random 
// number is needed. So, if the user does not set the seed, this will always
// use the same sequence of numbers. It is recommended to set the seed on 
// startup using the time: MRandSeed(TimeCurrent())
FUNCTION
MRandSeed(INT nSeed)

    INT tt;
    
    mt[0] = (nSeed BITAND 0xFFFFFFFF);
    
    FOR mti = 1 TO 623 DO
        tt = mt[mti - 1];
        mt[mti] = UAdd(UMult(1812433253, (tt BITXOR UDiv(tt, 1073741824))), mti);
    END
    
    mtb = True;      //means mt[624] IS already initialized
    mag01[0] = 0; 
    mag01[1] = 0x9908B0DF;
END


// The following functions do unsigned long integer math with Citect's 
// signed long integer variables. They work for the above functions, but
// may not be suitable for other applications


//Unsigned Add: adds the two (signed) Long parameters, treated as
//unsigned long, and returns the result as a (signed) Long result:
PRIVATE
INT
FUNCTION 
UAdd(INT x, INT y)
    REAL tmp;
    
    tmp = IntToReal(x) + IntToReal(y);
    
    IF tmp < -2147483648 THEN
        RETURN IntToReal(4294967296.0 + tmp);
    ELSE
        IF tmp > 2147483647 THEN
            RETURN IntToReal(tmp - 4294967296.0);
        Else
            RETURN IntToReal(tmp);
        END 
    END
END


//Unsigned Mult: multiplies the two (signed) Long parameters, treated as
//unsigned long, and returns the lowest 4 bytes of the 8 bytes result
//as a (signed) Long result:
PRIVATE 
INT
FUNCTION 
UMult(INT x, INT y)
    
    INT bb, cc, dd, ff, gg, hh;
    INT r3, r2, r1, r0;
    REAL tmp;
    
    bb = (x / 65536) MOD 256;
    cc = (x / 256) MOD 256;
    dd = x MOD 256;
    
    ff = (y / 65536) MOD 256;
    gg = (y / 256) MOD 256;
    hh = y MOD 256;
    
    r0 = dd * hh;
    r1 = cc * hh + dd * gg + r0 / 256;
    r2 = bb * hh + cc * gg + dd * ff + r1 / 256;
    r3 = (((x / 16777216) * hh + bb * gg + cc * ff + dd * (y / 16777216)) MOD 256) + r2 / 256;
   
    tmp = IntToReal(r3 MOD 256) * 16777216 + (r2 MOD 256) * 65536 + (r1 MOD 256) * 256 + (r0 MOD 256);
    
    IF tmp < -2147483648 THEN 
        RETURN 4294967296.0 + tmp;
    ELSE 
        IF tmp > 2147483647 THEN
            RETURN tmp - 4294967296.0;
        ELSE
            RETURN tmp;
        END
    END
END


//Unsigned Divide: divides the two (signed) Long parameters, treated as
//unsigned long, and returns the result as a (signed) Long result:
PRIVATE
INT
FUNCTION UDiv(INT x, INT y)    
    IF x < 0 THEN
        RETURN Fix((4294967296.0 + x) / y);
    ELSE
        RETURN Fix(x / y);
    END
END


// Emulates the VB Fix() function. Takes a REAL value and drops the decimals without rounding 
// Returns a long integer equal to the floating point value with no decimal
//
// Note: Pass 8.4 and it will return 8. Pass -8.4 and it will return -8.
//
PRIVATE
INT 
FUNCTION 
Fix(REAL rValue)
    RETURN rValue - (rValue MOD 1);
END 


c0Title: Popup Page (Allows for Unlimited SG Associations)
c1Code:
// Displays a popup window like WinPopup or AssPopup, except any number
// of associations may be made before calling Popup()
// A title may optionally be specified. No close button is displayed.
//
// Example:
//           	Ass(-2, 1, "Furn" + nFurnace:#, 0);
//              Ass(-2, 2, "Furn" + nFurnace:#, 0);
//              EM3_Popup("!B_Furn_Damper", "B FURNACE " + nFurnace:# + " DAMPERS");
//
FUNCTION
Popup(STRING sPage, STRING sTitle = "");

	INT		x, y;
	REAL	ScaleX, ScaleY;

	DspGetMouse(x, y);

	ScaleX = StrToReal(PageInfo(16));
	ScaleY = StrToReal(PageInfo(17));
	y = y * ScaleY + StrToInt(PageInfo(15));

	x = x * ScaleX + StrToInt(PageInfo(14));

	IF x > WndInfo(0) - 150 THEN
		x = x - 150;
	ELSE
		x = x + 50;
	END

	IF y > WndInfo(1) - 150 THEN
		y = y - 150;
	ELSE
		y = y + 20;
	END

	x = x / ScaleX;
	y = y / ScaleY;

	WinNewAt(sPage, x, y, 1 + 8 + 32 + 256 + 512);

	IF sTitle <> "" THEN
		WinTitle(sTitle);
	END
END


c0Title: Check if a Graphics Page Exists
c1Code:
// Returns TRUE if the specified page exists, otherwise returns FALSE
//
INT
FUNCTION
Plus_PageExists(STRING sPage)
	ErrSet(1);
	IsError();
	PageFileInfo(sPage, 0);

	IF IsError() = 261 THEN
		RETURN FALSE;
	ELSE
		RETURN TRUE;
	END
END


c0Title: Check if a Window Exists
c1Code:
// Check if a window exists with the specified title. Returns TRUE or FALSE
PRIVATE
INT
FUNCTION
WindowExists(STRING sTitle)
	RETURN (WndFind(sTitle) <> 0);
END


c0Title: Reading Privileges from __Users.rdb
c1Code:
I found the users.rdb contains either the privilege number, or -1 for no privileges, or the number of the group that contains the list of privileges (with the highest bit set to indicate it is not a privilege number). You have to mask off the highest bit to get the group number, then open the group named GRP to get the values. I found the prefix was GRP since you can see the groups in the kernel on PAGE RDB Groups.groups

Here's my test function that retrieves each user name and global privilege list and prints it in the main window of the kernel. Instead of GrpToStr() you could use GrpFirst() and GrpNext() to get the individual elements.

FUNCTION
GetGlobal()

        INT hUsers;
        INT nPriv_G;
        STRING sPrivileges;
        STRING sName;
        INT nGroup;
        INT hGroup;

        hUsers = RdbOpen("_Users");
        RdbFirstRec(hUsers);

        WHILE RdbEOF(hUsers) = FALSE DO
                sName = RdbGet(hUsers, "Name");
                nPriv_G = RdbGet(hUsers, "PRIV_G");

                SELECT CASE nPriv_G

                CASE -1         // No privileges

                        sPrivileges = "";

                CASE IS < -1    // Group of privileges

                        nGroup = nPriv_G BITAND 0x7FFF;
                        hGroup = GrpOpen("GRP" + nGroup:#, 0);

                        sPrivileges = GrpToStr(hGroup);

                        GrpClose(hGroup);

                CASE ELSE               // Single privilege

                        sPrivileges = nPriv_G;

                END SELECT

                TraceMsg("User: " + sName + " Privileges: " + sPrivileges);
                RdbNextRec(hUsers);
        END

        RdbClose(hUsers);
END


c0Title: Read Trend Tags
c1Code:
This is taken from a function populating a form with trend tag names

INT hTrendRDB;

hTrendRDB = RdbOpen("_Trend");
RdbFirstRec(hTrendRDB);

WHILE RdbEOF(hTrendRDB) = FALSE DO
    sTagName = RdbGet(hTrendRDB, "NAME");
    FormAddList(sTagName);
    RdbNextRec(hTrendRDB);
END

RdbClose(hTrendRDB);


c0Title: Read Variable Tags
c1Code:
This is taken from a function populating a form user types

INT mhRDB;

mhRDB = RDBOpen("_Users");
IF (mhRDB <> -1) THEN
	mError = RDBFirstRec(mhRDB);
	WHILE (mError <> -1) DO
		sAddType = RDBGet(mhRDB, "TYPE");
		IF (StrTrim(sAddType) <> "") THEN
			FormAddList(sAddType);
		END
		mError = RDBNextRec(mhRDB);
	END
	RDBClose(mhRDB);
END


c0Title: Read Alarms
c1Code:
INT        hDigAlmRDB        = -1;
STRING    sCustom1        = "";
STRING    sCustom2        = "";
STRING    sCustom3        = "";
STRING    sCustom4        = "";
STRING    sCustom5        = "";
STRING    sCategory        = "";
STRING    sAlarmTag        = "";
STRING    sArea            = "";
    
hDigAlmRDB = RdbOpen("_DIGALM");    // Access run time digital alarms database

IF (hDigAlmRDB <> -1) THEN    

    RdbFirstRec(hDigAlmRDB);

    WHILE NOT (RdbEOF(hDigAlmRDB)) DO    // FOR all digital alarms in system    

        sCategory = RdbGet(hDigAlmRDB, "CATEGORY");        // Get Alarm Category
        sAlarmTag = RdbGet(hDigAlmRDB, "TAG");            // Get Alarm Tag Name
        sArea     = RdbGet(hDigAlmRDB, "AREA");            // Get Alarm Area
        sCustom1  = RdbGet(hDigAlmRDB, "CUSTOM1");        // Get Alarm Custom Field 1
        sCustom2  = RdbGet(hDigAlmRDB, "CUSTOM2");        // Get Alarm Custom Field 2
        sCustom3  = RdbGet(hDigAlmRDB, "CUSTOM3");        // Get Alarm Custom Field 3
        sCustom4  = RdbGet(hDigAlmRDB, "CUSTOM4");        // Get Alarm Custom Field 4
        sCustom5  = RdbGet(hDigAlmRDB, "CUSTOM5");        // Get Alarm Custom Field 5

        'Do something with the data here...
		                    
        RdbNextRec(hDigAlmRDB);
        
        SleepMS(1);
    END
END
        
RdbClose(hDigAlmRDB);


c0Title: Read Variables and Search by Type
c1Code:
hRDB = RDBOpen("_VARIABL");

IF hRDB >= 0 THEN
    nMaxList = 256;
    nRec = RDBPosRec(hRDB,nLastRec);
    nTemp = 0;

    WHILE nMaxList >= 0 AND nRec >=0 DO
        nValue = StrToInt(RDBGet(hRDB, "RawType"));
        ! Check if an selected type variable
        IF ((nValue = 0) AND nSrchDig) OR
           ((nValue = 1) AND nSrchInt) OR
           ((nValue = 2) AND nSrchReal) OR
           ((nValue = 4) AND nSrchLong) OR
           ((nValue = 8) AND nSrchByte) THEN 

            sTemp = RDBGet(hRDB, "Tag");

            IF (sSrchStr = "") OR (StrSearch(0,sTemp,sSrchStr) >= 0) THEN            
                sNameComment = sTemp + " " + DspInfoField(0,sTemp,"Comment");
                FormAddList(sNameComment);
                nMaxList = nMaxList - 1;     
            END   
        END

        nRec = RDBNextRec(hRDB);                                
        nLastRec = nLastRec + 1;
    END

    RDBClose(hRDB);
END


c0Title: RDBPosRec(hRDB, nRec) Function
c1Code:
This function jumps to the specified record number (0 to RdbNoRec() - 1) and returns the record number or -1 for Fail.


c0Title: User Login Redundancy
c1Code:
v1.10

Unfortunately, creating, deleting, and editing users doesn't work properly with redundant servers. This problem is currently being looked into. To work around this, these Cicode functions store the users in a separate database that is shared between all Citect nodes, with a redundant database on another file server. The user list in Citect then only contains generic user types like Operator, Engineer, etc. In the shared database, all individual user names, passwords, and Types are listed and can be added, modified, and deleted. Passwords are encrypted.

When a user tries to log in, it searches the database for the user name and password he specified. If they are correct, it reads the Type from that record and tries to login to Citect using the Login() function. It assumes that the user name and password to log in with will be the same as the type name (operator, engineer, etc) and the password will be lower case.

In your project, you can use the following user functions:

UserLogin()
UserLogout()
ChangeUserPassword(iMode)
AddRemoveUser()
GetUserInfo(iMode)
These replace the Citect LoginForm(), Logout(), UserPasswordForm(), UserEditForm(), and UserInfo() functions. The original functions should no longer be used.

These functions look and work about the same as the ones that come with Citect. The difference is that adding a user, changing a password, or deleting a user causes both the primary and standby databases to be updated. If either database is unavailable (PC or network failure), Windows will hang for 30sec trying to reach the other PC, then an error message will be displayed. To avoid that for every subsequent device command, the functions won't try to access that database again for 1min. As long as either database is available, the command will execute successfully. Each function is described in more detail below.
Requirements
User.ci This file must be copied into your project.

System Label The following label must be defined in your project:

Name: TEST_NO_ERR(EXPR)
Expression: IF (EXPR) <> 0 THEN RETURN -1; END
Comment: Aborts fn if expr doesn't return 0

System Devices. UserDB and UserDB_S have to point to the primary and standby locations of the UserDB DBF files, respectively. Every Citect computer will access both databases, so the paths should be UNC paths or drives that are mapped the same on every Citect PC. For example:

Name: UserDB
Format: {Name,16}{FullName,64}{Password,8}{Type,12}
FileName: \\primaryPC\c_drive\citect\data\userdb.DBF
Type: dBASE_DEV

Name: UserDB_S
Format: {Name,16}{FullName,64}{Password,8}{Type,12}
FileName: \\standbyPC\c_drive\citect\data\userdb_s.DBF
Type: dBASE_DEV

Startup function UserStartup() must be called on startup to synchronize the databases. Configure this in the Computer Setup wizard or Project Editor | System | Parameters | Code \ Startup = UserStartup()

Cicode Function Documentation
UserStartup()
This function should run at startup to synchronize the user databases. The date/time of both files are compared and the newer file is copied over the older file. A status message will display in the main window of the Kernel describing the synchronization.

UserLogin()
This function replaces LoginForm() but adds a dropdown list for selecting the user name

UserLogout()
This function replaces Logout()

ChangeUserPassword(iMode)
This function replaces UserPasswordForm()

Parameter: iMode 0 User can change any user's password without confirming the old password

1 User can only change his own password and must confirm old password

AddRemoveUser()
This function replaces UserCreateForm() and UserEditForm().

Notes: To delete a user, enter the user's name and click Remove User. The other fields are ignored. To add a user, all fields must be filled in.

GetUserInfo(iMode)
This function replaces UserInfo(). Mode 6 has been added to show user type.

Parameter: iMode 0 Returns TRUE if anyone's logged in

1 Returns the login name of the user

2 Returns the full name of the user

3 Returns the time the user logged in

4 Returns the time the user entered the last command

5 Returns the number of commands entered by the user

6 Returns the Type of the logged in user


Cicode

///////////////////////////////////////////////////////////////////////////////////
// User.ci v1.10
//
// Custom Login, Logout, UserCreate, etc functions that support redundancy.
//
// Using this, Citect's User database only contains user types and privileges.
// The individual user names, passwords, and type names are stored in a separate
// database that is located on the primary server with a redundant copy on the
// standby server. Adding, deleting, and modifying users writes to both copies,
// and calling UserStartup() on startup will synchronize both files.
//
// See the Readme.doc file for instructions.
//
// Revisions:
// ?/??/00 Scott Mack  Original
// 7/26/00 Eric Black  Customized & added dropdown lists
// 8/16/00 Eric Black  Added user database file redundancy
// 5/29/02 Eric Black  Fixed problem with blank or partial passwords being accepted
//                     for logins when a nonblank password was in the database
// 1/13/05 Eric Black  Added password encryption and error messages for blank passwords
//
///////////////////////////////////////////////////////////////////////////////////


//////////////////////////// MODULE CONSTANTS /////////////////////////////////////

// Any UserDb function
INT     PRIMARY = 1;
INT     STANDBY = 2;
INT     NO_ERR = 0;
INT     FAIL = -1;

// ChangeUserPassword()
INT     ANY_USER = 0;
INT     THIS_USER = 1;

// GetUserInfo()
INT     LOGGED_IN = 0;
INT     USER_NAME = 1;
INT     FULL_NAME = 2;
INT     LOGIN_TIME = 3;
INT     LAST_CMD_TIME = 4;
INT     CMD_COUNT = 5;
INT     USER_TYPE = 6;

// ErrSet()
INT     ENABLE_CHECK = 0;
INT     DISABLE_CHECK = 1;

// Message()
INT     OK_BUTTON = 0;
INT     CANCEL_BUTTON = 1;
INT     STOP_ICON = 16;
INT     EXCLAMATION_ICON = 48;

//////////////////////////// MODULE VARIABLES /////////////////////////////////////

INT     mhDev = BAD_HANDLE;
INT     mhDev_S = BAD_HANDLE;
INT     mbPrimaryActive = TRUE; // Which database to log to
INT     mbStandbyActive = TRUE; // Which database to log to
INT     miFailTime;             // Time one of the devices last failed

STRING  msUserName;             // Currently logged in user
STRING  msFullName;
STRING  msType;
STRING  msPassword;
STRING  msRetypePassword;

STRING  msNewUserName;          // Temp storage
STRING  msNewFullName;
STRING  msNewType;
STRING  msNewPassword;
STRING  msNewRetypePassword;
STRING  msOldPassword;


//////////////////////////// MODULE FUNCTIONS ///////////////////////////////////


// UserStartup
//
// This function should run at startup to synchronize the user databases.
// The date/time of both files are compared and the newer file is copied over
// the older file. A status message will display in the main window of the Kernel
// describing the synchronization.
//
FUNCTION
UserStartup()

        INT     hFile;
        INT     tPrimary;
        INT     tStandby;

        STRING  sPrimaryFile;
        STRING  sStandbyFile;

        hFile = DevOpen("UserDB", 16);
        sPrimaryFile = PathToStr(DevInfo(hFile, 3));
        DevClose(hFile);

        hFile = DevOpen("UserDB_S", 16);
        sStandbyFile = PathToStr(DevInfo(hFile, 3));
        DevClose(hFile);

        hFile = FileOpen(sPrimaryFile, "r")
        tPrimary = FileGetTime(hFile);
        FileClose(hFile);

        hFile = FileOpen(sStandbyFile, "r")
        tStandby = FileGetTime(hFile);
        FileClose(hFile);

        IF tPrimary > tStandby THEN             // if Primary file is newer
                TraceMsg("@(Replacing Standby UserDB file with Primary copy)");
                FileCopy(sPrimaryFile, sStandbyFile, 0);
        ELSE
                TraceMsg("@(Replacing Primary UserDB file with Standby copy)");
                FileCopy(sStandbyFile, sPrimaryFile, 0);
        END
END

       
// UserLogin
//
// This function replaces LoginForm() but adds a dropdown list for selecting
// the user name
//
// Modified:    5/29/02 Replaced StrSearch with Compare() so false positives aren't accepted
//              1/14/05 Added password encryption
//
INT
FUNCTION
UserLogin()

        STRING  sName;
        STRING  sPasswordInDb;

        INT     bDone = FALSE;
        INT     nStatus;

        msPassword = "";
        msRetypePassword = "";

        TEST_NO_ERR(UserDbOpen());

        WHILE bDone = FALSE DO

                FormNew("@(Login Form)", 30, 5, 5);
                FormPrompt(1, 0, "@(Name)");
                FormComboBox(10, 0, 16, 10, sName, 0);

                AddUserNames();

                FormPassword(1, 2, "@(Password)" + " ", msPassword, 16);
                FormButton(1, 4, "  " + "@(OK)" + "  ", 0, 1);
                FormButton(11, 4, "@(Cancel)", 0, 2);

                IF FormRead(0) = NO_ERR THEN
                        msPassword = EncryptDecrypt(msPassword);

                        TEST_NO_ERR(UserDbFirst());

                        IF UserDbFind(sName, "Name") = NO_ERR THEN                      // Case insensitive

                                sPasswordInDb = UserDbGetField("Password");
                                IF Compare(sPasswordInDb, msPassword) = TRUE THEN       // Check pwd against UserDb. Case sensitive.

                                        msUserName = UserDbGetField("Name");
                                        msFullName = UserDbGetField("FullName");
                                        msType = UserDbGetField("Type");

                                        Login(msType, StrLower(msType));                // Login a Citect User with the Type for the Username and Password

                                        bDone = TRUE;
                                        nStatus = NO_ERR;
                                ELSE
                                        ErrorPopup("@(Incorrect password)");
                                END
                        ELSE
                                ErrorPopup("@(Incorrect Username)");
                        END
                ELSE
                        bDone = TRUE;
                        nStatus = 298;
                END
        END

        UserDbClose();
       
        RETURN nStatus;
END


// UserLogout
//
// This function replaces Logout()
//
FUNCTION
UserLogout()
        Logout();
        msUserName = "";
        msFullName = "";
        msPassword = "";
        msRetypePassword = "";
        msType = "";
END


// ChangeUserPassword
//
// This function replaces UserPasswordForm()
//
// Parameter: iMode     0 ANY_USER      User can change any user's password without confirming the old password
//                      1 THIS_USER     User can only change his own password and must confirm old password
//
// Notes: For the parameter, the number or the label may be used. ChangeUserPassword(1) and
// ChangeUserPassword(THIS_USER) are identical.
//
FUNCTION
ChangeUserPassword(INT iMode = THIS_USER)

        msNewUserName = msUserName;
        msNewPassword = "";
        msNewRetypePassword = "";
        msOldPassword = "";

        FormNew("@(Change Password)", 36, 5, 8);

        IF iMode = ANY_USER THEN
                FormPrompt(0, 0, "@(Name)");
                FormComboBox(19, 0, 16, 10, msNewUserName, 0);
                AddUserNames();
        ELSE
                FormPassword(0, 0, "@(Enter Old Password)" + " ", msOldPassword, 16);
        END

        FormPassword(0, 1, "@(Enter New Password)" + " ", msNewPassword, 16);
        FormPassword(0, 2, "@(Retype New Password)", msNewRetypePassword, 16);

        IF iMode = ANY_USER THEN
                FormButton(0, 4, "@(Change Password)", _ChangePassword, 1);
        ELSE
                FormButton(0, 4, "@(Change Password)", _ChangeMyPassword, 1);
        END
               
        FormButton(19, 4, "@(Cancel)", 0, 2);

        FormRead(0);
END


// _ChangePassword
//
// Internal function used with ChangeUserPassword()
//
// Modified: 5/29/02 Replaced StrSearch with Compare() so false positives aren't accepted
//           1/14/05 Added password encryption and error message for blank passwords
//
INT
FUNCTION
_ChangePassword()

        INT     hForm;
        INT     hField;         // Not used

        FormCurr(hForm, hField);        // Get form handle
        FormGetData(hForm);

        IF msNewPassword <> "" THEN
                msNewPassword = EncryptDecrypt(msNewPassword);
                msNewRetypePassword = EncryptDecrypt(msNewRetypePassword);

                IF Compare(msNewPassword, msNewRetypePassword) = TRUE THEN      // Case sensitive compare
                       
                        IF UserDbFind(msNewUserName, "Name") = NO_ERR THEN
                                TEST_NO_ERR(UserDbSetField("Password", msNewPassword));
                                Prompt("@(Password Changed Successfully)");
                        ELSE
                                ErrorPopup("@(User not found)");
                        END
                ELSE
                        ErrorPopup("@(Passwords do not match)");
                END
        ELSE
                ErrorPopup("@(Password cannot be blank)");
        END

        UserDbClose();

        RETURN NO_ERR;
END


// _ChangeMyPassword
//
// Internal function used by ChangeUserPassword()
//
// Modified:  5/29/02 Replaced StrSearch with Compare() so false positives aren't accepted
//            1/14/05 Added encryption and error message for blank passwords
INT
FUNCTION
_ChangeMyPassword()

        STRING  sPassword;
        INT     hForm;
        INT     hField;         // Not used

        FormCurr(hForm, hField);        // Get form handle
        FormGetData(hForm);

        IF msNewPassword <> "" THEN
                msNewPassword = EncryptDecrypt(msNewPassword);
                msNewRetypePassword = EncryptDecrypt(msNewRetypePassword);
                msOldPassword = EncryptDecrypt(msOldPassword);

                IF Compare(msNewPassword, msNewRetypePassword) = TRUE THEN
                        TEST_NO_ERR(UserDbOpen());
                        TEST_NO_ERR(UserDbFirst());
                        TEST_NO_ERR(UserDbFind(msNewUsername, "Name"));

                        sPassword = UserDbGetField("Password");

                        IF Compare(sPassword, msOldPassword) = TRUE THEN
                                TEST_NO_ERR(UserDbSetField("Password", msNewPassword));
                                Prompt("@(Password changed successfully)");
                        ELSE
                                ErrorPopup("@(Old Password is incorrect)");
                        END

                ELSE
                        ErrorPopup("@(New Passwords do not match)");
                END
        ELSE
                ErrorPopup("@(Password cannot be blank)");
        END

        UserDbClose();

        RETURN NO_ERR;
END


// AddRemoveUser
//
// This function replaces UserCreateForm() and UserEditForm()
//
// Notes: To delete a user, enter the user's name and click Remove User. The other fields are ignored
//      To add a user, all fields must be filled in.
//
FUNCTION
AddRemoveUser()
        INT     hRDB;
        INT     iErr;

        STRING  sAddType;

        msNewPassword = "";
        msNewRetypePassword = "";
        msNewUserName = "";
        msNewFullName = "";
        msNewType = "";
       
        FormNew("@(Add/Remove User)", 32, 6, 8);
        FormPrompt(0, 0, "@(Name)");
        FormComboBox(15, 0, 16, 10, msNewUserName, 0);

        AddUserNames();

        FormPrompt(0, 1, "@(Full Name)");
        FormField(15, 1, 16, 1, 1, msNewFullName, "", 0);
        FormPrompt(0, 2, "@(Type)");
        FormComboBox(15, 2, 16, 5, msNewType);

        hRDB = RDBOpen("_Users");
        IF (hRDB > BAD_HANDLE) THEN
                iErr = RDBFirstRec(hRDB);
                WHILE (iErr > BAD_HANDLE) DO
                        sAddType = RDBGet(hRDB, "TYPE");
                        IF (StrTrim(sAddType) <> "") THEN
                                FormAddList(sAddType);
                        END
                        iErr = RDBNextRec(hRDB);
                END
                RDBClose(hRDB);
        END

        FormPassword(0, 3, "@(Enter Password)" + " ", msNewPassword, 16);
        FormPassword(0, 4, "@(Retype Password)", msNewRetypePassword, 16);

        FormButton(0, 5, "@(Add User)", _AddUser, 1);
        FormButton(10, 5, "@(Remove User)", _RemoveUser, 1);
        FormButton(23, 5, "@(Cancel)", 0, 2);

        FormRead(0);
END


// _AddUser
//
// Internal function used by AddRemoveUser()
//
// Modified:  5/29/02 Replaced StrSearch with Compare() so false positives aren't accepted
//            1/14/05 Added encryption and error message for blank passwords
//
INT
FUNCTION
_AddUser()

        INT     hForm;
        INT     hField;         // Not used

        FormCurr(hForm, hField);        // Get form handle

        TEST_NO_ERR(UserDbOpen());

        FormGetData(hForm);

        IF msNewPassword = "" THEN
                ErrorPopup("@(Password cannot be blank)");
                UserDbClose();
                RETURN FAIL;
        END

        msNewPassword = EncryptDecrypt(msNewPassword);
        msNewRetypePassword = EncryptDecrypt(msNewRetypePassword);

        IF UserDbFind(msNewUserName, "Name") = NO_ERR THEN
                ErrorPopup("@(User already exists)");
                UserDbClose();
                RETURN FAIL;
        END

        IF msNewType = "" THEN
                ErrorPopup("@(User type must be specified)");
                UserDbClose();
                RETURN FAIL;
        END

        IF Compare(msNewPassword, msNewRetypePassword) = TRUE THEN
                TEST_NO_ERR(UserDbAppend());
                TEST_NO_ERR(UserDbSetField("Name", msNewUserName));
                TEST_NO_ERR(UserDbSetField("FullName", msNewFullName));
                TEST_NO_ERR(UserDbSetField("Password", msNewPassword));
                TEST_NO_ERR(UserDbSetField("Type", msNewType));
                UserDbClose();
                Prompt("User added successfully");
        ELSE
                ErrorPopup("@(Passwords do not match)");
        END

        RETURN NO_ERR;
END


// _RemoveUser()
//
// Internal function used by AddRemoveUser()
//
INT
FUNCTION
_RemoveUser()

        INT     hForm;
        INT     hField;         // Not used

        FormCurr(hForm, hField);        // Get form handle
        FormGetData(hForm);

        TEST_NO_ERR(UserDbOpen());

        TEST_NO_ERR(UserDbFirst());

        IF UserDbFind(msNewUserName, "Name") = NO_ERR THEN
                TEST_NO_ERR(UserDbDelete());
                Prompt("@(User deleted successfully)");
        ELSE
                ErrorPopup("@(User not found)");
        END

        UserDbClose();
       
        RETURN NO_ERR;
END


// GetUserInfo
//
// This function replaces UserInfo(). Mode 6 has been added to show user type.
//
// Parameter: iMode     0 Returns TRUE if anyone's logged in
//                      1 Returns the login name of the user
//                      2 Returns the full name of the user
//                      3 Returns the time the user logged in
//                      4 Returns the time the user entered the last command
//                      5 Returns the number of commands entered by the user
//                      6 Returns the Type of the logged in user
//
STRING
FUNCTION
GetUserInfo(INT iMode)

        SELECT CASE iMode
                CASE LOGGED_IN
                        RETURN UserInfo(LOGGED_IN);
                CASE USER_NAME
                        RETURN msUserName;
                CASE FULL_NAME
                        RETURN msFullName;
                CASE LOGIN_TIME
                        RETURN UserInfo(LOGIN_TIME);
                CASE LAST_CMD_TIME
                        RETURN UserInfo(LAST_CMD_TIME);
                CASE CMD_COUNT
                        RETURN UserInfo(CMD_COUNT);
                CASE USER_TYPE
                        RETURN msType;
                CASE ELSE
                        RETURN FAIL;
                END SELECT
END


// UserDbOpen
//
// Internal function. This function opens the primary and standby userDB devices. When one fails, the other will
// be used for 1 min, then then next time this runs, it will try to open the failed device again. If both devices
// have failed, both will be retried.
//
PRIVATE
INT
FUNCTION
UserDbOpen()

        INT     iErr;
        INT     iErr_S;

        IF (mbPrimaryActive = FALSE) AND (mbStandbyActive = FALSE) THEN         // If both devices have failed, try them both again
                mbPrimaryActive = TRUE;
                mbStandbyActive = TRUE;
        END

        IF (mbPrimaryActive * mbStandbyActive = FALSE) AND (TimeCurrent > miFailTime + 60) THEN // If either primary or standby is FALSE (0) and it's
                mbPrimaryActive = TRUE;                                                         // been > 1min since the failure, try both again.
                mbStandbyActive = TRUE;
        END
               

        IF mbPrimaryActive THEN                 // If primary is enabled
                IF mhDev = BAD_HANDLE THEN
                        ErrSet(DISABLE_CHECK);
                        mhDev = DevOpen("UserDB");
                        iErr = IsError();
                        ErrSet(ENABLE_CHECK);
                END
        END

        IF mbStandbyActive THEN         // If standby is enabled
                IF mhDev_S = BAD_HANDLE THEN
                        ErrSet(DISABLE_CHECK);
                        mhDev_S = DevOpen("UserDB_S");
                        iErr_S = IsError();
                        ErrSet(ENABLE_CHECK);
                END
        END

        IF mhDev = BAD_HANDLE THEN
                IF mhDev_S = BAD_HANDLE THEN
                        ErrorPopup("@(Cannot open primary or standby user database)", iErr, PRIMARY + STANDBY);
                        RETURN FAIL;
                ELSE
                        ErrorPopup("@(Cannot open primary user database)" + "^n" + "@(Switching to standby only)", iErr, PRIMARY);
                        mbStandbyActive = TRUE;
                        RETURN NO_ERR;
                END
        ELSE
                IF mhDev_S = BAD_HANDLE THEN
                        ErrorPopup("@(Cannot open standby user database)" + "^n" + "@(Switching to primary only)", iErr_S, STANDBY);
                        mbPrimaryActive = TRUE;
                        RETURN NO_ERR;
                ELSE
                        mbPrimaryActive = TRUE;
                        mbStandbyActive = TRUE;
                        RETURN NO_ERR;
                END
        END
END


// UserDbClose
//
// Close the primary and standby UserDB databases if they're open
//
PRIVATE
FUNCTION
UserDbClose()
        IF mhDev > BAD_HANDLE THEN
                ErrSet(DISABLE_CHECK);
                DevClose(mhDev);
                ErrSet(ENABLE_CHECK);
                mhDev = BAD_HANDLE;
        END

        IF mhDev_S > BAD_HANDLE THEN
                ErrSet(DISABLE_CHECK);
                DevClose(mhDev_S);
                ErrSet(ENABLE_CHECK);
                mhDev_S = BAD_HANDLE;
        END
END


// UserDbNext
//
// Internal function. Selects the next record in both UserDB files (if they're open).
//
// Return Value:        The error from the primary if active, otherwise returns the standby's error
//
// Notes:               If an error was returned (other than EOF) then that device is de-activated
//
PRIVATE
INT
FUNCTION
UserDbNext()
        INT     iErr = NO_ERR;
        INT     iErr_S = NO_ERR;
        INT     iReturnVal;

        IF mbPrimaryActive THEN
                ErrSet(DISABLE_CHECK);
                iErr = DevNext(mhDev);
                ErrSet(ENABLE_CHECK);
        END

        IF mbStandbyActive THEN
                ErrSet(DISABLE_CHECK);
                iErr_S = DevNext(mhDev_S);
                ErrSet(ENABLE_CHECK);
        END

        IF (iErr <> NO_ERR) AND (NOT DevEOF(mhDev)) THEN
                ErrorPopup("@(Cannot read next record in primary user database)", iErr, PRIMARY);
        END

        IF (iErr_S <> NO_ERR) AND (NOT DevEOF(mhDev_S)) THEN
                ErrorPopup("@(Cannot read next record in standby user database)", iErr_S, STANDBY);
        END

        RETURN PickError(iErr, iErr_S);
END


// UserDbGetField
//
// Internal function. Gets the contents of a field in the primary database, or from standby if the
// primary isn't available.
//
// Return Value:        The string read from the field. If neither device works, returns a blank string
//
PRIVATE
STRING
FUNCTION
UserDbGetField(STRING sField)

        STRING  sVal;
        INT     iError;

        IF mbPrimaryActive THEN
                ErrSet(DISABLE_CHECK);
                sVal = DevGetField(mhDev, sField);
                iError = IsError();
                ErrSet(ENABLE_CHECK);
                IF iError = NO_ERR THEN
                        RETURN sVal;
                ELSE
                        ErrorPopup("@(Cannot read field from primary user database)", iError, PRIMARY);
                END
        END

        IF mbStandbyActive THEN
                ErrSet(DISABLE_CHECK);
                sVal = DevGetField(mhDev_S, sField);
                iError = IsError();
                ErrSet(ENABLE_CHECK);
                IF iError = NO_ERR THEN
                        RETURN sVal;
                ELSE
                        ErrorPopup("@(Cannot read field from standby user database)", iError, STANDBY);
                END
        END

        RETURN "";
END


// UserDbSetField
//
// Internal function. Writes a value to a field in the current record in both the primary and standby databases (if they're active)
//
// Parameters:  sField  The field name to write to
//              sVal    The string value to write
//             
PRIVATE
INT
FUNCTION
UserDbSetField(STRING sField, STRING sVal)

        INT     iErr = NO_ERR;
        INT     iErr_S = NO_ERR;

        IF mbPrimaryActive THEN
                ErrSet(DISABLE_CHECK);
                iErr = DevSetField(mhDev, sField, sVal);
                ErrSet(ENABLE_CHECK);
                IF iErr <> NO_ERR THEN
                        ErrorPopup("@(Cannot write to primary user database)", iErr, PRIMARY);
                END
        END

        IF mbStandbyActive THEN
                ErrSet(DISABLE_CHECK);
                iErr_S = DevSetField(mhDev_S, sField, sVal);
                ErrSet(ENABLE_CHECK);
                IF iErr_S <> NO_ERR THEN
                        ErrorPopup("@(Cannot write to standby user database)", iErr_S, STANDBY);
                END
        END

        RETURN PickError(iErr, iErr_S);
END


// UserDbAppend
//
// Internal function. Adds a blank record to the end of both databases
//
PRIVATE
INT
FUNCTION
UserDbAppend()

        INT     iErr = NO_ERR;
        INT     iErr_S = NO_ERR;
        INT     iReturnVal;

        IF mbPrimaryActive THEN
                ErrSet(DISABLE_CHECK);
                iErr = DevAppend(mhDev);
                ErrSet(ENABLE_CHECK);
        END

        IF mbStandbyActive THEN
                ErrSet(DISABLE_CHECK);
                iErr_S = DevAppend(mhDev_S);
                ErrSet(ENABLE_CHECK);
        END

        IF (iErr <> NO_ERR) AND (NOT DevEOF(mhDev)) THEN
                ErrorPopup("@(Cannot append record to primary user database)", iErr, PRIMARY);
        END

        IF (iErr_S <> NO_ERR) AND (NOT DevEOF(mhDev_S)) THEN
                ErrorPopup("@(Cannot append record to standby user database)", iErr_S, STANDBY);
        END

        RETURN PickError(iErr, iErr_S);
END



// UserDbDelete
//
// Deletes the current record in both databases
//
PRIVATE
INT
FUNCTION
UserDbDelete()

        INT     iErr = NO_ERR;
        INT     iErr_S = NO_ERR;

        IF mbPrimaryActive THEN
                ErrSet(DISABLE_CHECK);
                iErr = DevDelete(mhDev);
                ErrSet(ENABLE_CHECK);
        END

        IF mbStandbyActive THEN
                ErrSet(DISABLE_CHECK);
                iErr_S = DevDelete(mhDev_S);
                ErrSet(ENABLE_CHECK);
        END

        IF iErr <> NO_ERR THEN
                ErrorPopup("@(Cannot delete current record in primary user database)", iErr, PRIMARY);
        END

        IF iErr_S <> NO_ERR THEN
                ErrorPopup("@(Cannot delete current record in standby user database)", iErr_S, STANDBY);
        END

        RETURN PickError(iErr, iErr_S);
END


// UserDbFirst
//
// Internal function. Selects the first record in the primary and standby devices (if they're active)
//
PRIVATE
INT
FUNCTION
UserDbFirst()

        INT     iErr;
        INT     iErr_S;

        IF mbPrimaryActive THEN
                ErrSet(DISABLE_CHECK);
                DevFirst(mhDev);
                iErr = IsError();
                ErrSet(ENABLE_CHECK);
        END

        IF mbStandbyActive THEN
                ErrSet(DISABLE_CHECK);
                DevFirst(mhDev_S);
                iErr_S = IsError();
                ErrSet(ENABLE_CHECK);
        END

        IF iErr <> NO_ERR THEN
                ErrorPopup("@(Cannot select 1st record in primary user database)", iErr, PRIMARY);
        END

        IF iErr_S <> NO_ERR THEN
                ErrorPopup("@(Cannot select 1st record in standby user database)", iErr_S, STANDBY);
        END

        RETURN PickError(iErr, iErr_S);
END


// UserDbEOF
//
// Internal function. Checks if the end of the active database has been reached.
//
PRIVATE
INT
FUNCTION
UserDbEOF()
        IF mbPrimaryActive THEN
                RETURN DevEOF(mhDev);
        END
        IF mbStandbyActive THEN
                RETURN DevEOF(mhDev_S);
        END
        RETURN TRUE;
END


// AddUserNames
//
// Internal function. Reads list of user names from UserDB and adds it to the current combobox
// before the form is displayed
//
PRIVATE
FUNCTION
AddUserNames()

        TEST_NO_ERR(UserDbOpen());

        TEST_NO_ERR(UserDbFirst());

        WHILE NOT UserDbEOF() DO                // Load list of usernames into combo box
                FormAddList(UserDbGetField("Name"));
                UserDbNext();
        END
END


// UserDbFind
//
// Internal function. Wrapper for DevFind function.
//
// Return value:        Returns NO_ERR for success or error code returned from DevFind
//                      Function aborts if search string is blank (DevFind would cause HW alarm) and returns FAIL
//
PRIVATE
INT
FUNCTION
UserDbFind(STRING sText, STRING sField)

        INT     iErr = NO_ERR;
        INT     iErr_S = NO_ERR;

        IF sText = "" THEN
                RETURN FAIL;
        END

        TEST_NO_ERR(UserDbOpen());

        TEST_NO_ERR(UserDbFirst());

        IF mbPrimaryActive THEN
                ErrSet(DISABLE_CHECK);
                iErr = DevFind(mhDev, sText, sField);
                ErrSet(ENABLE_CHECK);
        END

        IF mbStandbyActive THEN
                ErrSet(DISABLE_CHECK);
                iErr_S = DevFind(mhDev_S, sText, sField);
                ErrSet(ENABLE_CHECK);
        END

        IF mbPrimaryActive AND mbStandbyActive AND (iErr = NO_ERR) AND (iErr_S <> NO_ERR) THEN
                ErrorPopup("@(Primary and standby user databases are not the same)" + "^n" + "@(Using primary database)", iErr_S, STANDBY);
        END

        IF mbPrimaryActive AND mbStandbyActive AND (iErr_S = NO_ERR) AND (iErr <> NO_ERR) THEN
                ErrorPopup("@(Primary and standby user databases are not the same)" + "^n" + "@(Using standby database)", iErr, PRIMARY);
        END

        RETURN PickError(iErr, iErr_S);
END


// ErrorPopup
//
// Internal function. Displays an error message (and error code if specified)
//
// Parameters:  sErr            Error message string to display
//              iErr            Integer error code to display on the next line
//              iMode           1 PRIMARY       Disables primary device
//                              2 STANDBY       Disables standby device
//                                              Note: PRIMARY and STANDBY modes can be combined. E.g. ErrorPopup("My Err", 0, PRIMARY + STANDBY)
//
PRIVATE
FUNCTION
ErrorPopup(STRING sErr, INT iErr = NO_ERR, INT iMode = 0);

        STRING  sErrDesc;
        INT     iIcon;

        Sleep(0);       // Delay this task for 1 timeslice. If this function was called from a form callback function,
                        // this delay is needed to allow the form to close. See Q2977

        IF (iMode BITAND PRIMARY) = PRIMARY THEN
                IF mbPrimaryActive = FALSE THEN         // If that device has already been disabled, abort the function
                        RETURN FAIL;
                END
                mbPrimaryActive = FALSE;
                miFailTime = TimeCurrent();
        END

        IF (iMode BITAND STANDBY) = STANDBY THEN
                IF mbStandbyActive = FALSE THEN         // If that device has already been disabled, abort the function
                        RETURN FAIL;
                END
                mbStandbyActive = FALSE;
                miFailTime = TimeCurrent();
        END

        sErrDesc = sErr;

        IF iErr <> NO_ERR THEN                                  // If an error code was passed, append it to the end of the message
                sErrDesc = sErrDesc + "^n" + "@(Error)" + ": " + iErr:#;
        END

        IF iMode = 0 THEN
                iIcon = EXCLAMATION_ICON;
        ELSE
                iIcon = STOP_ICON;
        END
       
        Message("@(User Database Error)", sErrDesc, iIcon);
END


// PickError
//
// Internal function. Decides which error code to use for primary and standby device open/read/write/delete/etc errors.
//
// Parameters:  iErr    Primary device integer error code
//              iErr_S  Standby device integer error code
//
// Return value:        If either device works, NO_ERR is returned. If both devices fail,
//                      the primary error is returned. If there is no primary error, the
//                      standby error is returned instead
PRIVATE
INT
FUNCTION
PickError(INT iErr, INT iErr_S)

        INT     bPrimaryFail;
        INT     bStandbyFail;

        IF (mbPrimaryActive = FALSE) OR (iErr <> NO_ERR) THEN
                bPrimaryFail = TRUE;
        END

        IF (mbStandbyActive = FALSE) OR (iErr_S <> NO_ERR) THEN
                bStandbyFail = TRUE;
        END

        IF bPrimaryFail AND bStandbyFail THEN
                IF iErr <> NO_ERR THEN
                        RETURN iErr;
                ELSE
                        RETURN iErr_S;
                END
        ELSE
                IF bPrimaryFail THEN
                        RETURN iErr_S;
                ELSE
                        RETURN iErr;
                END
        END
END


// Compare
//
// Internal function. Compares two strings for equality. Case sensitive.
//
// Parameters:  sString1        1st string to compare
//              sString2        2nd string to compare
//
// Return value:        TRUE if strings are identical, otherwise FALSE
//
PRIVATE
INT
FUNCTION
Compare(STRING sString1, STRING sString2)

        IF sString1 = sString2 THEN     // non-case-sensitive compare
                IF (StrSearch(0, sString1, sString2) = 0) OR (StrLength(sString1) = 0) THEN
                        RETURN TRUE;    // strings match starting with character 0 or they're both blank
                ELSE
                        RETURN FALSE;   // Strings have same characters but different case
                END
        ELSE
                RETURN FALSE;           // Strings are not the same
        END
END



// EncryptDecrypt()
//
// Encrypts and decrypts strings using a simple XOR method. Pass a string to
// this funtion to encrypt it. Pass an encrypted string to this function to
// decrypt it.
//
// Revision: 1.00  Eric Black    Original
//           1.01  Eric Black    Removed null chars from output. See Note #4
//                               Only en/decrypt up to the first null char
//                                  because encrypted nulls reveal the key
//                               256 character strings are supported instead
//                                  of only 128.
//           1.02  Eric Black    Different length strings now use different
//                                  starting points in the key
//
// Arguments: sData   The text to encrypt or decrypt
//            sKey    The desired encryption/decryption key
//
// Note: 1. You can use any length encryption key but longer keys are more
//          secure.
//       2. The output string is the same length as the input.
//       3. Version 1.00 created strings containing nulls, which are hard
//          to work with or save to a file. In v1.01 if a character would
//          become a null after encryption it is not encrypted.
//       4. Strings encoded with one version of this function cannot be
//          decoded with a different version.
STRING
FUNCTION
EncryptDecrypt(STRING sData, STRING sKey = "r|_9g(c~rmt<v+V<b7@Dxaw`9Ej\*Ox/")

        INT nChar;
        INT iInChar;
        INT iOutChar;
        INT iKeyChar;
        INT iDataLength;
        INT iKeyLength;
        STRING sOutput;

        iDataLength = StrLength(sData);
        iKeyLength = StrLength(sKey);

        FOR nChar = 0 TO iDataLength - 1 DO
                // StrGet/SetChar would be faster but only support 128 chars
                iInChar = StrToChar(StrMid(sData, nChar, 1));
                iKeyChar = StrToChar(StrMid(sKey, (nChar + iDataLength) MOD iKeyLength, 1));
                iOutChar = iInChar BITXOR iKeyChar;

                IF iOutChar = 0 THEN    // Don't en/decrypt char if the result is a null
                        iOutChar = iInChar;
                END

                sOutput = sOutput + CharToStr(iOutChar);
        END

        RETURN sOutput;
END 


c0Title: Extended UserCreate() Parameters
c1Code:
http://bugzilla.citect.com/show_bug.cgi?id=16743

    * NCR 16743 - Creating and Modifying Users in Citect Runtime.


Use the Cicode function UserCreate to create a user with User Privileges. Use the Cicode function, UserSetStr to modify a user field then call UserUpdateRecord to recompile and reload the user runtime database. If you wish to modify more than one field then make multiple calls to UserSetStr but you need only call UserUpdateRecord once.

The include project has a label for the arguments:

UserCreate(s1,s2,s3,s4,s5="",pG="",p1="",p2="",p3="",p4="",p5="",p6="",p7="",p8="")


c0Title: Pearson's Hash Algorithm
c1Code:
INT		mcHashRandom[256] = 49, 118, 63, 252, 13, 155, 114, 130, 137, 40, 210, 62, 219, 
                            246, 136, 221, 174, 106, 37, 227, 166, 25, 139, 19, 204, 212, 64, 176, 70, 11, 170, 58,
                            146, 24, 123, 77, 184, 248, 108, 251, 43, 171, 12, 141, 126, 41, 95, 142, 167, 46, 178, 
                            235, 30, 75, 45, 208, 110, 230, 226, 50, 32, 112, 156, 180, 205, 68, 202, 203, 82, 7, 247, 
                            217, 223, 71, 116, 76, 6, 31, 194, 183, 15, 102, 97, 215, 234, 240, 53, 119, 52, 47, 179, 
                            99, 199, 8, 101, 35, 65, 132, 154, 239, 148, 51, 216, 74, 93, 192, 42, 86, 165, 113, 89, 
                            48, 100, 195, 29, 211, 169, 38, 57, 214, 127, 117, 59, 39, 209, 88, 1, 134, 92, 163, 0, 
                            66, 237, 22, 164, 200, 85, 9, 190, 129, 111, 172, 231, 14, 181, 206, 128, 23, 187, 73, 
                            149, 193, 241, 236, 197, 159, 55, 125, 196, 60, 161, 238, 245, 94, 87, 157, 122, 158, 115, 
                            207, 17, 20, 145, 232, 107, 16, 21, 185, 33, 225, 175, 253, 81, 182, 67, 243, 69, 220, 
                            153, 5, 143, 3, 26, 213, 147, 222, 105, 188, 229, 191, 72, 177, 250, 135, 152, 121, 218, 
                            44, 120, 140, 138, 28, 84, 186, 198, 131, 54, 2, 56, 78, 173, 151, 83, 27, 255, 144, 249, 
                            189, 104, 4, 168, 98, 162, 150, 254, 242, 109, 34, 133, 224, 228, 79, 103, 201, 160, 90, 
                            18, 61, 10, 233, 91, 80, 124, 96, 244, 36;
INT 	miHashBytes[256];

// Converts any string into a fairly unique long integer using Pearson's hash algorithm
// Case-sensitive
PRIVATE
INT
FUNCTION
Hash(STRING sKey)

	INT cHashTableSize = 0xFFFF;
	INT nChar;
	INT iKeyVal;
	INT h1;
	INT h2;
	INT iKeyLen;

	iKeyLen = StrLength(sKey);
	
	FOR nChar = 0 TO iKeyLen - 1 DO
		miHashBytes[nChar] = StrGetChar(sKey, nChar);
	END
   
	h1 = miHashBytes[0];
	h2 = h1 + 1;
	
	FOR nChar = 1 TO iKeyLen - 1 DO
		h1 = mcHashRandom[h1 BITXOR miHashBytes[nChar]];
		h2 = mcHashRandom[h2 BITXOR miHashBytes[nChar]];
	END
	
	iKeyVal = (h1 * 0xFF + h2) MOD cHashTableSize;
	RETURN iKeyVal;
END


c0Title: RC4 Encryption Algorithm
c1Code:
// RC4.ci
// Functions for encrypting and decrypting text using the RC4 algorithm


INT miBox[256];
INT miKey[256];
INT miByteArray[256];


// Encrypt a string (up to 128 characters) using a key (password) and the RC4 encryption 
// algorithm. Returns the encrypted string.
//
// The key (up to 128 characters) should not contain nulls. Longer keys are more secure.
//
// To avoid problems handling null characters, the characters in the encrypted string are
// converted to hexadecimal. The encrypted string will be 2x as long as the original text
// but can be easily copied or saved to a file.
//
// For a description of RC4 see http://en.wikipedia.org/wiki/RC4
//
// Example:
// sEncrypted = Rc4Encrypt("secret", "Pa$$w0rd");
// sDecrypted = Rc4Decrypt(sEncrypted, "Pa$$w0rd");
//
STRING
FUNCTION
Rc4Encrypt(STRING sText, STRING sKey)

	INT nCharacter;
	INT nCharacters = StrLength(sText);
	
	FOR nCharacter = 0 TO nCharacters - 1 DO
		miByteArray[nCharacter] = StrGetChar(sText, nCharacter);
	END
	
    RC4(sKey, nCharacters);
    
    RETURN HexEncode(nCharacters);	
END


// Uses the RC4 encryption algorithm to decrypt a hex string using the key (password)
// that it was encrypted with. Returns the decrypted string.
//
STRING
FUNCTION
Rc4Decrypt(STRING sText, STRING sKey)

	INT nCharacter;
	STRING sOutput;
	INT	cNull = 0;
	INT nCharacters = StrLength(sText) / 2;
	
	HexDecode(sText);
	
	RC4(sKey, nCharacters);
	
	FOR nCharacter = 0 TO nCharacters - 1 DO
		StrSetChar(sOutput, nCharacter, miByteArray[nCharacter]);
	END
	StrSetChar(sOutput, nCharacter, cNull);
	
	RETURN sOutput;
END


// Encrypt or decrypt the characters stored in miByteArray using the specified key and 
// the RC4 encryption algorithm. The encrypted characters are written back to the array.
// This function is called by Rc4Encrypt() and Rc4Decrypt().
INT
FUNCTION
RC4(STRING sKey, INT nTextLength)
    
    INT i = 0;
    INT j = 0;
    STRING sResult;
    INT nCharacter;
    INT nKeyLength = StrLength(sKey)

    IF ((nKeyLength = 0) OR (nKeyLength > 127)) THEN
        RETURN -1;
    END
    
	FOR nCharacter = 0 TO nKeyLength - 1 DO
		miKey[nCharacter] = StrGetChar(sKey, nCharacter);
	END
    
    FOR nCharacter = 0 TO 255 DO				// Identity permutation
        miBox[nCharacter] = nCharacter;
    END
        
    FOR i = 0 TO 255 DO							// Key-scheduling algorithm (KSA)
        j = (j + miBox[i] + miKey[i MOD nKeyLength]) MOD 256;

        miBox[j] = miBox[i] BITXOR miBox[j];	// Swap miBox[i] and miBox[j]
        miBox[i] = miBox[i] BITXOR miBox[j];
        miBox[j] = miBox[i] BITXOR miBox[j];
    END
    
    i = 0;
    j = 0;

    FOR nCharacter = 0 TO nTextLength - 1 DO				// Pseudo-random generation algorithm (PRGA)
        i = (i + 1) MOD 256;
        j = (j + miBox[i]) MOD 256;

        miBox[j] = miBox[i] BITXOR miBox[j];	// Swap miBox[i] and miBox[j]
        miBox[i] = miBox[i] BITXOR miBox[j];
        miBox[j] = miBox[i] BITXOR miBox[j];

        miByteArray[nCharacter] = miByteArray[nCharacter] BITXOR miBox[(miBox[i] + miBox[j]) MOD 256];
    END
    
	RETURN 0;
END


// Read character codes from miByteArray and copy them to a string as hex values
PRIVATE
STRING
FUNCTION
HexEncode(INT nCharacters)

	INT nCount;
	STRING sHex;
	
	FOR nCount = 0 TO nCharacters - 1 DO
		sHex = sHex + HexToStr(miByteArray[nCount], 2);
	END
	
	RETURN sHex;
END


// Read hex values from a string and copy them to miByteArray as integers
PRIVATE
FUNCTION
HexDecode(STRING sText)
	
	INT		nCharacter;
	STRING	sHexCharacter;
	INT		nCharacters = StrLength(sText) / 2;

    FOR nCharacter = 0 TO nCharacters - 1 DO
    	sHexCharacter = StrMid(sText, nCharacter * 2, 2);
    	miByteArray[nCharacter] = StrToHex(sHexCharacter);
    END
END


c0Title: XOR Encrypt/Decrypt
c1Code:
// EncryptDecrypt()
//
// Encrypts and decrypts strings using a simple XOR method. Pass a string to
// this funtion to encrypt it. Pass an encrypted string to this function to
// decrypt it.
//
// Revision: 1.00  Eric Black    Original
//           1.01  Eric Black    Removed null chars from output. See Note #4
//                               Only en/decrypt up to the first null char
//                                  because encrypted nulls reveal the key
//                               256 character strings are supported instead
//                                  of only 128.
//           1.02  Eric Black    Different length strings now use different
//                                  starting points in the key
//
// Arguments: sData   The text to encrypt or decrypt
//            sKey    The desired encryption/decryption key
//
// Note: 1. You can use any length encryption key but longer keys are more
//          secure.
//       2. The output string is the same length as the input.
//       3. Version 1.00 created strings containing nulls, which are hard
//          to work with or save to a file. In v1.01 if a character would
//          become a null after encryption it is not encrypted.
//       4. Strings encoded with one version of this function cannot be 
//          decoded with a different version.
STRING
FUNCTION
EncryptDecrypt(STRING sData, STRING sKey = "r|_9g(c~rmt<v+V<b7@Dxaw`9Ej\*Ox/")

	INT nChar;
	INT iInChar;
	INT iOutChar;
	INT iKeyChar;
	INT iDataLength;
	INT iKeyLength;
	STRING sOutput;

	iDataLength = StrLength(sData);
	iKeyLength = StrLength(sKey);

	FOR nChar = 0 TO iDataLength - 1 DO
		// StrGet/SetChar would be faster but only support 128 chars
		iInChar = StrToChar(StrMid(sData, nChar, 1));
		iKeyChar = StrToChar(StrMid(sKey, (nChar + iDataLength) MOD iKeyLength, 1));
		iOutChar = iInChar BITXOR iKeyChar;

		IF iOutChar = 0 THEN	// Don't en/decrypt char if the result is a null
			iOutChar = iInChar;
		END

		sOutput = sOutput + CharToStr(iOutChar);
	END

	RETURN sOutput;
END


c0Title: Merge Sort - Sync 2nd Array (Stable)
c1Code:
GLOBAL STRING gsSortArray[479];  // Contains strings to sort
GLOBAL STRING gsSortArray2[479]; // Contains strings to sort
STRING msMergeTemp[479];         // Temporary storage for Merge()
STRING msMergeTemp2[479];        // Temporary storage for Merge()

FUNCTION
MergeSort(INT iFirst, INT iLast, INT nArray = 1)

    INT i;
    INT m = 1;
    INT n = iLast - iFirst + 1;

    WHILE m <= n DO
        i = iFirst;
        WHILE i < n - m DO
            Merge(i, i + m - 1, Min(i+2*m-1,n-1), nArray);
            i = i + 2 * m;
        END
        m = m * 2;
    END
END


// Supporting function for MergeSort()
PRIVATE
FUNCTION
Merge(INT iFirst, INT iMiddle, INT iLast, INT nArray = 1)
    INT i;
    INT j;
    INT k;

    FOR i = iFirst TO iMiddle DO
        msMergeTemp[i] = gsSortArray[i];
        msMergeTemp2[i] = gsSortArray2[i];
    END
    
    FOR j = iMiddle + 1 TO iLast DO
        msMergeTemp[iMiddle + 1 + iLast - j] = gsSortArray[j];
        msMergeTemp2[iMiddle + 1 + iLast - j] = gsSortArray2[j];
    END
    
    i = iFirst;
    k = iFirst;
    j = iLast;
    WHILE k <= iLast DO
        IF ((nArray = 1) AND (msMergeTemp[j] < msMergeTemp[i])) OR
           ((nArray = 2) AND (msMergeTemp2[j] < msMergeTemp2[i])) THEN
           
            gsSortArray[k] = msMergeTemp[j];
            gsSortArray2[k] = msMergeTemp2[j];
            j = j - 1;
        ELSE
            gsSortArray[k] = msMergeTemp[i];
            gsSortArray2[k] = msMergeTemp2[i];
            i = i + 1;
        END
        k = k + 1;
    END
END


c0Title: Quick Sort (Unstable, Recursive)
c1Code:
GLOBAL STRING Table[479];

FUNCTION 
Quick_Sort( Int First_Element, Int Last_Element )
    Int Pivot_Value;

    If First_Element < Last_Element Then
	Pivot_Value = Partition( First_Element, Last_Element );
	Quick_Sort( First_Element, Pivot_Value - 1 );
	Quick_Sort( Pivot_Value + 1, Last_Element );
    End
End


Int
Function
Partition( Int First, Int Last )
    STRING Temp, Pivot;
    Int Up, Down;
    
    Pivot = Table[First];
    Up = First;
    Down = Last;

    While Up < Down Do
	While (Table[Up] <= Pivot) And (Up < Last) Do
	    Up = Up + 1;
	End

	While Table[Down] > Pivot Do
	    Down = Down - 1;
	End

	If Up < Down Then
	    Temp = Table[Up];
	    Table[Up] = Table[Down];
	    Table[Down] = Temp;
	End
    End

    Temp = Table[First];
    Table[First] = Table[Down];
    Table[Down] = Temp;

    Return Down;

End   


c0Title: Shell Sort - 10,000 elements (Unstable)
c1Code:
// Sort.ci contains Shell Sort function (and supporting functions) for alphabetizing strings //
// VERSION	1.10	EB	6/27/03	Added range checking
//								Increased max number of elements from 479 to 10059
//								Added international/normal mode option
//								Corrected handling of >118 char int'l strings
//								Corrected handling of strings containing commas
//
//			1.00	EB	2/10/03	Original release (see Q3750)
//			
// NOTE		Since Cicode arrays can only contain 479 elements (strings), 21 arrays are
//			used to allow for up to 10059 elements. To increase this, add more arrays
//			after msShellArray20. Modify GetSortElement() and SetSortElement() to use
//			the additional arrays, and set the MAX_ELEMENT constant to:
//			(479 * Number of arrays) - 1
//			

// Module constants
INT		ELEMENTS_PER_ARRAY = 479;
INT		MAX_ELEMENT = 10058;
INT		ERR_OUT_OF_RANGE = 257;
INT		NO_ERR = 0;

//StrCompare Constants
INT STR_LESS_THAN = 1;
INT STR_EQUAL_TO = 2;
INT STR_GREATER_THAN = 3;

// Temporary storage for strings to sort
GLOBAL	STRING gsShellArray[479];
		STRING msShellArray1[479];
		STRING msShellArray2[479];
		STRING msShellArray3[479];
		STRING msShellArray4[479];
		STRING msShellArray5[479];
		STRING msShellArray6[479];
		STRING msShellArray7[479];
		STRING msShellArray8[479];
		STRING msShellArray9[479];
		STRING msShellArray10[479];
		STRING msShellArray11[479];
		STRING msShellArray12[479];
		STRING msShellArray13[479];
		STRING msShellArray14[479];
		STRING msShellArray15[479];
		STRING msShellArray16[479];
		STRING msShellArray17[479];
		STRING msShellArray18[479];
		STRING msShellArray19[479];
		STRING msShellArray20[479];


// FUNCTION		Sort
//
// DESCRIPTION	Sorts (alphabetizes) an array of strings with correct handling of non-
//				English characters. Uses the ShellSort algorithm.
//
// ARGUMENTS	iFirst			Starting element number (default = 0)
//				iLast			Last used element number (default = 10058)
//				bInternational	Set to TRUE for international-safe sorting (default = FALSE)
//
// RETURN VALUE	Returns TRUE if successful or FALSE if the iFirst or iLast parameter is
//				out of range.
//
//
// USAGE		Follow these steps in order:
//
//				1. Call EnterCriticalSection("Sort").
//				   This is necessary so the arrays are not used by 2 threads at once.
//				2. Use SetSortElement() to store each string to sort.
//				   If < 480 strings are needed, write them directly to gsShellArray[]
//				3. Call the sort function.
//				   Pass the first and last element numbers that were filled with data so it
//				   is not necessary to clear out data left in the array by a previous sort.
//				4. Read all the strings back using GetSortElement(). 
//				   If < 480 strings were used, read them directly from gsShellArray[]
//				5. Call LeaveCriticalSection("Sort") so other threads are allowed to use it.
//				   See Citect KB article Q3402
//
// NOTES		International-safe mode uses Windows locale information to sort non-English
//				characters correctly. This increases the sorting time by approximately 3x.
//
//				See Citect Knowledge Base article Q3750 for more information.
//
INT
FUNCTION
Sort(INT iFirst = 0, INT iLast = 10058, INT bInternational = FALSE)

    INT		i;
    INT		iGapSize;
    INT		iCurPos
    INT		nElements;
    INT		bExit;
    INT		bIsGreater;
    STRING	sTemp;

    IF (iFirst < 0) OR
       (iFirst > MAX_ELEMENT - 1) OR
       (iLast <= iFirst) OR
       (iLast > MAX_ELEMENT)	 THEN
	
	    	RETURN FALSE;
    END

    nElements = iLast - iFirst + 1;

    WHILE iGapSize <= nElements DO
        iGapSize = iGapSize * 3 + 1;
    END

    WHILE iGapSize > 1 DO
        iGapSize = iGapSize / 3;
        FOR i = (iGapSize + iFirst) TO iLast DO
            iCurPos = i;
            sTemp = GetSortElement(i);
            bExit = FALSE;
            WHILE bExit = FALSE DO
            	
            	IF bInternational = TRUE THEN
            		bIsGreater = (StrCompare(GetSortElement(iCurPos - iGapSize), sTemp) = STR_GREATER_THAN);
            	ELSE
            		bIsGreater = (GetSortElement(iCurPos - iGapSize) > sTemp);
            	END
            	
                IF bIsGreater THEN
                    SetSortElement(iCurPos, GetSortElement(iCurPos - iGapSize));
                    iCurPos = iCurPos - iGapSize;
                    IF (iCurPos - iGapSize) < iFirst THEN
                        bExit = TRUE;
                    END
                ELSE
                    bExit = TRUE;
                END
            END
            SetSortElement(iCurPos, sTemp);
        END
    END
    
    RETURN TRUE;
END


// FUNCTION		GetSortElement
//
// ARGUMENT		iElement	Element number to read (0 to 10058)
//
// RETURN VALUE	The value contained in that element or "" if the element
//				number was out of range.
//
STRING
FUNCTION
GetSortElement(INT iElement)

	INT iArray;
	INT iArrayElement;
	
	iArrayElement = iElement MOD ELEMENTS_PER_ARRAY;
	iArray = (iElement - iArrayElement) / ELEMENTS_PER_ARRAY;
	
	SELECT CASE iArray
	CASE 0
		RETURN gsShellArray[iArrayElement];
	CASE 1
		RETURN msShellArray1[iArrayElement];
	CASE 2
		RETURN msShellArray2[iArrayElement];
	CASE 3
		RETURN msShellArray3[iArrayElement];
	CASE 4
		RETURN msShellArray4[iArrayElement];
	CASE 5
		RETURN msShellArray5[iArrayElement];
	CASE 6
		RETURN msShellArray6[iArrayElement];
	CASE 7
		RETURN msShellArray7[iArrayElement];
	CASE 8
		RETURN msShellArray8[iArrayElement];
	CASE 9
		RETURN msShellArray9[iArrayElement];
	CASE 10
		RETURN msShellArray10[iArrayElement];
	CASE 11
		RETURN msShellArray11[iArrayElement];
	CASE 12
		RETURN msShellArray12[iArrayElement];
	CASE 13
		RETURN msShellArray13[iArrayElement];
	CASE 14
		RETURN msShellArray14[iArrayElement];
	CASE 15
		RETURN msShellArray15[iArrayElement];
	CASE 16
		RETURN msShellArray16[iArrayElement];
	CASE 17
		RETURN msShellArray17[iArrayElement];
	CASE 18
		RETURN msShellArray18[iArrayElement];
	CASE 19
		RETURN msShellArray19[iArrayElement];
	CASE 20
		RETURN msShellArray20[iArrayElement];
	CASE ELSE	// Invalid element number
		RETURN "";
	END SELECT
END


// FUNCTION		SetSortElement
//
// ARGUMENTS	iElement	Element number to write (0 to 10058)
//				sValue		String value to write (up to 127 characters long)
//
// RETURN VALUE	0 if successful, error 257 (Value out of range) if iElement is invalid
//
INT
FUNCTION
SetSortElement(INT iElement, STRING sValue)

	INT iArray;
	INT iArrayElement;

	iArrayElement = iElement MOD ELEMENTS_PER_ARRAY;
	iArray = (iElement - iArrayElement) / ELEMENTS_PER_ARRAY;
	
	SELECT CASE iArray
	CASE 0
		gsShellArray[iArrayElement] = sValue;
	CASE 1
		msShellArray1[iArrayElement] = sValue;
	CASE 2
		msShellArray2[iArrayElement] = sValue;
	CASE 3
		msShellArray3[iArrayElement] = sValue;
	CASE 4
		msShellArray4[iArrayElement] = sValue;
	CASE 5
		msShellArray5[iArrayElement] = sValue;
	CASE 6
		msShellArray6[iArrayElement] = sValue;
	CASE 7
		msShellArray7[iArrayElement] = sValue;
	CASE 8
		msShellArray8[iArrayElement] = sValue;
	CASE 9
		msShellArray9[iArrayElement] = sValue;
	CASE 10
		msShellArray10[iArrayElement] = sValue;
	CASE 11
		msShellArray11[iArrayElement] = sValue;
	CASE 12
		msShellArray12[iArrayElement] = sValue;
	CASE 13
		msShellArray13[iArrayElement] = sValue;
	CASE 14
		msShellArray14[iArrayElement] = sValue;
	CASE 15
		msShellArray15[iArrayElement] = sValue;
	CASE 16
		msShellArray16[iArrayElement] = sValue;
	CASE 17
		msShellArray17[iArrayElement] = sValue;
	CASE 18
		msShellArray18[iArrayElement] = sValue;
	CASE 19
		msShellArray19[iArrayElement] = sValue;
	CASE 20
		msShellArray20[iArrayElement] = sValue;
	CASE ELSE	// Invalid element number
		RETURN ERR_OUT_OF_RANGE;
	END SELECT
	
	RETURN NO_ERR;
END


// FUNCTION StrCompare
//
// DESCRIPTION Compare two strings using Windows Locale settings //
// RETURN VALUE:	STR_LESS_THAN (1) if string1 < string2
//					STR_EQUAL_TO (2) if string1 = string2
//					STR_GREATER_THAN (3) if string1 > string2
//
INT mhCompareString = -1; // Handle for CompareString DLL function

PRIVATE
INT
FUNCTION
StrCompare(STRING sString1, STRING sString2)
    INT iResult;
    INT iLength1;
    INT iLength2;
    INT MAX_LENGTH = 118;
    
    iLength1 = StrLength(sString1);
    iLength2 = StrLength(sString2);
    
    IF mhCompareString = -1 THEN
        mhCompareString = DLLOpen("kernel32", "CompareStringA", "JJJCJCJ");
    END
    
    iResult = DLLCall(mhCompareString, "1024,0,^"" + StrLeft(sString1, 118) + "^",-1,^"" + StrLeft(sString2, 118) + "^",-1");
    
    IF (iResult = STR_EQUAL_TO) AND (iLength1 > MAX_LENGTH) AND (iLength2 > MAX_LENGTH) THEN

    	sString1 = StrMid(sString1, MAX_LENGTH, iLength1 - MAX_LENGTH);
    	sString2 = StrMid(sString2, MAX_LENGTH, iLength2 - MAX_LENGTH);
    	
    	iResult = DLLCall(mhCompareString, "1024,0,^"" + sString1 + "^",-1,^"" + sString2 + "^",-1");
    END
    
    RETURN iResult;
END


c0Title: Wrap a string at specified intervals to the nearest word
c1Code:
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
//		FUNCTION NAME	
//						Wrap()
//
//		REV	DATE		WHO			DESCRIPTION
//		0	5/11/04		E.Black		Original
//
//     	GENERAL DESCRIPTION
//			
//			Adds carriage returns to a text string at specified intervals, to the nearest word. Text is truncated
//			at the end of the last specified line and "..." is appended.
//
// 		ARGUMENTS:
//
//			sText			-	Text string to wrap
//			iMaxColumns		-	Max number of characters per line
//			iMaxRows		-	Max number of rows of text (default is -1 for unlimited rows)
//
//     	RETURNED VALUE: 
//
//			The text string with carriage returns is returned.
//
//		PSEUDO CODE:
//
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

STRING
FUNCTION
Wrap(STRING sText, INT iMaxColumns, INT iMaxRows = -1)

	STRING sOutput;
	STRING sWord;
	STRING sLine;
	INT iRow = 1;
	
	WHILE sText <> "" DO
		sWord = StrWord(sText);
		
		IF (StrLength(sLine) + StrLength(sWord) + 1) <= iMaxColumns THEN

			IF sLine <> "" THEN
				sLine = sLine + " " + sWord;
			ELSE
				sLine = sWord;
			END

		ELSE
			IF iRow <> iMaxRows THEN

				IF sOutput <> "" THEN
					sOutput = sOutput + "^n" + sLine;
				ELSE
					sOutput = sLine;
				END
				
				sLine = sWord;
				iRow = iRow + 1;

			ELSE

				sOutput = sOutput + "^n" + sLine;
				sOutput = StrLeft(sOutput, StrLength(sOutput) - 3) + "...";
				RETURN sOutput;
			END
		END
	END
	
	IF sLine <> "" THEN
		IF sOutput <> "" THEN
			sOutput = sOutput + "^n" + sLine;
		ELSE
			sOutput = sLine;
		END
	END
	
	RETURN sOutput;
END



c0Title: String Replace
c1Code:
// Returns a string in which a specified substring has been replaced with another substring
// a specified number of times.
//
// ARGUMENTS:
//
//		sText		String expression containing substring to replace. 
//		sFind 		Substring being searched for. 
//		sReplace	Replacement substring. 
//		iStart 		Optional. Position within expression where substring search is to begin. 
//					If omitted, 0 is assumed. 
//		iCount 		Optional. Number of substring substitutions to perform. If omitted, the default value is �1, 
//					which means make all possible substitutions. 	
//
STRING
FUNCTION
Plus_StringReplace(STRING sText, STRING sFind, STRING sReplace, INT iStart = 0, INT iCount = -1)

	STRING	sResult;
	STRING	sResultLeft;
	STRING	sResultRight;
	INT		iFindLen;
	INT		iReplaceLen;
	INT		iResultLen;
	INT		iSearchPos;
	INT		iReplaceCount;
	INT		bEndReplace = 0;	
	
	sResult = sText;
	iFindLen = StrLength(sFind);
	iReplaceLen = StrLength(sReplace);
	
	IF iCount = 0 THEN
		bEndReplace = 1;
	END
	
	IF iStart > 0 THEN
		iSearchPos = iStart;
	END
	
	WHILE NOT bEndReplace DO
	
		iSearchPos = StrSearch(iSearchPos, sResult, sFind);
		
		IF iSearchPos > -1 THEN
			
			iResultLen = StrLength(sResult);
			sResultLeft =  StrLeft(sResult, iSearchPos);
			sResultRight = StrRight(sResult, iResultLen - iFindLen - iSearchPos);
			sResult = sResultLeft + sReplace + sResultRight;
			
			iReplaceCount = iReplaceCount + 1;
			
			IF (iReplaceCount >= iCount) AND (iCount <> -1) THEN
				bEndReplace = 1;
			END 
			
			iSearchPos = iSearchPos + iReplaceLen;
			
		ELSE
		
			bEndReplace = 1;
		END
		
	END
	
	RETURN sResult;
	
END  


c0Title: Hex Dump
c1Code:
// Convert each ASCII code in a string into hex
// Returns the hex string and sends it to the kernel
// iLength defaults to the string's length. Specify 
// the length manually if the string contains nulls.
STRING
FUNCTION
HexDump(STRING sText, INT iLength = 0)

	INT nCount;
	STRING sHex;
	INT iChar;
	
	IF iLength = 0 THEN
		iLength = StrLength(sText);
	END
	
	FOR nCount = 0 TO iLength - 1 DO
		iChar = StrGetChar(sText, nCount);
		sHex = sHex + HexToStr(iChar, 2);
	END
	
	TraceMsg(sHex + " = " + sText);
	RETURN sHex;
END


c0Title: Case-Sensitive String Compare
c1Code:
// Compares two strings for equality. Case sensitive.
// Returns TRUE if strings are identical, otherwise FALSE
INT
FUNCTION
StrCompare(STRING sString1, STRING sString2)

	IF (sString1 = sString2) THEN	// non-case-sensitive IGTS_Util_Compare
		IF (StrSearch(0, sString1, sString2) = 0) OR (StrLength(sString1) = 0) THEN
			RETURN TRUE;	// strings match starting with character 0 or they're both blank
		ELSE
			RETURN FALSE;	// Strings have same characters but different case
		END
	ELSE
		RETURN FALSE;		// Strings are not the same
	END
END


c0Title: Get a Field From a Delimited String
c1Code:
// Get a field value (text) from a string, where the string consists of a number 
// of fields separated by a field separation character.
//
// Example:
//		sText = "ab?cde?fghi?j";
//		sField = CSV_String_GetField(sText,3,"?");
//
//		In this case sField = "fghi"			
//
// ARGUMENTS:	sText			- string containing fields
//				iField			- index of field value to return (starting at 1)
//				sFieldSeparator	- 
//
// RETURNED VALUE: Field value as string.
//
STRING
FUNCTION
Plus_StringGetField(STRING sText, INT iField, STRING sFieldSeparator = ",")

	INT	iOffset		= 0;
	INT	iPos		= 0;
	INT	iIndex		= 1;

	ErrSet(1);
	
	WHILE (sText <> "") AND (iIndex <= iField) DO

		iPos = StrSearch(iOffset, sText, sFieldSeparator);
		IF (iPos < 0) THEN 
		
			iPos = StrLength(sText); 
		END

		IF (iField = iIndex) THEN

			IF iPos > iOffset THEN
				RETURN(StrMid(sText, iOffset, iPos-iOffset));
			ELSE
				RETURN "";
			END
		ELSE
			iIndex = iIndex + 1;
			iOffset = iPos + 1 ;
		END
	END

	ErrSet(0);
	
	RETURN("");

END


c0Title: Trim Left
c1Code:
// Returns the specified string with nCharsToTrim removed from the left (beginning)
STRING
FUNCTION
PlusStrLeftTrim(STRING sText, INT nCharsToTrim)
	RETURN StrMid(sText, nCharsToTrim, StrLength(sText) - nCharsToTrim);
END


c0Title: String Search In Reverse
c1Code:
// String.ci -- Q4944

// Searches for the last occurrance of a string within a string before the specified character.
//
// Arguments: sText		  String to check
//            sFind       String to search for
//            nSearchChar Starting character number (0 to string length - 1). Default = -1 for 
//                        the end character
//
// Returns the character number (starting with 0) or -1 if the string was not found.
//
// Note: If sFind is blank, nSearchChar is returned to be consistent with StrSearch().
//
// Example: nChar = StrSearchRev("abcdabcd", "ab")  // nChar = 4
//
INT
FUNCTION
StrSearchRev(STRING sText, STRING sFind, INT nSearchChar = -1)
	INT nFoundChar;

	IF nSearchChar = -1 THEN 
		nSearchChar = StrLength(sText) - 1;
	END
		
	nSearchChar = nSearchChar - StrLength(sFind) + 1;
	
	WHILE nSearchChar >= 0 DO
		nFoundChar = StrSearch(nSearchChar, sText, sFind);
		
		IF (nFoundChar <> -1) AND (nFoundChar <= nSearchChar) THEN
			RETURN nFoundChar;
		END
		nSearchChar = nSearchChar - 1;
	END
	
	RETURN -1;
END


c0Title: ProcessKill()
c1Code:
// process.ci


// Function:      ProcessKill 
// Description:   Closes any application
// 
// Revision:      1.00      Eric Black     Original
//                1.01      Eric Black     Added bForce option
//                1.02      Eric Black     Added CiVBA fn to get ProcID
//                                           and truly force it to close
//
// Arguments:     sTitle    Exact title of the window to close
//
//                bForce    TRUE   Force window to close immediately
//                          FALSE  Allow window to prompt user to save before 
//                                 closing (default)
//
// Returns Value: 0 if successful, otherwise a Citect error code //
// Notes:         1. Data may be lost if you force an application to close
//                   without saving
//                2. If the window didn't close within 5 seconds and 
//                   bForce = 0, error 21 (timeout) is returned.
//                3. This is for Win32 programs only. Win16 and DOS apps
//                   aren't supported.
// 
// Example:       ProcessKill("Untitled - Notepad"); 
//
INT
FUNCTION
ProcessKill(STRING sTitle, INT bForce = FALSE)

	INT hWnd;
	INT iResult;
	INT iStartTime;

	INT TIMEOUT = 5; // Seconds
	
	hWnd = WndFind(sTitle);
	
	IF hWnd <> 0 THEN

		iResult = VbCallReturn(VbCallRun(VbCallOpen("ProcessKill", hWnd, bForce)));

		IF bForce = TRUE THEN
			RETURN iResult;
		ELSE

			iStartTime = TimeCurrent();
			
			WHILE WndFind(sTitle) <> 0 DO
				IF TimeCurrent() - iStartTime > TIMEOUT THEN
					RETURN 21;	// Timeout error
				END
			END
			
			RETURN 0;	// Success
		END
	ELSE
		RETURN 289;		// Name does not exist
	END
END


// process.bas

Private Declare Function GetWindowThreadProcessId Lib "user32" (Byval hWnd As Long, lpdwProcessId As Long) As Long Private Declare Function OpenProcess Lib "kernel32" (Byval dwDesiredAccess As Long, Byval bInheritHandle As Long, Byval dwProcessID As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (Byval hObject As Long) As Long Private Declare Function TerminateProcess Lib "kernel32" (Byval hProcess As Long, Byval uExitCode As Long) As Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (Byval hwnd As Long, Byval wMsg As Long, Byval wParam As Long, Byval lParam As Long) As Long

'Supporting function for the Cicode ProcessKill function.
Public Function ProcessKill(hWnd As Long, Force As Long) As Integer

	Dim ProcessID As Long
	Dim hProc As Long

	Const SYNCHRONIZE = &H100000
	Const PROCESS_TERMINATE As Long = &H1
	Const WM_CLOSE = &H10

	If Force = 0 Then

		'Ask nicely
		PostMessage hWnd, WM_CLOSE, 0, 0

		'No way to know if it was successful without blocking Citect
		ProcessKill = 0		

	Else
		'Force closing

		GetWindowThreadProcessId hWnd, ProcessID
			
		If ProcessID <> 0 Then
			'Get the privilege to terminate the process	
			hProc = OpenProcess(SYNCHRONIZE Or PROCESS_TERMINATE, 0&, ProcessID)
		
			If hProc <> 0 Then
				If TerminateProcess(hProc, 0&) <> 0 Then
					ProcessKill = 0		'Success
				End If
			Else
				ProcessKill = 276	'No privilege for operation
			End If
	
			CloseHandle hProc
		Else
			ProcessKill = 289	'Name (process) does not exist
		End If

	End If
	
End Function


c0Title: Trend Import CSV
c1Code:
// TrendImport.ci v1.03
// Imports trend data from a CSV file
//
// Revisions
//
// 1.00b  6/10/05  Eric Black  Original
// 1.01   9/9/05   Eric Black  Missing samples are checked for and shown as <NA>
//                             Added rSamplePeriod and iMode arguments
//                             Out-of-order samples are skipped (and logged to the Kernel 
//                             if Mode 1 is set)
//                             Fixed problem importing MS samples as AM instead of PM
//                             Added function return values
// 1.02   12/16/05 Eric Black  File is now closed after import
// 1.03   11/9/06  Thilak Chandraratne   Fixed N/A value import
//                             Correctly import lines with missing end comma
//                             Returns error 262 if file cannot be opened
//                             GMT Bias option added (for importing from TrendReader utility)


INT		mcMaxElements = 15359;
INT		mcErrorOverflow = 275;
INT		mcTimeSec = 0;
INT		mcTimeMS = 1;
STRING	mcSampleNA = "N/A";
INT		mcErrorCannotOpenFile = 262;
INT		mcErrorCancelled = 299;
INT		mcErrorDateTimeConflict = 374;
STRING	mcFileModeRead = "r";
INT		mcMsgExclamationIcon = 48;
INT		mcMsgInformationIcon = 64;

STRING	msFields[22];	// Values read from one line of CSV file
STRING	msTrendTagNames[20];		// Trend tag names
INT		miField;

// Current set of samples being read for each of the trends in the CSV file
REAL	mrTrendSamples0[15359];	
REAL	mrTrendSamples1[15359];
REAL	mrTrendSamples2[15359];
REAL	mrTrendSamples3[15359];
REAL	mrTrendSamples4[15359];
REAL	mrTrendSamples5[15359];
REAL	mrTrendSamples6[15359];
REAL	mrTrendSamples7[15359];
REAL	mrTrendSamples8[15359];
REAL	mrTrendSamples9[15359];
REAL	mrTrendSamples10[15359];
REAL	mrTrendSamples11[15359];
REAL	mrTrendSamples12[15359];
REAL	mrTrendSamples13[15359];
REAL	mrTrendSamples14[15359];
REAL	mrTrendSamples15[15359];
REAL	mrTrendSamples16[15359];
REAL	mrTrendSamples17[15359];
REAL	mrTrendSamples18[15359];
REAL	mrTrendSamples19[15359];


// Imports trend data that has been exported to a CSV file // // ARGUMENTS //
//	sFile			File name to import. If no file is specified, you will be prompted to browse for it
//	rSamplePeriod	Sample period of the CSV file. If not specified it will default to the period between the first two samples
//	iMode			0  Silent mode
//					1  Display import status on the prompt line (Default)
//					2  Display popup "Trend Import Complete" message box (default)
//					Modes may be added.
//	iGMTBiasSec		Number of seconds to add to the time in CSV (to convert sample time from GMT to local time). Default = 0
//
// RETURN VALUE: 0 if successful or a Cicode error. 374 means some samples were skipped because they were out of sequence // // NOTES //
//	1. The CSV file may be created by TrnExportCSV() or TrnExportCSVMulti() from the www.citect.com Toolbox.
//	2. The CSV file must have a header line showing all trend tag names as well as time/date stamps on each line like this:
//
//		Date,     Time,       LOOP_1_PV,  LOOP_1_SP,  FIC_100
//		6/10/2005,10:31:38 AM,2078.120000,n/a,        2080.0
//		6/10/2005,10:31:39 AM,1156.000000,1338,       gated
//
//	3. Date and time format should match your Windows regional settings
//	4. Numbers should have a "." separator, not a ","
//	5. Spacing doesn't matter
//	6. Any number of samples may be imported
//	7. Up to 20 trends may be imported per CSV file
//	8. Times may be in MS, like "10:31:38.250 AM"
INT
FUNCTION
TrnImportCSV(STRING sFile = "", REAL rSamplePeriod = -1, INT iMode = 3, INT iGMTBiasSec = 0)

	INT		cModeDisplayStatus = 1;
	INT		cModeDisplayPopup = 2;

	INT		hFile;
	STRING	sLine;
	INT		iChar;
	INT		nTags;	// number of trend tags found in header
	INT		iErr;
	INT		nSample;
	INT		iTrend;
	INT		iLastSampleTime;
	INT		iLastSampleMS;
	INT		iThisSampleTime;
	INT		iThisSampleMS;
	INT		nSkipped;
	INT		iLine;
	
	ErrSet(1);
	
	AccessCriticalSection("TrnImportCSV");
	
	IF (sFile = "") THEN
		sFile = FormOpenFile("Open Trend CSV File", "", "CSV Files|*.CSV|All Files|*.*|");
		IF (sFile = "") THEN
			RETURN mcErrorCancelled;
		END
	END
	
	hFile = FileOpen(sFile, mcFileModeRead);
	IF (hFile = BAD_HANDLE) THEN
		IF ((iMode BITAND cModeDisplayPopup) = cModeDisplayPopup) THEN
			Message("Trend Import","Cannot open file: " + sFile, mcMsgExclamationIcon);
		END
		RETURN mcErrorCannotOpenFile;
	END
	
	GetLine(hFile);		// header
	WHILE (msFields[nTags + 2] <> "") DO
		msTrendTagNames[nTags] = msFields[nTags + 2];
!		TraceMsg("msTrendTagNames[" + nTags:# + "]=" + msTrendTagNames[nTags]);
		nTags = nTags + 1;
	END	

	nSample = 0;
	
	WHILE (FileEOF(hFile) = FALSE) DO

		GetLine(hFile, 1);
		iLine = iLine + 1;

		iThisSampleTime = GetTime(mcTimeSec, iGMTBiasSec);
		iThisSampleMS = GetTime(mcTimeMs, iGMTBiasSec);

		IF ((iThisSampleTime + (iThisSampleMS / 1000.0)) > (iLastSampleTime + (iLastSampleMS / 1000.0))) THEN	// Newer than last sample
					  
			IF ((nSample MOD 500 = 0) AND (iMode BITAND cModeDisplayStatus  = cModeDisplayStatus)) THEN
				Prompt("Trend Import " + TimeToStr(iThisSampleTime, 4));
			END
	
			IF (nSample > 0) THEN
				IF (rSamplePeriod > 0) THEN
				
					// Accept samples within 1/10 of a sample period accuracy
					WHILE ((iThisSampleTime + (iThisSampleMS / 1000.0)) > 
						  (iLastSampleTime + (iLastSampleMS / 1000.0) + (rSamplePeriod * 1.1))) DO
						  
						FOR iTrend = 0 TO nTags - 1 DO
							SetSample(iTrend, nSample, "N/A");
						END
						nSample = nSample + 1;
	
						iLastSampleMS = iLastSampleMS + (rSamplePeriod * 1000);
						iLastSampleTime = iLastSampleTime + ((iLastSampleMS - (iLastSampleMS MOD 1000)) / 1000.0);
						iLastSampleMS = iLastSampleMS MOD 1000;
	
						IF (nSample = mcMaxElements) THEN
							SetTrends(iTrend, iLastSampleTime, rSamplePeriod, nSample, iLastSampleMS);
							nSample = 0;
						END
					END
				ELSE
					// '1000.0' forces floating point calculation
					rSamplePeriod = (iThisSampleTime - iLastSampleTime + ((iThisSampleMS - iLastSampleMS) / 1000.0)) / nSample;
				END
			END
	
			FOR iTrend = 0 TO nTags - 1 DO
				SetSample(iTrend, nSample, msFields[iTrend + 2]);
			END
			nSample = nSample + 1;
	
			IF (nSample = mcMaxElements) THEN
				SetTrends(iTrend, iThisSampleTime, rSamplePeriod, nSample, iThisSampleMS);
				nSample = 0;
			END
			
			iLastSampleTime = iThisSampleTime;
			iLastSampleMS = iThisSampleMS;
			iThisSampleTime = 0;
			iThisSampleMS = 0;
		
		ELSE	// Sample was older than the previous sample
			nSkipped = nSkipped + 1;
			TraceMsg("Trend Import sample skipped. Out of order: (" + iLine:# +")" + msFields[0] + " " + msFields[1]);
		END
		
		Sleep(0);
	END

	IF (nSample > 0) THEN
		SetTrends(iTrend, iLastSampleTime, rSamplePeriod, nSample, iLastSampleMS);
	END

	IF ((iMode BITAND cModeDisplayPopup) = cModeDisplayPopup) THEN
		Message("Trend Import", "Import complete.", mcMsgInformationIcon );
	END

	IF ((iMode BITAND cModeDisplayStatus) = cModeDisplayStatus) THEN
		Prompt("Trend Import Complete");
		Sleep(2);
		Prompt("");
	END
	
	FileClose(hFile);
	
	LeaveCriticalSection("TrnImportCSV");
	
	IF (nSkipped = 0) THEN
		RETURN 0;
	ELSE
		RETURN mcErrorDateTimeConflict;		// 1 or more samples out of order
	END		
END


PRIVATE
INT
FUNCTION
GetTime(INT iMode, INT iGMTBiasSec=0)
	STRING sDate;
	STRING sTime;
	INT iTime;
	INT iChar;
	INT iLength;

	SELECT CASE iMode

	CASE mcTimeSec
		sDate = msFields[0];
		sTime = msFields[1];
		iChar = StrSearch(0, sTime, ".");
		IF iChar > 0 THEN	// Drop the MS
			sTime = StrLeft(sTime, iChar);
			iLength = StrLength(msFields[1]);
			IF iLength >= iChar + 7 THEN 		// Long enough to contain AM/PM after MS
				sTime = sTime + StrMid(msFields[1], iChar + 4, 3);
			END
		END
		iTime = StrToTime(sTime) + StrToDate(sDate);
		iTime = DateAdd(iTime, iGMTBiasSec);

	CASE mcTimeMs
		sTime = msFields[1];
		iChar = StrSearch(0, sTime, ".");
		IF iChar > 0 THEN
			iTime = StrRight(sTime, StrLength(sTime) - iChar - 1);
		ELSE
			iTime = 0;
		END

	END SELECT	
	
	RETURN iTime;
END


// Write arrays to trend data files
PRIVATE
FUNCTION
SetTrends(INT nTrends, INT iEndTime, REAL rSamplePeriod, INT nSamples, INT iEndMS);
	INT iSamples;

	IF nTrends > 0 THEN iSamples = TrnSetTable(msTrendTagNames[0], iEndTime, rSamplePeriod, nSamples, mrTrendSamples0[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 1 THEN iSamples = TrnSetTable(msTrendTagNames[1], iEndTime, rSamplePeriod, nSamples, mrTrendSamples1[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 2 THEN iSamples = TrnSetTable(msTrendTagNames[2], iEndTime, rSamplePeriod, nSamples, mrTrendSamples2[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 3 THEN iSamples = TrnSetTable(msTrendTagNames[3], iEndTime, rSamplePeriod, nSamples, mrTrendSamples3[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 4 THEN iSamples = TrnSetTable(msTrendTagNames[4], iEndTime, rSamplePeriod, nSamples, mrTrendSamples4[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 5 THEN iSamples = TrnSetTable(msTrendTagNames[5], iEndTime, rSamplePeriod, nSamples, mrTrendSamples5[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 6 THEN iSamples = TrnSetTable(msTrendTagNames[6], iEndTime, rSamplePeriod, nSamples, mrTrendSamples6[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 7 THEN iSamples = TrnSetTable(msTrendTagNames[7], iEndTime, rSamplePeriod, nSamples, mrTrendSamples7[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 8 THEN iSamples = TrnSetTable(msTrendTagNames[8], iEndTime, rSamplePeriod, nSamples, mrTrendSamples8[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 9 THEN iSamples = TrnSetTable(msTrendTagNames[9], iEndTime, rSamplePeriod, nSamples, mrTrendSamples9[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 10 THEN iSamples = TrnSetTable(msTrendTagNames[10], iEndTime, rSamplePeriod, nSamples, mrTrendSamples10[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 11 THEN iSamples = TrnSetTable(msTrendTagNames[11], iEndTime, rSamplePeriod, nSamples, mrTrendSamples11[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 12 THEN iSamples = TrnSetTable(msTrendTagNames[12], iEndTime, rSamplePeriod, nSamples, mrTrendSamples12[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 13 THEN iSamples = TrnSetTable(msTrendTagNames[13], iEndTime, rSamplePeriod, nSamples, mrTrendSamples13[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 14 THEN iSamples = TrnSetTable(msTrendTagNames[14], iEndTime, rSamplePeriod, nSamples, mrTrendSamples14[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 15 THEN iSamples = TrnSetTable(msTrendTagNames[15], iEndTime, rSamplePeriod, nSamples, mrTrendSamples15[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 16 THEN iSamples = TrnSetTable(msTrendTagNames[16], iEndTime, rSamplePeriod, nSamples, mrTrendSamples16[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 17 THEN iSamples = TrnSetTable(msTrendTagNames[17], iEndTime, rSamplePeriod, nSamples, mrTrendSamples17[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 18 THEN iSamples = TrnSetTable(msTrendTagNames[18], iEndTime, rSamplePeriod, nSamples, mrTrendSamples18[mcMaxElements - nSamples], iEndMS); END
	IF nTrends > 19 THEN iSamples = TrnSetTable(msTrendTagNames[19], iEndTime, rSamplePeriod, nSamples, mrTrendSamples19[mcMaxElements - nSamples], iEndMS); END END

// Read a line from the CSV file in as many 128 char chunks as necessary // and write to msFields[] array PRIVATE FUNCTION GetLine(INT hFile, INT iAddTrailingSeparator = 0)
	INT iErr = mcErrorOverflow;
	STRING sLine;
	STRING sSeparator = ",";
	
	ErrSet(1);

	WHILE (iErr = mcErrorOverflow) DO
		sLine = sLine + FileReadLn(hFile);
		iErr = IsError();
		IF (iAddTrailingSeparator AND (StrRight(sLine,1) <> sSeparator)) THEN
			sLine=sLine + sSeparator;
		END
		sLine = Split(sLine, iErr);
	END
	ErrSet(0);

END


// Splits a string at the specified separator into an array of strings (msFields[]) // If the mode is mcErrorOverflow then the end of the string is returned so it can be // added to the next chunk of data read from the data source PRIVATE STRING FUNCTION Split(STRING sText, INT iMode, STRING sSeparator = ",")

	INT iChar = -1;
	INT iLastChar = -1;
	STRING sTemp;
	INT iLength;
	
	iChar = StrSearch(iChar + 1, sText, sSeparator);
	
	WHILE (iChar > -1) DO
		sTemp = StrTrim(StrMid(sText, iLastChar + 1, iChar - iLastChar - 1));
		msFields[miField] = sTemp;
!		TraceMsg("msFields[" + miField:# + "] = " + msFields[miField]);
		iLastChar = iChar;
		iChar = StrSearch(iChar + 1, sText, sSeparator);
		miField = miField + 1;
	END
	
	iLength = StrLength(sText);
	sTemp = StrTrim(StrMid(sText, iLastChar + 1, iLength - iLastChar - 1));

	IF (iMode = mcErrorOverflow) THEN	// End of line was not reached
		RETURN sTemp;
	ELSE
		msFields[miField] = sTemp;
!		TraceMsg("msFields[" + miField:# + "] = " + msFields[miField]);
		miField = 0;
	END
END

// Stores a sample in one of the trend arrays. Checks for blank, n/a or gated values.
// Starts at the end of the array
PRIVATE
FUNCTION
SetSample(INT iTrend, INT iSampleNo, STRING sValue)

	REAL rValue;
	
	sValue = StrLower(sValue);
	
	SELECT CASE sValue
	CASE "", "n/a"
		rValue = TrnGetInvalidValue();
	CASE "gated"
		rValue = TrnGetGatedValue();
	CASE ELSE
		rValue = StrToReal(sValue);
	END SELECT

!	TraceMsg("Writing trend " + iTrend:# + " sample " + ISampleNo:# + " (Element " + ((mcMaxElements - 1) - iSampleNo):# + ") = " + sValue);

	SELECT CASE iTrend
	CASE 0
		mrTrendSamples0[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 1
		mrTrendSamples1[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 2
		mrTrendSamples2[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 3
		mrTrendSamples3[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 4
		mrTrendSamples4[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 5
		mrTrendSamples5[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 6
		mrTrendSamples6[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 7
		mrTrendSamples7[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 8
		mrTrendSamples8[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 9
		mrTrendSamples9[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 10
		mrTrendSamples10[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 11
		mrTrendSamples11[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 12
		mrTrendSamples12[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 13
		mrTrendSamples13[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 14
		mrTrendSamples14[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 15
		mrTrendSamples15[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 16
		mrTrendSamples16[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 17
		mrTrendSamples17[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 18
		mrTrendSamples18[(mcMaxElements - 1) - iSampleNo] = rValue;
	CASE 19
		mrTrendSamples19[(mcMaxElements - 1) - iSampleNo] = rValue;
	END SELECT
END


// Takes a REAL value and drops the decimals without rounding. Emulates the VB Fix() function // Notes: Pass 8.4 and it will return 8. Pass -8.4 and it will return -8.
PRIVATE
INT
FUNCTION
Fix(REAL rValue)
    RETURN rValue - (rValue MOD 1);
END 


// Replaces EnterCriticalSection() function // See Q3402 PRIVATE INT FUNCTION AccessCriticalSection(STRING sName)
	INT cErrorSemOwnerDied = 297;
	INT cSemWaitUntilClear = -1;
	INT cSemOpenExisting = 2;
	INT hSem;
	INT iError;
	
	hSem = SemOpen(sName, cSemOpenExisting);
	iError = SemWait(hSem, cSemWaitUntilClear);
	
	WHILE (iError = cErrorSemOwnerDied) DO
		iError = SemWait(hSem, cSemWaitUntilClear);
	END
	
	RETURN iError;
END 


c0Title: Trend Export CSV Multi
c1Code:
// TrendExport110.ci

INT MAX_TRENDS = 20;
!INT MAX_ELEMENTS = 15359;	// This works pre-v6
INT MAX_ELEMENTS = 4000;	// This limit can be increased in v6 with [Trend]MaxRequestLength up to 15359
							// MAX_ELEMENTS does not limit the max # samples, only the number read in each
							// block. Increase to increase performance, but it may cause more load on the
							// trend server.

STRING CRLF = "^0x0D^0x0A";		// Carriage Return & Line Feed characters

STRING msTags[21];      // List of trend tag names
STRING msFileBuffer;	// Buffer for text to log
INT  miLastTrend;       // Number of last trend specified
REAL mrTrend1[15359];   // Trend samples for the first trend tag
REAL mrTrend2[15359];
REAL mrTrend3[15359];
REAL mrTrend4[15359];
REAL mrTrend5[15359];
REAL mrTrend6[15359];
REAL mrTrend7[15359];
REAL mrTrend8[15359];
REAL mrTrend9[15359];
REAL mrTrend10[15359];
REAL mrTrend11[15359];
REAL mrTrend12[15359];
REAL mrTrend13[15359];
REAL mrTrend14[15359];
REAL mrTrend15[15359];
REAL mrTrend16[15359];
REAL mrTrend17[15359];
REAL mrTrend18[15359];
REAL mrTrend19[15359];
REAL mrTrend20[15359];

// FUNCTION:    TrnExportCSVMulti
//
// DESC:        Exports up to 20 trends to a CSV file
//
// VERSION:     1.00 8/03  Eric Black  Original
//              1.01 8/03  Eric Black  Allow variable number of trends
//              1.02 8/03  Eric Black  Separated time and date fields
//              1.10 6/05  Eric Black  Removed limit of 15359 samples from iLength
//                                     N/A and Gated samples export with standard labels
//
// ARGUMENTS:   sFilename        Path and filename to write to. If the file exists, it will be deleted
//              iTime            Citect time value for the end of the data to export
//              iPeriod          Number of seconds between samples
//              iLength          Number of samples
//              sTag1...sTag20   List of trend tag names
//
// EXAMPLE:     The following command will export Trend1 to Trend5 with 30 1-minute samples to d:\trnexport.csv:
//              TrnExportCSVMulti("D:\TrnExport.csv", StrToDate("8/8/2003")+StrToTime("9:00:00 AM"), 60, 30, "Trend1", "Trend2", "Trend3", "Trend4", "Trend5");
//
FUNCTION
TrnExportCSVMulti(STRING sFilename, INT iTime, INT iPeriod, INT iLength, 
                  STRING sTag1, STRING sTag2 = "", STRING sTag3 = "", STRING sTag4 = "", STRING sTag5 = "",
                  STRING sTag6 = "", STRING sTag7 = "", STRING sTag8 = "", STRING sTag9 = "", STRING sTag10 = "",
                  STRING sTag11 = "", STRING sTag12 = "", STRING sTag13 = "", STRING sTag14 = "", STRING sTag15 = "",
                  STRING sTag16 = "", STRING sTag17 = "", STRING sTag18 = "", STRING sTag19 = "", STRING sTag20 = "")
	
	INT iElement;				
	INT hFile;
	INT iSampleTime;
	INT iMode = 1+2;		// TrnGetTable mode=show gated/na + reverse order
	INT iTrend;
	INT TIME_LONG = 1;
	INT DATE_EXTENDED = 9;
	INT iBlockTime;
	INT iBlockSize=1;
	INT iLastUpdate;
	
	INT iVal;
	
	AccessCriticalSection("TrnExportCSVMulti");
	
	MakeTagsArray(sTag1, sTag2, sTag3, sTag4, sTag5, sTag6, sTag7, sTag8, sTag9, sTag10, sTag11, sTag12, sTag13, sTag14, sTag15, sTag16, sTag17, sTag18, sTag19, sTag20);

	miLastTrend = GetLastTrendNo();
	
	IF FileExist(sFilename) THEN
		FileDelete(sFilename);
	END
			
	hFile = FileOpen(sFilename, "a");
		
	LogCSVHeader(hFile);

	iBlockTime = iTime - (iLength * iPeriod);	// Find start time for export
	
	WHILE (iBlockTime <= iTime) AND (iBlockSize > 0) DO

		IF iLength > MAX_ELEMENTS THEN
			iBlockSize = MAX_ELEMENTS;
		ELSE
			iBlockSize = iLength;
		END

		iLength = iLength - iBlockSize;

		iBlockTime = iBlockTime + ((iBlockSize) * iPeriod);
		
		Prompt("Reading Trend Data...");
		ReadTrends(iBlockTime, iPeriod, iBlockSize, iMode);
		
		iSampleTime = iBlockTime - ((iBlockSize - 1) * iPeriod);  // Calculate beginning sample
		
		FOR iElement = 0 TO iBlockSize - 1 DO

			IF TimeCurrent() - iLastUpdate >= 1 THEN
				Prompt("Exporting from " + TimeToStr(iSampleTime, 4));
				iLastUpdate = TimeCurrent();
			END
		
			WriteFile(hFile, TimeToStr(iSampleTime, DATE_EXTENDED) + ",");	// Log date & time
			WriteFile(hFile, TimeToStr(iSampleTime, TIME_LONG) + ",");
	
			// Log each trend value if the tag name has been defined
			IF miLastTrend >= 1 THEN LogTrendValue(hFile, 1, mrTrend1[iElement]); END	
			iVal = TrnIsValidValue(mrTrend1[iElement]);
			IF miLastTrend >= 2 THEN LogTrendValue(hFile, 2, mrTrend2[iElement]); END
			IF miLastTrend >= 3 THEN LogTrendValue(hFile, 3, mrTrend3[iElement]); END
			IF miLastTrend >= 4 THEN LogTrendValue(hFile, 4, mrTrend4[iElement]); END
			IF miLastTrend >= 5 THEN LogTrendValue(hFile, 5, mrTrend5[iElement]); END
			IF miLastTrend >= 6 THEN LogTrendValue(hFile, 6, mrTrend6[iElement]); END
			IF miLastTrend >= 7 THEN LogTrendValue(hFile, 7, mrTrend7[iElement]); END
			IF miLastTrend >= 8 THEN LogTrendValue(hFile, 8, mrTrend8[iElement]); END
			IF miLastTrend >= 9 THEN LogTrendValue(hFile, 9, mrTrend9[iElement]); END
			IF miLastTrend >= 10 THEN LogTrendValue(hFile, 10, mrTrend10[iElement]); END
			IF miLastTrend >= 11 THEN LogTrendValue(hFile, 11, mrTrend11[iElement]); END
			IF miLastTrend >= 12 THEN LogTrendValue(hFile, 12, mrTrend12[iElement]); END
			IF miLastTrend >= 13 THEN LogTrendValue(hFile, 13, mrTrend13[iElement]); END
			IF miLastTrend >= 14 THEN LogTrendValue(hFile, 14, mrTrend14[iElement]); END
			IF miLastTrend >= 15 THEN LogTrendValue(hFile, 15, mrTrend15[iElement]); END
			IF miLastTrend >= 16 THEN LogTrendValue(hFile, 16, mrTrend16[iElement]); END
			IF miLastTrend >= 17 THEN LogTrendValue(hFile, 17, mrTrend17[iElement]); END
			IF miLastTrend >= 18 THEN LogTrendValue(hFile, 18, mrTrend18[iElement]); END
			IF miLastTrend >= 19 THEN LogTrendValue(hFile, 19, mrTrend19[iElement]); END
			IF miLastTrend >= 20 THEN LogTrendValue(hFile, 20, mrTrend20[iElement]); END
	
			WriteFile(hFile, CRLF);		// Add CRLF

			iSampleTime = iSampleTime + iPeriod;
			SleepMS(0);
		END
		
	END

	CloseFile(hFile);
	LeaveCriticalSection("TrnExportCSVMulti");
	Prompt("Export Complete - " + sFileName);
	Sleep(2);
	Prompt("");
END


PRIVATE
FUNCTION
ReadTrends(INT iTime, INT iPeriod, INT iLength, INT iMode);

	ErrSet(1);		// Disable error checking in case some trends don't exist
	INT iStart;

	IF miLastTrend >= 1 THEN TrnGetTable(msTags[1], iTime, iPeriod, iLength, mrTrend1, 1+2, 0); END;
	IF miLastTrend >= 2 THEN TrnGetTable(msTags[2], iTime, iPeriod, iLength, mrTrend2, iMode, 0); END;
	IF miLastTrend >= 3 THEN TrnGetTable(msTags[3], iTime, iPeriod, iLength, mrTrend3, iMode, 0); END;
	IF miLastTrend >= 4 THEN TrnGetTable(msTags[4], iTime, iPeriod, iLength, mrTrend4, iMode, 0); END;
	IF miLastTrend >= 5 THEN TrnGetTable(msTags[5], iTime, iPeriod, iLength, mrTrend5, iMode, 0); END;
	IF miLastTrend >= 6 THEN TrnGetTable(msTags[6], iTime, iPeriod, iLength, mrTrend6, iMode, 0); END;
	IF miLastTrend >= 7 THEN TrnGetTable(msTags[7], iTime, iPeriod, iLength, mrTrend7, iMode, 0); END;
	IF miLastTrend >= 8 THEN TrnGetTable(msTags[8], iTime, iPeriod, iLength, mrTrend8, iMode, 0); END;
	IF miLastTrend >= 9 THEN TrnGetTable(msTags[9], iTime, iPeriod, iLength, mrTrend9, iMode, 0); END;
	IF miLastTrend >= 10 THEN TrnGetTable(msTags[10], iTime, iPeriod, iLength, mrTrend10, iMode, 0); END;
	IF miLastTrend >= 11 THEN TrnGetTable(msTags[11], iTime, iPeriod, iLength, mrTrend11, iMode, 0); END;
	IF miLastTrend >= 12 THEN TrnGetTable(msTags[12], iTime, iPeriod, iLength, mrTrend12, iMode, 0); END;
	IF miLastTrend >= 13 THEN TrnGetTable(msTags[13], iTime, iPeriod, iLength, mrTrend13, iMode, 0); END;
	IF miLastTrend >= 14 THEN TrnGetTable(msTags[14], iTime, iPeriod, iLength, mrTrend14, iMode, 0); END;
 	IF miLastTrend >= 15 THEN TrnGetTable(msTags[15], iTime, iPeriod, iLength, mrTrend15, iMode, 0); END;
	IF miLastTrend >= 16 THEN TrnGetTable(msTags[16], iTime, iPeriod, iLength, mrTrend16, iMode, 0); END;
	IF miLastTrend >= 17 THEN TrnGetTable(msTags[17], iTime, iPeriod, iLength, mrTrend17, iMode, 0); END;
	IF miLastTrend >= 18 THEN TrnGetTable(msTags[18], iTime, iPeriod, iLength, mrTrend18, iMode, 0); END;
	IF miLastTrend >= 19 THEN TrnGetTable(msTags[19], iTime, iPeriod, iLength, mrTrend19, iMode, 0); END;
	IF miLastTrend >= 20 THEN TrnGetTable(msTags[20], iTime, iPeriod, iLength, mrTrend20, iMode, 0); END;

	ErrSet(0);
END


// Copy a series of trend tag names into one array PRIVATE FUNCTION MakeTagsArray(STRING sTag1, STRING sTag2, STRING sTag3, STRING sTag4, STRING sTag5, STRING sTag6, STRING sTag7, STRING sTag8, STRING sTag9, STRING sTag10, STRING sTag11, STRING sTag12, STRING sTag13, STRING sTag14, STRING sTag15, STRING sTag16, STRING sTag17, STRING sTag18, STRING sTag19, STRING sTag20)
	msTags[1] = sTag1;
	msTags[2] = sTag2;
	msTags[3] = sTag3;
	msTags[4] = sTag4;
	msTags[5] = sTag5;
	msTags[6] = sTag6;
	msTags[7] = sTag7;
	msTags[8] = sTag8;
	msTags[9] = sTag9;
	msTags[10] = sTag10;
	msTags[11] = sTag11;
	msTags[12] = sTag12;
	msTags[13] = sTag13;
	msTags[14] = sTag14;
	msTags[15] = sTag15;
	msTags[16] = sTag16;
	msTags[17] = sTag17;
	msTags[18] = sTag18;
	msTags[19] = sTag19;
	msTags[20] = sTag20;
END
	

// Look for the first blank trend name and assume that's the end of the list // Return the number of trends selected PRIVATE INT FUNCTION
GetLastTrendNo()

	INT iCount;
	
	FOR iCount = 1 TO MAX_TRENDS - 1 DO
		IF msTags[iCount + 1] = "" THEN
			RETURN iCount;
		END
	END

	RETURN iCount;
END


// Create header row by logging the time and each trend name separated by commas // If the current trend name is blank, append a CRLF and end // If there is a next trend, put a comma after the current tag name PRIVATE FUNCTION LogCSVHeader(INT hFile)
	INT iTrend;
	STRING sSeparator;
	
	FileWrite(hFile, "DATE,TIME");
	
	FOR iTrend = 1 TO miLastTrend DO
		
		IF msTags[iTrend] <> "" THEN
			WriteFile(hFile, "," + msTags[iTrend]);
		END
		
		IF (msTags[iTrend] = "") OR (iTrend = miLastTrend) THEN
			WriteFile(hFile, CRLF);		// Append CRLF
			RETURN;
 		END
	END
END


// Log a comma (if needed) followed by a sample value

PRIVATE
FUNCTION
LogTrendValue(INT hFile, INT iTrend, REAL rValue);

	STRING sText;
	
	IF iTrend > 1 THEN
		sText = "," + TrendValue(rValue);
	ELSE
		sText = TrendValue(rValue);
	END

	WriteFile(hFile, sText);
END


//Wrapper for FileWrite() uses buffering to mimimize disk access FUNCTION WriteFile(INT hFile, STRING sText)
	IF (StrLength(sText) + StrLength(msFileBuffer)) < 255 THEN
		FileWrite(hFile, msFileBuffer + sText);
	ELSE
		FileWrite(hFile, msFileBuffer);
		msFileBuffer = sText;
	END
END


//Wrapper for FileClose() uses buffering to mimimize disk access FUNCTION CloseFile(INT hFile)
	FileWrite(hFile, msFileBuffer);
	msFileBuffer = ""
	FileClose(hFile);
END


// Convert trend value into a string
// 6/17/05 Modified to use standard labels for n/a and gated PRIVATE STRING FUNCTION TrendValue(REAL rValue)

	INT iVal;
	iVal = TrnIsValidValue(rValue)

	SELECT CASE iVal
	CASE 0
		RETURN rValue:#.######;
	CASE 1
		RETURN "gated";
	CASE 2
		RETURN "n/a";
	CASE ELSE
		RETURN "error";
	END SELECT
END


// See Q3402
PRIVATE
INT
FUNCTION
AccessCriticalSection(STRING sName)
    INT hSem;
    INT iErr;

    hSem = SemOpen(sName, 2);
    iErr = SemWait(hSem, -1);

    WHILE iErr = 297 DO // Repeat if semaphore owner died 
          iErr = SemWait(hSem, -1);
    END

    RETURN iErr;
END


// Function:         Fix()
//
// Description:      Emulates the VB Fix() function. Takes a REAL value and drops 
//                                 the decimals without rounding 
//
// Argument:         rValue		Floating point value to convert 
//
// Return Value:     A long integer equal to the floating point value with no decimal places 
//
// Notes:            Pass 8.4 and it will return 8. Pass -8.4 and it will return -8.
//
PRIVATE
INT
FUNCTION
Fix(REAL rValue)
    RETURN rValue - (rValue MOD 1);
END 


c0Title: Process Analyst - Set Pen AutoScale
c1Code:
FUNCTION
AutoScale(STRING sPaObjectName, STRING sPen)
    OBJECT hPA;
    OBJECT hPanes;
    OBJECT hPane;
    OBJECT hPens;
    OBJECT hPen;
    INT iPaneCount;
    
    hPA = ObjectByName(sPaObjectName);
    hPanes = _ObjectGetProperty(hPA, "Panes");
    hPane = _ObjectCallMethod(hPanes, "get_Item", 1);
    hPens = _ObjectGetProperty(hPane, "Pens");
    hPen = _ObjectCallMethod(hPens, "get_ItemByName", sPen);
 
 _ObjectSetProperty(hPen, "VerticalAxisAutoscale", -1); 
END


c0Title: Get Variable Tag's Format
c1Code:
// FUNCTION:        GetFormat
// DESCRIPTION:     Returns information about the format of the specified tag, as specified in
//                  the Variable Tags form's Format field.
//
// ARGUMENTS:       sTag     Tagname to use
//
//                  iMode    0    Width (including decimal and decimal places)
//                           1    Number of decimal places
//                           2    Zero Padded
//                           3    Left Justified
//                           4    Engineering Units displayed
//                           5    Exponential (scientific) notation
//
// RETURN VALUE:    Modes 0 and 1 return an integer value. Modes 2-5 return 0 (FALSE)
//                    or 1 (TRUE). If Mode is invalid, -1 will be returned.
//
// SAMPLE: GetFormat("Motor101_SP", 1) will return the number of decimal places in that tag
//
INT
FUNCTION
GetFormat(STRING sTag, INT iMode)
     INT iFormat; 

    iFormat = TagInfo(sTag, 8); 

    SELECT CASE iMode
     CASE 0             // Width (#)
          RETURN iFormat BITAND 0xff
     CASE 1             // Decimals (.)
          RETURN (iFormat BITAND 0xff00) / 0xff
     CASE 2             // Zero Padding (0)
          IF (iFormat BITAND 0x10000) = 0x10000 THEN
               RETURN 1;
          ELSE
               RETURN 0;
          END
     CASE 3             // Left Justified (-)
          IF (iFormat BITAND 0x20000) = 0x20000 THEN
               RETURN 1;
          ELSE
               RETURN 0;
          END
     CASE 4             // EU Display (EU)
          IF (iFormat BITAND 0x40000) = 0x40000 THEN
               RETURN 1;
          ELSE
               RETURN 0;
          END
    CASE 5             // Exponential Notation (s)
          IF (iFormat BITAND 0x100000) = 0x100000 THEN
               RETURN 1;
          ELSE
               RETURN 0;
          END
     CASE ELSE         // Wrong Mode
          RETURN -1;
     END SELECT
END


c0Title: TagDebug Modified for Unlimited Tags (Don't Need to Modify Include Proj)
c1Code:
/* variables for the TagDebug functions */

STRING		sValue;         ! Value read or to write
STRING		sTag;           ! Variable Tag name
INT		hForm = -1;     ! Form handle


// This is a copy of TagDebug() with the max # tags limit removed
STRING
FUNCTION
Plus_TagDebug()

	IF hForm = -1 THEN
		sTag = "";
		sValue = "";
		hForm = FormNew("@(TagDebug)", 44, 3, 9);
		FormComboBox(0 ,0, 34, 5, sTag, 1);
		_Plus_TagDebugFillTagList();
		FormEdit(0, 1, sValue, 34);
		FormButton(36, 0, " " + "@(Read)" + "  ", _Plus_TagDebugRead, 0);
		FormButton(36, 1, " " + "@(Write)" + " ", _Plus_TagDebugWrite, 0);
		FormButton(36, 2, " " + "@(Close)" + " ", 0, 2);
		FormRead(0);
		hForm = -1;
		RETURN(sTag);
	END
END


// Supporting function for Plus_TagDebug()
PRIVATE
FUNCTION
_Plus_TagDebugFillTagList()
        INT     nMaxList;
        INT     nRec;
        INT     hRDB;
        
        hRDB = RdbOpen("_VARIABL");
        IF hRDB >= 0 THEN
                nRec = RdbFirstRec(hRDB);
                WHILE nRec >=0  DO
                        sTag = RdbGet(hRDB, "Tag");
                        FormAddList(sTag);
                        nRec = RdbNextRec(hRDB);                                
                END
		RdbClose(hRDB);
	END
END


// Supporting function for Plus_TagDebug()
!PRIVATE
INT
FUNCTION
_Plus_TagDebugRead()
        FormGetData(hForm);
        sValue = TagRead(sTag, 0);
        FormSetData(hForm);
	RETURN	0;
END


// Supporting function for Plus_TagDebug()
!PRIVATE
INT
FUNCTION
_Plus_TagDebugWrite()
        FormGetData(hForm);
        TagWrite(sTag, sValue, 0);
	RETURN 0;
END


c0Title: Authenticate Component Usage
c1Code:
Bundling functionality and program logic into an ActiveX DLL is an excellent form of encapsulation. But even when you expose functionality to your client application, you don�t need to allow unrestricted access to all of your public functions. Use this simple mechanism to secure your proprietary functions from unauthorized access.
Create a private global variable, g_Authorized, of type Boolean to hold the authorization state for your DLL. When the DLL loads, g_Authorized is initialized to False. Each function (or sub) that you wish to protect should first check the value of g_Authorized before proceeding. If g_Authorized = False, then raise a runtime error advising the user that the function call is not authorized. If g_Authorized = True, then execute the function. For example, here is a snippet from one of the encryption routines. You use encryption to keep the data private, so you want to protect the encryption function itself from unauthorized access:

Public Function Encrypt(PlainText As String, CipherType As axCipherType, Optional ByVal Key As Long = 0) As String 
Dim iX As Long 
Dim iAscii As Integer 
Dim CipherText As String 
Dim StringLen As Long 

If Not g_Authenticated Then 
Err.Raise vbObjectError, "Encrypt", "Application is not authorized to use this function"
End If


The client application must call this public function to set the state of the DLL to Authorized (g_Authorized = True):

Public Sub Authenticate(Code As Variant) 
If Code = "asd93d,ssd" Then 
g_Authenticated = True 
End If 
End Sub 


Passing the code parameter as a Variant makes it more secure because a potential hacker would have no idea what sort of data the expected authentication code is.
This is the basic methodology for DLL protection. Actually, you could employ much more secure algorithms. You could derive the code from any number of potential values, such as the current system date/time, hard disk free space, or any other checkable value. Only your own applications would know the correct algorithm, so they would be the only applications on the client PC capable of authenticating the DLL for their use. Such a code would be more secure from a hack attack because it would actually change from minute to minute or machine to machine.
�Joseph Geretz, Monsey, New York


c0Title: ActiveX Can�t Create Which Object?
c1Code:
When working on a large VB application that uses hundreds of COM objects, the �429 can�t create object� error doesn�t give you much help in determining which object could not be created. You can get around this limitation by writing a function to wrap the VB runtime CreateObject function:

Public Function CreateObject(sProgID as string) as object
     On Error Goto CreateErr
 
     ' Call the VB runtime CreateObject function
     Set CreateObject = VBA.CreateObject(sProgId)
 
     Exit Function
CreateErr:
     ' return the error with the name of the object 
     'that could not be created
     Err.Raise Err.Number, "CreateObject Wrapper", Err.Description & ": '" & sProgID & "'"
End Function


With this wrapper function, you get the 429 error and the name of the object that could not be created.

�Kelley L. Larsen, Monroe, Washington


c0Title: Define Properties to Use Standard Dialogs
c1Code:
It�s easy to add the standard LoadPicture and Font dialogs, complete with ellipsis, in a UserControl�s property list. The trick is to define the properties as StdPicture or StdFont, respectively. For example, you can paste this code into a new UserControl to load an image into the UserControl�s Picture property and change the font for an embedded textbox. Start a new project in VB5 or VB6, add an ActiveX control (UserControl), drop a textbox onto it, and paste in the code:

Option Explicit

Private Sub UserControl_InitProperties()
       ' Start with some sample text
       Text1.Text = "Some sample text"
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
       ' Restore any changes we made during design mode
       Set UserControl.Picture = PropBag.ReadProperty("Image", Nothing)
       Set Text1.Font = PropBag.ReadProperty("Font", Nothing)
       Text1.Text = PropBag.ReadProperty("Text", "Some sample text")
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
       ' Save any changes we made during design mode
       PropBag.WriteProperty "Image", UserControl.Picture, Nothing
       PropBag.WriteProperty "Font", Text1.Font, Nothing
       PropBag.WriteProperty "Text", Text1.Text, "Some sample text"
End Sub

Public Property Get Image() As StdPicture
       ' return the UserControl's image (if any)
       Set Image = UserControl.Picture
End Property

Public Property Set Image(ByVal newBackground As StdPicture)
       ' change the UserControl's background image
       Set UserControl.Picture = newBackground
       PropertyChanged "Image"
End Property

Public Property Get Font() As StdFont
       ' get the current textbox font details
       Set Font = Text1.Font
End Property

Public Property Set Font(ByVal newFont As StdFont)
       ' update the textbox font details
       Set Text1.Font = newFont
       PropertyChanged "Font"
End Property


Close the UserControl�s designer window and add a new project (Standard EXE). Drop a copy of the newly created UserControl onto the form, making sure the new control instance is large enough to see the textbox, and check the property list. Apart from the standard properties provided by VB, the property list contains two extra properties�Image and Font�complete with VB�s standard "..." for popping up the Image and Font dialogs. For example, if you change the Font properties, the font of the text displayed in the textbox changes immediately, and selecting an image places that image in the UserControl�s Picture property.

�John Cullen, Pedroucos, Portugal


c0Title: Dual Procedure IDS
c1Code:
When using VB to create a new ActiveX control with a Caption or Text property, you can set the corresponding Procedure ID to cause the Property Browser to update the property value with each keystroke, just as the Label and Text controls do. However, it�s not obvious how to make it the default property as well. That�s because (Default), Caption, and Text all appear in the Procedure ID list, allowing only one ID to be assigned to your new property. To get around this limitation, create another hidden property (check �Hide this member� in the Procedure Attributes dialog) that updates the same variable and you can make that the default property.

�Chuck Liem, Olathe, Kansas


c0Title: BinarySearch - Fast search in a sorted array
c1Code:
' Binary search in a string array
' Returns the index of the matching item, or -1 if the search fails 
'
' The arrays *must* be sorted and LBound should be >= 0 
'
Function BinarySearch(sArray() As String, sFind As String, Optional ByVal nFirst As Long = -1, Optional ByVal nLast As Long = -1)
    Dim nLow As Long
    Dim nMiddle As Long
    Dim nHigh As Long
    
    If nFirst = -1 Then nFirst = LBound(sArray)
    If nLast = -1 Then nLast = UBound(sArray)
    
    nLow = nFirst - 1
    nHigh = nLast + 1
    
    Do While (nHigh - nLow) > 1
        nMiddle = nLow + ((nHigh - nLow) \ 2)
        If sArray(nMiddle) < sFind Then
            nLow = nMiddle
        Else
            nHigh = nMiddle
        End If
    Loop
    
    If (nHigh = nLast + 1) Then
        BinarySearch = -1
    Else
        If (sArray(nHigh) <> sFind) Then
            BinarySearch = -1
        Else
            BinarySearch = nHigh
        End If
    End If
    
End Function


c0Title: Search a 2D Array for a String
c1Code:
'Check if a string matches an element in an array
Public Function InArray2D(sArray() As String, sFind As String, Optional nColumn As Long = -1) As Boolean
    Dim nRow As Long
    Dim nMax As Long
    
    If nColumn = -1 Then nColumn = LBound(sArray, 2)
    
    nMax = UBound(sArray, 1)
    
    For nRow = LBound(sArray, 1) To nMax
        If sArray(nRow, nColumn) = sFind Then
            InArray2D = True
            Exit Function
        End If
    Next
    
    InArray2D = False
        
End Function


c0Title: Check if an array is valid (has dimensioned subscripts)
c1Code:
'Returns TRUE if the specified variable has been dimensioned with array subscripts
'Any static array returns TRUE. A dynamic array only returns TRUE if it has been ReDim'd
'Returns FALSE if Split("") has been assigned to the array to make it invalid with subscripts 0 to -1
'This differs from IsArray which returns true for dynamic arrays that have not been ReDim'd
Public Function IsValidArray(vArray As Variant) As Boolean
    Dim nStart As Long
    
    On Error GoTo ErrorHandler
    
    If LBound(vArray, 1) <= UBound(vArray, 1) Then
        IsValidArray = True
    Else
        IsValidArray = False
    End If
    
    Exit Function
    
ErrorHandler:
    IsValidArray = False
End Function


c0Title: Compare Byte Arrays
c1Code:
'Compare two byte arrays. Returns True if they're equal
Public Function ByteArrayCompare(ByteArray1() As Byte, ByteArray2() As Byte) As Boolean
    On Error GoTo OnError
    Dim nElement As Long
    
    If (LBound(ByteArray1) <> LBound(ByteArray2)) Or _
       (UBound(ByteArray1) <> UBound(ByteArray2)) Then
        Exit Function
    End If
    
    For nElement = LBound(ByteArray1) To UBound(ByteArray1)
        If ByteArray1(nElement) <> ByteArray2(nElement) Then
            ByteArrayCompare = False
            Exit Function
        End If
    Next nElement
    
    ByteArrayCompare = True
 
    Exit Function
 
OnError:
    ByteArrayCompare = False
End Function


c0Title: Copy an Array Faster
c1Code:
Here�s an optimized method of copying one array to another. Usually when copying an array to another array, the developer iterates through each item of the source array, assigning the item to the associated item of the destination array:

Private Declare Function timeGetTime Lib "winmm.dll" () As Long 
Private Sub Copy() 
    Dim i Dim startTime As Long 
    Dim endTime As Long 
    Dim intSrc(1 To 6000000) As Integer 
    Dim intDest(1 To 6000000) As Integer 

    startTime = timeGetTime 

    For i = LBound(intSrc) To UBound(intSrc)
        intDest(i) = intSrc(i)
    Next i

    endTime = timeGetTime
    Debug.Print "Copy took: " & endTime - startTime & " ms."
End Sub


Instead, use the Win32 API function CopyMemory to copy the array from source to destination:

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 

Private Sub FastCopy() 
    Dim startTime As Long 
    Dim endTime As Long 
    Dim bytes As Long 
    Dim intSrc(1 To 6000000) As Integer 
    Dim intDest(1 To 6000000) As Integer 

    bytes = (UBound(intSrc) - LBound(intSrc) + 1) * Len(intSrc(LBound(intSrc)))
    startTime = timeGetTime
    CopyMemory intDest(LBound(intDest)), intSrc(LBound(intSrc)), bytes
    endTime = timeGetTime
    Debug.Print "FastCopy took: " & endTime - startTime & " ms."
End Sub


When compiled to native code with all optimizations, this second method averages up to 15 times faster, and a stunning 30 to 35 times faster when running as compiled p-code or in the Integrated Development Environment (IDE). But be warned: You can also GPF at blinding speeds if you miscalculate the number of bytes to copy, use bad source or destination addresses, or if your destination array isn�t sized sufficiently.

�Andrew Holliday, Phoenix, Arizona


c0Title: Determine Control�s Membership in a Control Array
c1Code:
To determine whether a control is a member of a control array, you can reference its Index property and handle the generated error when the control is not in an array. Alternatively, you can use the TypeName function, which returns �Object� for members of a control array. The trick to using it is to reference the control array, not just one of its members. You can do this using the Controls collection, keying on the control�s name:

Public Function IsCntlArray(cntl As Control) As Boolean
    IsCntlArray = (TypeName(cntl.Parent.Controls(cntl.Name)) = "Object")
End Function


�Bill McCarthy, Barongarook, Victoria, Australia


c0Title: Determine The Number of Dimensions in an Array
c1Code:
Determine The Number of Dimensions in an Array

'Returns the number of dimensions in the specified array 'or 0 if the array is not dimensioned Function ArrayDimensions(vArray As Variant) As Long
    Dim nDimension As Long
    Dim nStart As Long

    On Error GoTo FinalDimension

    Do
        nDimension = nDimension + 1
        nStart = LBound(vArray, nDimension)
    Loop

FinalDimension:
    ArrayDimensions = nDimension - 1
End Function


c0Title: Call the Click Event
c1Code:
If you need to fire a command button�s Click event, you can set the Value property to True:

cmdAdd.Value = True


The real benefit of this is that you can call code in other form modules. It is faster, however, to call the event procedure directly:

Call cmdAdd_Click


This is true for all controls, not just the command button.

�Paul D. Sherriff/Visual Basic Power Guides


c0Title: Create Better Button Arrows
c1Code:
Many times developers use a form�s default font arrow characters for To and From buttons between listboxes. To give your app a nicer, more solid look, do what Microsoft does�use the Marlett font, which is added by default to all Windows 95, 98, and NT4 and later installations.

Instead of giving a To button the caption �>,� change the font to Marlett and type �3� for the Caption property. Instead of a From button being a skeletal �<,� use Marlett and type �4� in the Caption property. For nice, solid Up and Down arrows, use Marlett �5� and �6.�

Marlett Arrows: 3456

�Robert Smith, Kirkland, Washington


c0Title: Display a Citect HTML Help page
c1Code:
Global Const gcAppName = "Tag Builder"
Global Const gcAppSection = "Settings"

Public Declare Function HtmlHelp Lib "HHCtrl.ocx" Alias "HtmlHelpA" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Any) As Long

'Displays Citect Help opened to the index tab with the specified topic selected in the index 'If the help file doesn't exist, the user is prompted to browse for it Public Function CitectHelpDisplay(Optional sTopic As String = vbNullString)
    Const HH_DISPLAY_INDEX = &H2
    
    Dim sFile As String
    Dim oFSO As FileSystemObject
    
    Set oFSO = New FileSystemObject
    
    sFile = CitectHelpFile()	'Property gets/sets saved citect help file path\name
    
    If (oFSO.FileExists(sFile) = False) Then
        
        sFile = BrowseFile(InitialDir:=sFile, _
                           Filter:="Help Files|*.chm;*.hlp", _
                           DialogTitle:="Select CitectSCADA Help File", _
                           OpenFile:=True)
        
        If sFile <> vbNullString Then
            CitectHelpFile = sFile
        Else
            Exit Function
        End If
    End If
        
    HtmlHelp 0, CitectHelpFile, HH_DISPLAY_INDEX, sTopic
    
End Function

Public Property Let CitectHelpFile(sFile As String)
    msCitectHelpFile = sFile
    SaveSetting gcAppName, gcAppSection, "CitectHelpFile", msCitectHelpFile End Property

Public Property Get CitectHelpFile() As String
    If msCitectHelpFile = vbNullString Then
        msCitectHelpFile = GetSetting(gcAppName, gcAppSection, "CitectHelpFile")
    End If
    
    CitectHelpFile = msCitectHelpFile
End Property


c0Title: A template for building collection class modules
c1Code:
The following is a template for building collection class modules in a very quick and effective way. Copy-and-paste this code into Notepad, that save it to a file named "COLLECTION CLASS.CLS" in the \TEMPLATE\CLASSES subdirectory under the main VB6 directory:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject END Attribute VB_Name = "CollectionClassName"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

'----------------------------------------------------
' A template for Collection Classes
'----------------------------------------------------
'
' What to do after you add this template to the ' current program:
'
' 1) change the name of the class as needed ' 2) use the search and replace command to change all
'    instances of "BaseClassName" (without quotes), into
'    the actual name of the base class
' 3) optionally modify the ADD method to initialize
'    properties of the NEWITEM object before adding it
'    to the private collection
' 4) delete these remarks
'------------------------------------------------------

Option Explicit

' The private collection used to hold the real data Private m_PrivateCollection As Collection

Private Sub Class_Initialize()
    ' explicit assignment is slightly faster than auto-instancing
    Set m_PrivateCollection = New Collection End Sub

' Add a new BaseClassName item to the collection

Public Sub Add(newItem As BaseClassName, Optional Key As Variant) Attribute Add.VB_Description = "Adds a member to a Collection object"
    ' TO DO: initialize new item's properties here
    ' ...
    ' add to the private collection
    m_PrivateCollection.Add newItem, Key End Sub

' Remove an item from the collection

Public Sub Remove(index As Variant)
Attribute Remove.VB_Description = "Removes a member from a Collection object"
    m_PrivateCollection.Remove index
End Sub

' Return a BaseClassName item from the collection

Function Item(index As Variant) As BaseClassName Attribute Item.VB_Description = "Returns a specific member of a Collection " _
    & "object either by position or key"
Attribute Item.VB_UserMemId = 0
    Set Item = m_PrivateCollection.Item(index) End Function

' Return the number of items in the collection

Property Get Count() As Long
Attribute Count.VB_Description = "Returns the number of members in a collection"
    Count = m_PrivateCollection.Count
End Property

' Remove all items from the collection

Public Sub Clear()
Attribute Clear.VB_Description = "Removes all members from a Collection object"
    Set m_PrivateCollection = New Collection End Sub

' Implement support for enumeration (For Each)

Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    ' delegate to the private collection
    Set NewEnum = m_PrivateCollection.[_NewEnum] 
End Function


You can now add a new collection class by selecting the "Collection Class" template when you add a class module to your current project. If you don't see the list of templates, enforce this capability in the Environment tab of the Tools | Options dialog box.
After you've added the template to the project, follow the easy 4-step procedure described at the top of the file to turn it into a real collection class. Note that the template above works only under VB6. To have it work under VB5, you must delete the following four lines, near the beginning of the file:

  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject


c0Title: Convert Values for Collection
c1Code:
If you�re adding something to a collection, you might want to convert it before adding it. This code adds a reference to the recordset, not the value of the field returned by this syntax normally:

' (col is a collection, rs is a recordset) 
col.Add rs("Some Field") 


When you try to get the value from the collection, you get an error if the recordset is gone�not the best coding practice. If you want a simple collection, you want to convert the value:

col.Add CStr(rs("Some Field"))


Here�s another way around the problem:

col.Add rs("Some Field").Value


The default property of a recordset is the .Value property, which is why you see a value when you code things such as str = rs("Some Field"). You should be coding with rs("Field").Value, but it�s more work, so you don�t. The penalty for shortcutting the default property comes when things don�t behave properly�for example, with a collection reference. If you have other object values that you want to put into a collection, be sure you know what you�re referencing�the object or the value.

�Dan Kobelt, Abbotsford, British Columbia, Canada


c0Title: Determining Credit Card Types
c1Code:
Need to determine a credit card type? Can't be bothered to write your own decision-making function?

Fear not - hear to help is our own ready-to-run code snippet. Just feed it a credit card number and it'll return a string of the appropriate card type.

If you want to determine whether a credit card number is valid, check out our handy code snippet here.

x = CreditCardType("5454 1234 4321 1234")


Code

Public Function CreditCardType(ByVal CardNo As String) As String

'*CARD TYPES            *PREFIX           *WIDTH
'American Express       34, 37            15
'Diners Club            300 to 305, 36    14
'Carte Blanche          38                14
'Discover               6011              16
'EnRoute                2014, 2149        15
'JCB                    3                 16
'JCB                    2131, 1800        15
'Master Card            51 to 55          16
'Visa                   4                 13, 16
    
'Just in case nothing is found
CreditCardType = "Unknown"

'Remove all spaces and dashes from the passed string
CardNo = Replace(Replace(CardNo, " ", ""), "-", "")

'Check that the minimum length of the string isn't less
'than fourteen characters and -is- numeric
If Len(CardNo) < 14 Or Not IsNumeric(CardNo) Then Exit Function

'Check the first two digits first
Select Case CInt(Left(CardNo, 2))
   Case 34, 37
      CreditCardType = "American Express"
   Case 36
      CreditCardType = "Diners Club"
   Case 38
      CreditCardType = "Carte Blanche"
   Case 51 To 55
      CreditCardType = "Master Card"
   Case Else

      'None of the above - so check the
	  'first four digits collectively
      Select Case CInt(Left(CardNo, 4))
	  
         Case 2014, 2149
            CreditCardType = "EnRoute"
         Case 2131, 1800
            CreditCardType = "JCB"
         Case 6011
            CreditCardType = "Discover"
         Case Else

            'None of the above - so check the
            'first three digits collectively
            Select Case CInt(Left(CardNo, 3))
               Case 300 To 305
                  CreditCardType = "American Diners Club"
               Case Else
         
               'None of the above -
               'so simply check the first digit
               Select Case CInt(Left(CardNo, 1))
                  Case 3
                     CreditCardType = "JCB"
                  Case 4
                    CreditCardType = "Visa"
               End Select

            End Select
			
      End Select
	  
End Select

End Function


Tip by Karl Moore


c0Title: Create a Windows Mutex
c1Code:
Create a Windows Mutex

'DLL Function Calls 

Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (ByVal lpMutexAttributes As Long, ByVal bInitialOwner As Long, ByVal lpName As String) As Long 
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 
  
'variable constant to match if the mutex exists 
Private Const ERROR_ALREADY_EXISTS = 183& 
  
'Application Variable Declarations
Public Const AppVer = "MyApp v1.1" 
Dim mutexvalue As Long 
  
'*the following code would go in the starting function of your application 
'either the main() or form_load() depending on how your application works 
 
'Create an individual mutex value for the application 
mutexvalue = CreateMutex(ByVal 0&, 1, AppVer) 
  
'If an error occured creating the mutex, that means it 
'must have already existed, therefore your application 
'is already running 
If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then 

   'Inform the user of running the same app twice  
   MsgBox "The application is already running." 
  
   'Terminate the application via the reference to it, its hObject value  
   CloseHandle mutexvalue 
End If 


c0Title: Call DLL Functions by Name (Dynamic Linking)
c2File: APIByName.zip
c1Code:
Call API functions by Name, without Declare, v 2.0
Author:	Arkadiy Olovyannikov (Featured Developer)
Category:	System/API
Type:	Classes
Difficulty:	Advanced
Version Compatibility:	 Visual Basic 5   Visual Basic 6
More information: This advanced module allows you to call API functions by name without declaring and to return values from them. It uses Assembly Language within VB code to accomplish this task.

Version 2.0, added 11/27/02, increases the range of API functions that can be called and was converted from a .bas module to a class.


c0Title: Calling .Net Classes from Visual Basic 6
c1Code:
Dev Source, April, 2005 by Peter Aitken

Despite all the power and features of Visual Studio.Net, lots of developers are sticking with good old Visual Basic 6 for at least some of their development projects. There's good reason for this. Tens of thousands of developers know VB6 from the inside out, and can create applications quickly and efficiently. The language's ease of interface design and excellent database tools make it a great choice for many kinds of projects. And the terrific new features of .Net, such as the Common Language Runtime and Web services, simply are not needed for many projects. In fact, there is a movement afoot from VB6 developers to try to convince Microsoft to continue supporting VB6, an idea with which I heartily concur.

Even so, the .Net class library has some mighty tempting goodies. Sometimes, while working on a VB6 project, I have found myself wanting to insert a class � only to realize it is a .Net class that I am thinking of. More than once, I have pondered whether to start a project in VB6 with its speed and ease of development, or in .Net with its undeniably powerful class library. Imagine my delight when I discovered that I did not have to chose one or the other, that I could use the .Net class library from a VB6 program. Not the whole library, and not every class, but enough to make a significant difference. This library is completely free to use and distribute; your end users do not need Visual Studio.Net, nor do you for that matter (although the documentation is useful).

What does the .Net class library offer? If you have worked much with .Net, you already have some idea, but here are a few of the capabilities that may be of interest when you are working in VB6:

Low level network access including DNS lookups, IP Addresses, sockets, and HTTP communication. Serialization, the ability to easily import/export the data of a class as XML. Powerful support for regular expressions. Advanced graphics capabilities for drawing, gradients, bitmap images, metafiles, and printing. Active directory access. Powerful collections of various kinds including sorted lists, dictionaries, and queues. Superior XML support as compared with MSXML. 

This is just a partial list, but I hope it whets your appetite!

To use .Net classes in VB6, you must add a reference to the type library for the assembly that contains the class. You do this as follows:

Select Project | References. In the References dialog box click the Browse button. Navigate to C:\WINDOWS\Microsoft.NET\Framework\v1.1.4322. Select the appropriate .tlb file and click Open. Click OK. 

How do you know which assembly to select in Step 4? You need to look up the class of interest in the .Net class library documentation. In the Requirements section, it lists the assembly that contains the class. For example, the SortedList class is in Mscorlib, which means you would select Mscorlib.tlb in step 4 above.

You also have to register the assembly as a COM object. Unlike standard DLLs, which are registered with the REGSVR32 command line application, your must use the REGASM application that is installed with the .Net runtime. Here's how:

Select Run from the Windows Start menu Enter cmd in the box and press Enter. Windows opens a command prompt. Change to the folder C:\WINDOWS\Microsoft.NET\Framework\v1.1.4322. Type "regasm system.dll" and press Enter. 

After doing this, you will be able to use some .Net classes as if they were COM objects. You must include the namespace qualifiers when declaring them, because VB6 does not give you the capability to import namespaces.

To illustrate, let's use the WebClient class from .Net. This handy class provides the capability to download from and upload to a resource identified by a URL. By using the WebClient class in your program, you avoid the various problems that are known to plague the Internet Transfer control (the usual way to accomplish this in VB6).

The DownloadFile method in WebClient easily downloads data from a URL and saves it in a local file. This class is in the System assembly, so follow the steps above to add System.tlb to your project references. Be sure to use REGASM to register the assembly as well; you need do this only once.

Here's some code that shows how to use this class in VB6 to download an image file and then display it in an Image control:
Dim wc As System.WebClient
Set wc = New System.WebClient
wc.downloadFile "http://www.somewhere.com/somefile.jpg", App.Path & "\filename.jpg"
Set Image1.Picture = LoadPicture(App.Path & "\filename.jpg")

When you run the code, the specified image displays in the Image control. Yes, it's really that simple!

Some .Net class methods are beyond the reach of VB6 programmers using this straightforward approach. This is because most .Net classes do not appear as COM objects, and it is COM that VB6 understands. Also, many .Net class methods use data types that are not available in VB6, either as arguments or as return values (or both, of course). Then you need to create a wrapper for the class and/or method.
Creating Wrappers

Continuing with the WebClient class for our examples, there is the OpenRead method that can read data from a resource directly into a program. But the return value of this method is the type Stream, available in .Net but not in VB6.

To get around this, you use .Net to create a small component that contains the functionality of the class while returning a data type that VB6 can deal with. This sort of component is often called a wrapper. The wrapper converts the method's return value from the Stream type that VB6 cannot use to the String type that it can.

For the present purposes � using the WebClient.OpenRead method in a VB6 program � the wrapper is very simple. Here's the code:
Imports System.IO
Imports System.Net
Imports System.Reflection
Imports System.Runtime.InteropServices
<Assembly:AssemblyKeyFileAttribute("sgKey.snk")>
<ClassInterface(ClassInterfaceType.AutoDual)> _
Public Class WebClientVB6
    Private wc As New WebClient

    Public Sub New()

    End Sub

    Public Function GetFileAsString(ByVal url As String) As String
        Dim sr As New StreamReader(wc.OpenRead(url))
        Dim buf As String = sr.ReadToEnd
        sr.Close()
        Return buf
    End Function

End Class

Most of this code will make sense to the .Net programmer. The one function GetFileAsString uses the StreamReader class to accept the download from the specified URL and store it in a type String. It is this type String that is returned to the calling program.

There are two parts that stand out. One is:
<Assembly:AssemblyKeyFileAttribute("sgKey.snk")>

This is required to sign the assembly with a strong name. I'll explain more about this in the next section. The other source code line that may seem strange is this:
<ClassInterface(ClassInterfaceType.AutoDual)> _

This line (or part of a line, actually � note the line continuation character) applies an attribute to the wrapper class. When it's exposed as a COM object, necessary for it to be used in a VB6 program, the Intellisense feature works properly.
Compiling and Registering Your Wrapper

The source code for the needed wrapper is simple. Unfortunately, compiling and using it is not quite as easy.

On the bright side, it can be done using batch files from the command line, and you do not even need Visual Studio to do so, just the .Net Software Development Kit which is a free download from Microsoft. You start by opening a command prompt and specifying the path to the SDK executables. You can type these commands in manually at the prompt or combine them in a batch file; the latter is certainly more convenient for regular use. Here's the command to set the required path:
path=%path%;C:\WINDOWS\Microsoft.NET\Framework\v1.1.4322;
  C:\Program Files\Microsoft Visual Studio .NET 2003\SDK\v1.1\Bin

This assumes that you have installed the SDK in the default location.

Next, you need a strong name key pair. Signing an assembly with a strong name is a requirement that ensures the data integrity and authenticity of an assembly, and also ensures that it has a unique name in the global assembly cache. You create a strong name key pair using sn.exe, the Strong name utility that is part of the .Net SDK. The syntax is:
sn -k filename

By custom, the .snk extension is used, so you might enter:
sn -k sgkey.snk

This key pair file was associated with the Visual Basic source this way:
<Assembly:AssemblyKeyFileAttribute("sgkey.snk")>

With the strong name in hand, you are ready to compile your source code. Here's the required command, assuming you saved the source code as WebClientVB6.vb.
vbc WebClientVB6.vb /r:System.dll /target:library /out:MyWrappers.dll 

The result of the compilation is a file named MyWrappers.dll. I used this generic name because you could compile multiple wrappers into a single assembly, although in this case only one wrapper is compiled.

The next two steps are to add the newly created assembly to the assembly cache and to register it. The first step is accomplished using the GACUTIL utility, another part of the SDK:
gacutil /i mywrappers.dll

The registration step is similar to what you did before when a wrapper was not needed:
regasm mywrappers.dll /tlb:mywrappers.tlb

The additional argument instructs the regasm utility to create the type library for the assembly as well as registering it.

Now you are ready to use the wrapped .Net class in your VB6 program.
Using Your Wrapped Class

Now we return to VB6 and see how the wrapped class method can be used. First, you add a reference to the assembly you just created. Open the References dialog box and you'll find the assembly name listed � MyWrappers, in this case. Check it and close the dialog box.

Now it's a simple matter of creating an instance of the wrapper using the assembly name and the wrapper name. Here's the code:
Dim wcr As MyWrappers.WebClientVB6
Set wcr = New MyWrappers.WebClientVB6

Then just call the wrapped method as shown here. This example downloads the home page of my web site and displays the HTML in a text box:
Text1.Text = wcr.GetFileAsString("http://www.pgacon.com")
Deploying Your Application

Getting your hybrid VB6/Net application to run on your development box is one thing. What about deploying it to your end-users? There is, as you might expect, a bit of added complexity in this process as well. Fortunately it is well explained in an article on the MSDN Web site.

The ability to call .Net classes from a VB6 program is a very useful skill for a programmer. There is some extra work involved, but overall you are likely to save a lot of time and effort by combining the strengths of the two development tools in one program.


c0Title: Creating a Windows DLL with Visual Basic
c1Code:
http://www.windowsdevcenter.com/pub/a/windows/2005/04/26/create_dll.html?page=1

by Ron Petrusha
04/26/2005 

As the first rapid application development language, Visual Basic attracted attention for its elegant graphical interface and overall ease of use, which allowed a relatively inexperienced programmer to accomplish in minutes what often took days for advanced programmers using languages like C and C++. As a result, Visual Basic drew millions of new programmers, many of whom might never have even considered programming had it not been for the language's simplicity. Because of this simplicity, and because Visual Basic was attracting a following that the proponents of other languages could only dream of, non-Visual Basic programmers (who were really green with envy) counterattacked by pointing to the inexperience of most Visual Basic programmers and to the problems that stem from Visual Basic's design goal of shielding the developer from the complexities of the underlying operating system. To bolster their contention that Visual Basic is underpowered and underdeveloped, critics liked to point to the many things "real" programmers do that Visual Basic programmers cannot. Perhaps the most common limitation that critics continually point to is Visual Basic's inability to create a standard Windows dynamic link library (DLL). 

Certainly it's true that out of the box, Visual Basic doesn't allow you to create a Windows DLL in the same way that you can create other project types, like a Standard EXE or an ActiveX DLL. In this article, we'll go exploring to see how Visual Basic generates its executables. In the process, we'll discover that with a little bit of extra work, we can in fact create Windows DLLs with Visual Basic. 

What Is a Windows Dynamic Link Library?
A dynamic link library (DLL) is a library of functions and procedures that can be called from an application or another DLL. Using a library in this way has two major functions:

It permits the sharing of code. The same DLL can be used by many other DLLs and applications. The Win32 API, for instance, is implemented as a series of Windows DLLs. Moreover, as long as multiple processes load the same DLL at the same base address, they can share the code in the DLL. In other words, a single DLL in memory can be accessed by multiple processes. 
It allows for component-based and modular development, which makes development and the upgrade process easier. 
Ordinarily, when a static library is used in application development, the library's modules must be linked into the finished application. With dynamic linking, the modules reside in a separate DLL file that is loaded dynamically, either when the application loads or when its member functions are needed.

A dynamic link library may include internal functions, which can be called only from within the DLL. Its main purpose, however, is to provide exported functions--that is, functions that reside in a module of the DLL and can be called from other DLLs and applications. Frequently, a definition (.def) file is used in C/C++ projects to list a DLL's exports.

A DLL also includes an optional entry point, which is called when a process or thread loads or unloads the DLL. Windows calls this entry point when a process loads and unloads the DLL. It also calls the entry point when the process creates or terminates a thread. That allows the DLL to perform any per-process and per-application initialization and cleanup. The syntax of this entry point, which must use the standard-call calling convention (used by default in Visual Basic), is:
Public Function DllMain(hinstDLL As Long, fdwReason As Long, 
   lpwReserved As Long) As Boolean

Its parameters are:

hInstDLL, a Long containing the instance handle of the DLL. This is the same as the DLL's module handle. 

fdwReason, a constant indicating why the entry point has been called. Possible values are:

DLL_PROCESS_ATTACH (1)
A process is loading the DLL. Any per-process initialization should be performed. 
DLL_THREAD_ATTACH (2)
The process is spawning a new thread. Any per-thread initialization should be performed. 
DLL_THREAD_DETACH (3)
A thread is exiting. Any per-thread cleanup should be performed. 
DLL_PROCESS_DETACH (0)
A process is detaching the DLL, or the process is exiting. Any per-process cleanup should be performed. 
lpvReserved
A Long that provides more information about DLL_PROCESS_ATTACH and DLL_PROCESS_DETACH. (It is unused if fdwReason is DLL_THREAD_ATTACH or DLL_THREAD_DETACH.) If fdwReason is DLL_PROCESS_ATTACH, it is Nothing for libraries loaded dynamically using functions like LoadLibrary and GetProcAddress, and it is not Nothing for libraries loaded statically by providing library stubs at compile time. If fdwReason is DLL_PROCESS_DETACH, it is Nothing if the call has resulted from a call to the Win32 FreeLibrary function, and it is not Nothing if the entry point is called during process termination. 
The return value of the function is meaningful only if fdwReason is DLL_PROCESS_ATTACH. If initialization succeeds, the function should return True; otherwise, it should return False. Note that because the function is an entry point called by Windows, the values of the arguments passed to the function are provided by Windows. Also, the entry point is not called when a thread is terminated using the Win32 TerminateThread function, nor is it called when a process is terminated using the Win32 TerminateProcess function.
The DLL Code

In attempting to develop a Windows DLL, we'll create a very simple library of math functions. The following is the DLL's code, which we'll store in a code module (a .bas file) named MathLib:
Option Explicit
 
Public Const DLL_PROCESS_DETACH = 0
Public Const DLL_PROCESS_ATTACH = 1
Public Const DLL_THREAD_ATTACH = 2
Public Const DLL_THREAD_DETACH = 3
 
Public Function DllMain(hInst As Long, fdwReason As Long, 
  lpvReserved As Long) As Boolean
   Select Case fdwReason
      Case DLL_PROCESS_DETACH
         ' No per-process cleanup needed
      Case DLL_PROCESS_ATTACH
         DllMain = True
      Case DLL_THREAD_ATTACH
         ' No per-thread initialization needed
      Case DLL_THREAD_DETACH
         ' No per-thread cleanup needed
   End Select
End Function
 
Public Function Increment(var As Integer) As Integer
   If Not IsNumeric(var) Then Err.Raise 5
   
   Increment = var + 1
End Function
 
Public Function Decrement(var As Integer) As Integer
   If Not IsNumeric(var) Then Err.Raise 5
   
   Decrement = var - 1
End Function
 
Public Function Square(var As Long) As Long
   If Not IsNumeric(var) Then Err.Raise 5
   
   Square = var ^ 2
End Function

Several characteristics about the code are worth mentioning. The first is that although it includes a DllMain procedure, no per-process or per-thread initialization needs to be performed. So DllMain simply returns True if it is called with the fdwReason argument set to DLL_PROCESS_ATTACH. 

Second, the point of providing a Windows DLL is to allow other languages to call it. To ensure interoperability, we want to confine ourselves to language features that the Win32 API supports, so that our DLL can be called from as many development environments and platforms as possible. We could have made each of our three math functions more flexible, for example, by defining both the incoming argument and the return value as Variants. That would have allowed the function to determine the data type it should interpret the incoming data as, in addition to the data type it should return. But the Variant is a data type defined by COM, Microsoft's Component Object Model, and is not a data type Win32 API recognizes. So instead, the code uses standard Win32 API data types.

We'll also need a test program to tell us whether our Windows DLL is working properly. For that purpose, we can create a Standard EXE project with one form and one code module. The code module simply consists of the Declare statements that define the functions found in the DLL:
Public Declare Function Increment Lib "MathLib.dll" (var As Integer) As Integer
 
Public Declare Function Decrement Lib "MathLib.dll" (var As Integer) As Integer
 
Public Declare Function Square Lib "MathLib.dll" (var As Long) As Long

Rather than simply specifying the name of the DLL in the Lib clause, you also should add the full path to the directory that contains the DLL. 

The form's code performs the calls to the DLL functions:
 
Option Explicit
 
Dim incr As Integer
Dim decr As Integer
Dim sqr As Long
 
Private Sub cmdDecrement_Click()
   decr = Increment(decr)
   cmdDecrement.Caption = "x = " & CStr(decr)
End Sub
 
Private Sub cmdIncrement_Click()
   incr = Increment(incr)
   cmdIncrement.Caption = "x = " & CStr(incr)
End Sub
 
Private Sub cmdSquare_Click()
   sqr = Square(srr)
   cmdSquare.Caption = "x = " & CStr(sqr)
End Sub
 
Private Sub Form_Load()
   incr = 1
   decr = 100
   sqr = 2
End Sub
The ActiveX DLL Project Type

Let's begin by creating an ActiveX DLL project and seeing what happens if we try to call it as if it were a standard Windows DLL. When you create an ActiveX DLL project, Visual Basic automatically adds a class module (a .cls file) to it. You can rename this if you want, but don't include any code. Instead, add a code module (a .bas file) to the project, add the DLL's code, and then compile the DLL. When you run the DLL test application, the error message dialog shown in Figure 1 appears. The error message indicates that although the DLL was found, the specific called function (Increment) was not.

Figure 1. Error when accessing an ActiveX DLL as a Windows DLL

The most likely cause of this error is that the function is not actually exported by the DLL. We can use the DumpBin utility to examine a DLL's exports by using the syntax 

Dumpbin /exports
If we run DumpBin using this syntax, we see the following output:
Microsoft (R) COFF Binary File Dumper Version 6.00.8447
Copyright (C) Microsoft Corp 1992-1998. All rights reserved.
 
 
Dump of file mathlib.dll
 
File Type: DLL
 
  Section contains the following exports for MathLib.dll
 
           0 characteristics
    41B9E52C time date stamp Fri Dec 10 10:04:28 2004
        0.00 version
           1 ordinal base
           4 number of functions
           4 number of names
 
    ordinal hint RVA      name
 
          1    0 0000192E DllCanUnloadNow
          2    1 00001902 DllGetClassObject
          3    2 00001918 DllRegisterServer
          4    3 000018EC DllUnregisterServer
 
  Summary
 
        1000 .data
        1000 .reloc
        1000 .rsrc
        1000 .text

Our DLL exports four functions, all of which are utility functions that support COM. Clearly we need to export DllMain and our three math functions. But how? Visual Basic does not appear to allow you to export DLL functions from ActiveX DLLs, thus effectively preventing you from using Visual Basic to create a standard Windows DLL. 

This difficulty, however, is not insurmountable. When we select the File -> Make .dll menu option to create an ActiveX DLL, it appears that Visual Basic is seamlessly taking our source code and outputting an ActiveX DLL. But if we examine the subdirectory in which Visual Basic was installed, it appears that the process is not quite so seamless. Along with VB6.EXE, the Visual Basic executable that defines the Visual Basic environment, we can also find C2.EXE and LINK.EXE, which are a compiler and a linker, respectively. Their presence in this directory suggests that VB6.EXE itself does not handle the generation of a DLL file, but that at some point in the compilation process, it calls these programs.

We can find out how Visual Basic is using the compiler and linker more precisely by renaming them and creating wrapper executables named C2 and LINK that in turn call the real compiler and linker. The following is the source code for a new version of a console-mode C2.EXE that calls the "real" C2 compiler, which we've renamed C2comp.exe: 
 
Public Sub Main()
 
On Error Resume Next
 
   Dim strCmd As String, strPath As String
   Dim oFS As New Scripting.FileSystemObject
   Dim ts As TextStream
 
   strCmd = Command
   
   strPath = App.Path
   
   Set ts = oFS.CreateTextFile(strPath & "\c2log.txt")
  
   ts.WriteLine "Beginning execution at " & Date & " " & Time()
   ts.WriteBlankLines 1
   ts.WriteLine "Command line parameters to c2 call:"
   ts.WriteLine "   " & strCmd
   ts.WriteBlankLines 1
   ts.WriteLine "Calling C2 compiler"
   
   Shell "c2comp.exe " & strCmd
   If Err.Number <> 0 Then
      ts.WriteLine "Error in calling C2 compiler..."
   End If
   
   ts.WriteBlankLines 1
   ts.WriteLine "Returned from c2 compiler call"
   ts.Close
   
End Sub

The process of compiling an ActiveX DLL produces the following output in our log file:
 
Beginning execution at 12/10/2004 12:44:22 PM
 
Command line parameters to c2 call:
   -il "C:\DOCUME~1\Ron\LOCALS~1\Temp\VB277103" -f "C:\VB Projects\
   MathLib\MathMod.bas" -W 3 -Gy -G5 -Gs4096 -dos -Zl -Fo"C:\
   VB Projects\MathLib\MathMod.OBJ" -QIfdiv -ML -basic
 
Calling C2 compiler
 
Returned from c2 compiler call

These are fairly standard command-line arguments to produce object files that in turn are supplied to the linker. That means that to determine how to produce a Windows DLL, we'll have to intercept the call to the linker so that we can see what arguments Visual Basic passes to it. The following code does that:
 
Public Sub Main()
 
On Error Resume Next
 
   Dim strCmd As String, strPath As String
   Dim oFS As New Scripting.FileSystemObject
   Dim ts As TextStream
 
   strCmd = Command
   
   strPath = App.Path
   
   Set ts = oFS.CreateTextFile(strPath & "\lnklog.txt")
   
   ts.WriteLine "Beginning execution at " & Date & " " & Time()
   ts.WriteBlankLines 1
   ts.WriteLine "Command line parameters to LINK call:"
   ts.WriteLine "   " & strCmd
   ts.WriteBlankLines 1
   ts.WriteLine "Calling LINK linker"
   
   Shell "linklnk.exe " & strCmd
   If Err.Number <> 0 Then
      ts.WriteLine "Error in calling linker..."
      Err.Clear
   End If
   
   ts.WriteBlankLines 1
   ts.WriteLine "Returned from linker call"
   ts.Close
   
End Sub

It requires that we rename the linker LinkLnk.exe and name our link wrapper Link.exe. 

When we attempt to compile an ActiveX DLL project, our linker log file contains the following output: 
 
Beginning execution at 12/11/2004 12:44:33 PM
 
Command line parameters to LINK call:
   "C:\Program Files\Microsoft Visual Studio\VB98\Class1.OBJ" 
   "C:\Program Files\Microsoft Visual Studio\VB98\Project1.OBJ" 
   "C:\Program Files\Microsoft Visual Studio\VB98\VBAEXE6.LIB" 
   /ENTRY:__vbaS 
   /OUT:"C:\Program Files\Microsoft Visual Studio\VB98\Project1.dll" 
   /BASE:0x11000000 
   /SUBSYSTEM:WINDOWS,4.0 /VERSION:1.0 
   /DLL  
   /INCREMENTAL:NO /OPT:REF /MERGE:.rdata=.text /IGNORE:4078 
 
Calling LINK linker
 
Returned from linker call

If we compare these command-line arguments with the syntax required to link the object files for a DLL using either C or C++, an omission becomes immediately apparent. Although the /DLL switch is supplied to create a standard DLL, there is no /DEF switch to define a module definition (.def) file that lists the functions exported by the DLL. (If we were programming in C or C++, we could use statements within our code to define our exports. Visual Basic doesn't support this, however, making the .def file the sole means of defining a library's exports.) Moreover, if we examine the files generated for an ActiveX DLL project by the Visual Basic environment, we'll also find that Visual Basic itself has not generated a .def file.
Creating the Windows DLL

So, after examining an ActiveX DLL's export table, intercepting Visual Basic's call to the compiler, intercepting Visual Basic's call to the linker, and comparing the arguments passed to the linker with those required by a C/C++ compiler to generate a Windows DLL, we've finally identified why we aren't able to successfully create a Windows DLL with Visual Basic. And fortunately, we can work around that restriction. We should be able to create a standard Windows DLL if we do the following:

1. Create a .def file for our project. We can specify our exported functions in the .def file in several ways, but it's best to keep it simple:
NAME MathLib
LIBRARY MathMod
DESCRIPTION "Add-on Library of Mathematical Routines"
EXPORTS DllMain @1
        Increment @2
        Decrement @3
        Square @4

The NAME statement defines the name of the DLL. The LIBRARY statement must either precede the list of exported functions or appear on the same line as the first function. The .def file should also list the ordinal position of each exported function preceded by an @ symbol.

2. Decide how we want to intercept the call to the linker. Two major techniques are available to do this:

o Patching the Import Address Table (IAT), which requires that we build a Visual Basic add-in that modifies the IAT in order to intercept particular calls by Visual Basic to the Win32 API. Although it's certainly the most elegant method, its complexity makes it a worthy subject for a separate article.

o Building a proxy linker that intercepts the call to the real linker, modifies the command-line arguments to be passed to the linker, and then calls the linker with the correct command-line arguments. This is the approach we used to discover what arguments Visual Basic was passing to the compiler and linker, and it's the approach we'll adopt to create a Windows DLL.

In building our proxy linker, we want a sufficiently flexible design so that we can generate other kinds of files, if need be.

3. Modify the arguments to the linker to add the /DEF switch along with the path and filename of our .def file. To do this, you must create a Visual Basic Standard EXE project, add a reference to the Microsoft Scripting Runtime Library, remove the form from the project, and add a code module. The source code for the proxy linker is as follows:
Option Explicit
 
Public Sub Main()
 
   Dim SpecialLink As Boolean, fCPL As Boolean, fResource As Boolean
   Dim intPos As Integer
   Dim strCmd As String
   Dim strPath As String
   Dim strFileContents As String
   Dim strDefFile As String, strResFile As String
   Dim oFS As New Scripting.FileSystemObject
   Dim fld As Folder
   Dim fil As File
   Dim ts As TextStream, tsDef As TextStream
 
   strCmd = Command
   
   Set ts = oFS.CreateTextFile(App.Path & "\lnklog.txt")
   
   ts.WriteLine "Beginning execution at " & Date & " " & Time()
   ts.WriteBlankLines 1
   ts.WriteLine "Command line arguments to LINK call:"
   ts.WriteBlankLines 1
   ts.WriteLine "   " & strCmd
   ts.WriteBlankLines 2
   
   ' Determine if .DEF file exists
   '
   ' Extract path from first .obj argument
   intPos = InStr(1, strCmd, ".OBJ", vbTextCompare)
   strPath = Mid(strCmd, 2, intPos + 2)
   intPos = InStrRev(strPath, "\")
   strPath = Left(strPath, intPos - 1)
   ' Open folder
   Set fld = oFS.GetFolder(strPath)
   
   ' Get files in folder
   For Each fil In fld.Files
      If UCase(oFS.GetExtensionName(fil)) = "DEF" Then
         strDefFile = fil
         SpecialLink = True
      End If
      If UCase(oFS.GetExtensionName(fil)) = "RES" Then
         strResFile = fil
         fResource = True
      End If
      If SpecialLink And fResource Then Exit For
   Next
      
   ' Change command line arguments if flag set
   If SpecialLink Then
      ' Determine contents of .DEF file
      Set tsDef = oFS.OpenTextFile(strDefFile)
      strFileContents = tsDef.ReadAll
      If InStr(1, strFileContents, "CplApplet", vbTextCompare) > 0 Then
         fCPL = True
      End If
      
      ' Add module definition before /DLL switch
      intPos = InStr(1, strCmd, "/DLL", vbTextCompare)
      If intPos > 0 Then
         strCmd = Left(strCmd, intPos - 1) & _
               " /DEF:" & Chr(34) & strDefFile & Chr(34) & " " & _
               Mid(strCmd, intPos)
      End If
      ' Include .RES file if one exists
      If fResource Then
         intPos = InStr(1, strCmd, "/ENTRY", vbTextCompare)
         strCmd = Left(strCmd, intPos - 1) & Chr(34) & strResFile & _
                  Chr(34) & " " & Mid(strCmd, intPos)
      End If
      
      ' If Control Panel applet, change "DLL" extension to "CPL"
      If fCPL Then
         strCmd = Replace(strCmd, ".dll", ".cpl", 1, , vbTextCompare)
      End If
      
      ' Write linker options to output file
      ts.WriteLine "Command line arguments after modification:"
      ts.WriteBlankLines 1
      ts.WriteLine "   " & strCmd
      ts.WriteBlankLines 2
   End If
   
   ts.WriteLine "Calling LINK.EXE linker"
   Shell "linklnk.exe " & strCmd
   If Err.Number <> 0 Then
      ts.WriteLine "Error in calling linker..."
      Err.Clear
   End If
   
   ts.WriteBlankLines 1
   ts.WriteLine "Returned from linker call"
   ts.Close
End Sub

This proxy linker modifies only the command-line arguments passed to the linker if a .def file is present in the directory that contains the Visual Basic project; otherwise it simply passes the command-line arguments on to the linker unchanged. If a .def file is present, it adds a /DEF switch to the command line. It also determines whether any resource files are to be added to the linked file list. Finally, it examines the export table to determine if a function named CplApplet is present; if it is, it changes the output file's extension from .dll to .cpl.

4. To install the proxy linker, rename the original Visual Basic linker LinkLnk.exe, copy the proxy linker to the Visual Basic directory, and name it Link.exe.

Once we create our proxy linker, we can reload our MathLib project and compile it into a DLL by selecting the Make MathLib.exe option from the File menu. 
Testing the DLL

Once we create our Windows DLL, the final step is to test it to make sure that it works. To do this, create a new Standard EXE project (let's call it MathLibTest) and add a code module. To make sure that code in our project can access the functions exported by the DLL, we use the standard Visual Basic Declare statement. We declare our three exported math routines in the code module as follows:
 
Option Explicit
 
Public Declare Function Increment Lib "C:\VBProjects\MathLib\mathlib.dll" ( _
                        value As Integer) As Integer
                        
Public Declare Function Decrement Lib "C:\VBProjects\MathLib\mathlib.dll" ( _
                        value As Integer) As Integer
               
Public Declare Function Square Lib "C:\VBProjects\MathLib\mathlib.dll" ( _
                        value As Long) As Long
We can then use the following code in the form module to call the routines in the DLL:
 
Option Explicit
 
Private Sub cmdDecrement_Click()
   txtDecrement.Text = Decrement(CInt(txtDecrement.Text))
End Sub
 
Private Sub cmdIncrement_Click()
   txtIncrement.Text = Increment(CInt(txtIncrement.Text))
End Sub
 
Private Sub cmdSquare_Click()
   txtSquare.Text = Square(CLng(txtSquare.Text))
End Sub
 
Private Sub Form_Load()
   txtIncrement.Text = 0
   txtDecrement.Text = 100
   txtSquare.Text = 2
End Sub
When we call each of the MathLib functions, the application window might appear as it does in Figure 2, confirming that the calls to the MathLib routines work as expected.


Figure 2: Testing calls to MathLib.dll

Ron Petrusha is the author and coauthor of many books, including "VBScript in a Nutshell." 

Notes:
You need to add the following to the custom linker Main sub, preferably after the check for Control Panel applet:
'*** change Entry point ******

If MsgBox("Set DllMain as the entry point?", vbYesNo) = vbYes Then

strCmd = Replace(strCmd, "/ENTRY:__vbaS", "/ENTRY:DllMain")

End If

Also, the DllMain function needs to return a long, and its arguments must be called byVal, as follows:
Public Function DllMain(ByVal hInst As Long, ByVal fdwReason As Long, ByVal lpvReserved As Long) As Long

Select Case fdwReason
Case DLL_PROCESS_DETACH
' No per-process cleanup needed
Case DLL_PROCESS_ATTACH
' No per-process initialization needed
DllMain = 1
Case DLL_THREAD_ATTACH
' No per-thread initialization needed
Case DLL_THREAD_DETACH
' No per-thread cleanup needed
End Select

End Function

Specifically, when passing a string to the DLL, the DLL needs to convert the string as follows:
sValue = StrConv(sValue, vbUnicode)

When returning a string from the DLL, either via a passed variable in a Sub or as the return value of a Function, the DLL needs to convert the string as follows:
sValue = StrConv(sValue, vbFromUnicode)

Or
MyFunction = StrConv(sValue, vbFromUnicode)

In any case, if an ActiveX DLL wants to show a modeless Form to a non-VB client, it just needs to use the ShowWindow API instead of the VB6 Show method.

To call a VB class within a VB Windows DLL you should avoid using New to instantiate it. See previous replies.


c0Title: Console Application
c1Code:
Author: Adam Visegradi

VB is normally for creating apps with GUI. But what can you do if you want to make a console mode application? You write it yourself? No! Just paste this code into a module and that's all. See the comments for details.
'Console control module by Adam Visegradi 
'With this module you can easily create console mode applications using the 5 
'easy-to-use routines: 
'   InitConsole 
'   WriteToConsole 
'   WriteLnToConsole 
'   ReadFromConsole 
'   CloseConsole 
' 
' IMPORTANT NOTES! 
'  -Do not forget to close the console before you exit: if you run the app 
'   from the IDE, forget to close the console form the app  and close it manually, 
'    the system will close the IDE too! 
'  -Your application can has only one console at the same time 
'  -Don't forget: The system runs the console, not you. So everything you do is a request, which can be denied. 
' 
'For TP, QBasic, etc. users: 
'Anybody could tell me, where blinking gone? (e.g.:Blinking blue => Dark blue, even in full screen mode) 

'The code: 

'API declarations: 
'Console initialization 
Private Declare Function AllocConsole Lib "kernel32" () As Long 
'Set's the console's title 
Private Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" (ByVal lpConsoleTitle As String) As Long 
'Closing the console 
Private Declare Function FreeConsole Lib "kernel32" () As Long 
'Getting the console's handle 
'NOTE: nStdHandle: the handle type(later), not the buffer for the handle. 
'           The function returns the handle 
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long 
'Console output 
Private Declare Function WriteC Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, ByVal lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long 
'Console input 
Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long 
'Text attribute setting 
Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long
'Console mode sttings(later) 
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleOutput As Long, dwMode As Long) As Long 

'Handle mode constants for SetConsoleMode and GetStdHandle 
Private Const STD_INPUT_HANDLE = -10& 
Private Const STD_OUTPUT_HANDLE = -11& 
Private Const STD_ERROR_HANDLE = -12& 
'Console input mode constants for SetConsoleMode(I don't know which of what, somebody please tell me.) 
Private Const ENABLE_LINE_INPUT = &H2 
Private Const ENABLE_ECHO_INPUT = &H4 
Private Const ENABLE_MOUSE_INPUT = &H10 
Private Const ENABLE_PROCESSED_INPUT = &H1 
Private Const ENABLE_WINDOW_INPUT = &H8 
'Console output mode constants for SetConsoleMode 
Private Const ENABLE_PROCESSED_OUTPUT = &H1 
Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2 

'Handle variables 
Private hIn As Long 
Private hOut As Long 

'Forecolor constants collected into an enumerated type for a simpler use 
Public Enum ConsoleForeGroundAttributes 
   fBlack = &H0 
   fDBlue = &H1 
   fDGreen = &H2 
   fDCyan = &H3 
   fDRed = &H4 
   fDMagenta = &H5 
   fDYellow = &H6 
   fGrey = &H7 
   fDGrey = &H8 
   fBlue = &H1 Or &H8 
   fGreen = &H2 Or &H8 
   fCyan = &H3 Or &H8 
   fRed = &H4 Or &H8 
   fMagenta = &H5 Or &H8 
   fYellow = &H6 Or &H8 
   fWhite = &H7 Or &H8 
End Enum 
'Backcolor constants 
Public Enum ConsoleBackGroundAttributes 
   bBlack = &H0 
   bDBlue = &H10 
   bDGreen = &H20 
   bDCyan = &H30 
   bDRed = &H40 
   bDMagenta = &H50 
   bDYellow = &H60 
   bGrey = &H70 
   bDGrey = &H80 
   bBlue = &H10 Or &H80 
   bGreen = &H20 Or &H80 
   bCyan = &H30 Or &H80 
   bRed = &H40 Or &H80 
   bMagenta = &H50 Or &H80 
   bYellow = &H60 Or &H80 
   bWhite = &H70 Or &H80 
End Enum 

'Writes a string to the console 
Public Sub WriteToConsole(StringToWrite As String, Optional ForeGroundAttributes As ConsoleForeGroundAttributes = fGrey, Optional BackGroundAttributes As ConsoleBackGroundAttributes = bBlack) 
   'Sets the console's text attributes for the following output 
   SetConsoleTextAttribute hOut, ForeGroundAttributes Or BackGroundAttributes 
   'Writes out the string 
   WriteC hOut, StringToWrite, Len(StringToWrite), vbNull, vbNull 
End Sub 

'Writes a string with a vbCrLf to the console 
Public Sub WriteLnToConsole(StringToWrite As String, Optional ForeGroundAttributes As ConsoleForeGroundAttributes = fGrey, Optional BackGroundAttributes As ConsoleBackGroundAttributes = bBlack) 
   'The same as WriteToConsole 
   SetConsoleTextAttribute hOut, ForeGroundAttributes Or BackGroundAttributes 
   WriteC hOut, StringToWrite + vbCrLf, Len(StringToWrite + vbCrLf), vbNull, vbNull 
End Sub 

'Reads a (!)line from the console(The app hangs on, until the user presses enter. Then the routine returns the string the user entered 
'and writes a vbCrLf to the console. The vbCrLf is written out by the system so it cannot be ignored. 
Public Function ReadFromConsole() As String 
   'Creates a buffer. (The buffer must be no longer than 256 bytes.) 
   Dim S As String * 256 
   'Reads the user input to the buffer 
   Call ReadConsole(hIn, S, Len(S), vbNull, vbNull) 
   'Trim the end of the buffer from the Chr(0) and sets the value of the function 
   ReadFromConsole = Left$(S, InStr(S, vbNullChar) - 3) 
End Function 

'Inits the console. If you don't enter a title, the system will give your app's name for the console window. 
Public Function InitConsole(Optional Title As String = "") As Boolean 
   'The function returns True only if there is no error occoured 
   'Create console 
   If AllocConsole = 0 Then 
       InitConsole = False 
   Else 
       'Gets the input-handle of the console 
       hIn = GetStdHandle(STD_INPUT_HANDLE) 
       'Sets the mode of the console. 
       If SetConsoleMode(hIn, ENABLE_ECHO_INPUT) <> 0 Then 
           InitConsole = False 
       Else 
           'Gets the output-handle of the console 
           hOut = GetStdHandle(STD_OUTPUT_HANDLE) 
           'If the Title is not "" then sets the console's title 
           If Title <> "" Then 
               If SetConsoleTitle(Title) = 0 Then 
                   InitConsole = False 
               Else 
                   InitConsole = True 
               End If 
           Else 
               InitConsole = True 
           End If 
       End If 
   End If 
End Function 

'Closes the console 
Public Function CloseConsole() As Boolean 
   If FreeConsole = 0 Then: CloseConsole = False: Else: CloseConsole = True 
End Function 

'So that's all, if you don't know something (or you know something that I don't know), 
'ask (or tell) me in the VBWeb's forum(vAdam), or in E-Mail: c0nan@skizo.hu ("c"+Zero+"nan@skizo.hu") 


c0Title: Create, Read, and Write a Console Window
c1Code:
Create, Read, and Write a Console Window

Option Explicit

Private Declare Function AllocConsole Lib "kernel32" () As Long 
Private Declare Function FreeConsole Lib "kernel32" () As Long 
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long 
Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, ByVal lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleOutput As Long, dwMode As Long) As Long
Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long

Private Const STD_INPUT_HANDLE = -10&
Private Const STD_OUTPUT_HANDLE = -11&
Private Const STD_ERROR_HANDLE = -12&

Private Const ENABLE_LINE_INPUT = &H2
Private Const ENABLE_ECHO_INPUT = &H4
Private Const ENABLE_MOUSE_INPUT = &H10
Private Const ENABLE_PROCESSED_INPUT = &H1 Private Const ENABLE_WINDOW_INPUT = &H8

Private Const ENABLE_PROCESSED_OUTPUT = &H1 Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2

Private Sub Main()
Dim sOutPut As String
Dim lHInput As Long, lHOutPut As Long, lHErr As Long Dim sInput As String * 255

'Create an instance of the console
AllocConsole

'Get handle to STD_INPUT, STD_OUTPUT, STD_ERROR lHInput = GetStdHandle(STD_INPUT_HANDLE) lHOutPut = GetStdHandle(STD_OUTPUT_HANDLE) lHErr = GetStdHandle(STD_ERROR_HANDLE)

'Allow Input
SetConsoleMode lHInput, ENABLE_ECHO_INPUT

'Write output
sOutPut = "Enter a number between 1 and 10." & vbCrLf WriteConsole lHOutPut, sOutPut, Len(sOutPut), vbNull, vbNull

'Read Input
ReadConsole lHInput, sInput, Len(sInput), vbNull, vbNull sInput = TrimWithoutPrejudice(sInput)

If IsNumeric(sInput) Then
    If CLng(sInput) < 1 Or CLng(sInput) > 10 Then
        sOutPut = "You did not follow the instructions"
    Else
        sOutPut = "You entered " & sInput
    End If
Else
    sOutPut = "You did not follow the instructions"
End If

sOutPut = sOutPut & vbCrLf
WriteConsole lHOutPut, sOutPut, Len(sOutPut), vbNull, vbNull
 
sOutPut = "Press Enter to exit" & vbCrLf WriteConsole lHOutPut, sOutPut, Len(sOutPut), vbNull, vbNull ReadConsole lHInput, sInput, Len(sInput), vbNull, vbNull sInput = TrimWithoutPrejudice(sInput)

'Finished
FreeConsole
End Sub

Public Function TrimWithoutPrejudice(ByVal InputString As String) As String
'http://www.freevbcode.com/ShowCode.ASP?ID=104

Dim sAns As String
Dim sWkg As String
Dim sChar As String
Dim lLen As Long
Dim lCtr As Long

sAns = InputString
lLen = Len(InputString)

If lLen > 0 Then
'Ltrim
    For lCtr = 1 To lLen
        sChar = Mid(sAns, lCtr, 1)
        If Asc(sChar) > 32 Then Exit For
    Next

sAns = Mid(sAns, lCtr)
lLen = Len(sAns)

'Rtrim
    If lLen > 0 Then
        For lCtr = lLen To 1 Step -1
            sChar = Mid(sAns, lCtr, 1)
            If Asc(sChar) > 32 Then Exit For
        Next
    End If
    sAns = Left$(sAns, lCtr)
End If

TrimWithoutPrejudice = sAns

End Function


c0Title: Creating a real console application in Visual Basic
c2File: Console.zip
c1Code:
http://www.nirsoft.net/vb/console_application_visual_basic.html
File::Console.zip

Some development tools, like Visual C++ and Delphi, allows the developer to easily create console applications. These tools provides specific methods and functions for writing to the console screen and their compiler also provides special option for creating console executable. Unfortunately, Visual Basic doesn't support console applications. Even if you use the Win32 API for writing into the console screen, Your application won't work, because the Visual Basic compiler always creates GUI application and it doesn't provide any compiler options for changing it to console application. 
But... with a small trick, it's possible to bypass the limitation of the Visual Basic compiler: 
I have developed a small utility that converts an Executable file (.exe) from GUI application mode to console application mode. So, you can develop a console application in Visual Basic, create an executable file, and then, use my utility to convert the executable into a console application. 
My utility was developed in Visual Basic, and the source code is provided within the sample package. You can use it by opening the appmodechange project from Visual Basic IDE. 

In order to create a console application in Visual Basic, you have to use Win32 API calls. 
The following code snippet writes a few lines into the console screen, some of them are shown in different colors ! 
'Console Application Sample
'Written by Nir Sofer.
'
'Web site: http://nirsoft.mirrorz.com
'
'In order to create a console application from this code, 
follow the instructions below:
'1. Make an executable file from this project.
'2. Run the "Application Mode Changer" utility and change the mode of the executable file to "Console Application".

Public Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long

Public Const STD_OUTPUT_HANDLE = -11&

Private Type COORD
        x As Integer
        y As Integer
End Type

Private Type SMALL_RECT
        Left As Integer
        Top As Integer
        Right As Integer
        Bottom As Integer
End Type

Private Type CONSOLE_SCREEN_BUFFER_INFO
        dwSize As COORD
        dwCursorPosition As COORD
        wAttributes As Integer
        srWindow As SMALL_RECT
        dwMaximumWindowSize As COORD
End Type
Private Declare Function GetConsoleScreenBufferInfo Lib "kernel32" (ByVal hConsoleOutput As Long, lpConsoleScreenBufferInfo As CONSOLE_SCREEN_BUFFER_INFO) As Long
Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long

Private Const FOREGROUND_BLUE = &H1     '  text color contains blue.
Private Const FOREGROUND_GREEN = &H2     '  text color contains green.
Private Const FOREGROUND_INTENSITY = &H8     '  text color is intensified.
Private Const FOREGROUND_RED = &H4     '  text color contains red.



Private hOutput             As Long

'The following function writes the content of sText variable into the console window:
Private Function WriteToConsole(sText As String) As Boolean
    Dim lWritten            As Long
    
    If WriteFile(hOutput, ByVal sText, Len(sText), lWritten, ByVal 0) = 0 Then
        WriteToConsole = False
    Else
        WriteToConsole = True
    End If
End Function

Public Sub Main()
    Dim scrbuf      As CONSOLE_SCREEN_BUFFER_INFO
    
    'Get the standard output handle
    hOutput = GetStdHandle(STD_OUTPUT_HANDLE)
    GetConsoleScreenBufferInfo hOutput, scrbuf
    WriteToConsole "Console Application Example In Visual Basic." & vbCrLf
    WriteToConsole "Written by Nir Sofer" & vbCrLf
    WriteToConsole "Web site: http://nirsoft.mirrorz.com" & vbCrLf & vbCrLf
    
    'Change the text color to blue
    SetConsoleTextAttribute hOutput, FOREGROUND_BLUE Or FOREGROUND_INTENSITY
    WriteToConsole "Blue Color !!" & vbCrLf
    
    'Change the text color to yellow
    SetConsoleTextAttribute hOutput, FOREGROUND_RED Or _
		FOREGROUND_GREEN Or FOREGROUND_INTENSITY
    WriteToConsole "Yellow Color !!" & vbCrLf
    
    'Restore the previous text attributes.
    SetConsoleTextAttribute hOutput, scrbuf.wAttributes
    If Len(Command$) <> 0 Then
        'Show the command line parameters:
        WriteToConsole vbCrLf & "Command Line Parameters: " & Command$ & vbCrLf
    End If
End Sub

After you create an executable file from this code, you have to use the Application Mode Changer for changing the executable mode from GUI application to console application. 
After you convert it to console mode, you'll get the following result: 

The Application Mode Changer
'Application Mode Changer
'Copyright (c) 2002 Nir Sofer
'
'Web site: http://nirsoft.mirrorz.com
'
'This small utility allows you to change the mode of an executable file (.exe) from
'GUI mode to console mode and vise versa.
'You can use this utility for creating console applications in Visual Basic environment.
'
'In order to do this, follow the instructions below:
'1. Write a console application in Visual Basic by using API calls (You can learn how to do it from my sample project)
'2. Create an executable file from your VB project.
'3. Run this utility, select your executable file, and click the "Change Mode" button. Your executable will be switched from GUI mode to console mode.
'
'If you successfully do the above 3 steps, you'll get a real console application !

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3

Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Const FILE_BEGIN = 0

'Application Modes:
Private Const IMAGE_SUBSYSTEM_WINDOWS_GUI = 2    'GUI Application
Private Const IMAGE_SUBSYSTEM_WINDOWS_CUI = 3    'Console Application

Private Const ERROR_CANNOT_WRITE_FILE = 1
Private Const ERROR_BAD_FILE_FORMAT = 2
Private Const ERROR_CANNOT_READ_FILE = 3
Private Const ERROR_CANNOT_OPEN_FILE = 4


Private Function GetErrorDesc(iError As Integer) As String
    Select Case iError
        Case ERROR_CANNOT_WRITE_FILE
            GetErrorDesc = "Cannot write to the file"
        
        Case ERROR_BAD_FILE_FORMAT
            GetErrorDesc = "Bad file format"
        
        Case ERROR_CANNOT_READ_FILE
            GetErrorDesc = "Cannot read from the file"
        
        Case ERROR_CANNOT_OPEN_FILE
            GetErrorDesc = "Cannot open the file"
    End Select
End Function

Private Sub ChangeMode(sFilename As String, iAppMode As Integer)
    Dim hFile           As Long
    Dim iError          As Integer
    Dim buffer(1024)    As Byte
    Dim lBytesReadWrite As Long
    Dim lPELocation     As Long
    
    'Open the file with Win32 API call
    hFile = CreateFile(sFilename, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, 0, 0)
    If hFile <> INVALID_HANDLE_VALUE Then
        'Read the Dos header.
        If ReadFile(hFile, buffer(0), &H40, lBytesReadWrite, 0) <> 0 Then
            If buffer(0) = &H4D And buffer(1) = &H5A Then
                'Get the location of the portable executable header.
                CopyMemory lPELocation, buffer(&H3C), 4
                If lPELocation = 0 Then
                    iError = ERROR_BAD_FILE_FORMAT
                Else
                    SetFilePointer hFile, lPELocation, ByVal 0, FILE_BEGIN
                    'Read the portable executable signature.
                    If ReadFile(hFile, buffer(0), 2, lBytesReadWrite, 0) <> 0 Then
                        'Check the signature.
                        If buffer(0) = &H50 And buffer(1) = &H45 Then
                            buffer(0) = iAppMode
                            SetFilePointer hFile, lPELocation + &H5C, ByVal 0, FILE_BEGIN
                            'Change the byte in the executable file to the desired application mode.
                            If WriteFile(hFile, buffer(0), 1, lBytesReadWrite, 0) = 0 Then
                                iError = ERROR_CANNOT_WRITE_FILE
                            End If
                            
                        Else
                            iError = ERROR_BAD_FILE_FORMAT
                        End If
                    Else
                        iError = ERROR_CANNOT_READ_FILE
                    End If
                End If
                
            Else
                iError = ERROR_BAD_FILE_FORMAT
            End If
        Else
            iError = ERROR_CANNOT_READ_FILE
        End If
                
        'Close the file
        CloseHandle hFile
    Else
        iError = ERROR_CANNOT_OPEN_FILE
    End If
    
    If iError = 0 Then
        MsgBox "The application mode was successfully changed", vbOKOnly Or vbInformation, ""
    Else
        MsgBox "Error: " & GetErrorDesc(iError), vbOKOnly Or vbExclamation, "Error"
    End If
End Sub

Private Sub cmdBrowse_Click()
    On Error GoTo canceled
    'Show the open dialog.
    OpenDialog.Flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly
    OpenDialog.ShowOpen
    txtFilename.Text = OpenDialog.FileName
    Exit Sub
canceled:

End Sub

Private Sub cmdChange_Click()
    ChangeMode txtFilename.Text, IIf(ModeOption(1).Value, IMAGE_SUBSYSTEM_WINDOWS_GUI, IMAGE_SUBSYSTEM_WINDOWS_CUI)
End Sub


c0Title: Clear Structure Data With One Assignment
c1Code:
User-defined types are useful when you need to store structured data that has no specific behavior. (If you have associated behav-ior, you should encapsulate the data in its own class.) Here�s a quick way to clear user-defined type variables without setting each subvariable:

' A user-defined type:
Private Type udtSomeType
    SubVariableOne As Integer
    SubVariableTwo As String
    SubVariableThree As Long
End Type

' A couple of class-level user-defined
' type variables:
Private TypeVariableOne As udtSomeType
Private TypeVariableTwo As udtSomeType

' A method in the class:
Private Sub ResetData()
    Dim CleanTypeVariable As udtSomeType
    TypeVariableOne = CleanTypeVariable
    TypeVariableTwo = CleanTypeVariable
End Sub


This method is especially convenient when the user-defined type has numerous subvariables.

�Dave Doknjas, Surrey, British Columbia, Canada


c0Title: Access: How to Find If an Object Exists in a Database
c1Code:
Article ID 90989
Last Review : January 18, 2007
Revision : 2.3

SUMMARY
This article shows you how to create a sample user-defined function to check if an object exists in the current database before you create a new object (such as a table, form, or report) in the database.

This article assumes that you are familiar with Visual Basic for Applications and with creating Microsoft Access applications using the programming tools provided with Microsoft Access. For more information about Visual Basic for Applications, please refer to your version of the "Building Applications with Microsoft Access" manual.

NOTE: Visual Basic for Applications is called Access Basic in Microsoft Access versions 1.x and 2.0. For more information about Access Basic, please refer to the "Introduction to Programming" manual in Microsoft Access version 1.x or the "Building Applications" manual in Microsoft Access version 2.0
Back to the top

MORE INFORMATION
To create the function, open a new module and enter the code appropriate for your version of Microsoft Access.

NOTE: In the following sample code, an underscore (

_

) at the end of a line is used as a line-continuation character. Remove the underscore from the end of the line when re-creating this code in Access Basic.

Microsoft Access Versions 2.0, 7.0, and 97

 '********************************************************************
   'Declarations section of the module

  '********************************************************************

   Option Explicit

  '********************************************************************
   ' FUNCTION: ObjectExists_20()
   '
   ' PURPOSE:
   '    Determines whether the specified object exists in the
   '    current database.
   '
   ' ARGUMENTS:
   '    ObjectType - A string representing the object whose names are to
   '                 be retrieved. ObjectType can be one of the
   '                 following:
   '
   '                 Tables, Queries, Forms, Reports, Macros, Modules
   '
   '    ObjectName - A string representing the name of the specified
   '                 ObjectType.
   '
   ' RETURNS:
   '    True (-1), if the object exists.
   '    False (0), if the object does not exist.
   '
   ' NOTES:
   '    This function uses data access objects (DAO) to determine if
   '    the specified object exists in the current database.
   '
  '********************************************************************
   Function ObjectExists_20% (ObjectType$, ObjectName$)
   On Error Resume Next

   Dim Found_Object%, Find_Object As String, ObjectNum As Integer
   Dim DB As Database, T As TableDef
   Dim Q As QueryDef, C  As Container
   Dim Msg As String
   Found_Object% = -1
   Set DB = dbengine(0)(0)

   Select Case ObjectType$
   Case "Tables"
       Find_Object = DB.TableDefs(ObjectName$).Name

   Case "Queries"
       Find_Object = DB.QueryDefs(ObjectName$).Name

   Case Else
       If ObjectType$ = "Forms" Then
           ObjectNum = 1
       ElseIf ObjectType$ = "Modules" Then
           ObjectNum = 2
       ElseIf ObjectType$ = "Reports" Then
           ObjectNum = 4
       ElseIf ObjectType$ = "Macros" Then
           ObjectNum = 5
       Else
            Msg = "Object Name """ & ObjectType & """ is an invalid"
            Msg = Msg & " argument to function ObjectExists_20!"
            MsgBox Msg, 16, "ObjectExists_20"
            Exit Function

       End If

       Set C = DB.Containers(ObjectNum)
       Find_Object = C.Documents(ObjectName$).Name

   End Select

   If Err = 3265 Or Find_Object = "" Then
       Found_Object% = 0
   End If

   ObjectExists_20% = Found_Object%

   End Function



c0Title: Access: Check if a Form is Open
c1Code:
Check if a Form is Open

Public Function IsOpenForm(strForm As String)
    IsOpenForm = (SysCmd(acSysCmdGetObjectState, acForm, strForm) > 0) 
End Function


c0Title: Access: Check if a Form is Loaded
c1Code:
'Returns TRUE if the specified form is loaded, whether visible or not 
Public Function IsFormLoaded(sForm As String) As Boolean
    IsFormLoaded = (SysCmd(acSysCmdGetObjectState, acForm, sForm) <> 0) 
End Function


c0Title: Access: Use labels to select sort order for a form
c1Code:
This was used to indicate that field names (labels) could be clicked on to sort the table by that field. The current sort field was indicated by it's label's text being underlined.

Option Compare Database
Option Explicit

Dim moMouseOverLast As Control

'Make the specified label bold until the mouse moves over another object that calls this function 
'or MouseOverHighlightRemove (such as the form background) 
'Should be called from the MouseMove event of each object 
Public Function MouseOverHighlight(oLabel As Control)
    Const conBold = 700
    Const conNormal = 400
    
    On Error Resume Next
    
    If (moMouseOverLast Is oLabel) = False Then
        moMouseOverLast.FontWeight = conNormal
       
        oLabel.FontWeight = conBold
        Set moMouseOverLast = oLabel
    End If
    
End Function


Public Function MouseOverHighlightRemove()
    Const conNormal = 400
    
    On Error Resume Next
    If IsNothing(moMouseOverLast) = False Then
        moMouseOverLast.FontWeight = conNormal
        Set moMouseOverLast = Nothing
    End If
    
End Function


'Set the form's OrderBy property to the specified field 
'If it was already set to that field, disable OrderBy 
'Set sField to "" to remove any OrderBy (but you must set oForm to the current form) 
'Append ' DESC' to the field name to sort in descending order 
Function ToggleOrderBy(sField As String, Optional lblField As Label, Optional oForm As Form)
    Static lblOldField As Label     'The label for the field that is currently sorted
    
    If IsNothing(oForm) Then
        Set oForm = lblField.Parent
    End If
    
    If (oForm.OrderBy = sField) Or (sField = vbNullString) Then  'Was already ordered by this field so disable it
        
        oForm.OrderBy = "ID"    'Have to set an orderby field before disabling it or no records may display
        oForm.OrderByOn = True
'        oForm.OrderByOn = False
        
        If IsNothing(lblField) = False Then
            lblField.FontUnderline = False
        End If
        
        Set lblOldField = Nothing
        
    Else                        'Set Order by or replace existing setting
        
        oForm.OrderBy = sField
        oForm.OrderByOn = True
        
        If IsNothing(lblOldField) = False Then
            On Error Resume Next
            lblOldField.FontUnderline = False
        End If
        
        lblField.FontUnderline = True
        Set lblOldField = lblField
        
    End If
    
End Function


c0Title: Access: Combo Box's AfterUpdate Event Fails
c1Code:
Article ID 125593
Last Review : November 6, 2000
Revision : 1.0

If you choose a combo box's drop-down arrow, close the drop-down box without selecting an item, and then type an entry in the text portion of the combo box, the combo box's AfterUpdate event fails to update the information in the combo box.
Back to the top

CAUSE
The combo box's Column property is not updated if you enter a value in the combo box manually after choosing the drop-down arrow.
Back to the top

RESOLUTION
To work around this problem, requery the combo box as the first action in your event procedure or event macro. For example, given a combo box named MyCombo, you could requery the combo box with the following Access Basic statement:

Me!MyCombo.requery

Back to the top

STATUS
Microsoft has confirmed this to be a problem in Microsoft Access version 2.0. This problem no longer occurs in Microsoft Access version 7.0.
Back to the top

MORE INFORMATION
A combo box's Column property is not updated if you type an entry in the combo box manually after choosing the combo box's drop-down arrow. If you are copying the value of the combo box's Column property to another control with the AfterUpdate event, you must requery the combo box as outlined in the "Resolution" section earlier in this article in order update the value of the Column property before you copy the value to another control.
Back to the top

Steps to Reproduce Problem
CAUTION: Following the steps in this example will modify the sample database NWIND.MDB. You may want to back up the NWIND.MDB file, or perform these steps on a copy of the NWIND database.
1. Open the sample database NWIND.MDB.
2. Open the Customer List query in Design view. Add the Contact Name field to the query's third column. Save and then close the query.
3. Open the Orders form in Design view. Change the Bill To combo box's properties as follows:

ColumnCount: 3
ColumnWidths: 2;0;2
ListWidth: 4 in
AfterUpdate: [Event Procedure]


4. Choose the Build button to the right of the AfterUpdate property. Enter the following code in the form module that opens:

Sub_Customer_ID_AfterUpdate ()
MsgBox Me![Customer ID].Column(2)

End Sub


Close the module.
5. View the form in Form view.
6. In the Bill To box, select Frankenversand. Note that a message box with the text "Peter Franken" appears. Choose OK.
7. In the Bill To box, type Godos and then press ENTER. Note that a message box with the text "Peter Franken" appears. The message box should display "Jose Pedro Freyre." Choose OK.
To correct this problem, add the following line to the combo box's AfterUpdate event procedure. Add this line before the MsgBox statement:

Me![Customer ID].Requery

Note that you can substitute the Recalc method for the Requery method. The Recalc method may provide better performance if you are not performing many floating-point operations. If you are performing many floating-point operations, the Requery method may provide better performance.
Back to the top

REFERENCES
For more information about combo box properties, search for "combo box: properties," and then "Combo Box Control Properties" using the Microsoft Access Help menu.

For more information about the Requery method search for "Requery," and then "Requery Method" using the Microsoft Access Help menu.
Back to the top
APPLIES TO
� Microsoft Access 2.0 Standard Edition 


c0Title: Access: Execute ad hoc SQL commands without creating queries
c1Code:
I'm always testing SQL queries to use in VBA or executing SQL actions like clearing out tables or fields like the status field. It's a pain having to choose to create a new query, select design view, close the table list, switch to SQL view, enter the query, then choose to close it and not save. So, I added a function called SQLCommand() to the latest build. It just displays an inputbox for you to enter any SQL select or action query. When you click OK it either shows the result table or warns you about how many rows the action will affect before it executes it, just like the query builder does. In the result table, you can even switch to Design or SQL view if you want. The query is automatically saved as SQLCommandQueryx and is deleted the next time you run SQLCommand (unless the result table is still open...so you can run multiple queries at the same time).

To make it easy to access I enabled the Utility 1 toolbar and added a Custom command to it. In its properties, I set the Caption to SQL and the On Action to =SQLCommand()

'Allows the user to enter any sql select or action query and emulates 'the way Access handles SQL queries executed from design view.
'Result tables (if any) are displayed in a table 'The user is warned about records being modified by action queries Public Function SQLCommand()
    Dim sSQL As String
    Dim oDB As DAO.Database
    Dim nQuery As Long
    Dim sQueryName As String
    Const cQueryName = "SQLCommandQuery"
    
    On Error GoTo ErrorHandler
    
    Set oDB = CurrentDb()
    sSQL = GetSetting("Access", "Settings", cQueryName)
    sSQL = InputBox("Enter SQL Command", Default:=sSQL)
    
    If sSQL <> "" Then
        nQuery = 1
        sQueryName = cQueryName & nQuery
        
        'Find the first available query name
        Do While QueryExists(oDB, sQueryName)
            nQuery = nQuery + 1
            sQueryName = cQueryName & nQuery
        Loop
        
        oDB.CreateQueryDef sQueryName, sSQL
        DoCmd.OpenQuery sQueryName, acViewNormal, acEdit
        SaveSetting "Access", "Settings", cQueryName, sSQL
        
        On Error Resume Next
        
        'Remove temp queries left behind from previous instances
        For nQuery = 1 To 20
            DoCmd.DeleteObject acQuery, cQueryName & nQuery
        Next
        
    End If

    Exit Function

ErrorHandler:

    MsgBox "SqlCommand() Error " & Err.Number & " " & Err.Description
    
End Function


'Check if the specified query is defined in the database Function QueryExists(oDB As DAO.Database, sQueryName As String) As Boolean
    Dim sName As String
    
    On Error Resume Next
    
    sName = oDB.QueryDefs(sQueryName).Name
    
    If Err.Number = 3265 Or sName = vbNullString Then
        QueryExists = False
    Else
        QueryExists = True
    End If
End Function


c0Title: Access: Get Names of Current Users' PCs
c1Code:
'Gets a CRLF delimited list of PC names which have locks on the current database '
'Note: If users log into the database, their login names are in the field LOGIN_NAME '
Public Function CurrentUsers() As String

    Const JetSchemaUserRoster = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
    Dim rs As ADODB.Recordset
    
    Set rs = CurrentProject.Connection.OpenSchema(Schema:=adSchemaProviderSpecific, _
                                                  SchemaID:=JetSchemaUserRoster)
    With rs
        
        Do While (.EOF = False)
            
            If ((!CONNECTED = True) And IsNull(!SUSPECT_STATE)) Then
                CurrentUsers = CurrentUsers & Trim(!COMPUTER_NAME) & vbCrLf
            End If
            
            .MoveNext
        Loop
        
    End With
    
End Function


c0Title: Access: Reading Custom Database Properties
c1Code:
'Create a custom database property
'These can be viewed in Access | File menu | Database Properties | Custom tab '
'prpType: an Integer value representing the data type of the
'         property you want to create. To view valid settings for
'         this argument, search online help for "Type property,"
'         display the topic "Type property (DAO)" and note the
'         constants available for Property objects such as dbText
'
'
Public Sub DbCustomPropertyCreate(prpName As String, prpType As Integer, prpValue As Variant)
    
    Dim db As Database
    Dim doc As Document
    Dim prp As Property
    
    Set db = CurrentDb
    Set doc = db.Containers!Databases.Documents!UserDefined
    Set prp = doc.CreateProperty()
    
    With prp
        .Name = prpName
        .Type = prpType
        .Value = prpValue
    End With
    
    doc.Properties.Append prp
 
End Sub
 

'Read the specified custom database property '
'These can be viewed in Access | File menu | Database Properties | Custom tab '
Public Function DbCustomPropertyGet(prpName As String) As Variant
   Dim db As Database, prp As Property
   Dim doc As Document
 
   Set db = CurrentDb
   Set doc = db.Containers!Databases.Documents!UserDefined
   On Error Resume Next
   Set prp = doc.Properties(prpName)
   If Err.Number = 0 Then
      DbCustomPropertyGet = prp.Value
   Else
      MsgBox "Custom Property '" & prpName & "' Not Found"
      DbCustomPropertyGet = Null
   End If
End Function


c0Title: Access: Simulate a MouseOver event
c1Code:
Since Access form objects don't provide a hWnd, this work-around can be used to simulate mouse over actions:

Dim moMouseOverLast As Control

'Make the specified label bold until the mouse moves over another object that calls this function 'or MouseOverHighlightRemove (such as the form background) 'Should be called from the MouseMove event of each object Public Function MouseOverHighlight(oLabel As Control)
    Const conBold = 700
    Const conNormal = 400
    
    On Error Resume Next
    
    If (moMouseOverLast Is oLabel) = False Then
        moMouseOverLast.FontWeight = conNormal
       
        oLabel.FontWeight = conBold
        Set moMouseOverLast = oLabel
    End If
    
End Function


Public Function MouseOverHighlightRemove()
    Const conNormal = 400
    
    On Error Resume Next
    If IsNothing(moMouseOverLast) = False Then
        moMouseOverLast.FontWeight = conNormal
        Set moMouseOverLast = Nothing
    End If
    
End Function


Example Code:

Private Sub Detail_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    MouseOverHighlightRemove
End Sub

Private Sub lblNameCurrent_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    MouseOverHighlight lblNameCurrent
End Sub


c0Title: Access: Calculated fields misinterpreted
c1Code:
http://allenbrowne.com/ser-45.html
Provided by Allen Browne, January 2004

Unlike fields in a table, there is no way to specify the data type for calculated fields. If your data sorts incorrectly, or the wrong records are returned, Access is probably treating your calculated numeric or date field as text.

Typecast calculated fields to avoid these errors.

Calculated fields are widely used in normalized databases, and this problem is ubiquitous. There are postings every day in the newsgroups that trace back to this issue. (If this is a new area for you, see calculated fields.)

In Queries
This example calculates when payment is due - 30 days from the order date, or today if the order date is blank:

SELECT OrderID, Nz(DateAdd("d",30,[OrderDate]),Date()) AS PaymentDue
FROM Orders;


Test it by opening the Northwind sample database, creating a new query, and pasting the statement into SQL View (View menu). You will notice that Access left-aligns the PaymentDue field. That is a visual clue that it understands the calculated field as text. Sort or filter on this field, and your results will be wrong.

To specify the data type of a calculated field, wrap the calculation in CDate(), CLng(), CDbl(), CCur(), etc.:

SELECT OrderID, CDate(Nz(DateAdd("d",30,[OrderDate]),Date())) AS PaymentDue
FROM Orders;


These conversion functions cannot handle Null. Use Nz() inside the conversion.

Hint: Use CVDate(). While this function is a vestige from Access Basic, it is incredibly useful for calculated date fields. It allows you to output Nulls and still have Access recognise the data type correctly.

In Forms and Reports
For calculated controls on a form or report, all you need do is set the Format property of the control.

In general, you should think of the Format property as affecting how the data is presented to the user, not how it is stored in the database. Nevertheless, if you set the Format property of a calculated control to a numeric or date type, Access will recognize and process the data correctly.

This works for unbound controls as well: Set the Format to "Short Date", and Access will not accept an invalid date. Set the Format to "General Number", and the user cannot enter a non-numeric value.

In VBA Code
Whenever you work with Variants, there is a danger that the data type can be misunderstood. Variants do have a subtype, so the problem is less prevalent than with calculated fields, but it is still good practice to explicitly typecast, especially when working with fields or mixed data types.

For more information, see Working with Variables.


c0Title: Access: Display Two Fields Combined
c1Code:
Let�s say you want to bind your listbox to a recordset, but you also want to display two fields concatenated together, such as �Jones, Barbara.� You can do this by using a calculated expression in the SQL statement of the query:

SELECT PersonID, LastName, FirstName, LastName + ', ' + FirstName AS FullName FROM Person ORDER BY LastName, FirstName


�Deborah Kurata, Pleasanton, California


c0Title: Access: Delete from Joined Tables
c1Code:
Access Delete & Update SQL in Jet
Discussion in newsgroups remembered me a old Jet trick. Say you made a join on 2 tables and want to delete records from one. In TSQL you can explicit specify this as:

Delete From Table1 
From Table1 inner join Table2 


But in jet this will not work. What you have to do - is to specify table you want to delete using DISTINCTROW keyword:

Delete DISTINCTROW Table1.* From Table1 inner join Table2 


Good explanation together with links to Microsoft KB is here: http://www.mvps.org/access/queries/qry0022.htm


c0Title: Access: Check if a Query or Table Definition Exists
c1Code:
'Check if the specified query is defined in the database
Function DbQueryExists(oDB As DAO.Database, sQueryName As String) As Boolean
    Dim sName As String
    
    On Error Resume Next
    
    sName = oDB.QueryDefs(sQueryName).Name
    
    If Err.Number = 3265 Or sName = vbNullString Then
        DbQueryExists = False
    Else
        DbQueryExists = True
    End If
End Function

'Check if the specified query is defined in the database
Function DbTableExists(oDB As DAO.Database, sTableName As String) As Boolean
    Dim sName As String
    
    On Error Resume Next
    
    sName = oDB.TableDefs(sTableName).Name
    
    If Err.Number = 3265 Or sName = vbNullString Then
        DbTableExists = False
    Else
        DbTableExists = True
    End If
End Function


c0Title: Access: Export a Table, Saved Query, or SQL Statement to a dBase File
c1Code:
'Export a table, saved query, or SQL text to a dBase file. If the file exists, overwrite it
'sFile should not have any extension
'Since Access only handles DBF file names up to 8 characters long, the file is automatically renamed if necessary
Public Function DbExportDbf(oDB As DAO.Database, ofso As FileSystemObject, ByVal sTable As String, ByVal sPath As String, ByVal sFile As String)
    Const cTempQueryName = "qryExportDbfTemp"
    Dim sShortFileName As String
    Dim oTempQuery As DAO.QueryDef
    
    If Len(sFile) > 8 Then
        sShortFileName = Left(sFile, 8)
        
        If (ofso.FileExists(sPath & sShortFileName & ".dbf") = True) Then
            ofso.DeleteFile sPath & sShortFileName & ".dbf"
        End If
    Else
        sShortFileName = sFile
    End If
    
    If (ofso.FileExists(sPath & sFile & ".dbf") = True) Then
        ofso.DeleteFile sPath & sFile & ".dbf"
    End If
    
    If (DbTableExists(oDB, sTable) = False) And (DbQueryExists(oDB, sTable) = False) Then
        If DbQueryExists(oDB, cTempQueryName) = True Then
            oDB.QueryDefs.Delete cTempQueryName
        End If
        
        Set oTempQuery = oDB.CreateQueryDef(cTempQueryName, sTable)
        sTable = cTempQueryName
    End If
    
    DoCmd.TransferDatabase acExport, "dBase III", sPath, acTable, sTable, sShortFileName
    
    If IsNothing(oTempQuery) = False Then
        Set oTempQuery = Nothing
        oDB.QueryDefs.Delete cTempQueryName
    End If
    
    If Len(sFile) > 8 Then
        ofso.GetFile(sPath & sShortFileName & ".dbf").Name = sFile & ".dbf"
    End If

End Function



c0Title: Access: Create/Update A Link to an External Table
c1Code:
'Add a link to the specified DBF file. If the table name already exists, it's replaced
Public Function DbRelinkDBF(oDB As DAO.Database, sTable As String, sPath As String, sFile As String)
    
    On Error Resume Next
    
    oDB.Execute "DROP TABLE " & sTable
    
    On Error GoTo 0
    
    DoCmd.TransferDatabase acLink, "dBase III", sPath, acTable, sFile, sTable
    
End Function


c0Title: Access: Find the Path of the Current Access Database
c1Code:
Public Function BasePath() As String
    Static sBasePath As String
    Dim sDbFile As String
    
    If sBasePath = vbNullString Then
        sDbFile = CurrentDb.Name
        sBasePath = Left(sDbFile, InStrRev(sDbFile, "\"))
    End If
    
    BasePath = sBasePath
    
End Function


c0Title: Access: Efficient way to update status bar text for processes running in a long loop
c1Code:
Example:

If StatusUpdateNeeded Then
    StatusUpdate "Data Created: " & Format(OutputDbfSize(), "0.##") & " MB"
End If


Code:

Dim mnLastUpdateTime As Long

'Display text on the status bar
Public Function StatusUpdate(sText As String)
    If sText = vbNullString Then sText = " "
    SysCmd acSysCmdSetStatus, sText
    mnLastUpdateTime = Int(Timer)
    DoEvents
End Function

'Check if at least one second has elapsed since the last status update
Public Function StatusUpdateNeeded() As Boolean
    StatusUpdateNeeded = (Int(Timer) > mnLastUpdateTime)
End Function


c0Title: ADO: Don�t Use Default Properties When Working With Hierarchical Recordsets
c1Code:
It�s common VB knowledge that you can omit the default property of a control or an object. For example, statements such as Text1.Text = "blah" and Text1 = "blah" are equivalent, with Text being a default property of text control. Objects behave similarly. When you have two tables, Orders and Items, in a parent-child relationship by OrderNumber, you can build a hierarchical recordset that stores Items� data for a particular order within its parent�s record in a column called chapter1 as specified in the rsOrders.Open... statement. To retrieve the Items for particular orders, you need to loop through the parent recordset rsOrders, and assign the data stored in column chapter1 to a child recordset rsItems. Use a statement such as this:

Set rsItems = rsOrders("chapter1").Value


If you rely on Value being the default property of Column object and you omit this property in code, you get a Type Mismatch error if your rsItems variable is declared as ADODB.Recordset. Some examples I found in the Microsoft help files would declare this variable as Variant. In this case, you can pass the assignment

Set rsItems = rsOrders("chapter1")

with no error generated, but later on, if you try to loop through the child set of data, you get an Object Required error referring to an .EOF property that does not exist on a Variant.

None of these problems happen if you declare rsItems properly as ADODB.Recordset and use the Value property of the Column object explicitly. Strangely enough, when you omit .Columns (which is a default property of Recordset object), nothing bad happens. Here�s a code example that works:

Private Sub cmdGetRecords_Click()
    Dim connstring As String
    Dim cnn As ADODB.Connection
    Dim rsOrders As ADODB.Recordset
    Dim rsItems As ADODB.Recordset

    Set rsOrders = New ADODB.Recordset
    Set cnn = New ADODB.Connection

    connstring = "Provider=MSDataShape.1;Data " & "Source=TestDatabase;Initial " & "Catalog=SalesOrderProcess; Connection " & "Timeout=15;DataProvider=SQLOLEDB; User " & "ID=sa; Password=pass"
    cnn.Open connstring
    rsOrders.Open "SHAPE {Select * From " & "Orders} APPEND ({Select * From Items} " & "as chapter1 RELATE OrderNumber TO " & "OrderNumber)", cnn

    Do Until rsOrders.EOF
        Set rsItems = rsOrders("chapter1").Value
        Do Until rsItems.EOF
            Debug.Print rsItems(0), rsItems(1), rsItems(2), rsItems(3)
            rsItems.MoveNext
        Loop
        rsOrders.MoveNext
    Loop
End Sub


�Brian Hunter, Brooklyn, New York


c0Title: DAO: Set A Field's Value Where...
c1Code:
'Set sField to sValue in sTable
'sWhere clause may optionally be specified but should not include WHERE keyword
Public Sub DbSetField(oDB As DAO.Database, ByVal sTable As String, ByVal sFieldName As String, _
                      ByVal sFieldValue As String, Optional ByVal sWhere As String = vbNullString)
    
    Dim sQuery As String
    
    sFieldValue = Replace(sFieldValue, "'", "''")
    
    sQuery = "UPDATE " & sTable & " " & _
             "SET [" & sFieldName & "] = '" & sFieldValue & "'"
             
    If sWhere <> "" Then
        sQuery = sQuery & " WHERE " & sWhere
    End If
    
    oDB.Execute sQuery
   
End Sub


c0Title: DAO: Insert a new record into the specified table
c1Code:
Insert a new record into the specified table

'Insert a new record into the specified table
'sFields is a comma-separated list of fields
'sValues is a comma-separated list of values. String values should be in single quotes
Public Sub DbAddRecord(oDB As DAO.Database, sTable As String, sFields As String, ByVal sValues As String)

    Dim sQuery As String
    
    sQuery = "INSERT INTO " & sTable & " (" & sFields & ") " & _
             "VALUES (" & sValues & ");"
             
    oDB.Execute sQuery

End Sub


c0Title: DAO: Get the Value of a Field Where...
c1Code:
Get the Value of a Field Where...

'Returns the value of the specified field where the sWhere clause is true
'sWhere should not include WHERE keyword
'sField may be an expression such as "Left(Name,1)"
Public Function DbLookupField(oDB As DAO.Database, sTable As String, sField As String, sWhere As String) As String
            
    Dim oLookup As DAO.Recordset
    Dim sQuery As String
    Dim vValue As Variant
    
    sQuery = "SELECT " & sField & " FROM [" & sTable & "] WHERE " & sWhere
    Set oLookup = oDB.OpenRecordset(sQuery)
            
            
    If oLookup.EOF = False Then
        oLookup.MoveFirst
        vValue = oLookup(0).Value
        If (IsNull(vValue) = False) Then
            DbLookupField = vValue
        Else
            DbLookupField = vbNullString
        End If
    Else
        DbLookupField = vbNullString
    End If
    
    oLookup.Close

End Function


c0Title: DAO: Check if a Recordset is Empty
c1Code:
'Returns TRUE if the specified recordset is empty
Public Function DbIsEmptyRecordset(rs As DAO.Recordset) As Boolean
    DbIsEmptyRecordset = ((rs.BOF = True) And (rs.EOF = True))
End Function


c0Title: DAO: Search for a Record in a Table
c1Code:
'Check if the specified field value exists in a table/query
'Where clause is optional and should not include WHERE keyword
'Returns TRUE or FALSE
Public Function DbRecordExists(oDB As DAO.Database, _
                               ByVal sTable As String, _
                               Optional ByVal sField As String = vbNullString, _
                               Optional ByVal vValue As Variant, _
                               Optional ByVal sWhere As String = vbNullString) As Boolean

    Dim oRecordset As DAO.Recordset
    Dim sQuery As String
    Dim sValueSeparator As String
    
    Select Case VarType(vValue)
    Case vbInteger, vbLong, vbByte, vbDecimal
        sValueSeparator = vbNullString
    Case Else
        sValueSeparator = "'"
    End Select
    
    sQuery = "SELECT " & IIf(sField <> vbNullString, sField, "*") & " " & _
             "FROM [" & sTable & "] " & _
             "WHERE "
             
    If sField <> vbNullString Then
        
        sQuery = sQuery & sField & " = " & sValueSeparator & vValue & sValueSeparator
        
        If sWhere <> vbNullString Then
            sQuery = sQuery & " AND " & sWhere
        End If
    
    Else
        
        If sWhere <> vbNullString Then
            sQuery = sQuery & sWhere
        End If
        
    End If

    Set oRecordset = oDB.OpenRecordset(sQuery)
    
    If (oRecordset.BOF = True) And (oRecordset.EOF = True) Then
        DbRecordExists = False
    Else
        DbRecordExists = True
    End If

End Function



c0Title: DAO: Convert a recordset into a 1 or 2 dimensional array
c1Code:
'Convert a recordset to a Long array
'
Public Function DbGetArrayLong1D(oDB As DAO.Database, sQuery As String) As Long()

    Dim nRecords As Long
    Dim nArray() As Long
    Dim rs As DAO.Recordset
    Dim nRecord As Long
    
    Set rs = oDB.OpenRecordset(sQuery)
    
    If DbIsEmptyRecordset(rs) = False Then
        
        rs.MoveLast
        nRecords = rs.RecordCount
        rs.MoveFirst
        
        ReDim nArray(1 To nRecords)
        
        For nRecord = 1 To nRecords
            nArray(nRecord) = rs.Fields(0)
            rs.MoveNext
        Next
        
        rs.Close
        
    End If
    
    DbGetArrayLong1D = nArray
    
End Function


'Convert a recordset to a string array
'If the recordset is empty, and empty array is returned with LBound = 0, UBound = -1
'
Public Function DbGetArrayString1D(oDB As DAO.Database, sQuery As String) As String()
    Dim nRecords As Long
    Dim sArray() As String
    Dim rs As DAO.Recordset
    Dim nRecord As Long
    
    Set rs = oDB.OpenRecordset(sQuery)
    
    If DbIsEmptyRecordset(rs) = False Then
        
        rs.MoveLast
        nRecords = rs.RecordCount
        rs.MoveFirst
        
        ReDim sArray(1 To nRecords)
        
        For nRecord = 1 To nRecords
            sArray(nRecord) = rs.Fields(0)
            rs.MoveNext
        Next
        
        rs.Close
    
    Else
        
        'Create an empty array with LBound = 0, UBound = -1
        sArray = Split("")
        
    End If
    
    DbGetArrayString1D = sArray
    
End Function


'Convert a recordset to a String array
'If the recordset is empty, and empty array is returned with LBound = 0, UBound = -1
'
Public Function DbGetArrayString2D(oDB As DAO.Database, ByVal sQuery As String) As String()
    Dim nRecords As Long
    Dim nFields As Long
    Dim sArray() As String
    Dim rs As DAO.Recordset
    Dim nRecord As Long
    Dim nField As Long
    
    Set rs = oDB.OpenRecordset(sQuery)
    
    If DbIsEmptyRecordset(rs) = False Then
        
        rs.MoveLast
        nRecords = rs.RecordCount
        rs.MoveFirst
        
        nFields = rs.Fields.Count
        
        ReDim sArray(1 To nRecords, 1 To nFields)
        
        For nRecord = 1 To nRecords
            For nField = 1 To nFields
                sArray(nRecord, nField) = rs.Fields(nField - 1)
            Next
            
            rs.MoveNext
        Next
        
        rs.Close
    
    Else
        
        'Create an empty array with LBound = 0, UBound = -1
        sArray = Split("")
        
    End If
    
    DbGetArrayString2D = sArray
    
End Function


c0Title: Array Dimension Transposition
c1Code:
Problem is GetRows() returns a bass ackwards array. The first dimension contains fields (columns), and the second dimension contains records (rows). So a standard multi-dimensional array output routine (using nested For statements) outputs your data backwards!! For example the following array iteration routine would give you the following output:

Sub PrintArray(a As Variant)
    Dim row As Integer, col As Integer
    Dim temp As String
    
    Debug.Print Space$(9) & temp
    For row = LBound(a) To UBound(a)
        For col = LBound(a, 2) To UBound(a, 2)
            temp = temp & Space$(4) & a(row, col) & " "
        Next col
        Debug.Print temp
        temp = vbNullString
    Next row
        
End Sub


Output

1         2         3         4         
Text1     Text2     Text3     Text4      
Memo1     Memo2     Memo3     Memo4      
1         2         3         4          
1/1/2006  1/2/2006  1/3/2006  1/4/2006   
1.5       2         3         4          
True      False     True      False 


We want:

1       Text1     Memo1     1     1/1/2006     1.5    True           
2       Text2     Memo2     2     1/2/2006     2      False           
3       Text3     Memo3     3     1/3/2006     3      True           
4       Text4     Memo4     4     1/4/2006     4      False 


So we gotta transpose the dimensions of the array GetRows() returns so that the first dimension contains records (rows), and the second dimension contains fields (columns). Then you can pass the array to a standard output routine, and avoid having to hard code your columns.

Here's the revised code with new TransposeArray and PrintArray subs (I also tossed in kindler's recordcount suggestion).

Sub RevisedLoadArray()

    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim avarOriginalArray As Variant
    Dim avarTransposedArray
    Dim intRecord As Integer
    Dim intRecordCount As Integer

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("SELECT * FROM tblRecords", dbOpenSnapshot)

    With rst
        .MoveLast
        .MoveFirst
        avarOriginalArray = .GetRows(.RecordCount)
    End With
    
    ' Print number of records retrieved.
    Debug.Print UBound(avarOriginalArray, 2) + 1 & " records retrieved."
    
    ' Transpose array dimensions.
    avarTransposedArray = TransposeArray(avarOriginalArray)
    
    ' Output array data.
    Call PrintArray(avarTransposedArray)
               
    rst.Close: Set rst = Nothing
    dbs.Close: Set dbs = Nothing

End Sub

Function TransposeArray(v As Variant) As Variant ' Transpose dimensions of a 0-based ' multi-dimensional array

    Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant

    Xupper = UBound(v, 2)
    Yupper = UBound(v, 1)

    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = v(Y, X)
        Next Y
    Next X

    TransposeArray = tempArray

End Function

Sub PrintArray(a As Variant)
    Dim row As Integer, col As Integer
    Dim temp As String
    
    Debug.Print Space$(9) & temp
    For row = LBound(a) To UBound(a)
        For col = LBound(a, 2) To UBound(a, 2)
            temp = temp & Space$(4) & a(row, col) & " "
        Next col
        Debug.Print temp
        temp = vbNullString
    Next row
        
End Sub


Here's the output:

16 records retrieved.
         
  1     Text1     Memo1     1     1/1/2006     1.5   True           
  2     Text2     Memo2     2     1/2/2006     2.5   False           
  3     Text3     Memo3     3     1/3/2006     3.5   True           
  4     Text4     Memo4     4     1/4/2006     4.5   False           
  5     Text5     Memo5     5     1/5/2006     5.5   True           
  6     Text6     Memo6     6     1/6/2006     6.5   False           
  7     Text7     Memo7     7     1/7/2006     7.5   True           
  8     Text8     Memo8     8     1/8/2006     8.5   False           
  9     Text9     Memo9     9     1/9/2006     9.5   True           
 10     Text10    Memo10   10     1/10/2006   10.5   False           
 11     Text11    Memo11   11     1/11/2006   11.5   True           
 12     Text12    Memo12   12     1/12/2006   12.5   False           
 13     Text13    Memo13   13     1/13/2006   13.5   True           
 14     Text14    Memo14   14     1/14/2006   14.5   False           
 15     Text15    Memo15   15     1/15/2006   15.5   True           
 16     Text16    Memo16   16     1/16/2006   16.5   False 


c0Title: Excel: Transferring Records to Excel with Automation
c1Code:
Excel's CopyFromRecordset method is probably the fastest way to copy over the records via Automation. It also provides a great deal of flexibility on where and how the records are to be copied. You can use a named range in an existing worksheet or specify starting columns for the records.

Here are a couple of different ways to transfer a recordset over to Excel. In order to use these samples, set a reference to "Microsoft Excel 8.0 Object Library" under Tools Menu/References first.

'************* Code Start *****************
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'
Sub sCopyFromRS()
'Send records to the first
'sheet in a new workbook
'
Dim rs As Recordset
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim objXL As Excel.Application
Dim objWkb As Workbook
Dim objSht As Worksheet
  Set rs = CurrentDb.OpenRecordset("Customers", _
                    dbOpenSnapshot)
  intMaxCol = rs.Fields.Count
  If rs.RecordCount > 0 Then
    rs.MoveLast:    rs.MoveFirst
    intMaxRow = rs.RecordCount
    Set objXL = New Excel.Application
    With objXL
      .Visible = True
      Set objWkb = .Workbooks.Add
      Set objSht = objWkb.Worksheets(1)
      With objSht
        .Range(.Cells(1, 1), .Cells(intMaxRow, _
            intMaxCol)).CopyFromRecordset rs
      End With
    End With
  End If
End Sub

Sub sCopyRSExample()
'Copy records to first 20000 rows
'in an existing Excel Workbook and worksheet
'
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Dim db As Database
Dim rs As Recordset
Dim intLastCol As Integer
Const conMAX_ROWS = 20000
Const conSHT_NAME = "SomeSheet"
Const conWKB_NAME = "J:\temp\book1.xls"
  Set db = CurrentDb
  Set objXL = New Excel.Application
  Set rs = db.OpenRecordset("Customers", dbOpenSnapshot)
  With objXL
    .Visible = True
    Set objWkb = .Workbooks.Open(conWKB_NAME)
    On Error Resume Next
    Set objSht = objWkb.Worksheets(conSHT_NAME)
    If Not Err.Number = 0 Then
      Set objSht = objWkb.Worksheets.Add
      objSht.Name = conSHT_NAME
    End If
    Err.Clear
    On Error GoTo 0
    intLastCol = objSht.UsedRange.Columns.Count
    With objSht
      .Range(.Cells(1, 1), .Cells(conMAX_ROWS, _
          intLastCol)).ClearContents
      .Range(.Cells(1, 1), _
        .Cells(1, rs.Fields.Count)).Font.Bold = True
      .Range("A2").CopyFromRecordset rs
    End With
  End With
  Set objSht = Nothing
  Set objWkb = Nothing
  Set objXL = Nothing
  Set rs = Nothing
  Set db = Nothing
End Sub

Sub sCopyRSToNamedRange()
'Copy records to a named range
'on an existing worksheet on a
'workbook
'
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Dim db As Database
Dim rs As Recordset
Const conMAX_ROWS = 20000
Const conSHT_NAME = "SomeSheet"
Const conWKB_NAME = "c:\temp\book1.xls"
Const conRANGE = "RangeForRS"

  Set db = CurrentDb
  Set objXL = New Excel.Application
  Set rs = db.OpenRecordset("Customers", dbOpenSnapshot)
  With objXL
    .Visible = True
    Set objWkb = .Workbooks.Open(conWKB_NAME)
    On Error Resume Next
    Set objSht = objWkb.Worksheets(conSHT_NAME)
    If Not Err.Number = 0 Then
      Set objSht = objWkb.Worksheets.Add
      objSht.Name = conSHT_NAME
    End If
    Err.Clear
    On Error GoTo 0
    objSht.Range(conRANGE).CopyFromRecordset rs
  End With
  Set objSht = Nothing
  Set objWkb = Nothing
  Set objXL = Nothing
  Set rs = Nothing
  Set db = Nothing
End Sub


c0Title: Excel: Connect to Excel Using OLE DB
c1Code:
Microsoft documentation says you can connect to Excel 97 or Excel 2000 using the Microsoft.Jet.OLEDB 4.0 provider. If you use the Microsoft ADO Data Control, however, you will have problems. From the property page for the ADO Data Control, choose the Use Connection String radio button and click on the Build button. Then, select the database name, choosing an Excel file as your database. Now, if you click on Test Connection, you get an error message saying the connection failed because the file is in an unrecognized format.

But wait, there�s hope! Acknowledge the error message and return to the General tab of the property pages. In the Connection String textbox, add this code to the end of the connection string:

Extended Properties = Excel 8.0;


Your full connection string now looks like this:

Provider=Microsoft.Jet.OLEDB.4.0; Data Source = FileName; Extended Properties=Excel 8.0;


Now if you click on the Build button, then click on the Test Connection button, the connection is successful.

�Michael J. McElwee, Highland Park, Illinois


c0Title: Excel: Convert Numbers to Excel Column Names
c1Code:
Microsoft Excel labels its columns A though Z, then AA, AB, and so on. To access a given cell of an Excel sheet using the Excel object library reference, use a statement like this:

Dim xlapp as New Excel.Application
xlapp.Range("A1").Value = 6


This statement sets the first cell of the sheet to 6. If you convert the column names from alphabet-like (A through IV) to numbers, you can then go through a loop to access every cell in a given sheet or range. This function performs the required conversion. It works only through Column 701, but Excel doesn�t allow nearly that many columns, so it�s a nonissue:

Private Function GetXLCol(Col As Integer) As String 
    ' Col is the present column, not the number of cols
    Const A = 65    'ASCII value for capital A

    Dim iMults As Integer
    Dim sCol As String
    Dim iRemain As Integer

    ' THIS ALGORITHM ONLY WORKS UP TO ZZ. It fails on AAA
    If Col > 701 Then   
        GetXLCol = ""
        Exit Function
    End If

    If Col <= 25 Then
        sCol = Chr(A + Col)
    Else
        iRemain = Int((Col / 26)) - 1
        sCol = Chr(A + iRemain) & GetXLCol(Col Mod 26)
    End If

    GetXLCol = sCol
End Function


�Michael J. McElwee, Highland Park, Illinois


c0Title: Excel: Define Named Ranges in Excel Before Executing Queries Against Worksheets
c1Code:
Once you�ve established a connection to Microsoft Excel using OLE DB, you�re not out of the woods. You still have to define a Named Range in Excel; then you can treat this named range like a database table to perform queries against. To do this from Excel, select the range of cells you want to represent the table�column headers in the first row�then choose Name | Define from the Insert menu to bring up the Define Name dialog. Choose a name for your table and click on OK. Be sure to have valid column names or they will be renamed for you in the recordset or table you bring into your application.

As a different approach, you might wish to do things through VB code. Using the Excel 8.0 object as a reference, this example takes a file specified by the FileName string and creates a named range whose name is specified by the variable TableName. This example chooses the used portion of the first sheet as the table range:

Public Sub MakeExcelTable(FileName As String, Tablename As String)
       Dim BookXL As Excel.Workbook
       Dim RangeXL As Excel.Range
       Dim SheetXL As Excel.Worksheet

       Set BookXL = GetObject(FileName)

       With BookXL
             Set SheetXL = BookXL.ActiveSheet
             Set RangeXL = SheetXL.UsedRange  
             ' Selects the entire used range of the first sheet
             .Names.Add TableName, RangeXL
             .Windows.item(1).Visible = True
             .Save
       End With

       Set BookXL = Nothing
End Sub


�Michael J. McElwee, Highland Park, Illinois


c0Title: SQLite: COM Wrapper for SQLite Database Engine
c1Code:
http://www.thecommon.net/2.html

Fast and reliable COM-Tools for developers
dhSQLite

This is our latest tool and was developed as a fast alternative to ADO, encapsulating the super-fast SQLite-engine from: www.sqlite.org

With only two Dlls you get a complete Replacement to the whole ADO/JET-environment - no dependency-hazzle anymore (working even on Linux/Wine).

Current version of dhSQLite is 1.2 - sqlite_engine.dll is 3.4.0.

Since Version 1.2 dhSQLite has builtin support for a nearly complete set of VB-Functions, new Interfaces for easy implementable userdefined Functions and Collations, and it includes the SQLite-FTS2-Module, wich means FullText-TableScans.

The dhSQLite-Wrapper is not absolutely compatible to ADO - but using it feels like working with ADO (or the somewhat older DAO) - just look at the Source inside the Demo below (wich contains comparison-tests with ADO/JET) - there are very few differences regarding the Code, but huge differences in terms of performance.

Download: dhSQLite-Binaries and VB6-Demo-Source

We found SQLite a wonderful engine with a very clean API - it was pure fun, to write this wrapper around it and we've done our best, to not absorb too much of its great "native speed". In short, the SQLite-engine is faster than JET - and our COM-wrapper is faster than ADO - but test this out yourself.

We've developed our wrapper with dhRPCServer in mind, so we finetuned especially the Heap-management, the Serialization/Deserialization-performance and the UpdateBatch- capabilities of the dhSQLite-Recordsets - both tools combined are faster than every other (R)DBMS we've tested so far (faster than e.g. Firebird or a MS-SQLServer 2K in a Multi-User-Stresstest-scenario running on 8 concurrent Clients). Our combination of an real Appserver, the fast serializing Wrapper and the great performing SQLite-engine can easily drive a 100MBit-LAN into its limits - 100% LAN-Load, whilst serving disconnected
Recordsets (uncompressed) with ca. 400 'Customers'-Resultsets/sec consuming only 28% processor-load on a cheap 2GHz-Athlon Dual-CPU).

So thanks again to D. Richard Hipp and the SQLite-community.

Features:
- ADO-like behaviour (reusable skills)
- Nearly complete set of builtin VB-Functions (IIF, Instr, DateDiff, DatePart, ... etc.)
- Add your own userdefined Functions and Collations with ease
- Fulltext-Search-capabilities (sqlite_engine.dll now includes FTS2)
- Full unicode-support (regarding Upper, Lower, Like-Compares even on UTF8-DBs)
- Connection-, Recordset-, Field- and Command-Objects
- DB-Object-Hierarchy (the complete DB-Schema as tree)
- DB-Encryption-Support (Key, Rekey - thanks to Robert Simpson)
- In-Memory- and attachable DBs
- Fast Recordset Serialization (with a "Serialize-Changes-Only"-option)
- Deserialization- and UpdateBatch-Support
- Stronger Type-Checking whilst working with Recordsets
- VB-Date- and VB-Boolean-Type AutoConversion
- ADO-Control-Binding-support (feature is only usable, if ADO is installed)
- XCopy-deployable using DirectCOM.dll

Performance:
Normally ca. 2-3 times faster than ADO/Jet in "Read-Direction" - Serializing is ca. 8 times as fast as with ADO/PropertyBags (on larger Recordsets). Inserts using Command-Objects are ca. 8-10 times as fast as with ADO/JET. Combined with the dhRPCServer as the AppServer-Layer, you can expect ca. 120 Responses/sec, serving 'Select from Orders' or ca. 500 Responses/sec serving 'Select from Customers' - stresstested from multiple Clients against a "Standard-NWind.db' on a simple Dual-Athlon-CPU (2GHz - SATA 7200/min, 512 MB Ram, 100MBit-LAN, Protocol-Compression and -Encryption enabled).


c0Title: Create ODBC DSN Programmatically
c1Code:
Create ODBC DSN Programmatically
You can create, edit, or delete your program's ODBC entry automatically.
This code checks if an ODBC source has been made; if not, it configures one according to your program's specification. To edit or remove an existing ODBC source, change the fRequest parameter to the ODBC_CONFIG_DSN or ODBC_REMOVE_DSN values, respectively:

Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long

Public Sub MakeODBCDataSource()
     Const ODBC_ADD_DSN = 1        
     ' Add data source
     Const ODBC_CONFIG_DSN = 2     
     ' Configure (edit) data source
     Const ODBC_REMOVE_DSN = 3     
     ' Remove data source
     Const vbAPINull As Long = 0&  
     ' NULL Pointer
     Dim lngRet
     ' Check if it has been done, only do this once
     If GetSetting(App.ExeName, "options", "ODBCSetup", "No") = "No" Then
          Dim sDriver As String
          Dim sAttributes As String
          sDriver = "Microsoft Access Driver (*.mdb)"
          sAttributes = sAttributes & "DSN=MyDSN" & Chr$(0)
          sAttributes = sAttributes & "DBQ=C:\Temp\Myfile.mdb" &  Chr$(0)
          lngRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, sDriver, sAttributes)
          SaveSetting App.ExeName, "options", "ODBCSetup", "Yes"
     End if
End Sub


-Dan Newsome


c0Title: Data Updating Speed
c1Code:
Data Updating Speed
When updating the values of several records in a loop, put a BeginTrans, CommitTrans around the loop. This will significantly speed up the update process:

BeginTrans
Do Until dsData.EOF
    dsData.Edit
    dsData!sState_cd = "CA"
    dsData.MoveNext
Loop
CommitTrans


�Paul D. Sherriff/Visual Basic Power Guides


c0Title: Create Soundex codes for "sounds like" indexing
c1Code:
This function converts a string to its soundex equivalent. This can be used to help index strings and allow for similar sounding lookup without too much overhead. You can find out more information about the soundex system from the NARA.

Public Function Soundex(sWord As String) As String

    Dim nPos As Long
    Dim nSoundPos As Long
    Dim bLastVowel As Boolean
    Dim sLastCode As String
    Dim sCode As String
    
    If Len(sWord) = 0 Then
        Soundex = "0000"
        Exit Function
    End If
    
    Soundex = UCase(Mid(sWord, 1, 1)) & "000"
    nSoundPos = 2
    nPos = 2
    bLastVowel = False
    
    sLastCode = xSoundexGetCode(UCase(Mid(sWord, 1, 1)))
    
    Do While nPos <= Len(sWord) And nSoundPos <= 4
        If xSoundexIsVowel(Mid(sWord, nPos, 1)) Then
            bLastVowel = True
        Else
            sCode = xSoundexGetCode(Mid(sWord, nPos, 1))
            If bLastVowel Then
                sLastCode = ""
            End If
            If sCode <> sLastCode Then
                If Len(sCode) = 1 Then
                    sLastCode = sCode
                    Mid(Soundex, nSoundPos, 1) = sCode
                    nSoundPos = nSoundPos + 1
                End If
            End If
            bLastVowel = False
        End If
        nPos = nPos + 1
    Loop
    
End Function

Private Function xSoundexIsVowel(sLetter As String) As Boolean

    Select Case UCase(sLetter)
        Case "A", "E", "I", "O", "U", "Y"
            xSoundexIsVowel = True
        Case Else
            xSoundexIsVowel = False
    End Select

End Function

Private Function xSoundexGetCode(sLetter As String) As String

    Select Case UCase(sLetter)
        Case "B", "F", "P", "V"
            xSoundexGetCode = "1"
        Case "C", "G", "J", "K", "Q", "S", "X", "Z"
            xSoundexGetCode = "2"
        Case "D", "T"
            xSoundexGetCode = "3"
        Case "L"
            xSoundexGetCode = "4"
        Case "M", "N"
            xSoundexGetCode = "5"
        Case "R"
            xSoundexGetCode = "6"
        Case Else
            xSoundexGetCode = ""
    End Select
End Function

Private Function xSoundexTest()
    Debug.Assert Soundex("Gutierrez") = "G362"
    Debug.Assert Soundex("Pfister") = "P236"
    Debug.Assert Soundex("Jackson") = "J250"
    Debug.Assert Soundex("Tymczak") = "T522"
    Debug.Assert Soundex("VanDeusen") = "V532"
    Debug.Assert Soundex("Tymczak") = "T522"
    Debug.Assert Soundex("Ashcraft") = "A261"
    Debug.Assert Soundex("Washington") = "W252"
    Debug.Assert Soundex("Lee") = "L000"
End Function


Sample Usage:

Debug.Print Soundex("Equivalent") 'E214
Debug.Print Soundex("Eqivilent")  'Also E214


c0Title: Assign Null Fields to Controls Without Error
c1Code:
Here�s a great way to assign Null values from a database to your VB controls. Concatenating an empty string to Null produces an empty string. Using the & operator, you can convert all nonstring values to strings using little code:

txtName.Text = rs("Name") & ""

�Deborah Hammel, Sparks, Maryland


c0Title: Automatically Repairing Corrupt Databases
c1Code:
When you�re using VB�s built-in database functionality, you�re likely to get a corrupted database sooner or later. Use this code to open your databases and automatically repair any corrupt ones:

On Local Error Resume Next
DidRetry% = False
Db$="My-Db.MDB"
DoOpenDatabase:
Err = 0
Set SomeDb = OpenDatabase(Db$)
If Err = 3043 Then
    'The dreaded "Disk or Network Error" ...
    MsgBox "Database Engine error. Please restart Windows and this application", 16 
    End 
ElseIf Err = 3049 Then 
    'Database corrupted 
    If Not DidRetry% Then     'Try to repair database ...
        RepairDatabase Db$
        DidRetry% = True
        GoTo DoOpenDatabase
    Else
        MsgBox "Database repair failed. Please _ contact Tech Support", 16 
        End 
    End If 
End If 


�Michiel de Bruijn


c0Title: Calculate Date/Time Differences in Multiple Units
c1Code:
VB's DateDiff function works fine when you want to know the difference between two dates for a specific interval. To get the number of days between now and Christmas, you can use: DateDiff("d", Now, "25 Dec"). Sometimes you want to find the difference using more than one interval�for example, you might want to know the months and days until a special event, or the hours and minutes between two times. The DateIntervals routine allows you to pass in two dates and your own variables for the intervals you want. The routine fills the variables with the largest full interval of the desired type, less any other intervals you request. To get the hours and minutes between 9 a.m. and 5:15 p.m., pass in two times and two variables, using commas to skip over the larger intervals you don�t need:

DateIntervals "9:00am", "5:15pm", , , , Hours, Minutes


Upon returning, Hours holds 8, and Minutes holds 15. The results are always positive numbers, up to the limits of the DateDiff function:

 
Public Sub DateIntervals(ByVal Date1 As Date, ByVal Date2 As Date, ParamArray Prams())
     ' Returns the greatest full interval (yr, mo, 
     ' day, hr, min, sec) between two dates
     ' Calling procedure supplies variable(s) for 
     ' the desired interval(s)
     ' Ex1: DateIntervals Birthday, Now, Yr, Mo, 
     ' Dy, Hr, Mn, Sec <Exactly how old are you?
     ' Ex2: DateIntervals Now, "25 Dec", , , Days  
     ' <How many days until Christmas?
     ' LFS: 1999 for VBPJ
 
     If UBound(Prams) < 0 Then Exit Sub
 
     Dim Temp As Date
     Dim i As Long, itr As String * 1
     Const interval = "mdhns"
 
     If (DateValue(Date1) = 0) Xor _
          (DateValue(Date2) = 0) Then
     ' Assume today if one is a time and the other 
     ' is a date...
          If DateValue(Date1) = 0 Then _
               Date1 = Date1 + DateValue(Now)
          If DateValue(Date2) = 0 Then _
               Date2 = Date2 + DateValue(Now)
     End If
     If Date1 > Date2 Then
          ' Swap dates if first is after second...
          ' Temp = Date1
          Date1 = Date2
          Date2 = Temp
     End If
     If Not IsMissing(Prams(0)) Then
          Prams(0) = Year(Date2) - Year(Date1)
          Temp = DateAdd("yyyy", Prams(0), Date1)
          Prams(0) = Prams(0) + (Temp > Date2)
          Date1 = DateAdd("yyyy", Prams(0), Date1)
          If UBound(Prams) < 1 Then Exit Sub
     End If
     For i = 1 To IIf(UBound(Prams) > 5, 5, _
          UBound(Prams))
          If Not IsMissing(Prams(i)) Then
               itr = Mid$(interval, i, 1)
               Prams(i) = DateDiff(itr, Date1, Date2)
               Prams(i) = Prams(i) + (DateAdd(itr, _
                    Prams(i), Date1) > Date2)
               Date1 = DateAdd(itr, Prams(i), Date1)
          End If
     Next i
End Sub


�Larry Serflaten, Monticello, Minnesota


c0Title: Calculate Holidays
c1Code:
This class knows about a several holidays and can return date value representing the day that a holiday falls on for a given year. It can also detemine if a given date is a holiday.

Code:

'--- clsHolidays

Option Explicit

'The following properties are exposed:
' Count() As Long
' HolidayName(holiday As holidays) As String ' HolidayInYear(holiday As holidays, InYear As Date) As Date ' IsHoliday(DateQuery As Date) As Boolean ' HolidayNameOfDate(DateQuery As Date) As String

Public Enum Holidays
    NewYearsDay
    MartinLutherKingDay
    GroundhogDay
    ValentinesDay
    PresidentsDay
    SaintPatricksDay
    TaxDay
    Easter
    MothersDay
    MemorialDay
    FlagDay
    FathersDay
    IndependenceDay
    LaborDay
    ColumbusDay
    Halloween
    ElectionDay
    VeteransDay
    ThanksgivingDay
    ChristmasEve
    Christmas
    NewYearsEve
    
    HolidayCount
End Enum

Public Property Get Count() As Long
    
    Count = HolidayCount
    
End Property

Public Property Get HolidayName(holiday As Holidays) As String
    
    Select Case holiday
        Case NewYearsDay
            HolidayName = "New Year's Day"
        Case MartinLutherKingDay
            HolidayName = "Martin Luther King Day"
        Case PresidentsDay
            HolidayName = "President's Day"
        Case Easter
            HolidayName = "Easter"
        Case MemorialDay
            HolidayName = "Memorial Day"
        Case IndependenceDay
            HolidayName = "Independence Day"
        Case LaborDay
            HolidayName = "Labor Day"
        Case ColumbusDay
            HolidayName = "Columbus Day"
        Case VeteransDay
            HolidayName = "Veterans' Day"
        Case ThanksgivingDay
            HolidayName = "Thanksgiving Day"
        Case Christmas
            HolidayName = "Christmas"
        Case NewYearsEve
            HolidayName = "New Years Eve"
        Case Halloween
            HolidayName = "Halloween"
        Case GroundhogDay
            HolidayName = "Groundhog Day"
        Case ValentinesDay
            HolidayName = "Valentine's Day"
        Case SaintPatricksDay
            HolidayName = "Saint Patrick's Day"
        Case TaxDay
            HolidayName = "Tax Day"
        Case MothersDay
            HolidayName = "Mother's Day"
        Case FlagDay
            HolidayName = "Flag Day"
        Case FathersDay
            HolidayName = "Father's Day"
        Case ElectionDay
            HolidayName = "Election Day"
        Case ChristmasEve
            HolidayName = "Christmas Eve"
        Case Else
            Debug.Assert False
            HolidayName = "Error."
    End Select
    
End Property

Public Property Get HolidayInYear(holiday As Holidays, _
    InYear As Date) As Date
    
    Select Case holiday
        Case NewYearsDay
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 1, 1)
        Case MartinLutherKingDay
            HolidayInYear = DayOfWeek(InYear, 1, 3, vbMonday)
        Case PresidentsDay
            HolidayInYear = DayOfWeek(InYear, 2, 3, vbMonday)
        Case Easter
            HolidayInYear = CalcEaster(InYear)
        Case MemorialDay
            HolidayInYear = LastDayInMonth(InYear, 5, vbMonday)
        Case IndependenceDay
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 7, 4)
        Case LaborDay
            HolidayInYear = DayOfWeek(InYear, 9, 1, vbMonday)
        Case ColumbusDay
            HolidayInYear = DayOfWeek(InYear, 10, 2, vbMonday)
        Case VeteransDay
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 11, 11)
        Case ThanksgivingDay
            HolidayInYear = DayOfWeek(InYear, 11, 4, vbThursday)
        Case Christmas
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 12, 25)
        Case NewYearsEve
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 12, 31)
        Case Halloween
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 10, 31)
        Case GroundhogDay
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 2, 2)
        Case ValentinesDay
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 2, 14)
        Case SaintPatricksDay
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 3, 17)
        Case TaxDay
            HolidayInYear = CalcTaxDay(InYear)
        Case MothersDay
            HolidayInYear = DayOfWeek(InYear, 5, 2, vbSunday)
        Case FlagDay
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 6, 14)
        Case FathersDay
            HolidayInYear = DayOfWeek(InYear, 6, 3, vbSunday)
        Case ElectionDay
            HolidayInYear = DayOfWeek(InYear, 11, 1, vbTuesday)
        Case ChristmasEve
            HolidayInYear = DateSerial(DatePart("yyyy", InYear), 12, 24)
        Case Else
            Debug.Assert False
    End Select
    
End Property

Private Function CalcTaxDay(InYear As Date) As Date

    CalcTaxDay = DateSerial(DatePart("yyyy", InYear), 4, 15)
    Do While DatePart("w", CalcTaxDay) = vbSunday Or _
       DatePart("w", CalcTaxDay) = vbSaturday
        CalcTaxDay = DateAdd("d", 1, CalcTaxDay)
    Loop

End Function

Private Function LastDayInMonth(dateYear As Date, nMonth As Long, _
        nDayOfWeek As VbDayOfWeek) As Date
    
    Dim dateValid As Date
    LastDayInMonth = DateSerial(DatePart("yyyy", dateYear), nMonth, 1)
    
    Do Until DatePart("m", LastDayInMonth) <> nMonth
        If DatePart("w", LastDayInMonth) = nDayOfWeek Then
            dateValid = LastDayInMonth
        End If
        
        LastDayInMonth = DateAdd("d", 1, LastDayInMonth)
    Loop
    
    LastDayInMonth = dateValid
    
End Function

Private Function DayOfWeek(dateYear As Date, nMonth As Long, nWeeks As _
        Long, nDayOfWeek As VbDayOfWeek) As Date
    
    DayOfWeek = DateSerial(DatePart("yyyy", dateYear), nMonth, 1)
    
    If DatePart("w", DayOfWeek) > nDayOfWeek Then
        DayOfWeek = DateAdd("d", 7 - (DatePart("w", DayOfWeek) - _
                  nDayOfWeek), DayOfWeek)
    ElseIf DatePart("w", DayOfWeek) < nDayOfWeek Then
        DayOfWeek = DateAdd("d", (nDayOfWeek - DatePart("w", DayOfWeek)), _
                  DayOfWeek)
    End If
    
    DayOfWeek = DateAdd("d", ((nWeeks - 1) * 7), DayOfWeek)
    
End Function

Private Function CalcEaster(InYear As Date) As Date
    
    Dim nGolden As Long
    Dim nTillPaschal As Long
    Dim nDayPaschal As Long
    Dim nCentury As Long
    Dim nEpact As Long
    Dim nSundayPaschal As Long
    
    Dim nMonth As Long
    Dim nDay As Long
    Dim nYear As Long
    
    nYear = DatePart("yyyy", InYear)
    nGolden = nYear Mod 19
    nCentury = nYear \ 100
    nEpact = (nCentury - nCentury \ 4 - (8 * nCentury + 13) \ 25 + 19 * _
           nGolden + 15) Mod 30
    nTillPaschal = nEpact - (nEpact \ 28) * (1 - (nEpact \ 28) * (29 \ _
                 (nEpact + 1)) * ((21 - nGolden) \ 11))
    nDayPaschal = (nYear + nYear \ 4 + nTillPaschal + 2 - nCentury + _
                nCentury \ 4) Mod 7
    nSundayPaschal = nTillPaschal - nDayPaschal
    nMonth = 3 + (nSundayPaschal + 40) \ 44
    nDay = nSundayPaschal + 28 - 31 * (nMonth \ 4)
    
    CalcEaster = DateSerial(nYear, nMonth, nDay)
    
End Function

Public Property Get IsHoliday(DateQuery As Date) As Boolean
    
    Dim i As Long
    
    IsHoliday = False
    
    For i = 0 To HolidayCount - 1
        If Int(DateQuery) = Int(HolidayInYear(i, DateQuery)) Then
            IsHoliday = True
            Exit For
        End If
    Next
    
End Property

Public Property Get HolidayNameOfDate(DateQuery As Date) As String
    
    Dim i As Long
    
    HolidayNameOfDate = "None"
    
    For i = 0 To HolidayCount - 1
        If Int(DateQuery) = Int(HolidayInYear(i, DateQuery)) Then
            HolidayNameOfDate = HolidayName(i)
            Exit For
        End If
    Next
    
End Property

'--- End of clsHolidays


Sample Usage:

        
Dim objHolidays As clsHolidays
Dim i As Long
Set objHolidays = New clsHolidays
    
For i = 0 To objHolidays.Count - 1
    Debug.Print objHolidays.HolidayName(i) & " occurs on " & _
    Format(objHolidays.HolidayInYear(i, Now), "mmmm dd, yyyy")
Next

If objHolidays.IsHoliday(Now) Then
    Debug.Print "Today is " & objHolidays.HolidayNameOfDate(Now)
Else
    Debug.Print "Today is not a holiday"
End If


c0Title: Change Dates With Plus and Minus Keys
c1Code:
This simple piece of code saves a lot of headaches when it comes to altering dates. It allows you to use the plus and minus keys to increment and decrement date values easily. This example assumes there is a textbox named Text1 on a standard VB form:

Private Sub Form_Load()
    ' Make sure that there is a valid date in Text1.
    Text1.Text = Date
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    ' Pass handling to generic routine.
    KeyAscii = DateHandler(KeyAscii)
End Sub

Private Function DateHandler(KeyAscii As Integer) As Integer
    Dim nRet As Integer

    ' This routine adds or subtracts days, based on the 
    ' key pressed, from a date value found in the control 
    ' represented by the form's ActiveControl property 
    ' (usually a TextBox). The routine can be altered to 
    ' add and subtract months and years too.

    On Error GoTo ErrorHandler

    ' Constants which represent the '+' & '-' keys.
    Const KeyAdd = 43
    Const KeySubtract = 45

    ' This constant is here because '+' & '=' are on the 
    ' same key for most keyboards, but are sometimes inverted.
    Const KeyEquals = 61

    ' Determine the value of the key pressed, and 
    ' take the necessary action.
    Select Case KeyAscii
    Case KeyAdd, KeyEquals
        Me.ActiveControl.Text = DateAdd("d", 1, Me.ActiveControl)
        nRet = 0
    Case KeySubtract
        Me.ActiveControl.Text = DateAdd("d", -1, Me.ActiveControl)
        nRet = 0
    Case Else
        nRet = KeyAscii
    End Select

    ' Move the start position to the end of the 
    ' text for a cleaner look.
    If nRet = 0 Then
        Me.ActiveControl.SelStart = Len(Text1.Text)
    End If

    ' Return a new KeyAscii value.
    DateHandler = nRet
    Exit Function
 
ErrorHandler:
    DateHandler = 0
    Exit Function
End Function


�Sheppe Pharis, Kelowna, British Columbia, Canada


c0Title: Clean Up the MonthView
c1Code:
If you�ve tried using the Microsoft MonthView control, part of the Windows Common Controls 2 collection, you probably discarded it after discovering the quirky spinner that pops up when you click on the year. This is supposed to make it easy to change years. Unfortunately, when you click on one of the spinner buttons, an ugly border artifact appears to the right of the spinner. If you don�t mind eliminating the spinners, you can still use the control. You must subclass the MonthView control temporarily and destroy the spinner button when it is created:

' Form code
Option Explicit

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const GWL_WNDPROC = (-4)

Private Sub MonthView1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim d As Date

    If MonthView1.HitTest(X, Y, d) = mvwTitleYear Then
        lmvWndProc = SetWindowLong(MonthView1.hWnd, GWL_WNDPROC, AddressOf MVWndProc)
    End If
End Sub

' Module code
Option Explicit

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const GWL_WNDPROC = (-4)
Private Const WM_CREATE = &H1
Private Const WM_PARENTNOTIFY = &H210
Public lmvWndProc As Long

Public Function MVWndProc(ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case msg
    Case WM_PARENTNOTIFY
        Select Case LoWord(wParam)
        Case WM_CREATE
            DestroyWindow lParam
            SetWindowLong hWnd, GWL_WNDPROC, lmvWndProc
        End Select
    End Select

    MVWndProc = CallWindowProc(lmvWndProc, hWnd, msg, wParam, lParam)
End Function

Public Function LoWord(lnum As Long) As Integer
    CopyMemory LoWord, lnum, 2
End Function

Public Function HiWord(lnum As Long) As Integer
    CopyMemory HiWord, ByVal VarPtr(lnum) + 2, 2
End Function


�Matt Hart, Tulsa, Oklahoma


c0Title: Convert between UTC time and local time
c1Code:
Copy the date/time elements into a SYSTEMTIME structure. Use the SystemTimeToFileTime API function to convert the SYSTEMTIME into a FILETIME structure.
Use the LocalFileTimeToFileTime API function to convert from the local time to UTC time. Use the FileTimeToSystemTime API function to convert the UTC time into a SYSTEMTIME structure. Pull the fields out of the SYSTEMTIME to get the Visual Basic date format. Reverse the steps to go from a UTC time to the local file system time.

 
Option Explicit
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
 
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long 
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long 
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
 
' Convert a Date into a SYSTEMTIME.
Private Sub DateToSystemTime(ByVal the_date As Date, ByRef system_time As SYSTEMTIME)
    With system_time
        .wYear = Year(the_date)
        .wMonth = Month(the_date)
        .wDay = Day(the_date)
        .wHour = Hour(the_date)
        .wMinute = Minute(the_date)
        .wSecond = Second(the_date)
    End With
End Sub

' Convert a SYSTEMTIME into a Date.
Private Sub SystemTimeToDate(system_time As SYSTEMTIME, ByRef the_date As Date)
    With system_time
        the_date = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
    End With
End Sub

Private Sub Command1_Click()
    Dim the_date As Date
    Dim system_time As SYSTEMTIME
    Dim local_file_time As FILETIME
    Dim utc_file_time As FILETIME
 
    ' Get the local time.
    the_date = CDate(txtLocalTime.Text)
 
    ' Convert it into a SYSTEMTIME.
    DateToSystemTime the_date, system_time
 
    ' Convert it to a FILETIME.
    SystemTimeToFileTime system_time, local_file_time
 
    ' Convert it to a UTC time.
    LocalFileTimeToFileTime local_file_time, utc_file_time
 
    ' Convert it to a SYSTEMTIME.
    FileTimeToSystemTime utc_file_time, system_time
 
    ' Convert it to a Date.
    SystemTimeToDate system_time, the_date
 
    ' Display the result.
    txtUTCTime.Text = Format$(the_date)
End Sub
 
Private Sub Command2_Click()
    Dim the_date As Date
    Dim system_time As SYSTEMTIME
    Dim local_file_time As FILETIME
    Dim utc_file_time As FILETIME
 
    ' Get the UTC time.
    the_date = CDate(txtUTCTime.Text)
 
    ' Convert it into a SYSTEMTIME.
    DateToSystemTime the_date, system_time
 
    ' Convert it to a UTC time.
    SystemTimeToFileTime system_time, utc_file_time
 
    ' Convert it to a FILETIME.
    FileTimeToLocalFileTime utc_file_time, local_file_time
 
    ' Convert it to a SYSTEMTIME.
    FileTimeToSystemTime local_file_time, system_time
 
    ' Convert it to a Date.
    SystemTimeToDate system_time, the_date
 
    ' Display the result.
    txtLocalTime.Text = Format$(the_date) End Sub Private Sub Form_Load()
    txtLocalTime.Text = Date & " " & Time End Sub


c0Title: Convert to/from Packed Julian dates
c1Code:
Option Explicit

Public Function DateToPackedJulian(ByVal TheDate As Date) As Long 
'===========================================================================
'   DateToPackedJulian - Converts a date to a Julian day in the form of a packed DWORD.
'   The function works with dates based on the Gregorian (modern) calendar. Y2K COMPLAINT.
'
'   TheDate         The date to convert.
'   RETURNS         A DWORD whose LoWord is the year and the HiWord is the Julian day.
'===========================================================================
    TheDate = DateValue(TheDate)                ' strip the time part, if any
    
    ' split the date into two 16-bit numbers
    ' then pack into one 32-bit number:
    DateToPackedJulian = MakeDWord(Year(TheDate), (TheDate - DateSerial(Year(TheDate) - 1, 12, 31))) 
End Function

Public Function DateFromPackedJulian(ByVal Value As Long) As Date 
'===========================================================================
'   DateFromPackedJulian - Converts a packed Julian date (using DateToPackedJulian) to
'   a date data type.
'
'   Value           The julian value to convert.
'   RETURNS         A date representation of the julian date supplied.
'===========================================================================
    DateFromPackedJulian = DateSerial(LoWord(Value), 1, 1)  ' create date from Julian year
    DateFromPackedJulian = DateFromPackedJulian + _
        DateAdd("d", HiWord(Value) - 1, #12:00:00 AM#)      ' add in the # of days
End Function


Public Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long '===========================================================================
'   MakeDWord - Packs 2 16-bit integers into a 32-bit Long.
'
'   HiWord          The most significant 16 bits.
'
'   LoWord          The least significant 16 bits.
'
'   RETURNS:        A Long holding the full 32-bit value.
'===========================================================================
    
    MakeDWord = (HiWord * 65536) + (LoWord And &HFFFF&)
End Function


Public Function LoWord(ByVal lParam As Long) As Long 
'===========================================================================
'   LoWord - Returns Lo Word part of the supplied dual long value which is often needed
'   when working with long values returned by API calls.
'
'   lParam      Input. Dual value returned by API call.
'
'   RETURNS     the low order word of the supplied long value
'===========================================================================
    If (lParam And &H8000&) <> 0 Then
       LoWord = lParam Or &HFFFF0000
    Else
       LoWord = lParam And &HFFFF&
    End If   
End Function

Public Function HiWord(ByVal lParam As Long) As Long 
'===========================================================================
'   HiWord - Returns Hi Word part of the supplied dual long value which is often needed
'   when working with long values returned by API calls.
'
'   lParam      Input. Dual value returned by API call.
'
'   RETURNS     the high order word of the supplied long value
'===========================================================================
    HiWord = (lParam And &HFFFF0000) \ &H10000
    'CopyMemory ByVal VarPtr(HiWord), ByVal VarPtr(lParam) + 2, 2&
End Function


c0Title: Build Debugging/Profiling Into Your Code
c1Code:
To build debugging and profiling into your code, add this to the end of code lines:

'Code line Add this line (n should be replaced 'by a unique number)
i = j + 1 '*dbg* "Debug n" & time


Turn debugging/profiling on by simply doing a replace on all modules of '*dbg* with :debug.print. When you run your code, the output will be sent to the debug window. To turn off debugging/ profiling, replace :debug.print with '*dbg.* Even more interesting is the fact that you can do this at the procedure level as well. For example:

Sub Form_Load () '*dbg* "form_load:" & Time;


after replacement:

Sub Form_Load () : Debug.Print "form_load:" & Time;


Finally, if you like, you can change '*dbg* to a procedure name that could write all output to a file.

�Robert Meyering


c0Title: Create a VB Error Message Reference List
c1Code:
Have you ever wanted to have a hard copy listing all the VB error messages? Create a new standard EXE VB application and drop this code into the Load event of the main form:

Private Sub Form_Load()
    Dim i As Integer
    For i = 0 To 32000
        'Use this test in VB3:
        'If Error$(i) <> "User-defined error" Then
        'Use this test in VB4 and later:
        If Error$(i) <> "Application-defined " & "or object-defined error" Then 
            Printer.Print i, Error$(i) 
        End If 
    Next i
End Sub


This program prints all defined error descriptions. All undefined error descriptions return �Application-defined or object-defined error� (or �User-defined error� in VB3), so you check for these and ignore them.

�Vince A. Sempronio, Rockville, Maryland


c0Title: Debugging Events When They're Acting Funny
c1Code:
Use Debug.Print "Entering event ..." without breakpoints to trace events if they seem to act funny. Don�t use break points with MsgBoxes�they can alter the event sequence.

�Craig Goren


c0Title: Convert File Size Into Proper Strings
c1Code:
Use this small API from the shlwapi (Shell Windowing API) DLL that ships with Internet Explorer (IE) to help you convert file size in bytes into proper strings such as �1.41 KB� or �1.32 MB.� You need IE for this because it calls shlwapi.dll, which is present on all NT4, Windows 95+IE, and Windows 98 systems:

Private Declare Function StrFormatByteSize Lib "shlwapi" Alias "StrFormatByteSizeA" (ByVal dw As Long, ByVal pszBuf As String, ByRef cchBuf As Long) As String
 
Public Function FormatKB(ByVal Amount As Long) As String
     Dim Buffer As String
     Dim Result As String
     Buffer = Space$(255)
     Result = StrFormatByteSize(Amount, Buffer, Len(Buffer))
     If InStr(Result, vbNullChar) > 1 Then
          FormatKB = Left$(Result, InStr(Result, vbNullChar) - 1)
     End If
End Function


�Deepu Chandy Thomas, Kerala, India


c0Title: Check if file is in IE Cache
c1Code:
This function can be called to determine if a file is in Internet Explorers cache.

Private Declare Function GetUrlCacheEntryInfo Lib "wininet.dll" Alias _
    "GetUrlCacheEntryInfoA" _
    (ByVal sUrlName As String, _
    lpCacheEntryInfo As Any, _
    lpdwCacheEntryInfoBufferSize As Long) As Long

Function Cached(ByVal strURL As String) As Boolean
    Dim buffer As Long
    
    If (GetUrlCacheEntryInfo(strURL, ByVal 0&, buffer)) = 0 Then
    If (Err.LastDllError = 122) Then Cached = True
        
End Function


Example Usage
Just call the function and give it the url of the file you want to check:

MsgBox Cached("http://msdn.microsoft.com/")


c0Title: Easy File Move
c1Code:
To Move a File just use the NAME function. The NAME function in is intended for renaming files, but it moves them great.

Example Line:

Name "C:\MYTEXT.TXT" As "C:\SAVEDOCS\MYTEXT.TXT"


Note: You responsible for ensuring that the destination directory exists. This Command returns an Error 53 (File Not Found) if the source is not found OR if the destination dir is not found.

Tip Submitted By: Chris Woodruff


c0Title: Drop the file extension from a path
c1Code:
'Drops the extension from the end of a string like drive:\path\filename.ext
'Returns the shortened path\filename
Function DropExtension(ByVal Filename As String) As String
    Dim Count As Long
    Dim DotPos As Long
    Dim BackslashPos As Long
    
    DotPos = InStrRev(Filename, ".")
    BackslashPos = InStrRev(Filename, "\")
    
    If (DotPos > 0) And (DotPos > BackslashPos) Then
        DropExtension = Left$(Filename, DotPos - 1)
    Else    'No extension found
        DropExtension = Filename
    End If
    
End Function


c0Title: Return the drive\folder from a path & filename
c1Code:
'Return the drive\folder from a path & filename
Function FolderName(PathName As String) As String
    Dim X As Integer
    
    X = InStrRev(PathName, "\", Len(PathName) - 1, Compare:=vbTextCompare)
    FolderName = Left$(PathName, X - 1)
End Function


c0Title: Return the file name from a path & filename
c1Code:
'Return the file name from a path & filename
Function Filename(ByVal PathName As String) As String
    Dim Position As Long
    
    Position = InStrRev(PathName, "\", Compare:=vbTextCompare)
    
    Filename = Right$(PathName, Len(PathName) - Position)
End Function


c0Title: Return the file extension from a path & filename
c1Code:
'Return the file extension from a path & filename
Function FileExtension(ByVal sFile As String) As String
    Dim iPosition As Long
    
    sFile = Filename(sFile)
    iPosition = InStrRev(sFile, ".")
    
    If iPosition > 1 Then
        FileExtension = Right$(sFile, Len(sFile) - iPosition)
    Else
        FileExtension = vbNullString
    End If
    
End Function


c0Title: Add/Remove a Trailing Backslash From a Path
c1Code:
'Adds a trailing backslash to a path (if it doesn't already have one)
Public Function PathAddSeparator(ByVal Path As String) As String
    
    If Path <> vbNullString Then
        If Right$(Path, 1) <> "\" Then Path = Path & "\"
        PathAddSeparator = Path
    Else
        PathAddSeparator = vbNullString
    End If

End Function

Public Function PathRemoveSeparator(ByVal sPath As String) As String
    If Right(sPath, 1) = "\" Then
        PathRemoveSeparator = Left(sPath, Len(sPath) - 1)
    Else
        PathRemoveSeparator = sPath
    End If
End Function


c0Title: Browse for Folder
c1Code:
This displays the browse for folder common dialog via API's, thus allowing VB easy access to it.

Option Explicit

Private Type BrowseInfo
    hWndOwner      As Long
    pIDLRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260

Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String

    Dim nNull As Integer
    Dim lpIDList As Long
    Dim nResult As Long
    Dim sPath As String
    Dim bi As BrowseInfo

    bi.hWndOwner = hWndOwner
    bi.lpszTitle = lstrcat(sPrompt, "")
    bi.ulFlags = BIF_RETURNONLYFSDIRS

    lpIDList = SHBrowseForFolder(bi)
    
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        nResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        nNull = InStr(sPath, vbNullChar)
        If nNull Then
            sPath = Left$(sPath, nNull - 1)
        End If
    End If

    BrowseForFolder = sPath

End Function


Sample Usage:

        
Debug.Print BrowseForFolder(Me.hWnd, "Please select a folder:")


c0Title: Browse For Folder - Allows the user to browse for a folder using the shell namespace
c1Code:
Option Explicit

Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, Pidl As ITEMIDLIST) As Long 
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLIST 
Private Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal Pidl As Long, ByVal pszPath As String) As Long 
Private Declare Function SHGetPathFromIDListW Lib "shell32.dll" (ByVal Pidl As Long, ByVal pszPath As Long) As Long 
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long 
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Declare Function SendMessageA Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Declare Function SendMessageW Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long


Public Type SHITEMID                        ' Shell item identifier
     cb As Long
     abID As Byte
End Type

Public Type ITEMIDLIST                      ' Shell item identifier list
     mkid As SHITEMID
End Type

Private Type OSVERSIONINFO                      ' operating system version information [used by GetVersion]
    dwOSVersionInfoSize     As Long
    dwMajorVersion          As Long
    dwMinorVersion          As Long
    dwBuildNumber           As Long
    dwPlatformId            As Long
    szCSDVersion            As String * 128     ' Maintenance string for PSS usage
End Type


Private Enum OSVersionEnum
    VER_PLATFORM_WIN32s = 0
    VER_PLATFORM_WIN32_WINDOWS = 1
    VER_PLATFORM_WIN32_NT = 2
End Enum

Public Enum BrowseFolderFlags               ' flags used to browse for folders
    BIF_RETURNONLYFSDIRS = &H1
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_RETURNFSANCESTORS = &H8
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
End Enum

Public Type BROWSEINFO                      ' shell structure used to browse for folders
     hOwner As Long
     pidlRoot As Long
     pszDisplayName As String
     lpszTitle As String
     ulFlags As Long
     lpfn As Long
     lParam As Long
     iImage As Long
End Type

Public Enum ShellVirtualFolders     ' ShellFolder Browsing
    CSIDL_DESKTOP = &H0             ' Windows desktop - virtual folder at the root of the name space.
    CSIDL_INTERNET = &H1            ' Virtual folder representing the Internet
    CSIDL_PROGRAMS = &H2            ' File system directory that contains the user's program groups (which are also file system directories).
    CSIDL_CONTROLS = &H3            ' Control Panel - virtual folder containing icons for the control panel applications.
    CSIDL_PRINTERS = &H4            ' Printers folder - virtual folder containing installed printers.
    CSIDL_PERSONAL = &H5            ' File system directory that serves as a common respository for documents.
    CSIDL_FAVORITES = &H6           ' Favorite Places - file system folder that stores web (or other) links
    CSIDL_STARTUP = &H7             ' File system directory that corresponds to the user's Startup program group.
    CSIDL_RECENT = &H8              ' File system directory that contains the user's most recently used documents.
    CSIDL_SENDTO = &H9              ' File system directory that contains Send To menu items.
    CSIDL_BITBUCKET = &HA           ' Recycle bin - file system directory containing file objects in the user's recycle bin.
                                    ' The location of this directory is not in the registry; it is marked with the hidden
                                    ' and system attributes to prevent the user from moving or deleting it.
    CSIDL_STARTMENU = &HB           ' File system directory containing Start menu items.
    CSIDL_DESKTOPDIRECTORY = &H10   ' File system directory used to physically store file objects on the desktop (not to be confused
                                    ' with the desktop folder itself).
    CSIDL_DRIVES = &H11             ' My Computer - virtual folder containing everything on the local computer:
                                    ' storage devices, printers, and Control Panel. The folder may also contain mapped network drives.
    CSIDL_NETWORK = &H12            ' Network Neighborhood - virtual folder representing the top level of the network hierarchy.
    CSIDL_NETHOOD = &H13            ' File system directory containing objects that appear in the network neighborhood.
    CSIDL_FONTS = &H14              ' Virtual folder containing fonts.
    CSIDL_TEMPLATES = &H15          ' File system directory that serves as a common repository for document templates.
    CSIDL_COMMON_STARTMENU = &H16   '
    CSIDL_COMMON_PROGRAMS = &H17    '
    CSIDL_COMMON_STARTUP = &H18     '
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19  '
    CSIDL_APPDATA = &H1A            '
    CSIDL_PRINTHOOD = &H1B          '
    CSIDL_ALTSTARTUP = &H1D         ' // DBCS
    CSIDL_COMMON_ALTSTARTUP = &H1E  ' // DBCS
    CSIDL_COMMON_FAVORITES = &H1F
    CSIDL_INTERNET_CACHE = &H20
    CSIDL_COOKIES = &H21
    CSIDL_HISTORY = &H22
End Enum

Private OSVersion           As OSVERSIONINFO    ' private structure for various Public functions


Public Function BrowseForFolder(ByVal hWnd As Long, Optional ByVal TopFolder As ShellVirtualFolders = CSIDL_DESKTOP, Optional ByVal Title As String = "Select folder", Optional ByVal Flags As BrowseFolderFlags = BIF_RETURNONLYFSDIRS, Optional ByVal DefaultFolder As String) As String 
'===========================================================================
'   BrowseForFolder - Allows the user to browse for a folder using
'   the shell namespace.
'
'   TopFolder       Identifies the root folder.
'   Title           Attaches a description above the TreeView.
'   Flags           Misc flags defining behavior.
'   DefaultFolder   Reserved.
'===========================================================================
  
  Dim bi      As BROWSEINFO   ' input structure used by Shell API
  Dim idl     As ITEMIDLIST   ' input structure used by Shell API
  Dim Result  As Long         ' return code
  Dim Pidl    As Long         ' pointer to an Item ID List
  Dim Path    As String       ' resulting path returned
  Dim Pos     As Integer      ' parsing index

  ' Return default value if canceled
  BrowseForFolder = DefaultFolder

  With bi
    
    .hOwner = hWnd
    
    ' Convert virtual folder to pidl
    Result = SHGetSpecialFolderLocation(hWnd, TopFolder, idl)
    .pidlRoot = idl.mkid.cb
    
    ' set the dialog title
    .lpszTitle = Title
    ' input options
    .ulFlags = Flags
    
    ' Give callback info about default folder
    If Len(DefaultFolder) > 0 Then
    
      ' Set address of callback function
      .lpfn = ProcAddress(AddressOf BrowseCallbackProc)
    
      ' Convert to Ansi if not on NT
      If Not IsWinNt Then
        DefaultFolder = StrConv(DefaultFolder, vbFromUnicode)
      End If
      
      ' Store pointer to default folder
      .lParam = StrPtr(DefaultFolder)
    
    End If
    
  End With
  
  ' display browse dialog
  Pidl = SHBrowseForFolder(bi)
  
  ' Make sure Cancel not clicked
  If Pidl <> 0 Then
  
    ' size of the buffer to fit & pad with nulls
    Path = Space$(519) & vbNullChar
    
    ' copy the path to local buffer
    If CBool(SHGetPathFromIDList(Pidl, Path)) Then
      ' strip off null terminators
      Pos = InStr(Path, Chr$(0))
      BrowseForFolder = Left$(Path, Pos - 1)
    End If

    ' Release the pidl!
    CoTaskMemFree Pidl

  End If
    
End Function

Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long

  Const WM_USER             As Long = &H400
  Const BFFM_INITIALIZED    As Long = 1
  ' // messages to browser
  Const BFFM_SETSELECTIONA  As Long = (WM_USER + 102)
  Const BFFM_SETSELECTIONW  As Long = (WM_USER + 103)

  Static ExitProc           As Boolean
  
  If ExitProc Then Exit Function
  
  Select Case uMsg
  Case BFFM_INITIALIZED
  
    ' Avoid reentry resulting from dialog
    ' another firing a BFFM_INITIALIZED when
    ' it receives a BFFM_SETSELECTION.
    ExitProc = True
    
    ' Tell tree browser to select the path
    ' pointed to at lpData.
    If IsWinNt() Then
      SendMessageA hWnd, BFFM_SETSELECTIONW, Abs(True), ByVal lpData
    Else
      SendMessageW hWnd, BFFM_SETSELECTIONA, Abs(True), ByVal lpData
    End If
  
    ' Allow reentry
    ExitProc = False
    
  End Select
  
End Function


Public Function ProcAddress(ByVal lpFunction As Long) As Long 
'===========================================================================
'   ProcAddress - Returns the address of the supplied function.
'
'   lpFunction      Function name. Passed "AddressOf <name>"
'
'   RETURNS         The 32 bit address of the function.
'===========================================================================
    ProcAddress = lpFunction
End Function

Public Function IsWinNt() As Boolean
'===========================================================================
'   IsWinNT - Returns true if we're running Windows NT.
'===========================================================================
Exit Function
    ' NOTE: OSVERSIONINFO is defined at the module
    ' for imporved performance.
    
    If OSVersion.dwOSVersionInfoSize = 0 Then               ' this is our first time making this call
        OSVersion.dwOSVersionInfoSize = Len(OSVersion)      ' initialize so API knows which version being used
        GetVersionEx OSVersion                              ' make the call once & then save/re-use it
    End If

    IsWinNt = OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT ' return the result
    
End Function

Public Function SHGetPathFromIDList(ByVal Pidl As Long, ByRef pszPath As String) As Long '===========================================================================
'   SHGetPathFromIDList - ANSI/WIDE wrapper. Refer to the SDK.
'===========================================================================

    If Len(pszPath) = 0 Then pszPath = vbNullString     ' ensure blanks made NULL
    
    If IsWinNt Then                                     ' running in NT, use WIDE calls
        SHGetPathFromIDList = SHGetPathFromIDListW(Pidl, StrPtr(pszPath))
    Else                                                ' running on Win9X, use ANSI calls
        SHGetPathFromIDList = SHGetPathFromIDListA(Pidl, pszPath)
    End If

End Function


c0Title: FileOpen and FileSave Dialogs
c1Code:
Option Explicit

Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenFileName As OPENFileName) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFileName As OPENFileName) As Long
  
Public Enum OfnFlags
    OFN_ALLOWMULTISELECT = &H200        'Allow multiple files to be selected
    OFN_CREATEPROMPT = &H2000           'Prompt to create files that don't exist
    OFN_DONTADDTORECENT = &H2000000     'Don't add file to Windows' Recent Files list
    OFN_ENABLESIZING = &H800000         'Allow user to resize dialog
    OFN_EXPLORER = &H80000              'User explorer style (only takes effect if OFN_ALLOWMULTISELECT is used
    OFN_FILEMUSTEXIST = &H1000          'User can only enter existing FileNames. Must also set OFN_PATHMUSTEXIST
    OFN_FORCESHOWHIDDEN = &H10000000    'Show hidden or system files regardless of Explorer settings (won't show hidden system files)
    OFN_HIDEREADONLY = &H4              'Hide the bReadOnly checkbox
    OFN_LONGNAMES = &H200000            'If using non-explorer style dialog, set this to use long FileNames
    OFN_NOCHANGEDIR = &H8               'Don't change default directory when dialog closes
    OFN_NODEREFERENCELINKS = &H100000   'Don't replace .lnk FileNames with the path & FileName they point to
    OFN_NOLONGNAMES = &H40000           'If using non-explorer style dialog, use short FileNames
    OFN_NONETWORKBUTTON = &H20000       'Disable the network button
    OFN_NOTESTFILECREATE = &H10000      'Do not create file before closing the dialog
    OFN_NOVALIDATE = &H100              'Allow invalid characters in FileName
    OFN_PATHMUSTEXIST = &H800           'Don't accept paths that don't exist
    OFN_bReadOnly = &H1                  'Set read-only checkbox by default
    OFN_SHAREAWARE = &H4000             'Ignore sharing violations
    OFN_SHOWHELP = &H10                 'Show Help button. Owner window must handle the help request
End Enum

'Dummy declarations force capitalization of enum items
#If False Then
    Public OFN_ALLOWMULTISELECT
    Public OFN_CREATEPROMPT
    Public OFN_DONTADDTORECENT
    Public OFN_ENABLESIZING
    Public OFN_EXPLORER
    Public OFN_FILEMUSTEXIST
    Public OFN_FORCESHOWHIDDEN
    Public OFN_HIDEREADONLY
    Public OFN_LONGNAMES
    Public OFN_NOCHANGEDIR
    Public OFN_NODEREFERENCELINKS
    Public OFN_NOLONGNAMES
    Public OFN_NONETWORKBUTTON
    Public OFN_NOTESTFILECREATE
    Public OFN_NOVALIDATE
    Public OFN_PATHMUSTEXIST
    Public OFN_bReadOnly
    Public OFN_SHAREAWARE
    Public OFN_SHOWHELP
#End If
  
Private Type OPENFileName
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  nFlags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type
 
'FileOpenDialog and FileSaveDialog have the same set of arguments and return value, except bReadOnly is
'not used for FileSaveDialog.
'
'sFilter     File extension filter made of pairs of descriptions and filespecs separated by pipes.
'            Multiple filespecs may be separated by semicolons. For example:
'            "All Files (*.*)|*.*|Graphic Files|*.jpg;*.png|"
'            nFlags      nFlags from OfnFlags (default=0)
'            bReadOnly   Set to TRUE by FileOpenDialog if read-only was selected by the user
'
'Returns path & filename selected or VbNullString if user cancelled or there was an error. If the user doesn't
'enter an extension, one is appended based on the selected filter. If the selected filter has multiple extensions
'the last one will be used.
'
' Notes: Sometimes VB gives a compiler error saying you need a constant if you pass a OFN flag to the function.
'        Creating the exe file seems to fix this for running the uncompiled code also
'
Function FileOpenDialog(Optional ByVal sTitle As String, Optional ByVal sFolder As String, _
                        Optional ByVal sFilter As String = "All Files|*.*|", Optional ByVal nFlags As OfnFlags, Optional ByRef bReadOnly As Boolean)
    FileOpenDialog = FileDialog(sTitle, sFolder, sFilter, nFlags, bReadOnly, bSaveMode:=False)
End Function

Function FileSaveDialog(Optional ByVal sTitle As String, Optional ByVal sFolder As String, _
                        Optional ByVal sFilter As String = "All Files|*.*|", Optional ByVal nFlags As OfnFlags)
    Dim bUnused As Boolean
    
    FileSaveDialog = FileDialog(sTitle, sFolder, sFilter, nFlags, bUnused, bSaveMode:=True)
End Function

'This function handles both open and save dialogs
Private Function FileDialog(ByVal sTitle As String, ByVal sFolder As String, ByVal sFilter As String, ByVal nFlags As OfnFlags, ByRef bReadOnly, ByVal bSaveMode As Boolean)
    Dim OpenFile As OPENFileName
    Dim nResult As Long
    Dim sFileName As String
    Dim nNullPos As Long
    Dim sExtension As String
    
    If Right$(sFilter, 1) <> "|" Then    'Add 2 terminating pipes if there are none
        sFilter = sFilter & "||"
    ElseIf Right$(sFilter, 2) <> "|" Then    'Add 1 terminating pipe if there is only 1
        sFilter = sFilter & "|"
    End If

    sFilter = Replace(sFilter, "|", vbNullChar)
 
    With OpenFile
        .lStructSize = Len(OpenFile)
        .lpstrFilter = sFilter
        .nFilterIndex = 0
        .lpstrFile = sFolder & String$(257 - Len(sFolder), 0)
        .nMaxFile = Len(.lpstrFile) - 1
        .lpstrFileTitle = .lpstrFile
        .nMaxFileTitle = .nMaxFile
        .lpstrInitialDir = sFolder
        .lpstrTitle = sTitle
        .nFlags = nFlags
   
        If bSaveMode = True Then
            nResult = GetSaveFileName(OpenFile)
        Else
            nResult = GetOpenFileName(OpenFile)
        End If
        
        If nResult = 0 Then
           sFileName = vbNullString
        Else
            sFileName = TrimNull(.lpstrFile)
            If FileExtension(sFileName) = vbNullString Then
                sExtension = GetSelectedExtension(.lpstrFilter, .nFilterIndex)
                If sExtension <> "*" Then
                    sFileName = sFileName & "." & sExtension
                End If
            End If
            
            bReadOnly = ((.nFlags And OFN_bReadOnly) = OFN_bReadOnly)
        End If
        
    End With
    
    FileDialog = sFileName
End Function

Function GetSelectedExtension(ByVal sFilters As String, ByVal nFilterIndex As Long) As String
    Dim sFilterArray() As String
    sFilterArray = Split(sFilters, vbNullChar)
    GetSelectedExtension = FileExtension(sFilterArray(nFilterIndex * 2 - 1))
End Function

Function TrimNull(ByVal sText As String) As String
    TrimNull = Left(sText, InStr(sText, vbNullChar) - 1)
End Function

'Return the file extension from a path & filename
Function FileExtension(ByVal sFile As String) As String
    Dim nDotPosition As Long
    
    sFile = Filename(sFile)
    nDotPosition = InStrRev(sFile, ".")
    
    If nDotPosition > 1 Then
        FileExtension = Right$(sFile, Len(sFile) - nDotPosition)
    Else
        FileExtension = vbNullString
    End If
    
End Function

'Return the file name from a path & filename
Function Filename(ByVal PathName As String) As String
    Dim Position As Long
    
    Position = InStrRev(PathName, "\", Compare:=vbTextCompare)
    Filename = Right$(PathName, Len(PathName) - Position)
End Function


c0Title: Avoid Line Input Null Problems
c1Code:
Sometimes you have to move information from a flat file (mainframe or ASCII text file) to a database. Usually, this flat file is a set of records, and the delimiter between records is a carriage return/linefeed pair. Records might be different sizes and can contain Null characters. This code is a standard way to read a file line by line, but fails because strBuff loses Null characters, and the structure of the current record is incorrect:

Do Until EOF(1)
    '//-------After the next statement strBuff 
    'will be without Null characters
    Line Input #1, strBuff
Loop


I know at least three ways to fix this problem. Here�s my favorite way. You have to use Microsoft Scripting Runtime DLL (scrun.dll):

Dim FSO  As New FileSystemObject
Dim TS As TextStream
Dim strBuff As String
Set TS = FSO.OpenTextFile("c:\MyFlatFile.txt", ForReading)

Do Until TS.AtEndOfStream
       '//-------Reading current line and replacing 
       'Null characters to spaces
       strBuff = Replace(TS.ReadLine, Chr$(0), " ")
       '//-------Your parsing code here
Loop

TS.Close
Set FSO = Nothing


This code returns a correct result because the ReadLine method doesn�t lose Null characters. I used the Replace function only to prepare the current line for parsing. VB5 users need to use another approach to replace Nulls with space characters.

�Vladimir Olifer, Brooklyn, New York


c0Title: Clear File Attributes From Entire Directory Tree of Files
c1Code:
This function removes attributes from files in the folder you specify in strFolder. It also can walk down all subfolders of this folder recursively. This function was written mainly for removing the read-only flag that all files have after you copy a bunch from a CD (oldattribute = vbReadOnly), but you can use it with other attributes as well. Look for the other constants for file attributes in the object browser (subset scripting). To use this function, you must first set a Reference to the �Microsoft Scripting Runtime�:

Option Explicit

Private fso As New Scripting.FileSystemObject

Public Function ClearAttribute(strFolder As String, fIncludeSubfolders As Boolean, oldAttribute As VbFileAttribute) As Long
    Dim fld As Scripting.Folder
    Dim subfld As Scripting.Folder
    Dim file As Scripting.file
    Dim lngCount As Long

    Set fld = fso.GetFolder(strFolder)

    For Each file In fld.Files
        If file.Attributes And oldAttribute Then
            file.Attributes = file.Attributes And Not oldAttribute
            ' Count the files
            lngCount = lngCount + 1
        End If
    Next file

    If fIncludeSubfolders Then
        For Each subfld In fld.SubFolders
            ' Add total from this subfolder
            ' And its subfolders
            lngCount = lngCount + ClearAttribute(subfld.Path, True, oldAttribute)
        Next subfld
    End If

    ' Number of total processed files
    ClearAttribute = lngCount
End Function


�Hans Weichselbaumer, Passau, Germany


c0Title: Convert Short Filename Into Long Filename
c1Code:
You can use the Dir( ) function to return a long filename, but the return does not include path information. By parsing a given short path/filename into its constituent directories, you can use the Dir( ) function to build a long path/filename with 32-bit versions of VB, without the assistance of APIs:

Public Function GetLongFilename(ByVal sShortName As String) As String
    Dim sLongName As String
    Dim sTemp As String
    Dim iSlashPos As Integer

    ' Add \ to short name to prevent Instr from failing sShortName = sShortName & "\"
    ' Start from 4 to ignore the "[Drive
    ' Letter]:\" characters
    iSlashPos = InStr(4, sShortName, "\")

    ' Pull out each string between \ character for conversion 
    Do While iSlashPos 
        sTemp = Dir(Left$(sShortName, iSlashPos - 1), vbNormal Or vbHidden Or vbSystem Or vbDirectory)
        If sTemp = "" Then 
            ' Error 52 - Bad File Name or Number 
            GetLongFilename = ""
            Exit Function
        End If

        sLongName = sLongName & "\" & sTemp
        iSlashPos = InStr(iSlashPos + 1, sShortName, "\") 
    Loop 

    ' Prefix with the drive letter 
    GetLongFilename = Left$(sShortName, 2) & sLongName 
End Function 

'From any place, add this line
GetLongFilename("C:\PROGRA~1\COMMON~1")


This function, as written, expects a standard fully qualified, drive-based filespec.

�Alex Leyfman, Brooklyn, New York


c0Title: Copy/Delete/Move/Rename Files & Folders via Windows API. Uses Recycle Bin
c1Code:
Add the following objects to a new project:

      Name Value Description 
      FO_COPY &H2 Copies a file or folder 
      FO_DELETE &H3 Deletes a file or folder 
      FO_MOVE &H1 Moves a file or folder 
      FO_RENAME &H4 Renames a file or folder 
      FOF_ALLOWUNDO &H40 Used with Rename. When used with Delete the files get sent to the Recycle Bin. 
      FOF_FILESONLY &H80 Only allows files. 
      FOF_NOCONFIRMATION &H10 Does not display the Delete or Overwrite confirmation dialog. 
      FOF_SILENT &H4 Does not display the Windows animation while performing the opperation. 
      FOF_SIMPLEPROGRESS &H100 Does not display filenames. 


Add the following to a new module:

Public Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As Long ' only used if FOF_SIMPLEPROGRESS, sets dialog title
End Type

Public Const FO_COPY = &H2 ' Copy File/Folder
Public Const FO_DELETE = &H3 ' Delete File/Folder
Public Const FO_MOVE = &H1 ' Move File/Folder
Public Const FO_RENAME = &H4 ' Rename File/Folder
Public Const FOF_ALLOWUNDO = &H40 ' Allow to undo rename, delete ie sends to recycle bin
Public Const FOF_FILESONLY = &H80  ' Only allow files
Public Const FOF_NOCONFIRMATION = &H10  ' No File Delete or Overwrite Confirmation Dialog
Public Const FOF_SILENT = &H4 ' No copy/move dialog
Public Const FOF_SIMPLEPROGRESS = &H100 ' Does not display file names

Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
                        (lpFileOp As SHFILEOPSTRUCT) As Long


This will copy c:\backup to c:\backup2 and will not show filenames:

Dim op As SHFILEOPSTRUCT
With op
    .wFunc = FO_COPY ' Set function
    .pTo = "C:\backup2" ' Set new path
    .pFrom = "C:\backup" ' Set current path
    .fFlags = FOF_SIMPLEPROGRESS
End With
' Perform operation
SHFileOperation op


Not all functions require all the parameters. When you delete a file you do not need to specify the pTo parameter. This example sends the file c:\temp.txt to the recycle bin:

Dim op As SHFILEOPSTRUCT
With op
    .wFunc = FO_DELETE ' Set function
    .pFrom = "C:\temp.txt" ' Set File to delete
    .fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION ' Set Flags
End With
' Perform operation
SHFileOperation op


c0Title: Create A Full Directory Path
c1Code:
Use the following to create an entire directory path with one line of code! The IMAGEHLP.DLL comes with Win95 and WinNT.

Private Declare Function MakeSureDirectoryPathExists Lib "IMAGEHLP.DLL" (ByVal DirPath As String) As Long

Public Sub CreatePath(ByVal DestPath As String)

    If Right(DestPath, 1) <> "\" Then
        DestPath = DestPath & "\"
    End If

    If MakeSureDirectoryPathExists(DestPath) = 0 Then
        MsgBox "Error creating path: " & DestPath
    End If
End Sub


Tip Submitted By: Kevin Buchan


c0Title: Delete An Entire Directory Tree
c1Code:
This routine was developed in response to the numerous cries for a "DELTREE" like command for Visual Basic. It effectively deletes an entire directory tree reguardless of the attributes of the files and directories it contains. It requires a simple subroutine (included here) that comes with the Setup Wizard (AddDirSep). This small routine eliminates the need to provide a trailing back-slash at the end of a path name.

'******************************************************************************
'Deletes an entire directory tree reguardless of the file attributes
' of the specified directory's contents.
'Requirements: This routine requires a small routine named AddDirSep
' Which is found in the Microsoft Setup Wizard.
' IN: [inPath] - Full pathname of the directory tree to be removed.
'******************************************************************************
Sub FPDeleteTree(inPath As String)

    'Define the temporary variables
    Dim tmpPath As String, curPath As String
    Dim tmpFileName As String

    'Preserve the Specified path by copying it to another variable.
    curPath = inPath: AddDirSep curPath

    'Delete all files in the specified directory reguardless of their attributes.
    tmpFileName = Dir(curPath, vbNormal + vbHidden + vbSystem)

    Do While Not tmpFileName = ""
        SetAttr curPath & tmpFileName, vbNormal
        Kill curPath & tmpFileName
        tmpFileName = Dir
    Loop

    'Systematically cycle through the subdirectories and delete them
    ' and their contents.

    tmpPath = Dir(curPath, vbDirectory)

    Do While tmpPath = "." Or tmpPath = ".."
        tmpPath = Dir
    Loop

    Do While Not tmpPath = ""
        curPath = curPath & tmpPath
        AddDirSep curPath
        tmpFileName = Dir(curPath, vbNormal + vbHidden + vbSystem)

        Do While Not tmpFileName = ""
            SetAttr curPath & tmpFileName, vbNormal
            Kill curPath & tmpFileName
            tmpFileName = Dir
        Loop

        tmpPath = Dir(curPath, vbDirectory)

        Do While tmpPath = "." Or tmpPath = ".."
            tmpPath = Dir
        Loop

        If tmpPath = "" Then
            RmDir curPath
            curPath = inPath
            AddDirSep curPath
            tmpPath = Dir(curPath, vbDirectory)

            Do While tmpPath = "." Or tmpPath = ".."
                tmpPath = Dir
            Loop
        End If
    Loop

    AddDirSep inPath
    RmDir inPath
End Sub

'******************************************************************************
' SUB: AddDirSep
'******************************************************************************
' Add a trailing directory path separator (back slash) to the
' end of a pathname unless one already exists
' IN/OUT: [strPathName] - path to add separator to
'******************************************************************************
Sub AddDirSep(strPathName As String)
    If Right$(RTrim$(strPathName), Len(gstrSEP_DIR)) <> gstrSEP_DIR Then
        strPathName = RTrim$(strPathName) & gstrSEP_DIR
    End If
End Sub


Tip Submitted By: Fine Point Technologies


c0Title: Determine the File System Type
c1Code:
With the advent of the FAT32 file system, you might want to use VB to determine the type of file system being used for a particular drive. This example is set for the C drive; change the variable sDrive to test other drives. Run this routine; the variable sResult contains the file system name string:

Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Public Function WhichFileSystem(ByVal Drive As String) As String
       Dim sVolBuf As String * 255
       Dim sSysName As String * 255
       Dim lSerialNum As Long
       Dim lSysFlags As Long
       Dim lComponentLength As Long
       Dim lRes As Long

       lRes = GetVolumeInformation(Drive, sVolBuf, 255, lSerialNum, lComponentLength, lSysFlags, sSysName, 255)

       If lRes Then
              WhichFileSystem = Left$(sSysName, InStr(sSysName, Chr$(0)) - 1)
       Else
              WhichFileSystem = "<unknown>"
       End If
End Function


�Dan Verkade, Perris, California


c0Title: Directory Change Notification
c2File: DirMon.zip
c1Code:
This COM object uses the FindFirstChangeNotification family of API functions to fire off a notification when any file in a selected directory is changed. Designed primary to be used in Visual Basic, it encapsulates all of the thread work, so that an application can receive instantaneous notification of change without having to poll a directory, or the wait object that this API creates.

This zip file contains the OCX file, as well as a sample project. Read the readme.txt file for information on both.


c0Title: Dragging A Form Or Control
c1Code:
Here�s an easy way to let users move forms or controls around at runtime. Unlike other techniques that require capturing the mouse, moving the control or form as the mouse moves, and releasing the mouse when its button is no longer pressed, this technique requires only two simple API calls.

Declarations:

Declare Sub ReleaseCapture Lib "User" ()
Declare Sub SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Long)

Const WM_SYSCOMMAND = &H112
Const SC_MOVE = &HF012


Put the following lines in the MouseDown procedure of whatever form or control you want to allow the user to drag:

ReleaseCapture
SendMessage Thing.hWnd, WM_SYSCOMMAND, SC_MOVE, 0


This tip is reprinted from the VB Tips & Tricks Volume 1 book.
Parts of this tip was submitted by: Mani Visweswaran


c0Title: Copying the desktop image to a Form
c1Code:
Add the following code to a module:

Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal xSrc As Integer, ByVal ySrc As Integer, ByVal dwRop As Long) As Integer

Declare Function GetDesktopWindow Lib "user32" () As Long

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Public Const SRCCOPY = &HCC0020
Public Const SRCAND = &H8800C6
Public Const SRCINVERT = &H660046
}}
Form Code

Set the Form properties to the following:
{{{
AutoRedraw True 
BorderStyle 0 - None 
WindowState 2 - Maximized 


Now, add the following code to the form:

Private Sub Form_Load()
    Dim DeskhWnd As Long, DeskDC As Long

    'Get the hWnd of the desktop
    DeskhWnd& = GetDesktopWindow()

    'BitBlt needs the DC to copy the image. So, we need the GetDC API.
    DeskDC& = GetDC(DeskhWnd&)

    BitBlt Form1.hDC, 0&, 0&, _
    Screen.Width, Screen.Height, DeskDC&, 0&, 0&, SRCCOPY
End Sub


Add a command button to the form with following code:

Private Sub Command1_Click()
    Unload Me
    End
End Sub


Tip by Wolfgang


c0Title: Clear Form�s Controls With Quick Loop
c1Code:
This code allows you to set a form�s controls to a specific value. You can use it, for example, when you want to clear all textboxes in a form or when you want to uncheck all checkboxes:

Public Sub Clear(frm As Form)
    Dim ctl As Control
    For Each ctl In frm
        Select Case TypeName(ctl)
        Case "TextBox"
            ctl.Text = ""
        Case "CheckBox"
            ctl.Value = vbUnchecked
        Case Else
            ' handle others as needed
       End Select
    Next ctl
End Sub


�Daniel Augusto Ram�rez Villasana, M�xico City, M�xico


c0Title: Capture Reference to UserControl
c1Code:
Many programmers are familiar with declaring an object variable in class modules and other places to capture events from a form and handle them in a generic way:

Private WithEvents m_Form As Form


It might be useful to do this for user controls as well, but you need a reference to the UserControl object. Getting this reference proves harder than it should be. This code sets up the

m_UserControl

variable:

' Declarations
Private WithEvents m_UserControl As UserControl Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

Private Sub UserControl_Initialize()
	' Code to set up the m_UserControl variable
	Dim UC As UserControl
	CopyMemory UC, UserControl, 4
	Set m_UserControl = UC
	CopyMemory UC, 0&, 4
End Sub


Once this code has been executed, the

m_UserControl

events fire as expected. Using this technique and sharing the created reference, you can sink the UserControl events in a class module, allowing development of generic event handlers for your controls.

�Jeremy Adams, Tiverton, Devon, England


c0Title: Adding Simple Controls at Runtime
c1Code:
The withevents keyword is used in this example, since it is necessary to be able to trap any events the user generates from these controls.

Add a CommandButton to a form and call it Command1, then paste this code to the form and try running it. When the command button is pressed a new CommandButton and Textbox should be created at runtime and displayed.

Dim WithEvents cmdNewButton As VB.CommandButton Dim WithEvents txtNewTextbox As VB.TextBox

Private Sub Command1_Click()
    `Add a command button
    Set cmdNewButton = Controls.Add("VB.CommandButton", "cmdNewButton", Me)
    cmdNewButton.Move 0, 0
    cmdNewButton.Visible = True

    `Add a Textbox    
    Set txtNewTextbox = Controls.Add("VB.TextBox", "txtNewTextBox", Me)
    txtNewTextbox.Move 500, 500, 1000, 1000
    txtNewTextbox.Visible = True
End Sub


c0Title: Adding Simple Controls at Runtime With Events
c1Code:
Add 2 CommandButtons to a form (Command1 and Command2), then paste this code to the form and try running it. When Command1 is pressed, a new Textbox will be created at runtime and displayed. When Command2 is pressed, the textbox will be removed.

Events can be added as usual for the new control. The change event is shown below.

Dim WithEvents txtNewTextbox As VB.TextBox

Private Sub Command1_Click()
    'Add a Textbox    
    Set txtNewTextbox = Controls.Add("VB.TextBox", "txtNewTextBox", Me)
    txtNewTextbox.Move 500, 500, 1000, 1000
    txtNewTextbox.Visible = True
End Sub

Private Sub Command2_Click()
    Controls.Remove txtnewtextbox
    Set txtnewtextbox = Nothing
End Sub

Private Sub txtnewtextbox_Change()
 MsgBox "new textbox change event"
End Sub


c0Title: A better way to lock controls for faster updates
c1Code:
A while back I posted at tip showing you how to lock controls and make the stop repainting. This tip used the LockWindowUpdate Function which has a big drawback. It can only lock one object at a time.

This tip will do the same but in multiple windows. It uses a different approach. It uses the SendMessage function to send the

WM_SETREDRAW

to the control. This message sets or clears the redraw flag. If the redraw flag is cleared, the content of the given window is not updated after each change, and the window is not repainted until the redraw flag is set. For example, an application that must add several items to a list box can clear the redraw flag, add the items, and then set the redraw flag. The good thing about this approach is that you can lock multiple windows/controls at one time.

Thanks to Paul Holden for submitting this tip.

Add this code to a form or module:

Option Explicit

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
        ByVal lParam As Long) As Long
                   
Private Const WM_SETREDRAW = &HB
Public Function LockControl(objX As Object, cLock As Boolean)

   Dim i As Long
   
   If cLock Then
      ' Disable the Redraw flag for the specified window
      Call SendMessage(objX.hwnd, WM_SETREDRAW, False, 0)
   Else
      ' Enable the Redraw flag for the specified window, and repaint
      Call SendMessage(objX.hwnd, WM_SETREDRAW, True, 0)
      objX.Refresh
   End If

End Function
'-- End --'


To use the code add this line anywhere you wish to stop/start redrawing in a window:

   ' This will stop the Window redrawing
   LockControl Text1.hWnd, True

   ' Start redrawing the window again.
   LockControl Text1.hWnd, False
.. This will make the object named Text1 stop and start repainting.


c0Title: Adding Items To the ControlBox Menu
c1Code:
Need to add items to your ControlBox menu of your program? Well it's very easy if you implement subclassing in VB5 or VB6. The following code will add an "About" menu item.

Declare

Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Const WM_SYSCOMMAND = &H112
Public Const MF_SEPARATOR = &H800&
Public Const MF_STRING = &H0&
Public Const GWL_WNDPROC = (-4)
Public Const IDM_ABOUT As Long = 1010
Public lProcOld As Long


Code

In your module put:

Public Function SysMenuHandler(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    If iMsg = WM_SYSCOMMAND Then

        If wParam = IDM_ABOUT Then

            MsgBox "Subclassing works"
            Exit Function

        End If

    End If

 

    'Important to call original message handler!
    'Your app may not be the only subclasser around...
    SysMenuHandler = CallWindowProc(lProcOld, hWnd, iMsg, wParam, lParam)

End Function

In your Form put:

Private Sub Form_Load()

Dim lSysMenu As Long
Dim lRet As Long

    lSysMenu = GetSystemMenu(hWnd, 0&)
    lRet = AppendMenu(lSysMenu, MF_SEPARATOR, 0&, vbNullString)

    lRet = AppendMenu(lSysMenu, MF_STRING, IDM_ABOUT, "About...")

    Me.Show

    lProcOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SysMenuHandler)

End Sub

Private Sub Form_Unload(Cancel As Integer)

    'Set back control to original message handler, or you
    'will experience the mother of all crashes!

    SetWindowLong Me.hWnd, GWL_WNDPROC, lProcOld

End Sub


REMEMBER to not terminate your program with an End statement. You must unload it properly, like above. 


c0Title: Autosizing Combo Boxes
c1Code:
Are you combo boxes never wide enough? Do they always cut off the end of your list items?

Never fear - here to help is our handy code snippet. This beast will automatically size your combo box to the widest item within it. It even takes into account special fonts and bold text!

Just run the AutosizeCombo function, passing in your combo as an argument. It returns a True or False value dependant on success.

Sample Usage

x = AutosizeCombo(Combo1)


Code

Option Explicit

Private Const CB_SETDROPPEDWIDTH = &H160 Private Const CB_GETDROPPEDWIDTH = &H15F Private Const DT_CALCRECT = &H400

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function SendMessageLong Lib "user32" Alias _
        "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, ByVal lparam As Long) As Long

Private Declare Function DrawText Lib "user32" Alias _
    "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, _
    ByVal nCount As Long, lpRect As RECT, ByVal wFormat _
    As Long) As Long

Public Function AutosizeCombo(Combo As ComboBox) As Boolean
    
    'Automatically sizes a combo box to
    'hold the longest item within it

    Dim lngRet As Long
    Dim lngCurrentWidth As Single
    Dim rectCboText As RECT
    Dim lngParentHDC As Long
    Dim lngListCount As Long
    Dim lngCounter As Long
    Dim lngTempWidth As Long
    Dim lngWidth As Long
    Dim strSavedFont As String
    Dim sngSavedSize As Single
    Dim blnSavedBold As Boolean
    Dim blnSavedItalic As Boolean
    Dim blnSavedUnderline As Boolean
    Dim blnFontSaved As Boolean

On Error GoTo ErrorHandler

    'Grab the combo handle and list count

    lngParentHDC = Combo.Parent.hdc
    lngListCount = Combo.ListCount

    If lngParentHDC = 0 Or lngListCount = 0 Then Exit Function

    'Save combo box fonts, etc. to the parent
    'object (form), for testing lengths with the API

    With Combo.Parent

        strSavedFont = .FontName
        sngSavedSize = .FontSize
        blnSavedBold = .FontBold
        blnSavedItalic = .FontItalic
        blnSavedUnderline = .FontUnderline
        
        .FontName = Combo.FontName
        .FontSize = Combo.FontSize
        .FontBold = Combo.FontBold
        .FontItalic = Combo.FontItalic
        .FontUnderline = Combo.FontItalic

    End With

    blnFontSaved = True

    'Get the width of the widest item

    For lngCounter = 0 To lngListCount
       DrawText lngParentHDC, Combo.List(lngCounter), -1, rectCboText, _
            DT_CALCRECT

        'Add twenty to the the number as a margin
       lngTempWidth = rectCboText.Right - rectCboText.Left + 20

        If (lngTempWidth > lngWidth) Then
           lngWidth = lngTempWidth
        End If

    Next
 
    'Get current width of combo
 
    lngCurrentWidth = SendMessageLong(Combo.hwnd, CB_GETDROPPEDWIDTH, _
        0, 0)

    'If big enough then that's all A-OK
    If lngCurrentWidth > lngWidth Then

        AutosizeCombo = True
        GoTo ErrorHandler
        Exit Function
    
    End If
 
    '... but if not big enough, first calculate
    'the screen width to ensure we don't exceed it!
 
    If lngWidth > Screen.Width \ Screen.TwipsPerPixelX - 20 Then _
        lngWidth = Screen.Width \ Screen.TwipsPerPixelX - 20

    'Set the width of our combo
    lngRet = SendMessageLong(Combo.hwnd, CB_SETDROPPEDWIDTH, lngWidth, 0)

    'Set the function to True/False depending on API success
    AutosizeCombo = lngRet > 0
    
ErrorHandler:
        
    'If anything goes wrong, revert back!
    
    On Error Resume Next
    
    If blnFontSaved Then
      With Combo.Parent
        .FontName = strSavedFont
        .FontSize = sngSavedSize
        .FontUnderline = blnSavedUnderline
        .FontBold = blnSavedBold
        .FontItalic = blnSavedItalic
     End With
    End If

End Function


Tip by Karl Moore


c0Title: Account for Taskbars When Centering Forms
c1Code:
Most VB programmers must display a form centered on a screen. You can do this in a variety of ways, but most ignore aspects of the environment such as the taskbar or the office launchbar. This function takes these aspects into account to center a form within the client area perfectly:

 
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17
Public Sub CenterForm(Frm As Form)
       Dim Left As Long, Top As Long
       Left = (Screen.TwipsPerPixelX _
             * (GetSystemMetrics(SM_CXFULLSCREEN) / 2)) - _
             (Frm.Width / 2)
       Top = (Screen.TwipsPerPixelY * _
              (GetSystemMetrics(SM_CYFULLSCREEN) / 2)) - _
             (Frm.Height / 2)
       Frm.Move Left, Top
End Sub


�Konstantin Komissarchik, Brier, Washington


c0Title: Activate Currently Running Instance
c1Code:
This code will activate the running instance of the program. To use this technique you must know the Caption of the program�s main Form.

If App.PrevInstance Then
     AppActivate "MyApp Version 1.0"
     End
End If


c0Title: Always On Top Forms
c1Code:
This small demonstration shows how to make a form 'always on top', so that other windows do not obscure it. To use just place this code in a standard form.

Code:

Option Explicit

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const HWND_TOPMOST = -1

Private Sub Form_Resize()

SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE

End Sub


c0Title: Center Your Logo on MDI Forms
c1Code:
You can display a logo in the middle of your MDI form. The logo stays in the middle even when the MDI form is resized. After creating your own MDI form, add a standard form to your project and put an Image control named imgLogo on it. Instead of the Image control, you can use a Label control or whatever you want.
The standard form (frmLogo) should have these properties set:

PROPERTIES of frmLogo:

MDIChild = True
BorderStyle = 0 - None


Then put this code in your MDI form Resize event:

Private Sub MDIForm_Resize()
    ' Now center the frmLogo form in your MDI form 
    frmLogo.Left = (Me.ScaleWidth - frmLogo.Width) / 2 
    frmLogo.Top = (Me.ScaleHeight - frmLogo.Height) / 2 
End Sub 


Put this code in the logo form�s Activate and Resize events:

Private Sub Form_Activate()
    ' Force logo to background
    Me.ZOrder vbSendToBack
End Sub

Private Sub Form_Resize()
    ' Move logo to upper-left
    imgLogo.Move 0, 0
    ' The next fragment makes frmLogo's
    ' Width and Height equal to imgLogo's
    ' Width and Height
    Me.Width = imgLogo.Width
    Me.Height = imgLogo.Height
End Sub


Load and show the logo form during the MDI form�s Load event:

Private Sub MDIForm_Load()
    frmLogo.Show
End Sub


�Pavel Tsekov, Varna, Bulgaria


