Beispiel für eine wenige kB große Anwendung ohne Gebrauch der Forms-UnitTips & Tricks
Beispiel für eine wenige kB große Anwendung ohne Gebrauch der Forms-Unit
Immer wieder taucht die Frage auf, warum jede Delphi-Applikation mal gleich fast 200kB groß ist. Das liegt vor allem an der Unit Forms, die benötigt wird, sobald ein TForm-Objekt benutzt wird. Das ist ja nun bei allen Programmen der Fall, die mindestens ein Fenster besitzen.
Aber es geht auch anders! Gordy Cowie demonstriert in seinem Beispielprojekt, wie man auch ohne die Unit Forms auskommt und somit Programmdateien kompilieren kann, die nichteinmal 20kB groß sind. Die einzige Einschränkung ist eigentlich, daß man auf Standard-Windows-Controls beschränkt ist. Das reicht aber meistens schon aus, wie man sieht..
Tips zur Programmierung eines Bildschirmschoners
Eine ausführliche englische Anleitung hat Mark R. Johnson geschrieben. Die Anleitung mit der Download-Möglichkeit des beschreibenen Beispielprojekts hat er auf den CityZoo-Seiten veröffentlicht.
Umwandlung eines Zahlenwertes in ein ausgeschriebenes Zahlwort
Diese Funktion wandelt einen ganzzahligen, positven Wert in ein ausgeschriebenes Zahlwort um, wie es z.B. auf Schecks vorgeschrieben ist (123 entspricht z.B. "einhundertdreiundzwanzig"):
Function ZahlInString(n:Integer):String;
Const Zahlen1 : Array[0..9] Of String =
('','zehn','zwan','drei','vier','fünf','sech','sieb','ach','neun');
Zahlen : Array[0..9] Of String =
('','ein','zwei','drei','vier','fünf','sechs','sieben','acht','neun');
Var n100,
n10,
n1 : Integer;
s : String;
Function ZehnerUndEiner(n10,n1:Byte):String;
Var n:Integer;
Begin
n:=n10*10+n1;
Result:='';
If n10=0 Then Begin
If n1>0 Then
Result:=Result+Zahlen[n1];
If n1=1 Then
Result:=Result+'s';
End
Else Begin
If n10=1 Then Begin
If n=11 Then
Result:=Result+'elf'
Else
If n=12 Then
Result:=Result+'zwölf'
Else
Result:=Result+Zahlen1[n1]+'zehn';
End
Else Begin
Result:=Result+Zahlen[n1];
If n1>0 Then
Result:=Result+'und';
Result:=Result+Zahlen1[n10];
If n10<>3 Then
Result:=Result+'zig'
Else
Result:=Result+'ßig';
End;
End;
End; {ZehnerUndEiner}
begin
Result:='';
If n=0 Then Begin
Result:='null';
Exit;
End;
If n>=1000000000 Then Begin
s:=ZahlInString(n DIV 1000000000);
If s='eins' Then
Result:=Result+'einemilliarde'
Else
Result:=Result+s+'milliarden';
n:=n MOD 1000000000;
End;
If n>=1000000 Then Begin
s:=ZahlInString(n DIV 1000000);
If s='eins' Then
Result:=Result+'einemillion'
Else
Result:=Result+s+'millionen';
n:=n MOD 1000000;
End;
If n>=1000 Then Begin
s:=ZahlInString(n DIV 1000);
If s='eins' Then
s:='ein';
Result:=Result+s+'tausend';
n:=n MOD 1000;
End;
n100:=n Div 100;
n:=n MOD 100;
n10:=n Div 10;
n1:=n Mod 10;
If n100<>0 Then
Result:=Result+Zahlen[n100]+'hundert';
Result:=Result+ZehnerUndEiner(n10,n1);
end; {Georg W. Seefried}
|
Die Funktion gibt nur bis zum Wert "2147483647" korrekte Ergebnisse zurück.
So macht man einen Screenshot des Windows-Desktops
Ich möchte gerne ein Abbild des Windows-Desktops als Bild in mein Programm holen. Wie kann ich so eine Bitmap erzeugen? Mir geht es nicht darum, einfach den Druck auf die "Druck-Taste" zu simulieren. Ich möchte das Bitmap sozusagen direkt abgreifen.
Diese Prozedur speichert im übergebenen TBitmap ein Abbild des aktuellen Windows-Desktops:
procedure ScreenCapture(Bmp: TBitmap);
var
DeskWnd: HWnd;
DeskDC: HDC;
DeskCv: TCanvas;
R: TRect;
W, H: Integer;
begin
if Bmp = nil then Exit;
DeskWnd := GetDesktopWindow;
DeskDC := GetWindowDC(DeskWnd);
DeskCv := TCanvas.Create;
DeskCv.Handle := DeskDC;
W := Screen.Width;
H := Screen.Height;
R := Bounds(0, 0, W, H);
try
Bmp.HandleType := bmDIB;
Bmp.PixelFormat := pf24Bit;
Bmp.Width := W;
Bmp.Height := H;
Bmp.Canvas.CopyMode := cmSrcCopy;
Bmp.Canvas.CopyRect(R, DeskCv, R);
finally
DeskCv.Free;
ReleaseDC(DeskWnd, DeskDC);
end;
end; {Marco Lange}
|
Strings mit Wildcards (*,?) suchen
Ich möchte in einer Textdatei Strings suchen, die einer bestimmten Maske entsprechen. In der Maske sollen die üblichen Wildcards (*,?) erlaubt sein. Wie kann der String-Vergleich aussehen?
Ab der Professional-Version von Delphi 3 gibt es in der Unit Masks die Funktion "MatchesMask(..)", die das erledigt. Michael Winter hat jedoch herausgefunden, daß diese Funktion teilweise fehlerhafte Ergebnisse liefert.
MatchesMask('???', 'a') liefert z.B. fälschlicherweise true, in dem Fall scheinbar bei jeder ungeraden Anzahl Fragezeichen. Das Lesen im zweiten Parameter erfolgt je nach Länge der Maske über Len+1 hinaus, was mehr oder weniger zufällig ein falsches Ergebnis (wie oben) oder eine Zugriffsverletzung bringt. Michael hat daraufhin die Funktion "Like" geschrieben, die diese Fehler nicht zeigt und außerdem noch schneller als MatchesMask arbeitet.
Weitergehende Wildcard-Funktionen bietet die Funktion "MatchPattern", aus der Unit MatchPtn, die ein unbekannter Author auf Grundlage eines MSDN-Artikels nach Pascal übersetzt hat:
'*' : Zero or more chars.
'?' : Any one char.
[adgj] : Individual chars (inclusion).
[^adgj] : Individual chars (exclusion).
[a-d] : Range (inclusion).
[^a-d] : Range (exclusion).
[a-dg-j] : Multiple ranges (inclusion).
[^a-dg-j] : Multiple ranges (exclusion).
[ad-fhjnv-xz] : Mix of range & individual chars (inclusion).
[^ad-fhjnv-xz] : Mix of range & individual chars (exclusion).
|
E-Mails mit Anhang verschicken
Wie kann man über das Standard-Mailprogramm des Anwenders eine E-Mail mit Anhang verschicken?
Genau dafür ist Simple MAPI gedacht. Allerdings sollte man beachten, daß dieser Dienst wird nicht vom Betriebssystem angeboten, sondern von speziellen Anwendungsprogrammen zur Verfügung gestellt wird. Deswegen kann man nicht davon ausgehen, daß er immer zur Verfügung steht. Nur wenn ein Anwendungsprogramm installiert ist, das diese Schnittstelle anbietet und auch entsprechend konfiguriert ist, kann man sie nutzen.
Zu den Programmen, die Simple MAPI unterstützen, gehören Microsoft Exchange, Microsoft Outlook, Microsoft Outlook Express und der Netscape Messenger.
Um zu überprüfen, ob MAPI zur Verfügung steht, muß man nachschauen, ob im Windows-System-Verzeichnis die Datei MAPI32.DLL vorhanden ist. Fehlt sie, ist kein MAPI installiert. Um den Messenger MAPI - tauglich zu machen, muss in den Einstellungen unter "Mail & Diskussionsforen" die Option "Bei MAPI-basierten Anwendungen Netscape Messenger verwenden" aktiviert sein. Bei Outlook / Outlook Express gibt es ähnliche Optionen. Wenn man in einem dieser Programme diese Option aktiviert, kopiert das Programm seine eigene MAPI32.DLL in das Windows-System-Verzeichnis.
Die Prozedur SendMail von Christian Schwarz demonstriert die Implementation der Funktion "MapiSendMail"
[Probleme mit MAPI ab Delphi 3.01]
Das Problem liegt in der Routine InitMapi in MAPI.PAS. Dort wird überprüft, ob bestimmte Einträge in der Registry existieren. Das ist aber absoluter Unsinn, da die meisten MAPI-fähigen Programme diese Einträge gar nicht machen, bzw. diese Einträge schnell mal verloren gehen.
Folgendes Vorgehen schlage ich vor: Datei MAPI.PAS in dein lokales Source-Code-Verzeichnis kopieren, in MYMAPI.PAS umbenennen, Unit-Header entsprechend anpassen, und die Prozedur InitMapi ändern, so dass sie folgendermaßen aussieht:
procedure InitMapi;
begin
if not MAPIChecked then
begin
MAPIChecked := True;
MAPIModule := 0;
MAPIModule := LoadLibrary(PChar(MAPIDLL));
end;
end;
|
Einfache E-Mails ohne Anhang und mit eingeschränkter Textlänge kann man auch mit dem ShellExecute-Befehl versenden.
Töne über den Synthesizer der Soundkarte ausgeben
Den Synthesizerchip der Soundkarten spricht man über die MIDI-Befehle des Media Control Interface (MCI) aus der Unit "MMSystem" an. Wie das im speziellen mit dem Befehl "MidiOutShortMsg" funktioniert, zeigt diese Unit von Robert Roßmair, die auf Tastenklick FM-Töne verschieder Frequenzen erklingen läßt. Die Funktion dieser Unit demonstriert ein Beispielprojekt.
Im Abschnitt "Multimedia" wird beschrieben, wie man Töne verschiedener Frequenz über den internen PC-Speaker ausgibt.
Töne als Wave-Dateien generieren und über die Soundkarte ausgeben
Wenn man nicht den Synthesizer-Chip der Soundkarte bemühen möchte, sondern einzelne Töne als digitalen Datenstrom erzeugen möchte, kann man Samples generieren und im Wave-Format ablegen.
Die Funktion "MakeSound" berechnet einen solchen Datenstrom und speichert ihn in einem MemoryStream. Anschließend wird die API-Funktion "sndPlaySound" mit dem Parameter "SND_MEMORY" aufgerufen, um den Wave-Sound direkt aus dem Stream heraus abzuspielen. Im Parameter "Frequency" übergibt man die Frequenz des Tons in Hertz, im Parameter "Duration" die Dauer des Tons in Millisekunden:
uses
MMSystem;
procedure MakeSound(Frequency, Duration : integer);
{writes tone to memory and plays it}
var
WaveFormatEx : TWaveFormatEx;
MS : TMemoryStream;
i, TempInt,
DataCount,
RiffCount : integer;
SoundValue : byte;
w : double; // omega ( 2 * pi * frequency)
const
Mono : Word = $0001;
SampleRate : integer = 11025; // 8000, 11025, 22050, or 44100
RiffId : string = 'RIFF';
WaveId : string = 'WAVE';
FmtId : string = 'fmt ';
DataId : string = 'data';
begin
with WaveFormatEx do begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := Mono;
nSamplesPerSec := SampleRate;
wBitsPerSample := $0008;
nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
nBlockAlign := (nChannels * wBitsPerSample) div 8;
cbSize := 0;
end;
MS := TMemoryStream.Create;
with MS do begin
{Calculate length of sound data and of file data}
DataCount := (Duration * SampleRate) div 1000; // sound data
RiffCount := Length(WaveId)
+ Length(FmtId) + SizeOf(DWord)
+ SizeOf(TWaveFormatEx)
+ Length(DataId) + SizeOf(DWord)
+ DataCount; // file data
{write out the wave header}
Write(RiffId[1], 4); // 'RIFF'
Write(RiffCount, SizeOf(DWord)); // file data size
Write(WaveId[1], Length(WaveId)); // 'WAVE'
Write(FmtId[1], Length(FmtId)); // 'fmt '
TempInt := SizeOf(TWaveFormatEx);
Write(TempInt, SizeOf(DWord)); // TWaveFormat data size
Write(WaveFormatEx, SizeOf(TWaveFormatEx)); // WaveFormatEx record
Write(DataId[1], Length(DataId)); // 'data'
Write(DataCount, SizeOf(DWord)); // sound data size
{calculate and write out the tone signal} // now the data values
w := 2 * Pi * Frequency; // omega
for i := 0 to DataCount - 1 do begin
// wt = w *i /SampleRate
SoundValue := 127 + trunc(127 * sin(i * w / SampleRate));
Write(SoundValue, SizeOf(Byte));
end;
// you could save the wave tone to file with :
// MS.Seek(0, soFromBeginning);
// MS.SaveToFile('C:\MyFile.wav');
// then reload and play them without having to
// construct them each time.
{now play the sound}
sndPlaySound(MS.Memory, SND_MEMORY or SND_SYNC);
MS.Free;
end;
end; {Alan Lloyd}
|
Texte unter Windows als Text und nicht als Grafik drucken
Wenn man Texte druckt, indem man auf den Canvas der Printer-Variablen malt, werden diese als Grafik gedruckt und der Ausdruck geht verhältnismäßig langsam. Viel schneller ging es früher unter DOS, als die Texte einfach Zeilenweise an die Druckerschnittstelle geschickt wurden. Das ist auch auf Windows-konforme Art und Weise möglich.
Die Prozedur "DruckeRoh_String" schickt die Texte als "Raw Data" zum Drucker. Dadurch kann man z.B. auch noch gut alte Nadeldrucker verwenden, ohne beim Ausdruck eine Mittagsschläfchen machen zu können. Für die Gestaltung des Drucks benötigt man allerdings wie unter DOS die alten Esc-Sequenzen. Ein Beispiel für den Aufruf der Prozedur wäre DruckeRoh_String('Hallo Welt'#13#10'Seite auswerfen'#12).
uses WinSpool;
procedure DruckeRoh_String(DiesenText:string);
var Printer : array [0..255] of char;
p : Integer;
function RawDataToPrinter(const szPrinterName : string;
const data:string;
dwCount : DWORD) : boolean;
var
hPrinter : THandle;
DocInfo : TDocInfo1;
dwJOB : DWORD;
dwBytesWritten : DWORD;
begin
Result := False;
if OpenPrinter (pchar (szPrinterName), hPrinter, Nil) then
try
// Fill in the structure with info about this "document"
DocInfo.pDocName := 'My Document';
DocInfo.pOutputFile := Nil;
DocInfo.pDatatype := 'RAW';
// Inform the spooler the document is beginning
dwJob := StartDocPrinter (hPrinter, 1, @docInfo);
if dwJob <> 0 then
try
if StartPagePrinter (hPrinter) then
try
if WritePrinter (hPrinter, Pchar(data), dwCount, dwBytesWritten) then
Result := dwBytesWritten = dwCount;
finally
EndPagePrinter (hPrinter)
end
finally
EndDocPrinter (hPrinter);
end
finally
ClosePrinter (hPrinter)
end
end; {RawDataToPrinter}
begin
GetProfileString ('windows',
'device',
',,,',
Printer,
sizeof(Printer));
p := Pos (',', Printer);
if p > 0 then
Printer [p - 1] := #0;
RawDataToPrinter (Printer, DiesenText, length(DiesenText));
end; {Joachim Mohr}
|
Den Binärtyp einer ausführbaren Datei ermitteln
Oft ist es interessant zu erfahren, um welchen Binärtypen es sich bei einer ausführbaren Datei handelt.
1. Die Zielplattform eines laufenden Prozesses kann man mit der API-Funktion "GetProcessVersion" ermitteln:
var
ProcVersion : DWord;
ProcessID : longint;
{ProcessID zu einem Fensterhandle ermitteln}
GetWindowThreadProcessID(wnd,@ProcessID);
{ProcessVersion der gefunden ProcessID ermitteln}
ProcVersion:=GetProcessVersion(ProcessID);
Label1.Caprtion:=IntToStr(ProcVersion shr 16)+'.'+IntToStr(ProcVersion mod $1000);
|
2. Um den tatsächlichen Binärtypen zu ermitteln kann man die API-Funktion "GetBinaryType" benutzen. Diese liefert zwar sehr detaillierte Auskünfte, funktioniert jedoch nicht mit geladenen Modulen.
3. Um den Binärtypen eines laufenden Programms zu ermitteln, kann man den Header der EXE-Datei auslesen. In den ersten beiden Bytes muß 'MZ' stehen. Dann ist es eine EXE-, ansonsten eine COM-Datei. Wenn im Word auf Offset $18 ein Wert>=$40 und im DWord auf Offset $3c ein Wert>0 steht, ist es kein DOS-EXE. In dem Fall enthält das DWord auf $3c den Offset zum eigentlichen Header. Sind die ersten beiden Bytes des eigentlichen Headers 'NE', ist's 16-Bit, bei 'PE' ist's 32 Bit. Das ist bei weitem nicht vollständig und ohne jegliche Validitätsprüfung, diese hat Windows aber schon beim Laden des Moduls erledigt.
Aus dieser Beschreibung von Heiko Nocon habe ich die Funktion GetExeType entwickelt, die aber im Gegensatz zu GetBinaryType nur zwischen DOS- bzw. 16-Bit- und 32-Bit-Windows-Dateien unterscheidet.
Die Beschriftung des "Öffnen"-Buttons in TOpenDialog ändern
Wenn man die TOpenDialog-Komponente benutzt, um z.B. einen Dateinamen für eine neu zu erstellende Datei zu vergeben, ist die Button-Beschriftung "Öffnen" unpassend. Besser wärein diesem Falle die Beschriftung "Erstellen". Michael Winter hat 2 Möglichkeiten vorgestellt, die Button-Beschriftung zu ändern:
1.) Behandeln des OnShow-Events des Dialogs:
procedure TForm1.OpenDialog1Show(Sender: TObject);
var Dlg: TOpenDialog;
DlgWnd: HWnd;
begin
Dlg := Sender as TOpenDialog;
if ofOldStyleDialog in Dlg.Options then
DlgWnd := Dlg.Handle
else
DlgWnd := GetParent(Dlg.Handle);
if GetParent(DlgWnd) <> Application.Handle then
exit;
SetDlgItemText(DlgWnd, 1, 'Erstellen');
end;
|
type
TBrowseFileDialog = class(TOpenDialog)
protected
procedure DoShow; override;
end;
procedure TBrowseFileDialog.DoShow;
var H: HWnd;
begin
if ofOldStyleDialog in Options then
H := Handle
else
H := GetParent(Handle);
SetDlgItemText(H, 1, 'Erstellen');
inherited;
end;
|
Zugriff auf einen Printer-Canvas vor oder nach dem Ausdruck
Ein Schreibzugriff auf Printer.Canvas ist nur nach einem Aufruf der der BeginDoc-Methode des Printer-Objekts und vor einem Aufruf der der EndDoc-Methode möglich. Heiko Nocon hat im September 2000 die Erkenntnis in dcld gepostet, daß Printer.Canvas auch außerhalb BeginDoc..EndDoc existiert. Es ist dann aber kein vollwertiger DC, sondern nur ein IDC (information device context). Nachzulesen in der VCL-Unit Printers.pas.
Auf einem IDC sind keine Ausgaben möglich, (also z.B. TextOut geht natürlich nicht), Informationsfunktionen wie TextWidth, TextExtend usw. sollten aber eigentlich funktionieren. Ein Fehler in Printers.pas sorgt aber dafür, daß diese Funktionen nach einem Druckerwechsel nicht mehr korrekt funktionieren.
Die entsprechende Stelle der Unit Printers.pas und einen passenden Workaround habe ich vor ca. einem halben Jahr hier geposted, als ich mich im Zusammenhang mit der Programmierung einer WYSIWYG-Druckvorschau mit demselben Problem rumgeschlagen habe. Der Quelltext des Workaround ist im Prinzip 1:1 der Unit Printers.pas entnommen, er wird aber dort durch den Bug nicht durchlaufen, wenn der Drucker gewechselt wird.
procedure ChangePrinterAdjustFont(MyPrinter: TPrinter; NewPrinterIndex:
integer);
var
IDC: hdc;
begin
IDC:=MyPrinter.Handle;
MyPrinter.PrinterIndex:=NewPrinterIndex;
MyPrinter.Canvas.Refresh;
MyPrinter.Canvas.Font.PixelsPerInch:=GetDeviceCaps(IDC, LOGPIXELSY);
end; {Heiko Nocon} |
Wie man die Ähnlichkeit zweier Texte mit dem Levenshtein-Algorithmus ermittelt
Für die Suche in Texten und Dateien ist es oft wünschenswert, auch Texte zu finden, die dem Suchbegriff nur ähnlich sind. Auf der p.i.c.s.-Komponentenseite findet man eine Unit, die einen n-Gramme-Algorithmus von Reinhard Rapp benutzt, den er 1997 in der Zeitschrift c't veröffentlicht hat (dieser Algorithmus wird auch für die Suche im c't-Index benutzt).
Prominentester Vertreter dieser Algorithmen ist aber wohl die Ermittlung der Levenshtein-Distanz. Damit wird gemessen, wieviele der Basisoperationen "Weglassen", "Einfügen" und manchmal "Ändern" man machen muß, um String A in String B zu überführen. Die Levenshtein-Distanz "0" entspricht identischen Texten, kleine Distanzen entsprechen ähnlichen Texten. Andreas Schmidt hat eine Delphi-Umsetzung des Levenshtein-Algorithmus in dcld gepostet. Diese Unit demonstriert die Benutzung seiner Funktion "LevenshteinDistance".
Wie man eine Bitmap um eine beliebigen Winkel dreht 
Die Funktion "RotateBitmap" dreht eine Bitmap um den Winkel "Angle" (in Grad) gegen den Uhrzeigersinn. Die Bitmap muß das Format pf24Bit (also 24 Bit Farbtiefe) haben:
uses Math;
function RotateBitmap(Bitmap: TBitmap; Angle: Double; Color: TColor):TBitmap;
const
MaxPixelCount = 32768;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..MaxPixelCount] of TRGBTriple;
var
A,
CosTheta,
SinTheta : Extended;
xSrc, ySrc,
xDst, yDst,
xODst, yODst,
xOSrc, yOSrc,
xPrime, yPrime : Integer;
srcRow, dstRow : PRGBTripleArray;
begin
Result := TBitmap.Create;
// Workaround SinCos bug
A := Angle;
while A >= 360 do
A := A - 360;
while A < 0 do
A := A + 360;
// end of workaround SinCos bug
SinCos(A * Pi / 180, SinTheta, CosTheta);
if (SinTheta * CosTheta) < 0 then begin
Result.Width := Round(Abs(Bitmap.Width * CosTheta
- Bitmap.Height * SinTheta));
Result.Height := Round(Abs(Bitmap.Width * SinTheta
- Bitmap.Height * CosTheta));
end
else begin
Result.Width := Round(Abs(Bitmap.Width * CosTheta
+ Bitmap.Height * SinTheta));
Result.Height := Round(Abs(Bitmap.Width * SinTheta
+ Bitmap.Height * CosTheta));
end;
with Result.Canvas do begin
Brush.Color := Color;
Brush.Style := bsSolid;
FillRect(ClipRect);
end;
Result.PixelFormat := pf24bit;
Bitmap.PixelFormat := pf24bit;
xODst := Result.Width div 2;
yODst := Result.Height div 2;
xOSrc := Bitmap.Width div 2;
yOSrc := Bitmap.Height div 2;
if CosTheta < 0 then
Dec(xOSrc);
if SinTheta < 0 then
Dec(yOSrc);
for ySrc := Max(Bitmap.Height, Result.Height)-1 downto 0 do begin
yPrime := ySrc - yODst;
for xSrc := Max(Bitmap.Width, Result.Width)-1 downto 0 do begin
xPrime := xSrc - xODst;
xDst := Round(xPrime * CosTheta - yPrime * SinTheta) + xOSrc;
yDst := Round(xPrime * SinTheta + yPrime * CosTheta) + yOSrc;
if (yDst >= 0) and (yDst < Bitmap.Height) and
(xDst >= 0) and (xDst < Bitmap.Width) and
(ySrc >= 0) and (ySrc < Result.Height) and
(xSrc >= 0) and (xSrc < Result.Width) then begin
srcRow := Bitmap.ScanLine[yDst];
dstRow := Result.Scanline[ySrc];
dstRow[xSrc] := srcRow[xDst];
end;
end;
end;
end;
|
Wie man erkennt, ob der aktuelle Windows-Benutzer Administrator-Rechte hat
Die Funktion "IsAdmin" von Michael Winter gibt "true" zurück, wenn der aktuelle Windows-Benutzer Administrator-Rechte hat. Sie funktioniert natürlich nur unter Betriebssystemen, die eine ausgewachsene Benutzerverwaltung haben, also Windows NT, 2k und XP. UNter allen Windows 9x-Versionen gibt die Funktion grundsätzlich "false" zurück.
function IsAdmin: Boolean;
const
SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority =
(Value: (0, 0, 0, 0, 0, 5));
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;
var
hAccessToken : THandle;
ptgGroups : PTokenGroups;
dwInfoBufferSize : Cardinal;
psidAdministrators : PSID;
x : Integer;
begin
Result := false;
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
if not OpenThreadToken(GetCurrentThread, TOKEN_QUERY,
TRUE, hAccessToken) then begin
if GetLastError <> ERROR_NO_TOKEN then
Exit;
if not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,
hAccessToken) then
Exit;
end;
try
GetTokenInformation(hAccessToken, TokenGroups, nil,
0, dwInfoBufferSize);
if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
Exit;
GetMem(ptgGroups, dwInfoBufferSize);
try
if not GetTokenInformation(hAccessToken, TokenGroups, ptgGroups,
dwInfoBufferSize, dwInfoBufferSize) then
Exit;
if not AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0, psidAdministrators) then
Exit;
try
for x := 0 to ptgGroups^.GroupCount - 1 do begin
if EqualSid(psidAdministrators, ptgGroups^.Groups[x].Sid) then begin
Result := true;
Break;
end;
end;
finally
FreeSid(psidAdministrators);
end;
finally
FreeMem(ptgGroups);
end;
finally
CloseHandle(hAccessToken);
end;
end; {Michael Winter}
|