Tips & 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}
Wenn man einen Screenshot eines bestimmten Fensters oder Controls haben möchte, besorgt man sich das Handle dieses Fensters und ermittelt dann den Bildauschnitt mit der API-Funktion GetWindowRect(..). Diesen Ausschnitt kopiert man dann einfach aus dem Desktop-Screenshot.

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;
Nun immer statt der Unit Mapi deine neue Unit MyMapi in deine Programme einbinden. Dieses Vorgehen ist getestet unter Win95, Win98, Win98 SE mit Netscape, Outlook, Outlook Express, mit Delphi 3.02, Delphi 4 und Delphi 5 (Trial Version).

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);
Allerdings existieren durchaus z.B. 16-Bit-Programme mit der Zielplattform Windows 9x.

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;
2.) Ableiten eines Nachkommen von TOpenDialog:

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}
Diese Prozedur ist nach einem Druckerwechsel mit dem Index des neu ausgewählten Druckers aufzurufen.

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}