Delphi tips
Häufig stolpern Programmierer über dieselben Probleme, manchmal verursacht durch die Entwicklungsumgebung. Um zu verhindern, dass mir das mehr als einmal mit dem gleichen Fehler passiert, habe ich mich entschlossen diese Seite anzufangen. Delphi ist meine "Muttersprache" unter den Programmiersprachen, aber trotzdem könnten viele Beispiele mittlerweile veraltet sein, da sich Delphi in den letzten Jahren ständig weiterentwickelt hat und ich nicht Schritt halten konnte.
Sollten Sie Probleme, Fragen oder Anregungen zu den nachstehenden Funktionen haben, oder finden Sie sie einfach nützlich, so zögern Sie nicht, mir eine EMail zu schreiben an .
Übersicht
Anwendungs Funktionen
Filename der Anwendung (exe/dll)
Um den Filenamen der laufenden Anwendung zu erhalten, kann in der Regel folgender Aufruf gemacht werden:
sFileName := Application.ExeName;
// or
sFileName := ParamStr(0);
Vielleicht arbeiten Sie innerhalb einer DLL und sind am Namen der DLL anstelle der Anwendung interessiert, in diesem Fall können Sie folgende Funktion verwenden:
uses SysUtils;
sFileName := GetModuleName(HInstance); // returns the Dll name
sFileName := GetModuleName(0); // returns the Exe name
Version der Anwendung
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;
Starten einer externen Anwendung
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".
Starten einer Konsolenanwendung und Umleiten des stdoutput
Die meisten Konsolenanwendungen senden ihre Ausgaben zum stdoutput und stderror, und diese sind normalerweise mit der Bildschirmausgabe verknüpft. Sie können solche Anwendungen aber auch starten und die Ausgabe selber lesen, um sie in der eigenen Anwendung zu interpretieren. Um die Nachteile des Dateisystems und Berechtigungsprobleme zu umgehen, empfiehlt es sich, in Pipes umzuleiten und diese zu lesen.
Ein vollständiges Beispiel, wie die "cmd.exe" gestartet und mit Inputpipe wie auch mit Outputpipes verknüpft wird, finden Sie im Beispielprojekt 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;
Jede "ReadFile" Operation von einer Pipe blockt diese, bis entweder Daten vorhanden sind, oder die Pipe geschlossen wird (keine Daten mehr). Eine Anwendung welche Daten in eine Pipe schreibt, füllt deren Buffer und blockt dann solange, bis jemand am anderen Ende der Pipe die Daten liest. Dies bedeutet, sobald man aus mehr als einer Pipe liest, kann jede Pipe die anderen blocken. Für eine sichere Implementation müssen also Threads verwendet werden um die Pipes zu lesen.
Links auf EMail und Website
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;
Command line parameters
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.
Einbinden von externen Ressourcen wie Cursor
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.
- First you need a cursor file (sto_cursor.cur), copy it to your Delphi project directory.
- In the next step, create a resource script file. It's a simple text file with the extension (*.rc), name it (sto_cursor.rc).
- Now add the resource script file to your Delphi project, that way you can edit the file within the IDE and, more important, Delphi will know it has to compile this resources by building the project. Delphi will place a compiler directive into the project file (*.dpr).
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;
File & Pfad Funktionen
Häufig benötigte File Funktionen
You don't remember exactly the functionname, but you know there was a function...?
- ExtractFileDrive, ExtractFilePath, ExtractFileName, ExtractFileExt (uses SysUtils)
- ExtractShortPathName, ExpandUNCFileName (uses SysUtils)
- FileExists, DirectoryExists (uses SysUtils, FileCtrl)
- ForceDirectories (uses FileCtrl)
- SelectDirectory (uses FileCtrl)
- IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter (uses SysUtils Delphi6)
IncludeTrailingBackslash, ExcludeTrailingBackslash (uses SysUtils Delphi5) - LastDelimiter (uses SysUtils)
- MatchesMask (uses Masks)
Den langen Filenamen aus einem kurzen DOS Filenamen erhalten
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;
Die Grösse eines Files erhalten (über 2 GB)
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;
Verzeichnis öffnen Dialog
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;
Files und Verzeichnisse in den Papierkorb verschieben
"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;
Verzeichnis durchsuchen
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;
Wie kann ich Filenamen aus/in die Zwischenablage kopieren
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;
String Funktionen
Häufig benötigte String Funktionen
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 |
Mit PChar arbeiten
Es ist selten nötig direkt mit dem String Typ PChar zu arbeiten, beim Aufrufen des WindowsAPI und mit C- Libraries kommt man aber nicht drum herum. Im Gegensatz zum Delphi Typ String, ist PChar tatsächlich nur ein Pointer und man muss sich um die Speicherverwaltung selber kümmern.
Wenn eine Funktion eine Variable vom Typ PChar verlangt, diese aber nur liest (const Parameter), dann können Sie mit normalen Strings und konstanten Strings arbeiten. Die Windows Funktion im Beispiel erwartet zwei PChar Parameter.
procedure SayHello;
var
sNormalString: String;
begin
sNormalString:= 'hello';
MessageBox(0, PChar(sNormalString), 'ConstantString', MB_OK);
end;
Falls eine Funktion einen PChar erwartet um darin ein Resultat zu plazieren, dann muss der Speicher zuvor selber reserviert werden. Nach dem Funktionsaufruf ist es sehr einfach den PChar in einen String zu konvertieren, dazu wird einfach die PChar Variable dem String zugewiesen. In Delphi ist die Variable szBuffer (array of char) kompatibel zu PChar allerdings mit reserviertem Speicher.
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;
Diese Methode hat zwei grosse Nachteile, erstens muss man die benötigte Buffergrösse kennen, und dann kann man in eine undefinierte Situation geraten, falls eine nächste Version der Funktion einen grösseren Buffer akzeptiert. In diesem Fall würde der Buffer zufälligen Inhalt enthalten (allerdings führt ein fehlender #0 Character noch nicht zu gleich einem Bufferüberlauf).
Natürlich gibt es einen besseren Weg, und man kann sogar mit normalen String arbeiten. Wenn Sie später auf Unicode umsteigen müssen, so funktioniert der Code entsprechend auch mit WideStrings. Die meisten Windows API Funktionen liefern die benötigte Grösse zurück, sollte nicht genug Speicher reserviert sein, andernfalls geben sie die Länge des resultierenden Strings zurück.
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;
Verwenden von Windows Texten
Haben Sie auch schon eine kleine nützliche Funktion geschrieben, beim Weitergeben wurde es dann aber plötzlich schwierig, weil Sie gleichzeitig ein paar sprachabhängige Textressourcen mitliefern mussten? Möglicherweise können diese Texte von Windows ausgeliehen werden, jedenfalls einige der gängigsten Texte. Eine übersicht über vorhandene Texte liefert ein Ressourceneditor.
/// <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;
ColorToHtml / HtmlToColor
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;
Klassen und Objekte
Ereignisse zur Verfügung stellen
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;
Eigenschaften mit Index
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;
Windows Botschaften verwenden
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;
Delphi VCL
Ein StringGrid farbig darstellen
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;
Tabs in einem PageControl verstecken
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;
Spezielle Menu Shortcuts erstellen
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>.
Automatische Grössenanpassung der DropDown Liste einer Combobox
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;
Delphi IDE
IDE Tastenkürzel
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. |
Ausgabeverzeichnisse
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 and COM
Empty und Null
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;
Wie kann ich einen COM Server registrieren
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 |
Default Property in einem COM Object
In COM können Default Properties definiert werden, dies ist besonders hilfreich für Listen. Angenommen Sie haben eine Liste mit einem "Items" Property, so könnte der Code in etwa so aussehen:
// normales lesen des property
aItem := aList.Items[iIndex];
// mit einem definierten default property
aItem := aList[iIndex];
Ein Default Property zu definieren ist sehr einfach, vorausgesetzt man weiss wo man suchen muss. Im Typbibliothek Editor öffnet man das Register "Attribute" und setzt das "ID" Feld auf 0, fertig.
Modale Fenster in COM
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;
Interfaces ohne COM verwenden
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;