Writing software is my daily job since several years, but at at the same time it's still a hobby for me. Most of the applications i made, were written in Borland Delphi, i like the cleanness and consistence of this language.
Very often programmers stumble across the same problems, sometimes depending on the programming environment. To prevent myself from doing it more than once with the same problem, i decided to start this page with some code snippets and share it with other peoples with the same interests. The functions are all free and tested and most of them are written by myself. You can use them in your own applications, but this shouldn't prevent you from understanding what the code does ;-).
If you should have problems, questions or suggestions about the functions below, or if you simply find them useful, don't hesitate to send me an email to .
To get the filename of the application, most of the time you can call:
sFileName := Application.ExeName;
// or
sFileName := ParamStr(0);
Perhaps you are working on a DLL and are interested in the filename of the DLL rather than the filename of the application, then you can use this function:
uses SysUtils; sFileName := GetModuleName(HInstance); // returns the Dll name sFileName := GetModuleName(0); // returns the Exe name
With this function you can get the version of a file, which contains a version resource. This way you can display the version number of your application in an information dialog. To include a version resource to your Delphi application, set the "Versioninfo" in the project options.
uses Windows, SysUtils; /// <summary> /// This function reads the file resource of "FileName" and returns /// the version number as formatted text.</summary> /// <example> /// Sto_GetFmtFileVersion() = '4.13.128.0' /// Sto_GetFmtFileVersion('', '%.2d-%.2d-%.2d') = '04-13-128' /// </example> /// <remarks>If "Fmt" is invalid, the function may raise an /// EConvertError exception.</remarks> /// <param name="FileName">Full path to exe or dll. If an empty /// string is passed, the function uses the filename of the /// running exe or dll.</param> /// <param name="Fmt">Format string, you can use at most four integer /// values.</param> /// <returns>Formatted version number of file, '' if no version /// resource found.</returns> function Sto_GetFmtFileVersion(const FileName: String = ''; const Fmt: String = '%d.%d.%d.%d'): String; var sFileName: String; iBufferSize: DWORD; iDummy: DWORD; pBuffer: Pointer; pFileInfo: Pointer; iVer: array[1..4] of Word; begin // set default value Result := ''; // get filename of exe/dll if no filename is specified sFileName := FileName; if (sFileName = '') then begin // prepare buffer for path and terminating #0 SetLength(sFileName, MAX_PATH + 1); SetLength(sFileName, GetModuleFileName(hInstance, PChar(sFileName), MAX_PATH + 1)); end; // get size of version info (0 if no version info exists) iBufferSize := GetFileVersionInfoSize(PChar(sFileName), iDummy); if (iBufferSize > 0) then begin GetMem(pBuffer, iBufferSize); try // get fixed file info (language independent) GetFileVersionInfo(PChar(sFileName), 0, iBufferSize, pBuffer); VerQueryValue(pBuffer, '\', pFileInfo, iDummy); // read version blocks iVer[1] := HiWord(PVSFixedFileInfo(pFileInfo)^.dwFileVersionMS); iVer[2] := LoWord(PVSFixedFileInfo(pFileInfo)^.dwFileVersionMS); iVer[3] := HiWord(PVSFixedFileInfo(pFileInfo)^.dwFileVersionLS); iVer[4] := LoWord(PVSFixedFileInfo(pFileInfo)^.dwFileVersionLS); finally FreeMem(pBuffer); end; // format result string Result := Format(Fmt, [iVer[1], iVer[2], iVer[3], iVer[4]]); end; end;
For starting an external application, you can use the WindowsAPI function ShellExecute.
Often it is better to pass nil (instead of 'open') as the operation keyword, Windows will then use the default keyword, or 'open' if the default keyword is not defined. With nil it works like a doubleclick in the explorer.
uses ShellApi; ShellExecute(0, nil, 'calc.exe', '', '', SW_SHOWNORMAL);
Sometimes you need more control over the starting process, perhaps you want to wait until the process has finished or you need the exit code of the application.
uses Windows, ShellApi; /// <summary> /// Executes an external program or opens a document with its /// standard application.</summary> /// <param name="FileName">Full path of application or document.</param> /// <param name="Parameters">Command line arguments.</param> /// <param name="ExitCode">Exitcode of application (only avaiable /// if Wait > 0).</param> /// <param name="Wait">[milliseconds] Maximum of time to wait, /// until application has finished. After reaching this timeout, /// the application will be terminated and False is returned as /// result. 0 = don't wait on application, return immediately.</param> /// <param name="Hide">If True, application runs invisible in the /// background.</param> /// <returns>True if application could be started successfully, False /// if app could not be started or timeout was reached.</returns> function Sto_ShellExecute(const FileName, Parameters: String; var ExitCode: DWORD; const Wait: DWORD = 0; const Hide: Boolean = False): Boolean; var myInfo: SHELLEXECUTEINFO; iWaitRes: DWORD; begin // prepare SHELLEXECUTEINFO structure ZeroMemory(@myInfo, SizeOf(SHELLEXECUTEINFO)); myInfo.cbSize := SizeOf(SHELLEXECUTEINFO); myInfo.fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_NO_UI; myInfo.lpFile := PChar(FileName); myInfo.lpParameters := PChar(Parameters); if Hide then myInfo.nShow := SW_HIDE else myInfo.nShow := SW_SHOWNORMAL; // start file ExitCode := 0; Result := ShellExecuteEx(@myInfo); // if process could be started if Result then begin // wait on process ? if (Wait > 0) then begin iWaitRes := WaitForSingleObject(myInfo.hProcess, Wait); // timeout reached ? if (iWaitRes = WAIT_TIMEOUT) then begin Result := False; TerminateProcess(myInfo.hProcess, 0); end; // get the exitcode GetExitCodeProcess(myInfo.hProcess, ExitCode); end; // close handle, because SEE_MASK_NOCLOSEPROCESS was set CloseHandle(myInfo.hProcess); end; end;
To wait until the application has been started (instead of finished), replace "WaitForSingleObject" with "WaitForInputIdle".
Most console applications send their output to the stdoutput and stderror devices and these are normally connected to the display. You can start such an application and capture its output, to read and interpret it in your own application. To avoid the disadvantages of the filesystem and permission problems, it's best to redirect to pipes and read from them.
For a full example, of how to start the "cmd.exe" and using input pipe as well as output pipes, you can download this small example project StoRedirectedExecute.zip.
uses Windows, Classes;
type
TStoReadPipeThread = class(TThread)
protected
FPipe: THandle;
FContent: TStringStream;
function Get_Content: String;
procedure Execute; override;
public
constructor Create(const Pipe: THandle);
destructor Destroy; override;
property Content: String read Get_Content;
end;
constructor TStoReadPipeThread.Create(const Pipe: THandle);
begin
FPipe := Pipe;
FContent := TStringStream.Create('');
inherited Create(False); // start immediately
end;
destructor TStoReadPipeThread.Destroy;
begin
FContent.Free;
inherited Destroy;
end;
procedure TStoReadPipeThread.Execute;
const
BLOCK_SIZE = 4096;
var
iBytesRead: DWORD;
myBuffer: array[0..BLOCK_SIZE-1] of Byte;
begin
repeat
// try to read from pipe
if ReadFile(FPipe, myBuffer, BLOCK_SIZE, iBytesRead, nil) then
FContent.Write(myBuffer, iBytesRead);
// a process may write less than BLOCK_SIZE, even if not at the end
// of the output, so checking for < BLOCK_SIZE would block the pipe.
until (iBytesRead = 0);
end;
function TStoReadPipeThread.Get_Content: String;
begin
Result := FContent.DataString;
end;
/// <summary>
/// Runs a console application and captures the stdoutput and
/// stderror.</summary>
/// <param name="CmdLine">The commandline contains the full path to
/// the executable and the necessary parameters.
/// <param name="Output">Receives the console stdoutput.</param>
/// <param name="Error">Receives the console stderror.</param>
/// <param name="Wait">[milliseconds] Maximum of time to wait,
/// until application has finished. After reaching this timeout,
/// the application will be terminated and False is returned as
/// result.</param>
/// <returns>True if process could be started and did not reach the
/// timeout.</returns>
function Sto_RedirectedExecute(CmdLine: String;
var Output, Error: String; const Wait: DWORD = 3600000): Boolean;
var
mySecurityAttributes: SECURITY_ATTRIBUTES;
myStartupInfo: STARTUPINFO;
myProcessInfo: PROCESS_INFORMATION;
hPipeOutputRead, hPipeOutputWrite: THandle;
hPipeErrorRead, hPipeErrorWrite: THandle;
myReadOutputThread: TStoReadPipeThread;
myReadErrorThread: TStoReadPipeThread;
iWaitRes: Integer;
begin
// prepare security structure
ZeroMemory(@mySecurityAttributes, SizeOf(SECURITY_ATTRIBUTES));
mySecurityAttributes.nLength := SizeOf(SECURITY_ATTRIBUTES);
mySecurityAttributes.bInheritHandle := TRUE;
// create pipes to get stdoutput and stderror
CreatePipe(hPipeOutputRead, hPipeOutputWrite, @mySecurityAttributes, 0);
CreatePipe(hPipeErrorRead, hPipeErrorWrite, @mySecurityAttributes, 0);
// prepare startupinfo structure
ZeroMemory(@myStartupInfo, SizeOf(STARTUPINFO));
myStartupInfo.cb := Sizeof(STARTUPINFO);
// hide application
myStartupInfo.dwFlags := STARTF_USESHOWWINDOW;
myStartupInfo.wShowWindow := SW_HIDE;
// assign pipes
myStartupInfo.dwFlags := myStartupInfo.dwFlags or STARTF_USESTDHANDLES;
myStartupInfo.hStdInput := 0;
myStartupInfo.hStdOutput := hPipeOutputWrite;
myStartupInfo.hStdError := hPipeErrorWrite;
// since Delphi calls CreateProcessW, literal strings cannot be used anymore
UniqueString(CmdLine);
// start the process
Result := CreateProcess(nil, PChar(CmdLine), nil, nil, True,
CREATE_NEW_CONSOLE, nil, nil, myStartupInfo, myProcessInfo);
// close the ends of the pipes, now used by the process
CloseHandle(hPipeOutputWrite);
CloseHandle(hPipeErrorWrite);
// could process be started ?
if Result then
begin
myReadOutputThread := TStoReadPipeThread.Create(hPipeOutputRead);
myReadErrorThread := TStoReadPipeThread.Create(hPipeErrorRead);
try
// wait unitl there is no more data to receive, or the timeout is reached
iWaitRes := WaitForSingleObject(myProcessInfo.hProcess, Wait);
// timeout reached ?
if (iWaitRes = WAIT_TIMEOUT) then
begin
Result := False;
TerminateProcess(myProcessInfo.hProcess, UINT(ERROR_CANCELLED));
end;
// return output
myReadOutputThread.WaitFor;
Output := myReadOutputThread.Content;
myReadErrorThread.WaitFor;
Error := myReadErrorThread.Content;
finally
myReadOutputThread.Free;
myReadErrorThread.Free;
CloseHandle(myProcessInfo.hThread);
CloseHandle(myProcessInfo.hProcess);
end;
end;
// close our ends of the pipes
CloseHandle(hPipeOutputRead);
CloseHandle(hPipeErrorRead);
end;
Each "ReadFile" operation on a pipe will block, until there is either data to read, or the handle of the pipe is closed (no more data). An application who sends data to the pipe will fill up the buffer and block until someone reads the data at the other end of the pipe. This means, if we read more than one pipe, each pipe can block the others, so for a safe implementation we have to use threads to read the pipes.
For creating a link in your application, e.g. on the info dialog, you can use the following procedures.
uses ShellApi, SysUtils; function Sto_UrlEncode(const Text: String): String; var iPos: Integer; cCharacter: Char; begin Result := Text; // search for not web save characters for iPos := Length(Result) downto 1 do begin cCharacter := Result[iPos]; if (not (cCharacter in ['A'..'Z', 'a'..'z', '0'..'9'])) then begin Delete(Result, iPos, 1); Insert('%' + IntToHex(Ord(cCharacter), 2), Result, iPos); end; end; end; procedure Sto_OpenMail(const Address: String; const Subject: String = ''; const Body: String = ''; const Cc: String = ''; const Bcc: String = ''); var slParameters: TStrings; sMailCommand: String; iParameter: Integer; begin slParameters := TStringList.Create; try if (Subject <> '') then slParameters.Add('subject=' + Sto_UrlEncode(Subject)); if (Body <> '') then slParameters.Add('body=' + Sto_UrlEncode(Body)); if (Cc <> '') then slParameters.Add('cc=' + Cc); if (Bcc <> '') then slParameters.Add('bcc=' + Bcc); // bring parameters into a form like: // mailto:<address>?subject=<subjectline>&body=<mailtext>&cc=<address>&bcc=<address> sMailCommand := 'mailto:' + Address; for iParameter := 0 to slParameters.Count - 1 do begin if (iParameter = 0) then sMailCommand := sMailCommand + '?' else sMailCommand := sMailCommand + '&'; sMailCommand := sMailCommand + slParameters.Strings[iParameter]; end; ShellExecute(0, 'open', PChar(sMailCommand), nil, nil, SW_SHOWNORMAL); finally slParameters.Free; end; end; procedure Sto_OpenWebSite(const Site: String); begin ShellExecute(0, 'open', PChar(Site), nil, nil, SW_SHOWNORMAL); end;
To get the command line parameters passed at the application start, you can use the functions "ParamCount" and "ParamStr". The first parameter 0 contains the application filename, the same as you can get with "Application.ExeName".
//////////////////////////////////////////////////////////////// // in this example, the application was started with 3 // parameters ('Good', 'evening' and 'Delphi'). procedure Sto_CommandLineDemo; var iParamCount: Integer; sApplication: String; sParam1, sParam2, sParam3: String; begin iParamCount := ParamCount; // iParamCount = 3 sApplication := ParamStr(0); // sApplication = filename of application sParam1 := ParamStr(1); // sParam1 = 'Good' sParam2 := ParamStr(2); // sParam2 = 'evening' sParam3 := ParamStr(3); // sParam3 = 'Delphi' end;
If you need the complete command line (e.g. for a special parsing), then you can use the global variable "CmdLine" or the Windows API function "GetCommandLine" and get all parameters in one string.
There are several ways to load resources into your project, you could for example generate a compiled resource file (*.res) and include it to your project or you could load the ressource at runtime from a file. Both cases have drawbacks: to create a (*.res) file you need a tool like Delphi's image editor which is very limited, and loading the resource at runtime you have to deliver the resource file and make sure it exists when needed.
Fortunately there is an other method which can include resources from external files to your exe at compiletime. This example shows, how to include a cursor (sto_cursor.cur) to your project, in the example all files are placed in the Delphi project directory.
Now we have to fill the resource script, the example shows an include of the file (sto_cursor.cur). At the begin of the line has to be the id of the resource (my_cursor), it is defined by yourself. The id is followed by a keyword (CURSOR), which describes the type of the resource, and the third parameter is the filename.
my_cursor CURSOR "sto_cursor.cur"
After this is done, you can build your project and the resource will be compiled
(sto_cursor.res) and added to the exe. To display the new cursor, you first have to load the
resource. In the example, the unused cursor "crSqlWait" will be replaced by our cursor.
Normally you would have to unload a resource loaded with "LoadImage" but in this case
"Screen.Cursor" will handle this for you.
Note: the function "LoadCursor" has been superseded by "LoadImage".
const crMyCursor = crSqlWait; // replace an unneeded cursor procedure TForm1.FormCreate(Sender: TObject); begin // load the own cursor with id "my_cursor" and replace one of the existing cursors Screen.Cursors[crMyCursor] := LoadImage(HInstance, 'my_cursor', IMAGE_CURSOR, 0, 0, 0); end;
In a last step, you can show your cursor.
procedure TForm1.Button1Click(Sender: TObject); begin Screen.Cursor := crMyCursor; end; procedure TForm1.Button2Click(Sender: TObject); begin Screen.Cursor := crDefault; end;
You don't remember exactly the functionname, but you know there was a function...?
To get the short DOS filename, Delphi offers the function "ExtractShortPathName", to get the long filename from a DOS filename you can use the following function:
uses Windows, ShlObj, ActiveX; //////////////////////////////////////////////////////////////// // this function returns the long path from a short 8.3 DOS path. // if it was not possible to get the long path, the function gives // back "ShortPathName" as the result. function Sto_ExtractLongPathName(const ShortPathName: String): String; var bSuccess: Boolean; fncGetLongPathName: function (lpszShortPath: LPCTSTR; lpszLongPath: LPTSTR; cchBuffer: DWORD): DWORD stdcall; szBuffer: array[0..MAX_PATH] of Char; pDesktop: IShellFolder; swShortPath: WideString; iEaten: ULONG; pItemList: PItemIDList; iAttributes: ULONG; begin bSuccess := False; // try to use the function "GetLongPathNameA" (Win98/2000 and up) @fncGetLongPathName := GetProcAddress( GetModuleHandle('Kernel32.dll'), 'GetLongPathNameA'); if (Assigned(fncGetLongPathName)) then begin bSuccess := fncGetLongPathName(PChar(ShortPathName), szBuffer, SizeOf(szBuffer)) <> 0; if bSuccess then Result := szBuffer; end; // use an alternative way of getting the path (Win95/NT). the function // "SHGetFileInfo" (as often seen in examples) only converts the // filename without the path. if (not bSuccess) and Succeeded(SHGetDesktopFolder(pDesktop)) then begin swShortPath := ShortPathName; iAttributes := 0; if Succeeded(pDesktop.ParseDisplayName(0, nil, POLESTR(swShortPath), iEaten, pItemList, iAttributes)) then begin bSuccess := SHGetPathFromIDList(pItemList, szBuffer); if bSuccess then Result := szBuffer; // release ItemIdList (SHGetMalloc is superseded) CoTaskMemFree(pItemList); end; end; // give back the original path if unsuccessful if (not bSuccess) then Result := ShortPathName; end;
With this function you can receive the size of a file, it still works correctly with sizes larger than 2 GB.
uses SysUtils; //////////////////////////////////////////////////////////////// // this function determines the size of a file in bytes, the size // can be more than 2 GB. function Sto_GetFileSize(const FileName: String): Int64; var myFile: THandle; myFindData: TWin32FindData; begin // set default value Result := 0; // get the file handle. myFile := FindFirstFile(PChar(FileName), myFindData); if (myFile <> INVALID_HANDLE_VALUE) then begin Windows.FindClose(myFile); Int64Rec(Result).Lo := myFindData.nFileSizeLow; Int64Rec(Result).Hi := myFindData.nFileSizeHigh; end; end;
To browse for a file you can use the TOpenFile dialog, to browse for a directory there is a function "SelectDirectory". If you want to pre-select a node in the tree, don't use the "RootNode", use the "Directory" parameter instead. (Delphi6)
uses FileCtrl;
////////////////////////////////////////////////////////////////
// opens the directory browse dialog with a pre-selected node.
procedure TForm1.Button1Click(Sender: TObject);
var
sDirectory: String;
begin
sDirectory := 'C:\Program Files';
if SelectDirectory('Text above the tree', '', sDirectory) then
ShowMessage(sDirectory);
end;
"SHFileOperation" is a multipurpose function and can be used to copy, move, rename and delete files and directories. You can make use of the standard confirmation messages and the progress dialog of Windows.
uses SysUtils, ShellApi; //////////////////////////////////////////////////////////////// // - "Filenames" is a list of files and directories you want to delete. // the user will be asked for confirmation and the progress dialog will // be displayed if necessary. // - "ParentWindow" is the parent window for message boxes, you can pass "0". // after executing, you have to check, which files where really deleted, // because the user can cancel the deleting procedure. procedure Sto_DeleteFiles(const ParentWindow: HWND; const Filenames: TStrings; const ToRecycleBin: Boolean = True); var iFile: Integer; sFilenames: String; myFileOp: SHFILEOPSTRUCT; begin if (Filenames.Count = 0) then Exit; // create a #0 delimited string with two trailing #0 sFilenames := ''; for iFile := 0 to Filenames.Count - 1 do sFilenames := sFilenames + ExcludeTrailingPathDelimiter(Filenames.Strings[iFile]) + #0; sFilenames := sFilenames + #0; // prepare the SHFILEOPSTRUCT FillChar(myFileOp, SizeOf(myFileOp), 0); myFileOp.Wnd := ParentWindow; myFileOp.wFunc := FO_DELETE; myFileOp.pFrom := PChar(sFilenames); // could be moved to the recyclebin, even if "ToRecycleBin" is false. if ToRecycleBin then myFileOp.fFlags := myFileOp.fFlags or FOF_ALLOWUNDO; SHFileOperation(myFileOp); end;
You can use this code as a base to your own procedure, the procedure lists the content of a direcotry.
uses Classes, SysUtils; //////////////////////////////////////////////////////////////// // "Directory": will be searched for files and directories, the results will // be added with the full path to "List". directories are written with a // trailing "\" at the end. // "Mask": can contain one or several masks, delimited with a semikolon. to // ignore directory names, add an extension to the mask. for more detailed // information see the delphi function "FindFirst". // "Recursive": if true, subdirectories will be searched too. // "Append": if true, existing entries remain in "List". procedure Sto_SearchDirectory(List: TStrings; const Directory: String; const Mask: String = '*.*'; Recursive: Boolean = True; Append: Boolean = False); procedure _SearchDirectory(List: TStrings; const DelimitedDirectory: String; Masks: TStrings; Recursive: Boolean); var iMaskIndex: Integer; bFoundFile: Boolean; mySearchRec: TSearchRec; sFile, sDirectory: String; begin // list files and directories for iMaskIndex := 0 to Masks.Count - 1 do begin bFoundFile := FindFirst(DelimitedDirectory + Masks[iMaskIndex], faAnyFile, mySearchRec) = 0; while (bFoundFile) do begin // skip "." and ".." if (mySearchRec.Name <> '.') and (mySearchRec.Name <> '..') then begin sFile := DelimitedDirectory + mySearchRec.Name; // add delimiter to directories if ((mySearchRec.Attr and faDirectory) <> 0) then sFile := IncludeTrailingPathDelimiter(sFile); // add to list List.Add(sFile); end; // find next file bFoundFile := FindNext(mySearchRec) = 0; end; FindClose(mySearchRec); end; // recursive call for directories if (Recursive) then begin bFoundFile := FindFirst(DelimitedDirectory + '*', faDirectory, mySearchRec) = 0; while (bFoundFile) do begin // skip "." and ".." if (mySearchRec.Name <> '.') and (mySearchRec.Name <> '..') then begin sDirectory := IncludeTrailingPathDelimiter(DelimitedDirectory + mySearchRec.Name); _SearchDirectory(List, sDirectory, Masks, Recursive); end; // find next directory bFoundFile := FindNext(mySearchRec) = 0; end; FindClose(mySearchRec); end; end; var slMasks: TStringList; begin // prepare list if (not Append) then List.Clear; List.BeginUpdate; slMasks := TStringList.Create; try // prepare masks if (Mask = '') then slMasks.Add('*') else begin slMasks.Delimiter := ';'; slMasks.DelimitedText := Mask; end; // start recursive loop _SearchDirectory(List, IncludeTrailingPathDelimiter(Directory), slMasks, Recursive); finally slMasks.Free; List.EndUpdate; end; end;
When you use the copy function in the explorer, you don't really copy the files to the clipboard, instead you pass the filenames. Reading the filenames is easily done, writing the filenames to the clipboard is a bit more tricky, but let's see.
uses Clipbrd, ShellApi, ShlObj, Windows, SysUtils; //////////////////////////////////////////////////////////////// // copies filenames from the clipboard to "Filenames" if there // are any. the clipboard can contain file- and directory names. procedure Sto_PasteFilenamesFromClipboard(Filenames: TStrings); var hDropHandle: HDROP; szBuffer: PChar; iCount, iIndex: Integer; iLength: Integer; begin // check entry conditions if (Filenames = nil) then Exit; Filenames.Clear; // lock clipboard Clipboard.Open; try // does clipboard contain filenames? if (Clipboard.HasFormat(CF_HDROP)) then begin // get drop handle from the clipboard hDropHandle := Clipboard.GetAsHandle(CF_HDROP); // enumerate filenames iCount := DragQueryFile(hDropHandle, $FFFFFFFF, nil, 0); for iIndex := 0 to iCount - 1 do begin // get length of filename iLength := DragQueryFile(hDropHandle, iIndex, nil, 0); // allocate the memory, the #0 is not included in "iLength" szBuffer := StrAlloc(iLength + 1); try // get filename DragQueryFile(hDropHandle, iIndex, szBuffer, iLength + 1); Filenames.Add(szBuffer); finally // free the memory StrDispose(szBuffer); end; end; end; finally // unlock clipboard Clipboard.Close; end; end; //////////////////////////////////////////////////////////////// // copies filenames from "Filenames" to the clipboard. // "Filenames" can contain file- and directory names. function Sto_CopyFilenamesToClipboard(Filenames: TStrings): Boolean; var sFilenames: String; iIndex: Integer; hBuffer: HGLOBAL; pBuffer: PDropFiles; begin // check entry conditions Result := (Filenames <> nil) and (Filenames.Count > 0); if (not Result) then Exit; // bring the filenames in a form, // separated by #0 and ending with a double #0#0 sFilenames := ''; for iIndex := 0 to Filenames.Count - 1 do sFilenames := sFilenames + ExcludeTrailingPathDelimiter(Filenames.Strings[iIndex]) + #0; sFilenames := sFilenames + #0; // allocate memory with the size of the "DropFiles" structure plus the // length of the filename buffer. hBuffer := GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT, SizeOf(DROPFILES) + Length(sFilenames)); try Result := (hBuffer <> 0); if (Result) then begin pBuffer := GlobalLock(hBuffer); try // prepare the "DROPFILES" structure pBuffer^.pFiles := SizeOf(DROPFILES); // behind the "DROPFILES" structure we place the filenames pBuffer := Pointer(Integer(pBuffer) + SizeOf(DROPFILES)); CopyMemory(pBuffer, PChar(sFilenames), Length(sFilenames)); finally GlobalUnlock(hBuffer); end; // copy buffer to the clipboard Clipboard.Open; try Clipboard.SetAsHandle(CF_HDROP, hBuffer); finally Clipboard.Close; end; end; except Result := False; // free only if handle could not be passed to the clipboard GlobalFree(hBuffer); end; end;
You don't remember exactly the functionname, but you know there was a function...? (uses SysUtils, StrUtils, Classes).
| Functionames | Category |
|---|---|
| Length, Delete, Insert, Copy, StringReplace | Standard procedures |
| Pos, PosEx, LastDelimiter | Find substring |
| ExtractStrings, TStrings.CommaText, TStrings.DelimitedText | Splitting strings |
| SameText, CompareStr, CompareText | Compare strings |
| Trim, TrimLeft, TrimRight | Remove whitespaces |
| UpperCase, LowerCase | |
| Format, FormatFloat, FormatDateTime | Formatting |
| IntToStr, StrToInt, StrToIntDef, TryStrToInt, FloatToStr, StrToFloat, StrToFloatDef, TryStrToFloat | Datatype conversion |
| StringOfChar, FillChar |
Seldom you will have to use the string type PChar, though if you are working with the WindowsAPI or with C- Libraries you will have to. In contrast to the Delphi type "String", PChar is actually a pointer and you have to take care of the memory allocation.
If a function expects a variable of type PChar but does only read the variable (const parameter) you can work with normal strings and constant strings. In the example the windows function "MessageBox" expects two PChar arguments.
procedure SayHello; var sNormalString: String; begin sNormalString:= 'hello'; MessageBox(0, PChar(sNormalString), 'ConstantString', MB_OK); end;
If a function expects a PChar to place a result in it, then you have to allocate the memory yourself. After the function call it's very easy to convert the PChar to a String, you can simply assign the PChar to a String. In Delphi, the variable szBuffer (array of char) is compatible to PChar but with allocated memory.
function Sto_GetTempPathStatic: String;
var
szBuffer: array[0..MAX_PATH] of Char;
begin
GetTempPath(MAX_PATH + 1, szBuffer);
Result := szBuffer; // copy all characters until first 0#
end;
The method above has two major drawbacks, first you have to know the necessary buffersize, and then you can run into an unpredictable situation, if a next version of the function accepts a bigger buffer. In this case the buffer would contain random data (although a missing #0 character wouldn't lead to a buffer overrun).
Of course there is a better way, and you can even work with normal strings. If you later have to switch to unicode, the code works the same way with WideStrings. Most Windows API functions will return the needed size shouldn't there be enough allocated memory, otherwise they return the length of the resulting string.
function Sto_GetTempPath: String; var iAssumedSize, iSize: DWORD; begin // try with a reasonable buffer size iAssumedSize := 80; SetLength(Result, iAssumedSize); iSize := GetTempPath(iAssumedSize, PChar(Result)); // reserve more buffer if necessary if (iSize > iAssumedSize) then begin // in this case the terminating #0 is included in iSize. SetLength(Result, iSize); iSize := GetTempPath(iSize, PChar(Result)); end; // reduce buffer to the effectively used size. if the api call // was successful, the terminating #0 is not included in iSize. SetLength(Result, iSize); end;
Did you already write a small useful function for your library, but then it became difficult to share it, because you needed to deliver translated text resources? Maybe you can borrow the textes from the Windows environment, at least some of the most common textes. An overview of existing textes can give you a resource editor.
/// <summary>
/// Searches for a text resource in a Windows library.
/// Sometimes, using the existing Windows resources, you can
/// make your code language independent and you don't have to
/// care about translation problems.
/// </summary>
/// <example>
/// btnCancel.Caption := Sto_LoadWindowsStr('user32.dll', 801, 'Cancel');
/// btnYes.Caption := Sto_LoadWindowsStr('user32.dll', 805, 'Yes');
/// </example>
/// <param name="LibraryName">Name of the windows library like
/// 'user32.dll' or 'shell32.dll'</param>
/// <param name="Ident">Id of the string resource.</param>
/// <param name="DefaultText">Return this text, if the resource
/// string could not be found.</param>
/// <returns>Desired string if the resource was found, otherwise
/// the DefaultText</returns>
function Sto_LoadWindowsStr(const LibraryName: String; const Ident: Integer;
const DefaultText: String = ''): String;
const
BUF_SIZE = 1024;
var
hLibrary: THandle;
iSize: Integer;
begin
hLibrary := GetModuleHandle(PChar(LibraryName));
if (hLibrary <> 0) then
begin
SetLength(Result, BUF_SIZE);
iSize := LoadString(hLibrary, Ident, PChar(Result), BUF_SIZE);
if (iSize > 0) then
SetLength(Result, iSize)
else
Result := DefaultText;
end
else
Result := DefaultText;
end;
In HTML, colors are stored as text in the RGB (red green blue) format. Each part of the color has a hex value with two digits. With the following functions you can convert a TColor value to an HTML-color-string and reverse.
uses SysUtils, Graphics; //////////////////////////////////////////////////////////////// // converts a color to an html color string // clRed => #FF0000 function Sto_ColorToHtml(const Color: TColor): String; var iRgb: Longint; iHtml: Longint; begin // convert system colors to rgb colors iRgb := ColorToRGB(Color); // change BBGGRR to RRGGBB iHtml := ((iRgb and $0000FF) shl 16) or // shift red to the left ( iRgb and $00FF00) or // green keeps the place ((iRgb and $FF0000) shr 16); // shift blue to the right // create the html string Result := '#' + IntToHex(iHtml, 6); end; //////////////////////////////////////////////////////////////// // converts an html color string to a color, // can raise an EConvertError exception // #0000FF -> clBlue function Sto_HtmlToColor(Color: String): TColor; var iHtml: Longint; begin // remove the preceding '#' if (Length(Color) > 0) and (Color[1] = '#') then Delete(Color, 1, 1); // convert html string to integer iHtml := StrToInt('$' + Color); // change RRGGBB to BBGGRR Result := ((iHtml and $FF0000) shr 16) or // shift red to the right ( iHtml and $00FF00) or // green keeps the place ((iHtml and $0000FF) shl 16); // shift blue to the left end;
You can write your own events in your classes. As soon as you place the event property in the "published" part of the class declaration, the Delphi IDE will show the event in the objectinspector by adding the component. It's a common practice to write a virtual method for calling the event, often it's called like the event with "Do" at the begin. In this example, the object passes a boolean parameter to the event, which can be altered in the event procedure. If you don't have to pass parameters you can use the predefined type "TNotifyEvent" instead of your own event declaration ("TOnEvent").
interface
type
TOnEvent = procedure(Sender: TObject; var Continue: Boolean) of object;
TEventDemo = class(TObject)
protected
FOnEvent: TOnEvent;
procedure DoEvent; virtual;
published
property OnEvent: TOnEvent read FOnEvent write FOnEvent;
end;
implementation
procedure TEventDemo.DoEvent;
var
bContinue: Boolean;
begin
// set default values
bContinue := True;
// call the event
if Assigned(FOnEvent) then
FOnEvent(Self, bContinue);
// do other things
if bContinue then
begin
// ...
end;
end;
A special kind of properties are the indexed properties, they act like an array and can be used in the same fashion. However, the class has to take care of the memory management and the performed actions by implementing the methods ("GetIndexProperty" and "SetIndexProperty").
interface
type
TIndexPropertyDemo = class(TObject)
protected
function GetIndexProperty(Index: Integer): String; virtual;
procedure SetIndexProperty(Index: Integer; const Value: String); virtual;
public
property IndexProperty[Index: Integer]: String read GetIndexProperty write SetIndexProperty;
end;
implementation
procedure IndexPropertyDemo(ExistingDemoObject: TIndexPropertyDemo);
var
sText: String;
begin
sText := ExistingDemoObject.IndexProperty[0];
ExistingDemoObject.IndexProperty[1] := sText;
end;
In Delphi classes, you can catch windows messages directly and use them for your own purposes. To do this, write a method and add the keyword "message" with the message id. It's normally not a virtual method because a child class can implement it in the same manner. To pass the message to an ancestor class, you can use the keyword "inherited".
In the example you can see a small class which implements a transparent panel. There are two methods implemented "WMEraseBkgnd" and "CreateParams", they show the difference between a normal virtual method (CreateParams) and a message handler (WMEraseBkgnd).
interface
uses Windows, Messages;
type
TStoTransparentPanel = class(TWinControl)
private
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
implementation
procedure TStoTransparentPanel.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle:= Params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TStoTransparentPanel.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
// in this case, we want to intercept the windows message. if we would want to
// pass the message to the ancestor classes, we could use the keyword
// "inherited" without the procedure name. example:
// inherited;
Message.Result := 1;
end;
You can bring colors to your grids with a small amount of work. A comfortable way to do this is, to write your own "OnDrawCell" event and paint the text manually. The example works with a TStringGrid, though it's not very different for TDrawGrid's.
//////////////////////////////////////////////////////////////// // draws the text for one single cell in a grid procedure Sto_DrawCellText(const Canvas: TCanvas; const Rect: TRect; const Text: String; const BackColor, TextColor: TColor; const Alignment: TAlignment); const BORDER_WIDTH = 2; var iLeftBorder: Integer; begin // calculate the left border iLeftBorder := 0; case Alignment of taLeftJustify : iLeftBorder := Rect.Left + BORDER_WIDTH; taRightJustify: iLeftBorder := Rect.Right - BORDER_WIDTH - Canvas.TextWidth(Text) -1; taCenter : iLeftBorder := Rect.Left + (Rect.Right - Rect.Left - Canvas.TextWidth(Text)) div 2; end; // set colors Canvas.Font.Color := TextColor; Canvas.Brush.Color := BackColor; // paint the text ExtTextOut(Canvas.Handle, iLeftBorder, Rect.Top + BORDER_WIDTH, ETO_CLIPPED or ETO_OPAQUE, @Rect, PChar(Text), Length(Text), nil); end; //////////////////////////////////////////////////////////////// // the OnDrawCell event of the grid procedure TForm1.grdColoredStringGridDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); var grdColored: TStringGrid; sText: String; myBackColor: TColor; myTextColor: TColor; myAlignment: TAlignment; begin grdColored := TStringGrid(Sender); // set default values for the parameters, // get the values depending on the grid settings. sText := grdColored.Cells[ACol, ARow]; if (ARow < grdColored.FixedRows) or (ACol < grdColored.FixedCols) then myBackColor := grdColored.FixedColor else myBackColor := grdColored.Color; myTextColor := grdColored.Font.Color; myAlignment := taLeftJustify; // set your own values... myTextColor := clGreen; // draw the text in the cell Sto_DrawCellText(grdColored.Canvas, Rect, sText, myBackColor, myTextColor, myAlignment); end;
To write a wizard, it would be nice to use a PageControl with invisible Tabs. You can hide the tabs with the TabVisible property of TTabSheet and select the TabSheets in code.
//////////////////////////////////////////////////////////////// // hides all tabs (not the tabsheet itself) in the pagecontrol, // and selects the first tabsheet as the active displayed. procedure Sto_HideTabsInPageCtrl(PageControl: TPageControl); var iPage: Integer; begin // hide the tabs for iPage := 0 to PageControl.PageCount - 1 do PageControl.Pages[iPage].TabVisible := False; // set the active tabsheet if (PageControl.PageCount > 0) then PageControl.ActivePage := PageControl.Pages[0]; // hide the border of the pagecontrol PageControl.Style := tsButtons; end;
Delphi offers a comfortable way to show context sensitive helpfiles, however the support is limited to the Windows help system (.hlp). If you want to work with HTML help files (.chm), then you have to write some extra code. Here you can download a unit, which will allow you to use HTML help files. You can use the normal Delphi VCL framework and write your projects the same way, as you would using normal (.hlp) files.
| Download StoHtmlHelp (Delphi v6 v7) | StoHtmlHelp.zip |
|---|
To install the unit, simply add the unit to your project.
Since Delphi 2005, HTML help files are natively supported. You shouldn't use StoHtmlHelp then, instead add the "HTMLHelpViewer" unit to your project.
Adding shortcuts like <ctrl><c> to a menu item is very easy, since you can chose a lot of combinations in Delphi's property editor. What if you need another shortcut, not offered by the property editor? Special shortcuts like <ESC> or <alt><KeyDown> you can add at runtime in all possible combinations.
procedure TForm1.FormCreate(Sender: TObject);
begin
// shortcut definition, not offered by the property editor
mnuExit.ShortCut := ShortCut(VK_ESCAPE, []);
mnuFindNext.ShortCut := ShortCut(VK_DOWN, [ssAlt]);
end;
Shortcuts of the form <alt><?> are normally generated with the caption property of the menu item. Insert a "&" character to generate an <alt> shortcut with the next letter, "Hello &world" would generate the shortcut <alt><w>.
If the dropdown content exceeds the width of a combobox, then the text is hidden from the user. With the following small procedure you can fit the dropdown width automatically to the necessary size.
uses Windows, Messages, StdCtrls; //////////////////////////////////////////////////////////////// // this procedure sets the with of the dropdown box, if the // content is to large for the standard width. procedure Sto_AutoWidthCombobox(Combobox: TCombobox); const HORIZONTAL_PADDING = 4; var iWidth: Integer; iIndex: Integer; iLineWidth: Integer; begin iWidth := 0; // calculate the width of the drop down content for iIndex := 0 to Combobox.Items.Count - 1 do begin iLineWidth := Combobox.Canvas.TextWidth(Combobox.Items[iIndex]); Inc(iLineWidth, 2 * HORIZONTAL_PADDING); if (iLineWidth > iWidth) then iWidth := iLineWidth; end; // set the calculated width if necessary if (iWidth > Combobox.Width) then SendMessage(Combobox.Handle, CB_SETDROPPEDWIDTH, iWidth, 0); end;
In the standard configuration of the Delphi IDE, a lot of useful keyboard shortcuts are available, some of them are not very known. It's even possible to record and play simple keyboard macros.
| Shortcut | Description |
|---|---|
|
<ctrl><shift><0..9> <ctrl><0..9> |
Set or remove the bookmark 0..9 . Jump to the bookmark 0..9 in the currently opened file. |
|
<ctrl><shift><i> <ctrl><shift><u> |
Indent the selected rows. Unindent the selected rows. |
|
<ctrl><shift><up> <ctrl><shift><down> |
Switch between declaration and implementation. |
|
<alt><up> <ctrl><left_mouse_button> |
Find the implementation of a procedure or function. |
| <ctrl><e> | Incremental search mode. |
|
<ctrl><shift><r> <ctrl><shift><p> |
Start and stop the recording of a simple keyboard macro (record). Replays the macro (play). |
| <ctrl><shift><g> | Create a new GUID. |
In the project options you can set an output path for the executable and one for the compiled units (*.dcu). It's very useful to have the dcu's in a separate directory, but every programmer has to have this directory, otherwise he can't compile the project.
Since Delphi6 (?) it's possible to have global variables and relative paths in the output directories. Because all programmers will have at least a global temp path, you can set this variable as the dcu output directory. If you set a relative path as the executable directory, it's easier to move or copy the project.
| Path | Setting |
|---|---|
| ..\bin | Output path for the executable in a relative directory |
| $(TEMP) | Output path for units (*.dcu) |
Variants can handle several datatypes and some special states as EMPTY and NULL. Before you assign a value to a variant, it has the state EMPTY. There are a lot of functions to check the state or type of a variant and there are predefined variants you can use.
uses Variants; procedure VariantDemo; var vDemo: Variant; bTest: Boolean; begin // EMPTY vDemo := Unassigned; // assign EMPTY to variant bTest := VarIsEmpty(vDemo); // check if variant is EMPTY // NULL vDemo := NULL; // assign NULL to variant bTest := VarIsNull(vDemo); // check if variant is NULL // numeric vDemo := 8.8; // assign a float to variant bTest := VarIsNumeric(vDemo); // check if variant is numeric // text vDemo := 'demo'; // assign a string to variant bTest := VarIsStr(vDemo); // check if variant contains text // COM methods can define obtional parameters. if you are // working with typelibraries you have to pass a parameter // nevertheless, then you can pass "EmptyParam" vDemo := EmptyParam; bTest := VarIsEmptyParam(vDemo); end;
Before you can use and test your new created COM server, you have to register it. You can do this with the Delphi menu Start\Register ActiveX-Server or you can register it by yourself. It depends on the kind of server you have (in-process *.dll or out-of-process *.exe) how to register the server.
| Register | Unregister | |
|---|---|---|
| in-process (MyServer.dll) | regsvr32 MyServer.dll | regsvr32 /u MyServer.dll |
| out-of-process (MyServer.exe) | MyServer.exe /regserver | MyServer.exe /unregserver |
If you often have to do with COM servers, it is very useful to be able to (un)register them in the explorer. It's not difficult to extend the explorer's context menu, you can use this small reg file to add a "Register" and an "UnRegister" entry.
| Download regfile | StoComRegister.zip |
|---|
In COM you can define a default property, this is useful especially for lists. Assuming you have an implementation of a list with an "Items" property, the code could look like this:
// normal reading of an item aItem := aList.Items[iIndex]; // with a default property defined aItem := aList[iIndex];
Defining a default property is very easy, provided that you know where to look. In the typelibrary editor you go to the page "Attributes" and set the "ID" field to 0, done.
When you are using modal forms in a COM server, you will miss the support of the menu shortcuts and the automatic navigation between the controls with the TAB key. this is because the "Application" object doesn't handle the windows messages, it is the window of the client application.
//////////////////////////////////////////////////////////////// // if you display a form from inside a COM server, you will miss the // automatic navigation between the controls with the "TAB" key. // the "KeyPreview" property of the form has to be set to "True". procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); var bShift: Boolean; begin // check for tab key and switch focus to next or previous control. // handle this in the KeyPress event, to avoid a messagebeep. if (Ord(Key) = VK_TAB) then begin bShift := Hi(GetKeyState(VK_SHIFT)) <> 0; SelectNext(ActiveControl, not(bShift), True); Key := #0; // mark as handled end; end; //////////////////////////////////////////////////////////////// // if you display a form from inside a COM server, you will miss the // support of the menu- and action- shortcuts like "<Ctrl><S>". // the "KeyPreview" property of the form has to be set to "True". procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); const AltMask = $20000000; var myMessage: TWMKey; begin // recreate the original "KeyUp" message FillChar(myMessage, SizeOf(TWMKey), 0); myMessage.Msg := WM_KEYUP; myMessage.CharCode := Key; if (ssAlt in Shift) then myMessage.KeyData := AltMask; // find and execute matching shortcut if IsShortCut(myMessage) then Key := 0; // mark as handled end;
Normally you will use interfaces in combination with COM objects. In contrast to conventional objects, a COM object supports reference counting and will free itself when the last reference is released.
You can use interfaces for your conventional objects too, without supporting reference counting and automatically freeing. Doing this, you have to pay attention to some special facts.
ITest = interface(IInterface) // press <ctrl><shift><g> to create your own GUID for each interface. // this is necessary to implement the "QueryInterface" method. ['{CA51B752-0DF5-40D2-945C-A5CF2EAA3B31}'] procedure ShowText; end; TTest = class(TObject, ITest) protected FText: String; // IInterface function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; // ITest procedure ShowText; end;
Because every interface inherites from the parent interface "IInterface" (same as windows specific "IUnknown"), you have to support at least the three methods of "IInterface". This example shows a standard implementation.
function TTest._AddRef: Integer; begin Result := -1; // no reference counting supported end; function TTest._Release: Integer; begin Result := -1; // no reference counting supported end; function TTest.QueryInterface(const IID: TGUID; out Obj): HResult; begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; procedure TTest.ShowText; begin ShowMessage(FText); end;
When you later use the object, you have to be careful, that at the moment of destruction, no reference to the interface remains.
procedure WellUsed; var myTestObject: TTest; pTestInterface: ITest; begin // creating the object myTestObject := TTest.Create; // get a reference to the interface of the object, this will implicitly call "_AddRef" pTestInterface := myTestObject; // ... // release the reference to the interface, this will implicitly call "_Release" pTestInterface := nil; // freeing the object itself myTestObject.Free; end;
If you free the object, before the last reference to the interface is released, then the implicit call to "_Release" will call to a not existing object (Delphi will release the interface automatically, if you don't do it yourself).
procedure WrongUsed; var myTestObject: TTest; pTestInterface: ITest; begin myTestObject := TTest.Create; pTestInterface := myTestObject; // ... // freeing the object with an existing reference myTestObject.Free; // this releasing of the interface will implicitly call "_Release", but there // is no living object anymore. pTestInterface := nil; end;
Normally, calling a method of a not existing object will cause a runtime error, not in our example. That's because no member of the object is used inside "_Release", as soon as you access a member, you will get the expected error. So, first make sure you don't call a "_Release" on a not existing object, then don't access members inside of "_Release".
function TTest._Release: Integer; begin // this will cause an error, if the reference is released after the object was freed. FText := ''; Result := -1; // no reference counting supported end;
