Delphi - Tips und Tricks

Am Anfang jeden Abschnitts befindet sich eine Aufzählung der Betriebssystemversion. Bei einigen steht ein OK. Dieses OK bedeutet nur, das der Tip unter diesem Betriebssystem ausprobiert wurde. Ein Strich bedeutet, das es nicht ausgetestet wurde und nicht, das es nicht funktioniert.

Aktuelle Recordnummer einer DB Tabelle

Ermitteln der aktuellen Recordnummer einer DB Tabelle:

Erste Recordnummer ist '1'

Letzte Recordnummer ist 'Table1.RecordCount'

Funktioniert auch mit dem Typ TQuery.

Function GetRecNo(oTable: TTable):LongInt;
Var
  rslt: DBIResult;
  rRecordProp: RECProps;
  szErrMsg: DBIMSG;
begin
  Result := 0;
  Try
    oTable.UpdateCursorPos ;
    rslt := DbiGetRecord(oTable.Handle,dbiNOLOCK,nil,@rRecordProp);
    If rslt = DBIERR_NONE Then Begin
      // -- Nur bei dBase und FoxPro
      // Result := rRecordProp.iPhyRecNum;
      // -- Nur bei Paradox
      Result := rRecordProp.iSeqNum;
    End Else Begin
      Case rslt of
        DBIERR_BOF: Result := 1;
        DBIERR_EOF: Result := oTable.RecordCount;
        Else Begin
          DbiGetErrorString(rslt,szErrMsg);
          ShowMessage(StrPas(szErrMsg));
        End;
      End;
    End;
  Except
    on E: EDBEngineError do ShowMessage(E.Message);
  End;
end ;

Um diese Routine zu benutzen, muß die Unit DBITypes in Uses stehen.

Uses DBITypes,...;

Align für StringGrid

Text in einer StringGrid Zelle rechtsbündig, linksbündig und zentriert ausgeben.

procedure TForm1.Button1Click(Sender: TObject);
begin
  StringGrid1.Tag := 0;
  StringGrid1.Cells[1,1] := 'a123456';
  Application.ProcessMessages;

  StringGrid1.Tag := 1;
  StringGrid1.Cells[2,2] := 'a12';
  Application.ProcessMessages;

  StringGrid1.Tag := 2;
  StringGrid1.Cells[3,3] := 'a22';
  Application.ProcessMessages;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
Var tw,tc:Integer;
begin
  tw := StringGrid1.Canvas.TextWidth(StringGrid1.Cells[Col,Row]);
  Case StringGrid1.Tag of
    0: tc := Rect.Right - tw - 2; // Text rechtsbündig
    1: tc := Rect.Left + (Rect.Right - Rect.Left - tw) div 2; // Text zentrieren
    2: tc := Rect.Left + 2; // Text linksbündig
  End;
  StringGrid1.Canvas.TextRect(Rect,tc,Rect.Top+2,StringGrid1.Cells[Col,Row]);
end;

Alle BDE Alias Einträge besorgen

Eine String-Liste mit allen Aliaseinträgen der BDE besorgen:

Function GetAliasTable(Var lb:TStrings):Boolean;
Var fSession:TSession;
Begin
  Result := true;
  fSession := TSession.Create(Form1.Owner);
  Try
    fSession.SessionName := 'Temp';
    Try
      fSession.GetAliasNames(lb);
    Except
      Result := false;
    End;
  Finally
    fSession.Free;
  End;
End;

procedure TForm1.Button1Click(Sender: TObject);
Var fList:TStrings;
begin
  fList := TStringList.Create;
  Try
    GetAliasTable(fList);
    ListBox1.Items := fList;
  Finally
    fList.Free;
  End;
end;

Achtung: Uses DBTables; wird benötigt.

Alle BDE Tabellen zu einem Alias besorgen

Eine String Liste mit allen Tabellen besorgen, die zu einem Alias gehören:

Version 1: Die Tabellen werden komplett über die BDE besorgt.

Function GetDbTables(fAlias:String;Var lb:TStrings):Boolean;
Var fSession:TSession;
Begin
  Result := true;
  fSession := TSession.Create(Form1.Owner);
  Try
    fSession.SessionName := 'Temp';
    Try
      fSession.GetTableNames(fAlias,'*.db',true,false,lb);
    Except
      Result := false;
    End;
  Finally
    fSession.Free;
  End;
End;

Achtung: Uses DBTables; wird benötigt.

Version 2: Die Tabellen werden über die ALIAS aus dem Directory besorgt.

Function GetAliasPath(fAlias:String):String;
var Desc: DBDesc;
begin
  Result := '';
  If DbiGetDatabaseDesc(PChar(fAlias),@Desc) = DBIERR_NONE Then Begin
    Result := StrPas(Desc.szPhyName);
  End Else Begin
    If DbiInit(nil) = DBIERR_NONE Then Begin
      DbiGetDatabaseDesc(PChar(fAlias),@Desc);
      Result := StrPas(Desc.szPhyName);
    End;
  End;
end;

Function TForm1.GetDbTable(fAlias:String;Var lb:TStrings):Boolean;
Var s1:String; fl1:TFileListBox; i:Integer;
Begin
  Result := false;
  lb.Clear;
  fl1 := TFileListBox.Create(Self);
  Try
    s1 := GetAliasPath(fAlias);
    Try
      fl1.Parent := Self;
      fl1.Visible := false;
      fl1.FileType := [ftNormal];
      fl1.Directory := s1;
      fl1.Mask := '*.db';
      fl1.Enabled := true;
      ListBox2.Items := fl1.Items;
      If fl1.Items.Count > 0 Then Begin
        For i := 0 to fl1.Items.Count-1 do Begin
          lb.Add(fl1.Items[i]);
        End;
      End;
      Result := true;
    Except
    End;
  Finally
    fl1.Free;
  End;
End;

Achtung: Uses DBITypes, FileCtrl; wird benötigt.


procedure TForm1.Button1Click(Sender: TObject);
Var fList:TStrings;
begin
  fList := TStringList.Create;
  Try
    GetDbTables('SDMDB',fList);
    ListBox1.Items := fList;
  Finally
    fList.Free;
  End;
end;

Alle Dateien eines Dir mit SubDirs

Diese Funktion liest rekursiv alle Dateinamen eines Ordners und dessen Unterverzeichnisse in eine Stringliste ein und gibt außerdem als Result die Gesamtgröße des Verzeichnisbaumes zurück:

var VerzListe: TStringList;

Function VerzGroesse(Verzeichnis:string):longint;
Var SR: TSearchRec;
    Groesse: longint;
Begin
  Groesse:=0;
  If Verzeichnis[length(Verzeichnis)]<>'\' Then Verzeichnis:=Verzeichnis+'\';
  If FindFirst(Verzeichnis+'*.*',$3F,SR)=0 Then Begin
    If ((SR.Attr and faDirectory)>0) and (SR.Name<>'.') and (SR.Name<>'..') Then Begin
      Groesse:=Groesse+VerzGroesse(Verzeichnis+SR.Name)
    End Else Begin
      Groesse:=Groesse+SR.Size;
    End;
    If (SR.Name<>'.') and (SR.Name<>'..') Then VerzListe.Add(Verzeichnis+SR.Name);
    While FindNext(SR)=0 do Begin
      If ((SR.Attr and faDirectory)>0) and (SR.Name<>'.') and (SR.Name<>'..') Then Begin
        Groesse:=Groesse+VerzGroesse(Verzeichnis+SR.Name)
      End Else Begin
        Groesse:=Groesse+SR.Size;
      End;
      If (SR.Name<>'.') and (SR.Name<>'..') Then VerzListe.Add(Verzeichnis+SR.Name);
    End;
  End;
  FindClose(SR);
  Result:=Groesse;
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
  VerzListe:=TStringList.Create;
  Label1.Caption:=IntToStr(VerzGroesse('C:\Programme'))+' Byte';
  ListBox1.Items.Assign(VerzListe);
  VerzListe.Free;
end;

Anwendung zu einem Dokument finden

Durch diese Routine wird herausgefunden, mit welcher Applikation eine Datei verknüpft ist.

Function GetAppName(xFile:String):String;
Var pFile,pPath,pApp: Array [0..255] of Char;
Begin
  StrPCopy(pFile,xFile);
  pPath := #0;
  pApp := #0;
  FindExecutable(pFile,pPath,pApp);
  Result := StrPas(pApp);
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := GetAppName('c:\Bootlog.txt');
end;

Die Antwort für 'c:\Bootlog.txt'  ist: 'notepad.exe'
Die Antwort für 'c:\Config.sys'   ist: '':
Die Antwort für 'c:\autoexec.bat' ist: 'c:\autoexec.bat'

Um die Shell-Routine zu benutzen, muß die Unit ShellAPI in Uses stehen.

Uses ShellAPI,...;

Applikation in den Bildschirm einpassen

Diese Funktion berechnet die Größe einer Applikation so, daß sie genau in den Bildschirm paßt. Dabei wird das vorhandensein der Taskleiste berücksichtigt.

procedure TForm1.FormCreate(Sender: TObject);
Var sx,sy,ux,uy:Integer;
begin
  sx := GetSystemMetrics(SM_CXSCREEN); // Bildschirmbreite in Pixel
  sy := GetSystemMetrics(SM_CYSCREEN); // Bildschirmhöhe in Pixel
  ux := GetSystemMetrics(SM_CXFULLSCREEN); // Bildschirmbreite in Pixel ohne Taskleiste
  uy := GetSystemMetrics(SM_CYFULLSCREEN); // Bildschirmhöhe in Pixel ohne Taskleiste
  If (ux < Width) or (uy < Height) Then BorderStyle := bsSizeable;
  If uy < Height Then Begin
    Height := uy - 20;
    Width := Width + 16;
  End;
  If Width > ux Then Width := ux;
  ...
End;

Array von Komponenten erzeugen

Das ganze wird erklärt an einem Array vom Typ TEdit.

Als erstes wird ein Array für Komponenten erzeugt:

implementation

  Const MaxArray = 7;

  Var aEdit: Array [0..MaxArray] of TEdit;

In der FormCreate Procedure werden jetzt die Array's erzeugt. Das kann aber auch in irgendeiner anderen Procedure passieren:

procedure TForm1.FormCreate(Sender: TObject);
Var i:Integer;
begin
  For i := 0 to MaxArray do Begin
    aEdit[i] := TEdit.Create(Self); // Komponente erzeugen
    aEdit[i].Top := 20 + i * 24;
    aEdit[i].Left := 20;
    aEdit[i].Height := 21;
    aEdit[i].Width := 100;
    aEdit[i].Tag := i; // Array Index in der Komponente selbst speichern
    aEdit[i].OnClick := aEditClick; // OnClick Ereignis installieren
    aEdit[i].Parent := Form1; // z.B Self oder einen anderen Komponenten Namen
  End;
end;

Wichtig ist die Parent Zuweisung. Damit wird den Edit Komponenten das übergeordnete Fenster zugewiesen. In diesem Fall ist es das Hauptformular. Es kann aber auch z.B. eine Komponente vom Typ TPanel sein, dann werden alle Edit's in dieser Komponente angeordnet.

Die Komponenten sind jetzt im Hauptfoemular sichtbar.

Beim verlassen des Programms müssen die Komponenten entfernt werden, damit der reservierte Speicher wieder freigegeben wird:

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
Var i:Integer;
begin
  For i := 0 to MaxArray do Begin
    aEdit[i].Free;
  End;
end;

Der Zufriff auf die Properties erfolgt ganz normal:

procedure TForm1.Button1Click(Sender: TObject);
Var i:Integer;
begin
  For i := 0 to MaxArray do Begin
    aEdit[i].Text := IntToStr(i);
  End;
end;

Installieren einer Event Routine:

Die Zuweisung wurde schon beim Erzeugen der Komponenten erledigt:
    aEdit[i].OnClick := aEditClick; // OnClick Ereignis installieren


Vorher muß jedoch die Event Procedure geschrieben werden. Den formalen Aufbau guckt man sich am besten bei den fertigen Komponenten ab:

Procedure TForm1.aEditClick(Sender: TObject);
Begin
  Edit1.Text := IntToStr((Sender as TEdit).Tag);
End;

Für die Erkennung des Array-Index wird die Information aus dem Tag-Feld benutzt.

Die Procedure muß jetzt nur noch in der Typen Definiton eingetragen werden. Am besten unter Private. Das erleichtert ein wenig die Übersicht über die selbstgeschrieben Proceduren.

  private
    { Private-Deklarationen }
    Procedure aEditClick(Sender: TObject);

Audio CD im Laufwerk?

Einfach auf dem angegebenen Laufwerk nach einer Datei mit der Endung *.cda suchen:

Function AudioCD_InDrive(Drive:string):boolean;
Var SR : TSearchRec;
Begin
  Result:=SysUtils.FindFirst(Drive+'\*.cda',faAnyFile,SR)=0;
  SysUtils.FindClose(SR);
End;

BDE Alias zur Laufzeit erzeugen

  DBIAddAlias(nil,'MYALIAS',nil,'PATH:C:\MYPATH',True);

Parameternummer:
1 - nil
2 - Name des Alias - pchar
3 - Treiber Typ - wenn er nil ist, dann wird STANDARD benutzt
4 - Alias Parameter, im Format 'Option:Value;Option1:Value1'
5 - True für einen Persistent Alias

Um diese Routine zu benutzen, muß die Unit DBIProcs in Uses stehen.

Uses DBIProcs,...;

BDE beschleunigen

  1. Auf der Systemseite des BDE Konfigurationsprogramms kann die Variable LOCAL SHARE = false gesetzt werden. Diese Option muß nur dann auf true gesetzt werden, wenn BDE und nicht BDE Anwendungen gleichzeitig auf Paradox und DBase Tabellen zugreifen wollen.
  2. Beim Server BDE. Nach Möglichkeit sollte SQL Links 3.5 (oder höhere Version) benutzt werden. Sie ist beim Kauf der Intrabuilder/Client Version enthalten.
  3. Beim Server BDE. Wenn die Performance beim öffnen und update von Tabellen und Queries beschleunigt werden soll, dann sollte die Variable ENABLE SCHEMA CACHE = true gesetzt werden. Die einzige Situation, wo dies nicht gemacht werden kann, ist wenn Tabellen erzeugt oder die Struktur von existierenden Tabellen geändert wird. Es wurden Verbesserungen bis zum Faktor 10 beobachtet.
  4. Beim Server BDE. Stelle sicher, daß TRACE MODE = 0 ist (beim Driver Page des BDE Konfigurations Programms). Diese Option wird nur beim debugging benötigt und kann die Geschwindigkeit der Applikation erheblich runtersetzen.
  5. Beim Server BDE. Die ausdrückliche Benutzung von Start Transaktion und Ende Transaktion ist normalerweise schneller als sich darauf zu verlassen, daß die DBE SQL Links über AUTOCOMMIT es für einen erledigt. Setzte Variable SQLPASSTHRU MODE = SHARED NOAUTOCOMMIT und kontrolliere die Datentransaktionen in deinem Programm.

BDE Buffer schreiben

Um Datenbankaktionen zu beschleunigen, behält die BDE Daten im Hauptspeicher.

Wird die Tabelle geschlossen, werden die Daten in die Tabelle geschrieben:

Table1.Close;

Table1.Open;

Nachteil: Datensatzzeiger geht verloren

Besser: Direkter Zugriff auf die BDE

DbiSaveChanges(Table1.Handle);

Die Funktion kann folgende Ergebnisse haben:

DBIERR_NONE           Alle Änderungen wurden gespeichert.

DBIERR_INVALIDHNDL    Die Handlenummer ist ungültig oder nil.

DBIERR_NODISKSPACE    Die Änderungen wurden nicht gespeichert, weil die Disk voll ist.

DBIERR_NOTSUPPORTED   Diese Funktion unterstützt keine SQL Tabellen.

Um diese Routine zu benutzen, muß die Unit DBIProcs in Uses stehen.

Uses DBIProcs,...;

DBIUseIdleTime wird in 32bit Systemen nicht mehr unterstützt.

BDE entfernen

In Registry:

Im Dateisystem:

BDE Fehler mit Filenamen

Achtung:

Der Filename einer Tabelle darf nicht 'File.db' heissen. Wenn doch, dann tritt bei einem SQL Zugriff folgende Fehlermeldung auf:
Ungültiges Schlüsselwort
Symbol-String: File.db
WHERE
Zeilennummer: 2

Der SQL Befehl dazu lautet:

'SELECT * FROM File.db WHERE LastModify > LastExport'

BDE Tabelle mit Passwortschutz

Öffnet man eine Tabelle, die mit einem Passwort versehen ist, dann übernimmt die BDE die Eingabe des Passwortes. Man kann danach mit den Daten arbeiten. Wird die Tabelle wieder geschlossen, dann kann sie hinterher wieder geöffnet werden, ohne das das Passwort ein weiteres mal abgefragt wird. Eine erneute Abfrage findet erst nach einem Programmneustart statt.

Das ist nicht gut, denn wenn man eine geschützte Tabelle schliesst, soll sie auch unzugänglich sein.

Abhilfe:

Eine eigenes Formular zur Abfrage eines Passwortes bauen und vor dem öffnen der Tabelle den Zugang über DBI Funktionen selbst gestalten:

Uses DBIProcs,...

Var Password: String;
...

Function UnlockTable(pw:String):Boolean;
begin
  Result := false;
  If FunTable.Active = false Then Begin
    If PasswordBox.ShowModal = mrOK Then Begin
      If DBIAddPassword(PChar(Password)) = DBIERR_NONE Then Begin
        FunTable.Active := true;
        Result := true;
      End;
    End;
  End;
end;

Function LockTable(pw:String):Boolean;
begin
  Result := false;
  FunTable.Active := false;
  If DbiDropPassword(PChar(Password)) = DBIERR_NONE Then Begin
    Password := '';
    Result := true;
  End;
end;

Password sollte als globale Variable im Password-Formular definiert werden.

Beim Start einer Anwendung einen Startbildschirm (SplashScreen) anzeigen

Um einen Startbildschirm (SplashScreen) a la Delphi zu bekommen braucht man nur eine entsprechende Form (evtl. noch BorderStyle auf bsNone und Position auf poScreenCenter).

Um dieses Fenster vor dem Erstellen aller anderen Fenster anzuzeigen geht man folgendermaßen vor:

program Project1;

uses
  Windows, // wird nur für die Sleep-Routine gebraucht
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  Unit2 in 'Unit2.pas' {IntroMain};

{$R *.RES}

var
    Intro: TIntroMain; // Das Fenster, was angezeigt werden soll

begin
  Application.Initialize;

  Intro := TIntroMain.Create(Application);
  Intro.Show;
  Intro.Update;

  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TIntroMain, IntroMain);

  Sleep(2000); // Nur wenn das Laden zu schnell geht
  Intro.Free;

  Application.Run;
end.

Benutzer und freier Memory

procedure TForm1.Button1Click(Sender: TObject);
var MemoryStatus: TMemoryStatus;
begin
  MemoryStatus.dwLength := sizeof(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Label1.Caption := 'Total Physical Memory: ' + IntToStr(MemoryStatus.dwTotalPhys);
end;

Die Funktion GlobalMemoryStatus stellt auch andere Informationen zur Verfügung:

typedef struct _MEMORYSTATUS { // mst
  DWORD dwLength; // sizeof(MEMORYSTATUS)
  DWORD dwMemoryLoad; // percent of memory in use
  DWORD dwTotalPhys; // bytes of physical memory
  DWORD dwAvailPhys; // free physical memory bytes
  DWORD dwTotalPageFile; // bytes of paging file
  DWORD dwAvailPageFile; // free bytes of paging file
  DWORD dwTotalVirtual; // user bytes of address space
  DWORD dwAvailVirtual; // free user bytes
  } MEMORYSTATUS, *LPMEMORYSTATUS;

Betriebssystem ermitteln

Ermittlung des Betriebssystems (Win95, Win98, WinNT) und der Versionsnummer.

Function GetWindowsVersion:string;
Var
  OsVinfo: TOSVERSIONINFO;
  HilfStr: Array[0..50] of Char;
begin
  ZeroMemory(@OsVinfo,sizeOf(OsVinfo));
  OsVinfo.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);
  If GetVersionEx(OsVinfo) Then Begin
    If OsVinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then Begin
      If (OsVinfo.dwMajorVersion = 4) and (OsVinfo.dwMinorVersion > 0) Then Begin
        StrFmt(HilfStr,'Windows 98 - Version %d.%.2d.%d',
               [OsVinfo.dwMajorVersion, OsVinfo.dwMinorVersion,
                OsVinfo.dwBuildNumber AND $FFFF])
      End Else Begin
        StrFmt(HilfStr,'Windows 95 - Version %d.%d Build %d',
               [OsVinfo.dwMajorVersion, OsVinfo.dwMinorVersion,
                OsVinfo.dwBuildNumber AND $FFFF]);
      End;
    End;
    If OsVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT Then Begin
      StrFmt(HilfStr,'Microsoft Windows NT Version %d.%.2d.%d',
             [OsVinfo.dwMajorVersion, OsVinfo.dwMinorVersion,
              OsVinfo.dwBuildNumber AND $FFFF]);
    End;
  End Else StrCopy(HilfStr,'Fehler bei GetversionEx()!');
  Result := string(HilfStr);
end;

Bildschirmschoner schalten

SystemParametersInfo(SPI_SETSCREENSAVERACTIVE,1,Nil,0);

Bildschirmschoner ausschalten

SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,0,Nil,0);

Bildschirmschoner Status

Var Flag:Word;

SystemParametersInfo(SPI_GETSCREENSAVEACTIVE,0,@Flag,0);

Flag = 0 = ausgeschaltet

Flag = 1 = eingeschaltet

Hinweis

War der Bildschirmschoner ausgeschaltet, dann hat das Einschalten per Software keine Wirkung, weil keine Screen-Saver-Datei definiert wurde.

Bitmap aus Resource Datei

TImage.Picture.Bitmap.Handle := LoadBitmap(Handle,'BITMAPNAMEHERE');

SpeedButton.Glyph.Handle := LoadBitmap(HInstance,'BITMAP_NAME');

Bitmap in der Menüleiste

var
   Bmp1 : TPicture;

...

Bmp1 := TPicture.Create;
Bmp1.LoadFromFile('c:\where\b1.BMP');
SetMenuItemBitmaps( MenuItemTest.Handle,
                        0,
                        MF_BYPOSITION,
                        Bmp1.Bitmap.Handle,
                        Bmp1.Bitmap.Handle);
...
Erstelle ein TBitmap und lade eine Grafik in das Bitmap. Benutze die API-Funktion "SetMenuItemBitmaps", um das Bitmap mit dem MenüItem zu verknüpfen:

All this can by coded in the .Create of a form.

Result : It works, but only the right-top of the bitmap is displayed. Rest us to change the height and/or width of the menuitem according to the bitmap

Achtung, geht nur mit Untermenüs, bei denen auch ein Häckchen angezeigt werden kann.

Bitmap transparent machen

Man braucht alle beteiligten Bilder auf einem Canvas (z.B. dem einer TImage-Komponente). Zu jedem Bild braucht man eine Maske, in der alle transparenten Punkte schwarz und die anderen weiß sind. Im Bild selber sind alle transparenten Punkte schwarz.

Jetzt kann man ganz einfach mit folgender Funktion transparente Bilder auf ein Canvas zeichnen:

function TransparentDraw(ZielDC:Word; zLeft, zTop, zWidth, zHeight: Integer; QuellDC, MaskeDC: Word;
qLeft, qTop: Integer): Boolean;
begin
  Result:=BitBlt(ZielDC, zLeft, zTop, zWidth, zHeight, MaskeDC, qLeft, qTop, SrcAnd);
  Result:=Result and BitBlt(ZielDC, zLeft, zTop, zWidth, zHeight, QuellDC, qLeft, qTop, SrcInvert);
end;
Ausgefürht wird das ganze dann so:
  TransparentDraw(Ziel.Canvas.Handle, ZielLeft, ZielTop, ZielWidth, ZielHeight, Quell.Canvas.Handle,
Maske.Canvas.Handle, QuellLeft, QuellTop);


Ziel.Canvas.Handle -> Kann auch das TempBild von oben sein

ZielLeft -> Linker Anfang des Bilds auf dem Zielcanvas

ZielTop -> Oberer Anfang auf dem Zielcanvas

ZielWidth -> Breite des einzufügenden Bildes

ZielHeight -> Höhe des einzufügenden Bildes

Quell.Canvas.Handle -> Quelle

Maske.Canvas.Handle -> Maske

QuellLeft -> Position in dem Quellbild

QuellTop -> Position in dem Quellbild

Button in der Titelleiste

So kann man einen Button in die Titelzeile bringen:

unit Main;

interface

uses
  Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs;

type
  TForm1 = class(TForm)
    procedure FormResize(Sender: TObject);
  private
    CaptionBtn : TRect;
    procedure DrawCaptButton;
    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
    procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
    procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
    procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

const htCaptionBtn = htSizeLast + 1;
{$R *.DFM}

procedure TForm1.DrawCaptButton;
var
  xFrame,
  yFrame,
  xSize,
  ySize : Integer;
  R : TRect;
begin
  //Dimensions of Sizeable Frame
  xFrame := GetSystemMetrics(SM_CXFRAME);
  yFrame := GetSystemMetrics(SM_CYFRAME);

  //Dimensions of Caption Buttons
  xSize := GetSystemMetrics(SM_CXSIZE);
  ySize := GetSystemMetrics(SM_CYSIZE);

  //Define the placement of the new caption button
  CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
                       yFrame + 2, xSize - 2, ySize - 4);

  //Get the handle to canvas using Form's device context
  Canvas.Handle := GetWindowDC(Self.Handle);

  Canvas.Font.Name := 'Symbol';
  Canvas.Font.Color := clBlue;
  Canvas.Font.Style := [fsBold];
  Canvas.Pen.Color := clYellow;
  Canvas.Brush.Color := clBtnFace;

  try
    DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
    //Define a smaller drawing rectangle within the button
    R := Bounds(Width - xFrame - 4 * xSize + 2,
                       yFrame + 3, xSize - 6, ySize - 7);
    with CaptionBtn do
      Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
  finally
    ReleaseDC(Self.Handle, Canvas.Handle);
    Canvas.Handle := 0;
  end;
end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
  inherited;
  with Msg do
    if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
      Result := htCaptionBtn;
end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
  inherited;
  if (Msg.HitTest = htCaptionBtn) then
    ShowMessage('You hit the button on the caption bar');
end;
  

procedure TForm1.FormResize(Sender: TObject);
begin
  //Force a redraw of caption bar if form is resized
  Perform(WM_NCACTIVATE, Word(Active), 0);
end;

end.

CD Klappe auf und zu

CD Klappe öffnen:

mciSendString('Set cdaudio door open wait',nil,0,handle);

CD Klappe schliessen:

mciSendString('Set cdaudio door closed wait',nil,0,handle);

Um diese Routine zu benutzen, muß die Unit MMSystem in Uses stehen.

Uses MMSystem,...;

Andere Kommandos:

Close Border-Icon disablen

Das Close-Border-Icon kann leider nicht rausgekickt werden, aber man kann es disablen:

Procedure TForm1.EnableCloseButton;
Var MenuHandle:HMENU;
Begin
  MenuHandle:= GetSystemMenu(Self.Handle, False);
  EnableMenuItem(MenuHandle,SC_CLOSE,MF_BYCOMMAND or MF_ENABLED);
End;

Procedure TForm1.DisableCloseButton;
Var MenuHandle:HMENU;
Begin
  MenuHandle:= GetSystemMenu(Self.Handle, False);
  EnableMenuItem(MenuHandle,SC_CLOSE,MF_BYCOMMAND or MF_GRAYED);
End;

Oder was auch ganz witzig ist, einfach den Menüeintrag 'Schließen ALT-F4' rauswerfen:

procedure TForm1.Button3Click(Sender: TObject);
Var MenuHandle:HMENU;
begin
  MenuHandle:= GetSystemMenu(Self.Handle, False);
  DeleteMenu(MenuHandle,6,MF_BYPOSITION);
end;


Nachteil oder Vorteil: ALT-F4 funktioniert trotzdem noch.

Combo Box automatisch aufklappen

Combo Box aufklappen:

SendMessage(combobox1.Handle,CB_SHOWDROPDOWN,1,0);

Combo Box zuklappen:

SendMessage(combobox1.Handle,CB_SHOWDROPDOWN,0,0);

Compilerschalter der Delphi-Versionen

Es gibt (bisher) folgende Versionen:

VER80 - Delphi 1

VER90 - Delphi 2

VER93 - C++ Builder 1.0

VER100 - Delphi 3

VER110 - C++ Builder 3.0

VER120 - Delphi 4

VER125 - C++ Builder 4.0

VER130 - Delphi 5

Um also eine Anweisung nur vom Delphi 3-Compiler bearbeiten zu lassen, ist der entsprechende Ausdruck in folgendeCompiler-Direktiven einzuschließen:

{$IFDEF VER100}
   Anweisung nur für Delphi 3;
{$ENDIF}

Ebenso lassen sich Anweisungen nur für 32Bit-Programme oder 16Bit-Programme kompilieren:

{$IFDEF WIN32}
   Anweisung nur für 32Bit-Programme;
{$ELSE}
   Anweisung nur für 16Bit-Programme;
{$ENDIF}

Cursorposition in TMemo lesen und setzen

Procedure GetMemoLinePos(Memo:TMemo;var MemoRow,MemoCol:Integer);
Begin
  With Memo do Begin
    MemoRow := SendMessage(Handle,EM_LINEFROMCHAR,SelStart,0);
    MemoCol := SelStart - SendMessage(Handle,EM_LINEINDEX,MemoRow,0);
  End;
End;

Procedure SetMemoLinePos(Memo:TMemo;MemoRow,MemoCol:Integer );
Begin
  If MemoRow <= Memo.Lines.Count
    Then Memo.SelStart := SendMessage(Memo.Handle,EM_LINEINDEX,MemoRow,0) + MemoCol
    Else Memo.SelStart := SendMessage(Memo.Handle,EM_LINEINDEX,Memo.Lines.Count,0) + MemoCol
End;

Hinweis:

Wird MemoRow auf eine Spalte gesetzt, die nicht existiert, dann wird automatisch ein Übertrag berechnet:

Wenn eine Position im Memo-Feld gesetzt wird, sollte hinter dem SetMemoLinePos Befehl dem Memo-Feld der Focus gegeben werden.

Dateien kopieren

procedure FileCopy(von,nach:string);
var src,dest : tFilestream;
begin
  src := tFilestream.create(von,fmShareDenyNone or fmOpenRead);
  try
    dest := tFilestream.create(nach,fmCreate);
    try
      dest.copyfrom(src,src.size);
    finally
      dest.free;
    end;
  finally
  src.free;
end;

Siehe auch Funktion CopyFile(source,dest)

Dateien löschen, kopieren oder verschieben

1.) Dateien löschen

Dazu gibt es mehere Möglichkeiten:

var Dateiname : string;

{Möglichkeit 1: DeleteFile}
If not DeleteFile(Dateiname) Then ShowMessage('Datei "'+Dateiname+'" konnte nicht gelöscht werden!');

{Möglichkeit 2: Erase}
Var F : File;
Begin
  AssignFile(F,Dateiname);
  {$I-}
  Erase(F);
  {$I+}
  If IOResult<>0 Then ShowMessage('Datei "'+Dateiname+'" konnte nicht gelöscht werden!');

Die 3. Möglichkeit ist die API-Funktion SHFileOperation, mit dieser können Dateien auch in den Papierkorb verschoben werden. Außerdem kann man die Standard-Windows-Fortschrittanzeige anzeigen.

2.) Dateien kopieren oder verschieben

Auch dazu gibt es mehere Möglichkeiten:

{Möglichkeit 1: CopyFile}
var Quelldatei, Zieldatei : string;

if not CopyFile(PChar(Quelldatei), PChar(Zieldatei), true) then
  ShowMessage('Datei "'+Quelldatei+'" konnte nicht kopiert werden!');

{Möglichkeit 2: Per TFileStream}
FUNCTION QuickCopy ( Quelle, Ziel : STRING ) : BOOLEAN;
VAR
  S, T: TFileStream;
BEGIN
  Result := TRUE;
  S := TFileStream.Create( Quelle, fmOpenRead );
  TRY
    TRY
      T := TFileStream.Create( Ziel, fmOpenWrite OR fmCreate );
    EXCEPT
      Screen.Cursor := crDefault;
      MessageDlg('Fehler beim Erzeugen der Zieldatei'+#13+Ziel, mtError, [mbOK], 0);
      Result := FALSE;
    END;
    TRY
      TRY
        T.CopyFrom( S, S.Size ) ;
        if Config.CopyDat then
          FileSetDate( T.Handle, FileGetDate( S.Handle ) )
        else
          FileSetDate( T.Handle, DateTimeToFileDate(Now) );
        { Dateizeit setzen }
      EXCEPT
        Screen.Cursor := crDefault;
        MessageDlg('Fehler beim Kopieren der Zieldatei'+#13+Ziel, mtError, [mbOK], 0);
        Result := FALSE
      END;
    FINALLY
      T.Free
    END;
  FINALLY
    S.Free
  END
END; {QuickCopy}

Möchte man eine Datei verschieben, muß man die Quelldatei(en) anschließend noch löschen.

Die 3. Möglichkeit ist die API-Funktion SHFileOperation, mit dieser kann man auch die Standard-Windows-Fortschrittanzeige anzeigen.

Dateigröße (Filesize) ermitteln

Man kann die Datei als File of Byte öffnen und dann die Dateigröße mit der FileSize-Funktion ermitteln, oder man benutzt die FindFirst-Funktion:

Function MyFileSize(Filename:string):integer;
Var SR:TSearchRec;
begin
  If FindFirst(Filename,faAnyFile,SR) = 0 Then Begin
    Result := SR.Size;
  End Else Begin
    Result := -1;
  End;
  FindClose(SR);
end;

Dateiverknüpfung bestimmen

Durch diese Routine wird herausgefunden, mit welcher Application eine Datei verknüpft ist.

Function GetAppName(xFile:String):String;
Var pFile,pPath,pApp: Array [0..255] of Char;
Begin
  StrPCopy(pFile,xFile);
  pPath := #0;
  pApp := #0;
  FindExecutable(pFile,pPath,pApp);
  Result := StrPas(pApp);
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := GetAppName('c:\Bootlog.txt');
end;

Um die Shell-Routine zu benutzen, muß die Unit ShellAPI in Uses stehen.

Uses ShellAPI,...;

Datenbankzugriff auf Paradox-Tabelle

Standard Fehlerbehandlung für Datenbankzugriffe in Mermaid: Mit diesem Block konnten alle Fehler im ersten Mermaid System abgefangen werden.

    ...
    // SQL Befehl eintragen
    With Query3.SQL do Begin
      Clear;
      Add('SELECT *');
      Add('FROM CmdStack');
      Add('WHERE Codi = ' + IntToStr(Line));
      Add('AND Cmd < 2000');
    End;
    // Fehlercode für BDE Error
    ier := 0;
    // Alten Datenbankzugriff dichtmachen
    Query3.Active := false;
    Try
      // Neuen Datenbankzugriff aktivieren
      Query3.Active := true;
      // Wenn Datenbankinhalte vorhanden sind,
      // Dann kann hier irgendwas gemacht werden
      If not Query3.EOF Then Begin
        Val(DBGrid3.Fields[0].Text,CmdCnt,ier);
        Val(DBGrid3.Fields[2].Text,Station,ier);
        Val(DBGrid3.Fields[3].Text,Cmd,ier);
        Val(DBGrid3.Fields[4].Text,Para1,ier);
        Val(DBGrid3.Fields[5].Text,Para2,ier);
        Result := true;
      End;
    Except
      // SQL Zugriff ist schiefgegangen
      On E: EDBEngineError do Begin
        ser := 'SQL-Error ';
        ier := EDBEngineError(E).Errors[0].ErrorCode;
        ser := ser + IntToStr(EDBEngineError(E).Errors[0].ErrorCode) + ' : ' + E.Message;
        ErrMsg.Lines.Add(ser);
      End;
      // Beim Zugriff auf ein Datum in der Tabelle ist was schiegegangen.
      // Tritt auf, wenn z.B. ein Integer-Feld ohne Inhalt gelesen wird,
      // denn Felder ohne Eintrag haben den Status NIL
      // und den gibt es bei den Standardvariablen nicht.
      // Textfelder können immer gelesen werden, auch wenn sie leer sind.
      On E: EVariantError do Begin
        ser := 'DB-Error ';
        ser := ser + E.Message;
        ErrMsg.Lines.Add(ser);
      End;
      // Alle anderen Fehlermeldungen werden über GetLastError ausgegeben
      Else Begin
        ser := 'Error ' + IntToStr(GetLastError) + ' = ' + SysErrorMessage(GetLastError);
        ErrMsg.Lines.Add(ser);
      End;
    End;
    ...

Datensatznummer einer DB-Tabelle setzen

Suche ich noch für Paradox

Für dBase und Foxpro gilt:

Procedure fDbiSetToRecordNo(Tbl: TTable; RecordNum: LongInt);
Var rslt: dbiResult;
begin
  rslt:= DbiSetToRecordNo(Tbl.handle,RecordNum);
  If rslt <> DBIERR_NONE Then Begin
    If rslt = DBIERR_EOF Then tbl.last;
    If rslt = DBIERR_BOF Then tbl.first;
  End;
  Tbl.Resync([]);
end;

Datum der letzten Änderung lesen

Auslesen des Datums 'Geändert am' aus einer Datei.

s1 := 'C:\Autoexec.bat';

s2 := FormatDateTime('MM/DD/YYYY hh:mm:ss',FileDateToDateTime(FileAge(s1)));

Datumsformat einstellen

Innerhalb von Delphi und der BDE wird das Jahr immer 4-stellig gespeichert. Nur die Anzeige unterliegt den Windowseinstellungen. Mit dieser Prozedur setzt man nur für die eigene Anwendung das Datumsformat mit vierstelliger Jahreszahl:

procedure SetFourDigitYearFormat;
Var i:Integer;
Begin
  ShortDateFormat := AnsiUpperCase(ShortDateFormat);
  i := Pos('YYYY',ShortDateFormat);
  If i < 1 Then Begin
    i := Pos('YY',ShortDateFormat);
    if i > 0 Then Insert('YY',ShortDateFormat,i);
  End;
End;

Debugger mit Disassambler

Bei Delphi2 und 3 kann man im Debugger einen Disassambler zuschalten, allerdings ist dazu eine Änderung der Registry notwendig:

[HKEY_CURRENT_USER\Software\Borland\Delphi\3.0\Debugging]

"EnableCPU"="1"

Einstellungen bei Delphi:

  1. Unter 'Projekt/Optionen' alles markieren im Feld 'Debuggen'
  2. Unter 'Tools/Vorgaben' alles markieren im Feld 'Debugger'
  3. Beim Neustart von Delphi 'Ansicht/CPU-Fenster' akivieren

Der komplette Assemblercode (mit Rahmen um der aktuellen Zeile), alle Register und ein Speicherauszug werden dargestellt.

Delphi Dienst erfragen

Wie kann man unter Delphi einen Windows NT4.0 PC abfragen ob dort der Dienst XY läuft?

Es gibt API-Funktionen für den Zugriff auf den Service Control Manager (SCM) - wobei die Funktion QueryServiceStatus für die Abfrage des Service-Zustands zuständig ist. Das folgende Beispiel prüft nach, ob der als Parameter übergebene Service-Name bereits läuft und starten den Service, wenn er noch nicht läuft:

Uses WinSvc;

function TM_START.StartMSTRService(SrvName: String): Boolean;
var
  mgr: THandle;
  svc: THandle;
  status: TServiceStatus;
  p: PChar;
  s_name: String;
begin
  Result := False;
  mgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if mgr = 0 then
    raise Exception.Create('Service-Manager nicht erreicht!');
  svc := OpenService(mgr, PChar(SrvName), SERVICE_ALL_ACCESS);
  if svc = 0 then
    raise Exception.Create(Format('Service %s nicht gefunden!',[SrvName]));
  QueryServiceStatus(svc, status);
  // nur starten, wenn der Service nicht bereits läuft
  if status.dwCurrentState <> SERVICE_RUNNING then begin
    p := nil;
    StartService(svc, 0, p);
  end;
  CloseServiceHandle(svc);
  CloseServiceHandle(mgr);
  Result := True;
end;

Die maximale Textlänge eines TRichEdit erhöhen

Die Längenbeschränkung bei TRichEdit ist jedenfalls jenseits normalerweise nutzbarer Grenzen. Die RichEdit-Komponente besitzt aber wie auch TMemo und TEdit die Eigenschaft MaxLength, die die maximale Textlänge begrenzt. Per Voreinstellung hat diese immer den Wert "0". Das wird sowohl für TEdit und TMemo, als auch für TRichEdit als Maximalgröße von 32 Kilobyte interpretiert.

Nach der Erstellung kann ein RichEdit also erstmal nicht größer werden, als ein TMemo. Während bei diesem die 32kB aber bereits den höchtmöglichen Wert darstellen (zumindest bis Delphi 3), kann man der MaxLength-Eigenschaft der RichEdit-Komponente einfach einen höheren Wert zuweisen:

RichEdit1.MaxLength:=2147483647; //damit kann das Teil 2^31 Byte groß werden.

Über den maximalen Wert für MaxLength besteht bei mir allerdings Unklarheit. Maxlength ist als "integer" definiert und kann somit eben als höchsten Wert 2^31 annehmen. Mit der EM_EXLIMITTEXT-Nachricht kann man dem Ding aber Maximalgrößen zuweisen, die als "dword" definiert sind und damit als höchsten Wert 2^64 annehmen können...

Vorsicht, Richedits mit sehr großen Texten neigen zu schneckenhaftem Verhalten!

Directory Baum entfernen

Procedure RemoveTree(DirName:String);
Var FileSearch:SearchRec;
Begin
  { first, go through and delete all the directories }
  ChDir(DirName);
  FindFirst('*.*',Directory,FileSearch);
  While (DosError = 0) do Begin
    If (FileSearch.name <> '.') AND (FileSearch.name <> '..') AND ((FileSearch.attr AND Directory) <> 0) Then Begin
      If DirName[length(DirName)] = '\' Then Begin
        RemoveTree(DirName+FileSearch.Name);
      End Else Begin
        RemoveTree(DirName+'\'+FileSearch.Name);
      End;
      ChDir(DirName);
    End;
    FindNext (FileSearch)
  End;

  { then, go through and delete all the files }
  FindFirst('*.*',AnyFile,FileSearch);
  While (DosError = 0) do Begin
    If (FileSearch.name <> '.') AND (FileSearch.name <> '..') Then Begin
      Remove (workdir);
    End;
    FindNext (FileSearch)
  End;
  RmDir(DirName)

End;

Disable Tab in TabbedNotebook

Eine Tabellenseite in einer TPageControl Komponente unsichtbar machen:

TabSheet1.TabVisible := false;

und wieder sichtbar machen:

TabSheet1.TabVisible := true;

DOS Environment Variable lesen

Einlesen der DOS Umgebungsvariablen

procedure TForm1.Button1Click(Sender: TObject);
var DosEnv: PChar;
begin
  DosEnv := GetEnvironmentStrings;
  Repeat
    Memo1.Lines.Add(StrPas(DosEnv));
    DosEnv := DosEnv + StrLen(DosEnv) + 1;
  until DosEnv^ = #0;
End;

Ausgabebeispiel im Memofeld:

TMP=C:\WINDOWS\TEMP
winbootdir=C:\WINDOWS
COMSPEC=C:\WINDOWS\COMMAND.COM
SOUND=C:\PROGRA~1\CREATIVE\CTSND
MIDI=SYNTH:1 MAP:E MODE:0
PROMPT=$p$g
PATH=C:\WINDOWS;C:\WINDOWS\COMMAND;C:\SCSI
TEMP=C:\TEMP
CMDLINE=WIN
windir=C:\WINDOWS
BLASTER=A220 I10 D3 H5 P300 T6 E620

Drag & Drop vom Filemanager

Mit diesen Routinen können die kompletten Dateinamen empfangen werden, die per Drag and Drop vom Filemanager oder dem Desktop auf die eigene Form geschoben werden.

Die Funktion wird eingeschaltet durch

DragAcceptFiles(Handle,True);

und ausgeschaltet durch

DragAcceptFiles(Handle,False);

...
  { Private declarations }
  procedure WMDropFiles(VAR Msg: TWMDropFiles); message WM_DROPFILES;
  procedure AppOnMessage(VAR Msg: TMsg; Var Handled: Boolean);
...
implementation

USES ShellApi;

...

procedure TForm1.WMDropFiles(Var Msg: TWMDropFiles);
Var N: Word; Buffer: Array[0..255] of Char;
Begin
  With Msg do Begin
    For N := 0 TO DragQueryFile(Drop,$FFFFFFFF,nil,0)-1 do Begin
      DragQueryFile(Drop,N,Buffer,SizeOf(Buffer));
      ListBox1.Items.Add(StrPas(Buffer));
    End;
    DragFinish(Drop);
  End;
End;

Drag and Drop

Die Einträge der Inhalte zweier Listboxen sollen in eine dritte Listbox geschoben werden.

Quelle: Liste mit Namen vom Typ TListBox (ListBox1)

Quelle: Liste mit Namen vom Typ TListBox (ListBox2)

Ziel: Liste mit Namen vom Typ TListBox (ListBox3)

// Drag Funktion zulassen
ListBox1.DragMode = dmAutomatic
ListBox2.DragMode = dmAutomatic

// Wenn der Eintrag aus ListBox1 oder ListBox2 kommt, dann Drop zulassen
procedure TForm1.ListBox3DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := false;
  If Source = ListBox1 Then Accept := true;
  If Source = ListBox2 Then Accept := true;
end;

// Nur wenn Drop zugelassen wurde (Accept=true),
// dann wird diese Routine durchlaufen
procedure TForm1.ListBox3DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  ListBox3.Items.Add((Source as TListBox).Items[(Source as TListBox).ItemIndex]);
end;

Die Methoden DrogOver und DragDrop existieren für fast alle Komponeneten.

Drive ready check

Mit dieser Funktion kann bestimmt werden , ob in einem Laufwerk ein Medium liegt. Dies gilt für Diskettenlaufwerke, Wechselplatten und CD-ROM's.

function DiskInDrive(const Drive:char):Boolean;
Var
  DrvNum: byte;
  EMode: Word;
begin
  result := false;
  DrvNum := ord(Drive);
  If DrvNum >= ord('a') Then dec(DrvNum,$20);
  EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  Try
    If DiskSize(DrvNum-$40) <> -1 Then result := true;
  Finally
    SetErrorMode(EMode);
  End;
end;

Antworten:

true = Medium vorhanden

false = nix drin

Druckausgabe von Graphik

Ausdruck eines Bildes aus einer TImage-Komponente.

// Offset für den linken Rand berechnen
// Input: Linker Rand in Millimeter
// Output: Linker Rand in Dots
Function LeftOffset(Rand:Real):Integer;
Var i,j:Integer; a,b:Real;
Begin
  i := GetDeviceCaps(Printer.Handle,HORZRES); // Breite in Dots
  j := GetDeviceCaps(Printer.Handle,HORZSIZE); // Breite in mm
  a := i / j; // Druckerauflösung in Dots per mm
  i := GetDeviceCaps(Printer.Handle,PHYSICALOFFSETX); // Offset in cm
  b := (i * 10) / j; // Offset am linken Rand in mm
  Result := Round((Rand - b) * a); // Linker Rand in Dots
End;

// Offset für den oberen Rand berechnen
// Input: Oberer Rand in Millimeter
// Output: Oberer Rand in Dots
Function TopOffset(Rand:Real):Integer;
Var i,j:Integer; a,b:Real;
Begin
  i := GetDeviceCaps(Printer.Handle,VERTRES); // Höhe in Dots
  j := GetDeviceCaps(Printer.Handle,VERTSIZE); // Höhe in mm
  a := i / j; // Druckerauflösung in Dots per mm
  i := GetDeviceCaps(Printer.Handle,PHYSICALOFFSETY); // Offset in cm
  b := (i * 10) / j; // Offset am oberen Rand in mm
  Result := Round((Rand - b) * a); // Oberer Rand in Dots
End;

// Breite des Bilder in Drucker Dots
// Input: Breite in Millimeter
// Output: Breite in Dots
Function SizeWidth(Size:Real):Integer;
Var i,j:Integer; a,b:Real;
Begin
  i := GetDeviceCaps(Printer.Handle,HORZRES); // Auflösung in Dots per inch
  j := GetDeviceCaps(Printer.Handle,HORZSIZE); // Breite in mm
  Result := Round((i * Size) / j); // Breite in Dots
End;

// Höhe des Bilder in Drucker Dots
// Input: Höhe in Millimeter
// Output: Höhe in Dots
Function SizeHeight(Size:Real):Integer;
Var i,j:Integer; a,b:Real;
Begin
  i := GetDeviceCaps(Printer.Handle,VERTRES); // Auflösung in Dots per inch
  j := GetDeviceCaps(Printer.Handle,VERTSIZE); // Breite in mm
  Result := Round((i * Size) / j); // Höhe in Dots
End;

// Bild Drucken
// Input: ox = Abstand zum linken Rand in Millimeter
// oy = Abstand zum oberen Rand in Millimeter
// dx = Breite in Millimeter
// dy = Höhe in Millimeter
Procedure PrintImage(Image:TImage;ox,oy,dx,dy:Real);
var
  ScaleX,ScaleY: Integer;
  R: TRect;
begin
  With Printer do Begin
    BeginDoc;
    Try
      R := Rect(LeftOffset(ox),TopOffset(oy),LeftOffset(ox)+SizeWidth(dx),TopOffset(oy)+SizeHeight(dy));
      Canvas.StretchDraw(R,Image.Picture.Graphic);
    Finally
      EndDoc;
    End;
  End;
end;

// dy sorgt dafür, daß die Seitenverhältnisse der Bildes erhalten bleiben,
// ansonsten sind auch beliebige Verzerrungen möglich.
procedure TForm1.Button1Click(Sender: TObject);
Var dy: Real;
begin
  dy := 60 * Image1.Height / Image1.Width;
  PrintImage(Image1,20,20,60,dy);
end;


Um die Shell-Routine zu benutzen, muß die Unit Printers in Uses stehen.

Uses Printers,...;

Druckausgabe von Text

Hier wird der Inhalt einer Memo-Komponente auf einen Drucker ausgegeben. Der Drucker wird über die PrintDialog1-Komponente bestimmt. Der rechte Rand ist fest auf 20 mm eingestellt. Der Text wird so gedruckt, wie er in der Memo-Komponente zu sehen ist, wobei Memo.WordWrap auf true steht. Steht Memo.WordWrap auf false, und die Zeile ist länger als die Druckzeile, dann wird sie abgeschnitten. Eine Anpassung auf ein automatisches WordWrap bleibt dem Anwender überlassen.

// Offset für den linken Rand berechnen
// Input: Linker Rand in Millimeter
// Output: Linker Rand in Dots
Function LinkerRand(Rand:Real):Integer;
Var i,j:Integer; a,b:Real;
Begin
  i := GetDeviceCaps(Printer.Handle,HORZRES); // Breite in Dots
  j := GetDeviceCaps(Printer.Handle,HORZSIZE); // Breite in mm
  a := i / j; // Druckerauflösung in Dots per mm
  i := GetDeviceCaps(Printer.Handle,PHYSICALOFFSETX); // Offset in cm
  b := (i * 10) / j; // Offset am linken Rand in mm
  Result := Round((Rand - b) * a); // Linker Rand in Dots
End;

procedure PrintMemo(xMemo:TMemo;Titel:String);
var
  Lines: Integer;
  LineHeight: Integer;
  ActMemoLine: Integer;
  Pages: Integer;
  PageLine: Integer;
  LineOffset: Integer;
  TitelZeile: String;
begin
  Printer.BeginDoc;
  Printer.Canvas.Font := xMemo.Font;
  Lines := Printer.PageHeight div Printer.Canvas.TextHeight('Dummy') - 5;
  LineHeight := Printer.Canvas.TextHeight('Dummy');
  LineOffset := 5 * Printer.Canvas.TextHeight('Dummy');

  ActMemoLine := 0;
  For Pages := 1 to (xMemo.Lines.Count div Lines) + 1 do Begin
    TitelZeile := 'Delphi Info: [' + Titel + '] Seite ' + IntToSTr(Pages);
    Printer.Canvas.TextOut(LinkerRand(20),LineHeight * 2,TitelZeile);
    For PageLine := 0 to Lines - 1 do Begin
      If ActMemoLine < xMemo.Lines.Count Then Begin
        Printer.Canvas.TextOut(LinkerRand(20),PageLine * LineHeight + LineOffset,xMemo.Lines[ActMemoLine]);
      End Else Begin
        Printer.EndDoc;
        Exit;
      End;
      Inc(ActMemoLine);
    End;
    If ActMemoLine < xMemo.Lines.Count Then Begin
      Printer.NewPage;
    End;
  End;
  Printer.EndDoc;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  If PrintDialog1.Execute Then Begin
    PrintMemo(Memo1,'Titelzeile');
  End;
end;


Um die Shell-Routine zu benutzen, muß die Unit Printers in Uses stehen.

Uses Printers,...;

Druckerformatierung

Ein RTF Dokument (TRichEdit und TDBRichEdit) kann über seinen Print Befehl ausgedruckt werden (Richedit1.Print). Es wird dabei jedoch die volle Druckerseite benutzt. Die Ränder können über den PageRect eingestellt werden.

Einheiten:

1 Inch = 2.54 cm

1 Twips = 1/20 Pixel = 1/1440 Inch

Auflösung des Druckers in dpi (Dots Per Inch):

  LogX := GetDeviceCaps(Printer.Handle,LOGPIXELSX);

  LogY := GetDeviceCaps(Printer.Handle,LOGPIXELSY);

  LogX = 600 dpi

  LogY = 600 dpi

Größe des druckbaren Bereiches in Pixel (Dot):

  SizeX := Printer.PageWidth;

  SizeY := Printer.PageHeight;

Identisch mit:

  SizeX := GetDeviceCaps(Printer.Handle,HORZRES);

  SizeY := GetDeviceCaps(Printer.Handle,VERTRES);

  SizeX = 4727 Dots -> 7.878 inch = 20.011 cm

  SizeY = 6805 Dots -> 11.342 inch = 28.808 cm

Größe des Blattes in Pixel (Dot):

  PhyX := GetDeviceCaps(Printer.Handle,PHYSICALWIDTH);

  PhyY := GetDeviceCaps(Printer.Handle,PHYSICALHEIGHT);

  PhyX = 4960 Dots -> 8.266 inch = 20.997 cm

  PhyY = 7015 Dots -> 11.692 inch = 29.697 cm

Anzahl der Pixel vom linken und oberen Rand, die aufgrund der Mechanik des Druckers nicht zugänglich sind:

  OffX := GetDeviceCaps(Printer.Handle,PHYSICALOFFSETX);

  OffY := GetDeviceCaps(Printer.Handle,PHYSICALOFFSETY);

  OffX = 120 Dots -> 0.200 inch = 0.508 cm

  OffY = 101 Dots -> 0.168 inch = 0.428 cm

Beispiel:

// Ränder des Druckerblattes setzen
// l = Linker Rand in mm
// o = Oberer Rand in mm
// r = Rechter Rand in mm
// u = Unterer Rand in mm
Function TForm1.SetMargins(l,o,r,u:Real):TRect;
Var dx,dy,LogX,LogY,SizX,SizY,OffX,OffY,PhyX,PhyY:Integer;
Begin
  // Auflösung des Druckers in Pixel/Inch (dpi)
  LogX := GetDeviceCaps(Printer.Handle,LOGPIXELSX);
  LogY := GetDeviceCaps(Printer.Handle,LOGPIXELSY);
  // Größe des druckbaren Bereiches in Pixel
  SizX := Printer.PageWidth;
  SizY := Printer.PageHeight;
  // Nicht Druckbare Seitenränder in Pixel
  OffX := GetDeviceCaps(Printer.Handle,PHYSICALOFFSETX);
  OffY := GetDeviceCaps(Printer.Handle,PHYSICALOFFSETY);
  // Größe des Blattes in Pixel
  PhyX := GetDeviceCaps(Printer.Handle,PHYSICALWIDTH);
  PhyY := GetDeviceCaps(Printer.Handle,PHYSICALHEIGHT);

  Result.Left := Round(LogX * l / 25.4) - OffX;
  Result.Top := Round(LogY * o / 25.4) - OffY;
  dx := (PhyX - SizX - Offx); // nicht druckbarer rechter Rand
  dy := (PhyY - SizY - OffY); // nicht druckbarer unterer Rand
  Result.Right := PhyX - Round(LogX * r / 25.4) - dx;
  Result.Bottom := PhyY - Round(LogY * u / 25.4) - dy;
End;


procedure TForm1.ToolButton8Click(Sender: TObject);
begin
  If PrintDialog1.Execute Then Begin
    DBRichEdit1.PageRect := SetMargins(20,20,20,20);
    DBRichedit1.Print(DBGrid1.SelectedField.Text);
  End;
end;

Dynamische Arrays anlegen

Wichtig ist, daß man nicht auf Elemente zugreift, für die kein Speicherplatz reserviert worden ist.

Variante 1:

{$RANGECHECK OFF}

type

  TDynArray = array[0..0] of TIrgendwas;

  PDynArray = ^TDynArray;

var
  anzahl: Integer;
  DynArray: PDynArray;

  { Initialisierung }
  anzahl := 0;
  DynArray := nil;

  { Element hinzufügen }
  Inc(anzahl);
  ReAllocMem(DynArray, anzahl * SizeOf(TIrgendwas));

  { letztes Element löschen }
  Dec(anzahl);
  ReAllocMem(DynArray, anzahl * SizeOf(TIrgendwas));

  { alle Elemente löschen bzw. gesamten Array-Speicher wieder freigeben }
  ReAllocMem(DynArray, 0);

  { Zugriff auf Element Nr. x (0 < x <= anzahl) }

  { Element schreiben }
  if x <= anzahl then DynArray^[x-1] := irgendwas;

  { Element lesen }
  if x <= anzahl then irgendwas := DynArray^[x-1];

Hinweise:

Wenn TIrgendwas ein Record ist, greift man auf einzelne Felder mit DynArray^[x-1].FeldX zu. Man kann keine Speicherblöcke mit mehr als 2 GB allozieren.

Bevor man Daten als dynamische Arrays programmiert, sollte man sich fragen, ob es nicht sinnvoller ist, von vornherein auf dynamische Strukturen zu setzen. Delphi bietet hierfür beispielsweise TList an. Dieser Listentyp erlaubt beliebig viele Einträge und übernimmt dabei automatisch Bereichsprüfungen. Darüber hinaus bietet er den Vorteil, auch nachträglich Einträge an beliebiger Stelle einzufügen oder zu entfernen.

TList verwaltet aber nur die Zeiger auf die Daten und kümmert sich nicht um deren Inhalt. Man muß selbst dafür sorgen, daß die an Add/Insert übergebenen Zeiger ordnungsgemäß initialisiert worden sind. Außerdem werden durch Delete/Remove nur die Verweise in TList gelöscht. Die Daten bleiben erhalten und müssen manuell entfernt werden.

Type

  Liste : TList;

  TIrgendwas = ...

  PIrgendwas = ^TIrgendwas;

  i: Integer;

Var

  Irgendwas: PIrgendwas;



  ...

  Liste := TList.Create;

  ...

  i := Liste.Add(New(Irgendwas));

  PIrgendwas(Liste[i]^) := ...;

  ...

  Dispose(PIrgendwas(Liste[i]^));

  Liste.Delete(i);

  ...

  Liste.Free;

Man kann beliebig oft mit New(Irgendwas) neue Elemente erzeugen und an Liste übergeben. Die Verwaltung der Zeiger übernimmt Liste. Es hängt also kein Zeiger "in der Luft".

Delete setzt im Gegensatz zu Remove nur den Zeiger auf nil. Mit Pack werden diese nil-Zeiger aus der Liste entfernt.

Hier ist eine Version die gleich noch überprüft ob die Komponente schon existiert:

if not assigned(button1) then
  begin
    button1 := TButton.create(Form1);
    button1.parent := self; // !!!!!!!!!!!
    button1.visible := True;
    button1.left := 20;
    button1.top := 20;
    button1.width := 20;
    button1.height := 20;
  end;

Ein weiteres Beispiel:

Mit diesem Beispiel können Buttons erzeugen werden. Sie behalten keine Variable, und können deshalb die Buttons vor dem Programmende nicht ohne weiteres verändern oder löschen. Mit diesen Zeilen wird jedes mal eine Button auf einer Zufälligen Position von Form1 erzeugt.

With TButton.Create(Self) do
  begin
    Parent := Form1; //Wichtig!! Parent setzen!
    Caption := 'Hallo!!';
    Width := 90;
    Height := 50;
    Top := Random(Form1.ClientHeight-50); //Zufällige Position
    Left := Random(Form1.ClientWidth-90);
  end;

Ein anderes Programm starten und auf dessen Ende warten

Von einem Programm aus wird ein anderes Programm gestartet. Das Aufrufende Programm wird erst dann weitergeführt, wann das Gestartete beendet wurde.

Function ExecAndWait(sExe,sCommandLine:string): Boolean;
Var
  tsi: TStartupInfo;
  tpi: TProcessInformation;
  dw: DWord;
Begin
  Result := False;

  FillChar(tsi, SizeOf(TStartupInfo), 0);
  tsi.cb := SizeOf(TStartupInfo);
  If CreateProcess(
     nil, { Pointer to Application }
     PChar(sExe + ' ' + sCommandLine), { Pointer to Application mit Parameter }
     nil, { pointer to process security attributes }
     nil, { pointer to thread security attributes }
     False, { handle inheritance flag }
     CREATE_NEW_CONSOLE, { creation flags }
     nil, { pointer to new environment block }
     nil, { pointer to current directory name }
     tsi, { pointer to STARTUPINFO }
     tpi) { pointer to PROCESS_INF }
  Then Begin
    If WAIT_OBJECT_0 = WaitForSingleObject(tpi.hProcess, INFINITE) Then Begin
      If GetExitCodeProcess(tpi.hProcess, dw) Then Begin
        If dw = 0 Then Begin
          Result := True;
        End Else Begin
          SetLastError(dw + $2000);
        End;
      End;
    End;
    dw := GetLastError;
    CloseHandle(tpi.hProcess);
    CloseHandle(tpi.hThread);
    SetLastError(dw);
  End;
End;

Procedure TForm1.Button1Click(Sender: TObject);
Var t1,t2:LongInt;
Begin
  t1 := GetTickCount;
  b1 := ExecAndWait('c:\Programme\Microsoft Office\Winword\Winword.exe','c:\NetzwerkKonfiguration.txt');
  t2 := GetTickCount;
  Edit1.Text := IntToStr(t2-t1);
End;

Hinweis:
Der Bildschirmaufbau des Programms, welches den Prozeß startet wird nicht mehr upgedatet.

Ein Fenster immer zuoberst anzeigen, auch bei Minimierung

Manchmal möchte man, daß geöffnete (Unter-)Fenster einer Anwendung auf dem Desktop bleiben, wenn das Hauptfenster minimiert wird, oder daß ein Fenster immer im Vordergrund bleibt, auch wenn es nicht den Fokus hat.

Einstellung zur Laufzeit:

OnTop : SetWindowPos(Handle, HWND_TOPMOST, Left,Top, Width, Height, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

zurück : SetWindowPos(Handle, HWND_NOTOPMOST, Left, Top, Width, Height, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

OnDesktop : SetWindowLong(Handle, GWL_HWNDPARENT, 0);

zurück : SetWindowLong(Handle, GWL_HWNDPARENT, Application.Handle);

FormStyle dabei auf fsNormal setzen. Das ist alles!

Nachteil:

Wenn das Hauptfenster minimiert wird, wird für das Unterfenster ein Button in der Taskleiste angelegt.

Ein Programm ohne sichtbares Fenster starten

Im Projekt-Quelltext vor Application.Run folgende Zeile einfügen:

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);

  Application.ShowMainForm := false; // <-----

  Application.Run;
end.

Der Application-Button in der Taskleiste erscheint auch nicht.

Wer allerdings überhaupt kein Formular in seiner Anwendung braucht kann gleich noch die Unit 'Forms' aus dem 'uses' Bereich rauswerfen und so die Größe der EXE-Datei reduzieren.

Ein TMemo scrollen

Eine Memo oder Listbox kann per Befehl gescrollt werden.

Dieses Beispiel scrollt eine Memo-Komponente vom Ende (oder mittendrin) zum Anfang.

procedure TForm1.Button1Click(Sender: TObject);
Var
 ScrollMessage:TWMVScroll;
 i:Integer;
begin
  ScrollMessage.Msg := WM_VScroll;
  for i := Memo1.Lines.Count DownTo 0 do begin
    ScrollMessage.ScrollCode := sb_LineUp;
    ScrollMessage.Pos := 0;
    Memo1.Dispatch(ScrollMessage);
    Sleep(200);
  end;
end;


Es gibt noch andere ScrollCodes, die aber noch nicht getetstet wurden:

SB_BOTTOM
SB_ENDSCROLL
SB_LINEDOWN
SB_LINEUP
SB_PAGEDOWN
SB_PAGEUP
SB_THUMBPOSITION
SB_THUMBTRACK, SB_TOP


Die Typen Deklaration für TWMVScroll ist:

  TWMVScroll = record
    Msg: Cardinal;
    ScrollCode: Smallint; { SB_xxxx }
    Pos: Smallint;
    ScrollBar: HWND;
    Result: Longint;
  end;

Eine andere Möglichkeit bietet das Windows Message System:

SendMessage(Memo1.Handle,EM_LINESCROLL,x1,y1);

y1 = Memo1.Lines.Count-1 scrollt ans Ende
y1 = 4 scrollt 4 Zeilen vorwärts (nach unten)
y1 = -6 scrollt 6 Zeilen rückwärts (nach oben)
x1 scrollt nach links oder rechts


i := SendMessage(Memo1.Handle,EM_LINESCROLL,0,0);

i Liefert die Anzahl der Zeilen


SendMessage(Memo1.Handle,EM_SCROLL,n1,0);

n1 = SB_LINEDOWN  Scrollt 1 Zeile runter
n1 = SB_LINEUP    Scrollt 1 Zeile hoch
n1 = SB_PAGEDOWN  Scrollt 1 Seite runter
n1 = SB_PAGEUP    Scrollt 1 Seite hoch

Eine Anwendung ohne Eintrag in der Taskbar ausführen

Der Button in der Taskleiste wird nicht mehr angezeigt.

Die Funktionen müssen in der FormCreate Routine stehen.

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetWindowLong(Application.Handle,GWL_EXSTYLE,GetWindowLong(Application.Handle,GWL_EXSTYLE) and not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
  ShowWindow(Application.Handle,SW_HIDE);
end;

Eine CPL Datei ausführen

In der Systemsteuerung werden Programme für unterschiedliche Dienste zu Verfügung gestellt. Sie haben alle die Endung *.cpl und sind in C:\Windows\System zu finden. Sie können alle über die WinExec Funktion gestartet werden:

Function RunCpl(CplName:String):Boolean;
Begin
  Result := WinExec(PChar('rundll32.exe shell32.dll,Control_RunDLL ' + CplName),SW_SHOWNORMAL) > 32;
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
  RunCpl('Timedate.cpl');
end;

Eine Delphi-Applikation in einen Screensaver verwandeln

Um ein Projekt als Screensaver zu compilieren, geht man wie folgt vor:

Als erstes fügt man folgende Zeile in die Projektdatei ein:

{$D SCRNSAVE: Beschreibung des Savers...}

Windows ruft Screensaver mit der Option /c auf, wenn das Konfigurationsfenster geöffnet werden soll. Falls der Screen Saver in Aktion treten soll, wird die Option /s angegeben. Also muß man beim Start festellen, was nun gewünscht ist. Dazu fügt man ins FormCreate-Event des Hauptformulars folgendes ein:

  If ParamCount>0 Then
    If ParamStr(1)='/c'
      Then { Hier Konfigurations-Fenster öffnen}
      Else If ParamStr(1)='/s' Then { Hier Screen Saver starten }
  Application.Terminate;

Im Prinzip sind die Bildschirmschoner unter Windows ganz normale EXE-Dateien, welche die Endung *.SCR bekommen haben und sich im Windows-Hauptverzeichnis befinden. Damit Windows den Namen des Screensavers ermitteln kann, muß im Hauptprogramm die Modulbeschreibung

{$D SCRNSAVE: Name des Bildschirmschoners }

aufgenommen werden.

Windows bietet in der Systemsteuerung die Möglichkeit, das Setup des Bildschirmschoners aufzurufen. Die Datei wird hierzu einfach mit dem Parameter '/c' gestartet. Das Programm muß also darauf achten, diesen Parameter auszuwerten und den entsprechenden Setup-Dialog anzeigen. Wird der Bildschirmschoner von Windows nach der eingestellten Zeit ohne Tastendruck aufgerufen, so übergibt Windows den Commandozeilenparameter '/s'. Dies kann man auch manuell ohne Wartezeit in der Systemsteuerung|Desktop mit dem 'Test'-Button ausprobieren. Als erleichternder Hinweis für die Bildschirmschonerprogrammierer: Windows kümmert sich von ganz allein um das Zählen der Minuten bis zum Starten des Bildschirmschoners, d.h. man braucht sich nur noch Gedanken machen, was man auf dem Schwarzen Canvas darstellt ;-)

Der Bildschirmschoner selbst ist ein Form, welches einen schwarzen Hintergrund hat und sich auf volle Bildschirmgröße vergrößert. Dadurch kann mit dem Canvas des Forms auf dem gesamten Bildschirm geschrieben werden.

Der Bildschirmschoner wird abgebrochen, wenn entweder eine (Maus-)Taste gedrückt oder die Maus bewegt wurde. Die nötigen Systemereignisse kann man in der 'WndProc' des Forms abfragen (also diese überschreiben). Soll der Bildschirmschoner auch Passwortabragen beherrschen (die der Benutzer dann im oben genannten SetupDialog setzen kann), so kann man aus der 'WndProc' nach einem Tastendruck vor dem Beenden des Bildschirmschoners einen PaßwortDialog anzeigen, der dieses Paßwort vom Benutzer abfragt. Dabei sollte man natürlich darauf achten, daß der Benutzer nicht mit Alt-Tab o.ä. zur nächsten Anwendung wechseln kann, denn auch ein Bildschirmschoner ist "bloß" eine WindowsTask. Dies kann man verhindern, indem man in der 'WinProc' die Message wm_SysCommand mit den Msgs: sc_NextWindow, sc_PrevWindow und sc_TaskList herausfiltert.

Für das Abspeichern der Einstellungen des SetupDialoges ist es üblich, in der CONTROL.INI im WINDOWS-Verzeichnis einen Unterbereich anzulegen, der nach folgendem Schema aufgebaut ist.

[Screen Saver.NamedesBildschirmschoners]

Einstellung1=...

Einstellung...=... usw.

Hinweis:

Am besten man besorgt sich ein kleines Beispielprogramm.

Enter-Taste statt Tab-Taste

Wenn in der Hauptform die Eigenschaft 'KeyPreview' auf true steht, dann wird die nächste Komponente nicht mit der Tab-Taste sondern mit der Return-Taste erreicht.

Bei einigen Komponenten muß man jedoch auspassen:

Bei Buttons funktioniert es nicht, weil sie mit der Return-Taste ausgelöst werden.

Bei Memo Komponenten ist kein Zeilenwechsel mehr möglich.

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  If (Key = #13) Then Begin
    Key := #0; // Eat the enter key
    Perform(WM_NEXTDLGCTL,0,0); // gehe zur nächsten Komponente
  End;
end;

EOleSysError erkennen

Wenn eine DirectX Komponente benutzt wird (FTP, HTML, usw.) und Direct X ist nicht im System vorhanden, dann wird ein EOleSysError, mit dem Hinweis das eine Klasse nicht registriert ist, ausgelöst. Mit dieser Routine kann diese Meldung abgefangen werden. Voraussetzung ist jedoch, das sich die Komponente nicht im Formular befindet, da sonst beim Programmstart die Registrierung überprüft wird. Das Programm startet dann erst gar nicht.

Uses isp3, ComObj;

Function IsFtpInstalled:Boolean;
Var SaveErrorMode: Word; ftp1:TFTP;
Begin
  Result := true;
  SaveErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  Try
    ftp1 := TFTP.Create(Form1.Owner);
    ftp1.Free;
  Except
// On E: EOleSysError do Begin
// 'Class not registered' wird erzeugt
// End;
    Result := false;
  End;
  SetErrorMode(SaveErrorMode);
End;

Ereignisse (Events) Reihenfolge

Folgende Ereignisse werden in dieser Reihenfolge abgefeuert:

- OnCreate

- OnShow

- OnPaint

- OnActivate

- OnResize

- und nocheinmal OnPaint

Ermitteln der Mauskoordinaten

Mit einer simplen API-Funktion:

GetCursorPos(var Koordinaten : TPoint);

und hier das Beispiel:

Procedure GetMouseLocation;
Var MousePosition : TPoint;
Begin
  GetCursorPos(MousePosition);
  If MousePosition.x > 100 Then Edit1.Text := 'Die Maus ist zuweit rechts...';
End;

Lustig ist auch SetCursorPos - damit gehts umgekehrt, allerdings sind da die Parameter anders:

procedure SetCursorPos(x, y: integer)

Erste und Letzte Zeile in einem Memo ansteuern

In die Erste oder letzte Zeile einer TMemo Komponente springen.

procedure TForm1.GoToFirstButtonClick(Sender: TObject);
begin
  Memo1.Perform(EM_LineScroll,0,-Memo1.Lines.Count-1);
end;

procedure TForm1.GoToLastButtonClick(Sender: TObject);
begin
  Memo1.Perform(EM_LineScroll,0,Memo1.Lines.Count-1);
end;

Mit der EM_ScrollCaret-Nachricht scrollt man die aktuelle Cursorposition im Memo in die Anzeige:

  Memo1.Perform(EM_ScrollCaret, 0, 0);

Noch nicht ausprobiert:

SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,RichEdit1.Lines.Count-1);

Farbe der Zelle im TStrinGrid ändern

Füllt eine selektierte Zelle des StringGrid rot. Die Routine sitzt im OnDrawCell Event.

Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  If gdFocused in State Then Begin
    With (Sender as TStringGrid).Canvas do Begin
      Brush.Color := clRed;
      FillRect(Rect);
      TextOut(Rect.Left+2,Rect.Top+2,(Sender as TStringGrid).Cells[Col,Row]);
    End;
  End;
end;

Feldname aus einer Paradox Tabelle lesen

You need to use the FieldDefs property. The following example will add the list of fields and their respective sizes to a TMemo component named Memo1 on the form:

Procedure TForm1.ShowFields;
Var i:Word;
Begin
  Memo1.Lines.Clear;
  Table1.FieldDefs.Update; { must call in case Table1 is not active }
  For i := 0 to Table1.FieldDefs.Count - 1 do Begin
    With Table1.FieldDefs.Items[i] do Memo1.Lines.Add(Name + ' - ' + IntToStr(Size));
  End;
End;

A:

If you just wan the names then use the GetFieldNames Method of TTable to get the FieldNames:

GetIndexNames to get Index Names:

var FldNames, IdxNames : TStringList

Begin

  FldNames := TStringList.Create;
  IdxNames := TStringList.Create;

  If Table1.State = dsInactive then Table1.Open;
  Table1.GetFieldNames(FldNames);
  Table1.GetIndexNames(IdxNames);

  {...... do whatever the next bit is ......}

  FldNames.Free; {release the stringlist}
  IdxNames.Free;
Bnd;

To get specific field info, you will have to use FieldDef.

Fenster aus der Taskbar-Leiste holen

Die Applikation hat vorher über eine entsprechende Komponente ein Icon in der Taskbar erzeugt. Im OnClick oder OnDblClick Event wird dann folgender Code eingetragen, der die Applikation wieder auf den Bildschirm bringt.

// Fenster von der Taskbar in den Bildschirm holen

ShowWindow(Application.Handle,SW_RESTORE);

SendMessage(Application.Handle,WM_SYSCOMMAND,SC_HOTKEY,Application.Handle);

SendMessage(Application.Handle,WM_SYSCOMMAND,SC_RESTORE,Application.Handle);

Fenster bewegen ohne Titelleiste

Der einfachste Weg ist, Windows vorzugaukeln das die Caption-Bar angeklickt wird.

  ...
  private
    { Public-Deklarationen }
    procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
  end;
  ...

procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
  inherited;
  if M.Result = htClient then M.Result := htCaption;
end;

Hinweis:
Das ganze funktioniert nur, wenn der Cursor im Client Bereich der Form (Application) ist.

Fenster immer 'On Top' zeigen

WinNT: -

Win95: -

Win98: -

Win2k: -

Ein Unterfenster einer Anwendung immer zuoberst anzeigen, auch bei minimiertem Hauptfenster und wenn es nicht den Focus hat.

OnTop :     SetWindowPos(Handle, HWND_TOPMOST, Left,Top, Width,

            Height, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

zurück :    SetWindowPos(Handle, HWND_NOTOPMOST, Left, Top, Width,

            Height, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

OnDesktop : SetWindowLong(Handle, GWL_HWNDPARENT, 0);

zurück :    SetWindowLong(Handle, GWL_HWNDPARENT, Application.Handle);

FormStyle dabei auf fsNormal setzen.

Fenster in die Taskbar-Leiste schicken

Für die Applikation wird mit einer entsprechenden Komponente ein Icon in der Taskbar erzeugt.

// Fenster verkleinern

// Das Icon der Applikation landet jetzt in der Taskleiste

Application.Minimize;

// Button aus der Taskleiste entfernen

ShowWindow(Application.Handle, SW_HIDE);

Fenster Transparent darstellen

Zwei einfache Tricks, um ein Fenster "unsichtbar", also transparent zu zeichnen:

1. So kann man die Transparenz zur Laufzeit umschalten:

Geht, sieht aber doof aus. Sobald der Transparentmodus eingeschaltet und das Fenster bewegt wird, dann wird der Inhalt des Fensters unter dem eigenen mitbewegt.

Procedure MakeWindowTransparent (Form: TForm);
Var CurrentStyle : LongInt;
Begin
  Form.Visible := False;
  CurrentStyle := GetWindowLong(Form.Handle, GWL_EXSTYLE);
  SetWindowLong(Form.Handle, GWL_EXSTYLE, CurrentStyle Or WS_EX_TRANSPARENT);
  Form.Visible := True;
End;

Procedure MakeWindowOpaque (Form: TForm);
Var CurrentStyle : LongInt;
Begin
  Form.Visible := False;
  CurrentStyle := GetWindowLong (Form.Handle, GWL_EXSTYLE);
  SetWindowLong(Form.Handle, GWL_EXSTYLE, CurrentStyle And Not WS_EX_TRANSPARENT);
  Form.Visible := True;
End;

2. So wird ein Fenster transparent erstellt:
Geht und sieht gut aus. Sogar die Titelleiste verschwindet.

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Brush.Style := bsClear;
  Form1.BorderStyle := bsNone;
end;

Fenster verstecken bei Minimize

So verhindert man, daß nach einem Minimize die Applikation wieder in der Taskbar erscheint.

procedure WMSysCommand(var Message: TWMSysCommand); message WM_SysCommand;

Procedure TMainForm.WMSysCommand(var Message: TWMSysCommand);
Begin
  If Message.CmdType and $FFF0 = SC_MINIMIZE Then
    Hide
  Else
    Inherited;
End;

Feststellen, ob BDE installiert ist

Will ein Programm die BDE benutzen, und die BDE ist nicht vorhanden, dann stürzt das Programm ab. Am besten, vorher testen ob die BDE installiert wurde:

Function IsBde:Boolean;
Var DllPath, CfFile: String;
Begin
  CfFile := '';
  DllPath := '';
  Result := false;
  With TRegistry.Create do Begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('Software\Borland\Database Engine',False);
    CfFile := ReadString('ConfigFile01');
    DllPath := ReadString('DLLPath');
    Free;
  End;
  If (CfFile <> '') and (DllPath <> '') Then Begin
    Result := FileExists(CfFile);
  End;
End;

Um die Registry Funktionen zu benutzen, muß die Unit Registry in Uses stehen.

Uses Registry,...;

Feststellen, ob die Taskbar vorhanden ist

Feststellen, ob sich die Taskleiste im Hintergrund befindet.

Entspricht der Einstellung 'Automatisch im Hintergrund' in 'Start\Einstellungen\Task-Leiste...'

Function IsTaskbarHide:Boolean;
Var TB: TAppBarData;
Begin
  TB.cbSize := SizeOf(TB);
  Result := SHAppBarMessage(ABM_GETSTATE,TB) and (ABS_AUTOHIDE) > 0;
End;

Wird statt der Konstanten ABS_AUTOHIDE die Konstante ABS_ALWAYSONTOP benutzt, läßt sich feststellen, ob die Taskleiste immer im Vordergrund ist.
Entspricht der Einstellung 'Immer im Vordergrund' in 'Start\Einstellungen\Task-Leiste...'

Function IsTaskbarOnTop:Boolean;
Var TB: TAppBarData;
Begin
  TB.cbSize := SizeOf(TB);
  Result := SHAppBarMessage(ABM_GETSTATE,TB) and (ABS_ALWAYSONTOP) > 0;
End;

Um die Shell-Routinen zu benutzen, muß die Unit ShellAPI in Uses stehen.

Uses ShellAPI,...;

File Version lesen

Wenn eine Application über die Eigenschaftstabelle 'Version' verfügt, dann mit dieser Funktion die Angabe der Dateiversion ausgelesen werden.

Function GetFileVersion(FileName:String;Var Vers:String):Boolean;
Var Value,lp:PChar ; Size,Len:Integer; s1:String;
Begin
  Result := false;
  Vers := '';
  Size := GetFileVersionInfoSize(PChar(FileName),Size);
  If Size > 0 Then Begin
    lp := AllocMem(Size);
    Try
      If GetFileVersionInfo(PChar(FileName),0,Size,lp) Then Begin
        s1 := 'StringFileInfo\040704E4\FileVersion';
        If VerQueryValue(lp,PChar(s1),Pointer(Value),Len) Then Begin
          Vers := StrPas(Value);
          Result := true;
        End;
      End;
    Finally
      FreeMem(lp,Size);
    End;
  End;
End;

procedure TForm1.Button1Click(Sender: TObject);
Var s1,s2:String;
begin
  s1 := 'Project1.exe';
  GetFileVersion(s1,s2);
  Memo1.Lines.Add(s2);
end;

Filepath abkürzen

Wie kürzt man einen Dateipfad ab, daß er eine bestimmte Länge nicht überschreitet?

Ab Delphi 3 gibt es dafür die undokumentierte Funktion "MinimizeName" aus der Unit "SysUtils":

PathName := Appication.Exename;

Label1.Caption := MinimizeName(PathName, {Der abzukürzende Pfadname}

Label1.Canvas, {Die Referenz-Zeichenfläche}

Label1.Width); {Die maximale Ausgabe-Breite}

Zur Berechnung der maximal erlaubten Buchstabenzahl für den verkürzten Pfadnamen benötigt die Funktion die Zeichenfläche (und damit die für diese Zeichenfläche eingestellte Schriftart), auf der der Text ausgegeben werden soll und die Breite des Ausgaberechtecks.

Die Verkürzung eines Pfadnamens kann dann z.B. so aussehen:

C:\Programme\Borland\Delphi3\Projekte\Demos

wird zu

C:\...\Projekte\Demos

FileSize lesen

Funktioniert auch bei Directories und 'nur Lese' Files.

Function GetFileSize(Filename:string):integer;
Var SR:TSearchRec;
Begin
  If FindFirst(Filename,faAnyFile,SR) = 0 Then Begin
    Result:=SR.Size
  End Else Begin
    Result := -1;
  End;
  FindClose(SR);
End;

FindWindow, Getwindow

Alle Angaben für eine Applikation werden der Reihe nach in die Stringliste geschrieben. Result bezeichnet die Anzahl der Applikationen. Bei Result = 4 befinden sich also 16 Einträge in der Stringliste in der Reihenfolge: ApplicationName, HandleNummer, ClassName und Tasknummer.

Function GetApplication(Var Str:TStrings):Integer;
Var Hnd1:HWND; P:Array [0..256] of Char; Cnt:Integer;
Begin
  Cnt := 0;
  Str.Clear;
  Hnd1 := FindWindow(nil,nil);
  If (Hnd1 <> 0) Then Begin
    P[0] := #0;
    GetWindowText(Hnd1,P,255);
    If StrLen(P) > 0 Then Begin
      If IsWindowVisible(Hnd1) Then Begin
        Inc(Cnt);
        Str.Add(StrPas(P));
        Str.Add(IntToStr(Hnd1));
        GetClassName(Hnd1,P,32);
        Str.Add(StrPas(P));
        Str.Add(IntToStr(GetWindowTask(Hnd1)));
      End;
    End;
    While (Hnd1 <> 0) do Begin
      Hnd1 := GetWindow(Hnd1,GW_HWNDNEXT);
      P[0] := #0;
      GetWindowText(Hnd1,P,255);
      If StrLen(P) > 0 Then Begin
        If IsWindowVisible(Hnd1) Then Begin
          Inc(Cnt);
          Str.Add(StrPas(P));
          Str.Add(IntToStr(Hnd1));
          GetClassName(Hnd1,P,32);
          Str.Add(StrPas(P));
          Str.Add(IntToStr(GetWindowTask(Hnd1)));
        End;
      End;
    End;
  End;
  Result := Cnt;
End;

Das folgende Beispiel gibt die Liste der momentanen Applikation in ein Memofeld aus.

procedure TForm1.Button1Click(Sender: TObject);
Var Str1: TStrings;
begin
  Str1 := TStringList.Create;
  GetApplication(Str1);
  Memo1.Lines := Str1;
  Str1.Free;
end;

Flackern beim Neuzeichnen verhindern

If you do not include csOpaque in ControlStyle then Invalidate calls will cause the control's background to be erased. If you draw your control's background in the Paint method then you should do this in your constructor:

ControlStyle := ControlStyle + [csOpaque] ;

Funktioniert nicht, wenn eine TImage Komponente über den Bildschirm geschoben wird.

Flimmern bei Bitmap Bewegungen beseitigen

Das Problem entsteht meißt dadurch, das man eine TImage-Komponente auf das Formular klatscht und diese dann verschiebt. Windows zeichnet bei jedem verschieben jetzt erst den Hintergrund zurück und dann wieder die Komponente an der neuen Position. Auch wenn man es auf Quelltextebene macht, sieht man noch deutlich das nacheinander Bilder übereinander gezeichnet werden.

Lösung:

  1. Man zeichnet alle Figuren im Quelltext (das hat auch den Vorteil das sie transparent gezeichnet werden können (sieh unten)).
  2. Man zeichnet im Ereignis OnPaint des Formulars. Dann kann man, nach einer Änderung des Inhalts, einfach mit Form1.Paint; alles zeichenen lassen.
  3. Man zeichnet NIE hintereinander direkt auf das Formular. Es ist zwar richtig auf das Formular zu zeichnen, wenn man das ganze Fenster selber zeichnet, aber nie mehre Änderungen in einer Procedure auf dem Formular machen. Das umgeht man damit das man ein Zwischenbild erstellt:

Var TempBild:TImage;
Begin
  TempBild:=TImage.Create(self);
  TempBild.Width:=Self.ClientWidth;
  TempBild.Height:=Self.ClientHeight;
Jetzt zeichnet man was man wollte:
  TempBild.Canvas.Brush.Color:=Hintergrundfarbe;
  TempBild.Canvas.Rectangle(-1, -1, width,height); //Fenster löschen, indem ein Rechteck über das
gesammte Fenster gezeichnet wird.
  TempBild.Canvas.TextOut(5, 5, 'Quelltext von Christian Kästner (christian@kaestnerpro.de)');
  TempBild.Canvas.Draw(100, 20,...);
  [...]
Jetzt kopiert man das Zwischenbild auf das Formular. Weil die Änderungen erst unsichtbar hintereinander gemacht werden, und dann erst das fertige Bild gezeigt wird ist das Flimmern nun verschwunden.
  BitBlt(Self.Canvas.handle, 0, 0, Self.Width, Self.Height, TempBild.Canvas.Handle, 0, 0, SrcCopy);
Jetzt wird nur noch aufgeräumt:
  TempBild.Free;
end;

Fokus weiter schalten mit Enter Taste

Um nach Betätigen der Enter-Taste zum nächsten Control auf einem Formular zu wechseln, muß man zuerst die "KeyPreview"-Eigenschaft des Formulars auf "true" setzen. Anschließend kann man in der OnKeyPress-Methode des Formulars auf die Enter-Taste reagieren:

Procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char);
Begin
  If Key = #13 Then Begin {#13 = Enter}
    Key := #0;
    PostMessage(Handle, WM_NextDlgCtl, 0, 0);
  End;
End;

Bemerkung: Das funktioniert nicht mit einem DBGrid, weil das nächste Feld dort kein separates Objekt darstellt.

Fomulargröße beschränken

Begrenzung der Fenstergröße eines Formulars auf einen minimalen und maximalen Wert.

Die Formulareigenschaft BorderStyle muß bsSizable sein.

type
  TForm1 = class(TForm)
    ...
  private
    { Private-Deklarationen }
    { Begrenzung der Fenstergröße }
    Procedure WMSetMinMaxForm(var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
    ...
  public
    { Public-Deklarationen }
    ...
  end;

implementation

Procedure TForm1.WMSetMinMaxForm(var Message: TWMGetMinMaxInfo);
Var MinMaxSet: PMinMaxInfo;
Begin
  Inherited;
  MinMaxSet := Message.MinMaxInfo;
  MinMaxSet^.ptMaxTrackSize.X := 800;
  MinMaxSet^.ptMaxTrackSize.Y := 600;
  MinMaxSet^.ptMinTrackSize.X := 640;
  MinMaxSet^.ptMinTrackSize.Y := 480;
End;

Font installieren

Wenn in einem Programm ein besonderes TTF benutzt wird, das möglicherweise nicht auf dem Rechner vorhanden, auf dem die Applikation laufen soll, dann kann mit folgender Methode das Font geladen werden:

Im OnCreate Event

AddFontResource(pchar(ExtractFilePath(ParamStr(0)+'Irgendwas.TTF')));

SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);

Im OnClose Event

RemoveFontResource(pchar(ExtractFilePath(ParamStr(0)+'Irgendwas.TTF')));

SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);

Form begrenzen

    ...
  private
    { Private-Deklarationen }
    { Begrenzung der Fenstergröße }
    Procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
  public
    { Public-Deklarationen }
  end;

Procedure TForm1.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
Var MinMaxInfo: PMinMaxInfo;
Begin
  Inherited;
  MinMaxInfo := Message.MinMaxInfo;
  MinMaxInfo^.ptMaxTrackSize.X := Screen.Width;
  MinMaxInfo^.ptMaxTrackSize.Y := Screen.Height;
  MinMaxInfo^.ptMinTrackSize.X := 400;
  MinMaxInfo^.ptMinTrackSize.Y := 590;
End;

Form eines Formulars ändern

Dafür gibt es die sogenannten "Regions":

procedure TForm1.FormCreate(Sender:TObject);
var HR: HRgn;
      n:array[0..3] of TPoint;
begin
  n[0]:=Point(Width div 2,1);
  n[1]:=Point(1, Height div 2);
  n[2]:=Point(Width div 2,Height);
  n[3]:=Point(Width, Height div 2);

  HR:= CreateEllipticRgn (0, 0, Width, Height);
  {oder eine Raute:
  HR:= CreatePolygonRgn(n, 4, Alternate);}

  SetWindowRgn(Handle, HR, True);
end;

Form in die Zwischenablage kopieren

Inhalt der Form in die Zwischenablage kopieren.

var bitmap:tbitmap;
begin
  bitmap:=tbitmap.create;
  bitmap.width:=clientwidth;
  bitmap.height:=clientheight;
  try
    with bitmap.Canvas do CopyRect (clientrect,canvas,clientrect);
    clipboard.assign(bitmap);
  finally
    bitmap.free;
  end;
end;

Um diese Routine zu benutzen, muß die Unit ClipBrd in Uses stehen.

Uses ClipBrd,...;

Form Move Event

Es gibt leider keinen FormMove Event. Er kann aber durch eine Windows Message erkannt werden. Dazu muß folgende Procedure implementiert werden:

  private
    { Private-Deklarationen }
    Procedure WMMove(Var Message : TWMMove); message WM_Move;

Procedure TForm1.WMMove(Var Message : TWMMove);
begin
  Label1.Caption := 'X = '+IntToStr(Message.XPos)+', Y = '+IntTOStr(Message.YPos);
end;

Die Procedure wird aufgerufen, solange die Form bewegt wird.

Form/Komponente Enter/Leave Event

Über das Windows Message System kann erkannt werden, ob die Maus eine Form oder Komponente betritt oder verläßt.

  private
    { Private-Deklarationen }
    procedure CMMouseEnter(var AMsg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var AMsg: TMessage); message CM_MOUSELEAVE;

Form1.SetFocus sorgt z.B. dafür, das die automatisch in den Vordergrund geholt wird, wenn die Maus drauf ist.

  procedure TForm1.CMMouseEnter(var AMsg: TMessage);
  begin
    Form1.SetFocus;
    Edit1.Text := 'Enter Form';
    If aMsg.LParam = LongInt(Panel1) Then Edit2.Text := 'Enter Panel1';
    If aMsg.LParam = LongInt(Panel2) Then Edit2.Text := 'Enter Panel2';
    If aMsg.LParam = LongInt(Panel3) Then Edit2.Text := 'Enter Panel3';
    If aMsg.LParam = LongInt(Edit1) Then Edit2.Text := 'Enter Edit1';
  end;

  procedure TForm1.CMMouseLeave(var AMsg: TMessage);
  begin
    Edit1.Text := 'Leave Form';
    If aMsg.LParam = LongInt(Panel1) Then Edit2.Text := 'Leave Panel1';
    If aMsg.LParam = LongInt(Panel2) Then Edit2.Text := 'Leave Panel2';
    If aMsg.LParam = LongInt(Panel3) Then Edit2.Text := 'Leave Panel3';
    If aMsg.LParam = LongInt(Edit1) Then Edit2.Text := 'Leave Edit';
  end;

Gedrehten Text ausgeben

Da Delphi das Drehen von Fonts nicht als Funktionalität zur Verfügung stellt, muß man das selbst machen. Das geht folgendermassen (der gewählte Font sollte eine TrueType-Schriftart sein):

procedure TForm1.Button1Click(Sender: TObject);
var
  lf : TLogFont;
  tf : TFont;
begin
  with Form1.Canvas do begin
    Font.Name := 'Arial';
    Font.Size := 24;
    tf := TFont.Create;
    tf.Assign(Font);
    GetObject(tf.Handle, sizeof(lf), @lf);
    lf.lfEscapement := 450;
    lf.lfOrientation := 450;
    tf.Handle := CreateFontIndirect(lf);
    Font.Assign(tf);
    tf.Free;
    TextOut(20, Height div 2, 'gedrehter Text!');
  end;
end;

Gelöschte Datensätze aus einer Datenbank entfernen

Das funktioniert mit folgender Routine aus der RxLib:

uses BDE;

procedure PackTable(Table: TTable);
var
  FCurProp: CurProps;
  TblDesc: CRTblDesc;
  hDb: hDbiDB;
  TablePath: array[0..dbiMaxPathLen] of Char;
  Exclusive: Boolean;
begin
  if not Table.Active then
    _DBError(SDataSetClosed);
  Check(DbiGetCursorProps(Table.Handle, FCurProp));
  if StrComp(FCurProp.szTableType, szParadox) = 0 then begin
    hDb := nil;
    FillChar(TblDesc, SizeOf(CRTblDesc), 0);
    with TblDesc do begin
      StrPCopy(szTblName, Table.TableName);
      StrCopy(szTblType, FCurProp.szTableType);
      bPack := True;
    end;
    Check(DbiGetDirectory(Table.DBHandle, False, TablePath));
    Table.Close;
    try
      Check(DbiOpenDatabase(nil, szCFGDBSTANDARD, dbiReadWrite,
                            dbiOpenExcl, nil, 0, nil, nil, hDb));
      Check(DbiSetDirectory(hDb, TablePath));
      Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
      Check(DbiCloseDatabase(hDb));
    finally
      Table.Open;
    end;
  end
  else
    if StrComp(FCurProp.szTableType, szDBase) = 0 then begin
      Exclusive := Table.Exclusive;
      Table.Close;
      try
        Table.Exclusive := True;
        Table.Open;
        try
          Check(DbiPackTable(Table.DBHandle, Table.Handle, nil,
                nil,True));
        finally
          Table.Close;
        end;
      finally
        Table.Exclusive := Exclusive;
        Table.Open;
      end;
    end
    else
      DbiError(DBIERR_WRONGDRVTYPE);
end;

Get Task ID

Diese Routinen holen die ID Nummern und Programmnamen aller laufenden Prozesse. Benötigt wird dazu die Library PSAPI.DLL. Sie ist frei im Internet verfügbar. Es sind die gleichen PID's, wie sie auch der Windows NT Task-Manager zeigt.

Uses PsAPI;

Var PidList: PInteger;
    PidCount: Integer;


Procedure GetPidList;
Var cbNeeded: Integer;
Begin
  ReallocMem(PIDList,65536);
  If not EnumProcesses(PidList,65536,cbNeeded) Then cbNeeded := 0;
  ReallocMem(PIDList,cbNeeded);
  PIDCount := cbNeeded div SizeOf(Integer);
End;

Function GetPid(Index:Integer):Integer;
Begin
  If (Index >= 0) and (Index < PidCount) Then Begin
    Result := PInteger(PChar(PidList) + Index * SizeOf(Integer))^;
  End Else Begin
    Result := -1; // PID Index out of range
  End;
end;

Function GetBaseName(Pid:Integer):String;
Var Handle:THandle; szName: Array [0..255] of Char;
Begin
  Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,False,Pid);
  If handle <> 0 Then Begin
    Try
      If psapi.GetModuleBaseName(handle,0,szName,sizeof(szName)) > 0 Then
        Result := szName
      Else
        Result := 'System';
    Finally
      CloseHandle (handle)
    End;
  End Else Begin
    If Pid = 0 Then
      Result := 'Idle'
    Else
      Result := 'None';
  End;
End;



procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ReAllocMem(PidList,0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ReAllocMem(PidList,65536);
end;

procedure TForm1.Button1Click(Sender: TObject);
Var i:Integer; s1:String; Pid:Integer;
begin
  GetPidList;
  For i := 0 to PidCount-1 do Begin
    Pid := GetPid(i);
    If Pid >= 0 Then Begin
      s1 := GetBaseName(Pid);
      Memo1.Lines.Add(IntToStr(Pid) + Chr(9) + s1);
    End Else Begin
      Memo1.Lines.Add('Error by PID ' + IntToStr(Pid));
    End;
  End;
end;


Ausgabe:
0 Idle
2 None
20 None
24 None
34 None
40 None
43 None
67 None
74 None
90 None
80 None
95 None
97 None
105 None
42 None
115 None
119 None
126 None
170 nddeagnt.exe
101 Explorer.exe
167 SysTray.Exe
174 comsmd.exe
88 MGAHOOK.EXE
178 point32.exe
182 HPPROPTY.EXE
184 HPNRA.EXE
189 winhlp32.exe
191 eudora.exe
164 delphi32.exe
204 NOTEPAD.EXE
199 taskmgr.exe
210 NOTEPAD.EXE
220 notepad.exe
224 winhlp32.exe
227 winhlp32.exe
247 DataBaseFaq.exe
243 Project1.exe

Globale Exception Routine

Wenn in einem Programm sehr viele Fehler durch einen Try..Except..End Block abgefangen werden sollen, dann der Quelltext dadurch sehr groß werden. Es geht aber auch mit einer globalen Exception Routine:

Uses Windows, SysUtils;

Function GlobalException(s1:String; ExceptObject:TObject; ExceptAddr:Pointer):String;
Var
  ModuleName: array[0..MAX_PATH] of Char;
  s2: array[0..MAX_PATH] of Char;
  s3: String;
  Info: TMemoryBasicInformation;
begin
  VirtualQuery(ExceptAddr, Info, sizeof(Info));
  s2 := #0;
  If (Info.State <> MEM_COMMIT) or (GetModuleFilename(THandle(Info.AllocationBase),s2,SizeOf(s2)) = 0) Then Begin
    GetModuleFileName(HInstance,s2,SizeOf(s2));
  End;
  StrLCopy(ModuleName,AnsiStrRScan(s2,'\') + 1,SizeOf(ModuleName)-1);
  s3 := '';
  If ExceptObject.ClassType = EIntOverflow Then s3 := ' - Pech gehabt';
  Result := s1 + ExceptObject.ClassName + ' in Module ' + StrPas(ModuleName) + ' - ' + Exception(ExceptObject).Message + s3;
end;

Der Übergabeparameter s1 wird dazu benutzt, die Quelle der Funktion anzugeben.

Testausgabe für einen Integer-Overflow:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Try
    i1 := i1 * i1;
    Edit1.Text := 'alles klar';
  Except
    On E:Exception do Memo1.Lines.Add(GlobalException('(Button1Click) ',E,E));
  End;
end;

Ausgabe in eine TMemo Komponente:

(Button1Click) EIntOverflow in Module PROJECT1.EXE - Integer-Überlauf - Pech gehabt

Graphic (Bitmap) in Datenbank Speichern/Lesen

var
   bmp : TBitmap;
begin
     bmp := TBitmap.Create;
     bmp.Assign(TGraphicField(Table1.FieldByName('Graphic')));
     Image1.Picture.Graphic := bmp;
     bmp.Free;
end;


TGraphicField(Table1.FieldByName('MyPicture')).LoadFromFile('mybmp.bmp');

TGraphicField(Table1.FieldByName('MyPicture')).Assign(Image1.Picture.Bitmap);

Hint im TreeView ausschalten

Ich möchte gerne die automatische Hint-Anzeige eines TreeViews abschalten, also die "Tooltips", die erscheinen, wenn ein Node nicht vollständig im Fenster angezeigt wird. Wer weiß welche Möglichkeiten ich habe?

Ab Delphi4 hat TTreeView dafür die Eigenschaft "Tooltips". In Delphi3 wurde diese Eigenschaft nicht gekapselt, man muß sich deshalb mit der API-Funktion "SetWindowLong" behelfen:

const TVS_NoTooltips = $80;

Begin
  With TreeView1 do Begin
    SetWindowLong(Handle,GWL_Style,GetWindowLong(Handle,GWL_Style) or TVS_NoTooltips);
  End;
End;

Hint in einer Gridzelle

Ich möchte für jede Zelle eines StringGrids einen eigenen Hint anzeigen. Der Hinweistext wird aber erst aktualisiert, wenn der Mauszeiger das Grid verlässt. Wie kann ich einen neuen Hinweis anzeigen, wenn der Mauszeiger über eine neue Zelle bewegt wird?

Damit der Hint wieder auftaucht, muß man nur Application.CancelHint aufrufen - die MouseMove-Methode sieht dann wie folgt aus:

var
  LastCol, LastRow : longint;

procedure TForm1.StringGridMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var ACol, ARow: longint;
begin
  StringGrid.MouseToCell(X, Y, ACol, ARow);
  StringGrid.Hint:='Dieser Hinweis gilt nur für die Zelle '+IntToStr(ACol)+':'+IntToStr(ARow);
  if (ACol<>LastCol) or (ARow<>LastRow) then begin
    Application.CancelHint;
    LastCol:=ACol;
    LastRow:=ARow;
  end;
end;

Horizontales Scrollbar in einer ListBox

Die ListBox verfügt standardmäßig nicht über einen horizontalen Scrollbar. Durch die Message LB_SetHorizontalExtent kann dieser hinzugefügt werden. Der Parameter 1000 gibt den scrollbaren Bereich in Pixel an. Soll der scrollbare Bereich so groß sein, daß der längste String gerade noch dargestellt werden kann, dann muß die Länge des längsten String (in Pixeln) festgestellt werden (siehe [Länge und Höhe eines Strings in Pixel]).

procedure TForm1.FormCreate(Sender: TObject);
begin
  SendMessage(Listbox1.Handle,LB_SetHorizontalExtent,1000,0);
end;

Icon Datei in Image (Bitmap) laden

Über die Canvas.Draw Methode kann ein Icon in ein Bitmap umgewandelt werden.

procedure TForm1.sbClick(Sender: TObject);
Var MyIcon: TIcon;
begin
  MyIcon := TIcon.Create;
  try
    OpenDialog1.InitialDir := s1;
    If OpenDialog1.Execute Then Begin
      MyIcon.LoadFromFile(oOpenDialog1.FileName);
      Image1.Width := MyIcon.Width;
      Image1.Height := MyIcon.Height;
      Image1.Canvas.Draw(0,0, MyIcon);
      Image1.Picture.Bitmap.PixelFormat := pf4Bit;
    End;
  Finally
    MyIcon.Free;
  End;
end;

Bei der Zuweisung zum Bitmap hat das Attribut PixelFormat den Wert pfDevice. Dies ist in der Regel die Anzahl der Farben der Bildschirmauflösung. Das kann aber durch Zuweisung eines der folgenden Parameter in eine andere Farbauflösung konveriert werden:

Image1.Picture.Bitmap.PixelFormat := pfDevice; // für Bildschirm Farben
Image1.Picture.Bitmap.PixelFormat := pf1bit; // für Schwarz/Weiß
Image1.Picture.Bitmap.PixelFormat := pf4bit; // für 16 Farben
Image1.Picture.Bitmap.PixelFormat := pf8bit; // für 256 Farben
Image1.Picture.Bitmap.PixelFormat := pf15bit; // für 32768 Farben
Image1.Picture.Bitmap.PixelFormat := pf16bit; // für 65536 Farben
Image1.Picture.Bitmap.PixelFormat := pf24bit; // für 16777216 Farben

Icons aus Deteien extrahieren

Diese Funktionen brauchen die ShellApi:

Uses ShellAPI;

ExtractIcon kann alle Icons aus einem File holen. IconIndex ist der Laufparameter. Ist er nil dann sind keine mehr da.

procedure TForm1.Button1Click(Sender: TObject);
Var IconIndex:Word; ImageHandle:HIcon;
begin
  If OpenDialog1.Execute Then Begin
    IconIndex := 0;
    ImageHandle := ExtractIcon(hInstance,PChar(OpenDialog1.FileName),IconIndex );
    Edit2.Text := IntToStr(LongInt(ImageHandle));
    If LongInt(ImageHandle) <> 0 Then Begin
      Image1.Picture.Icon.Handle := ImageHandle;
      Edit1.Text := 'Hurra, ein Icon ist da';
    End Else Begin
      Edit1.Text := 'nix gefunden';
    End;
  End;
end;

ExtractAssociatedIcon besorgt das Icon, welches im Explorer zu sehen ist. Funktioniert bei allen Dateien. ExtractIcon funktioniert nur bei *.DLL und *.EXE.

procedure TForm1.Button1Click(Sender: TObject);
Var IconIndex:Word; ImageHandle:HIcon;
begin
  If OpenDialog1.Execute Then Begin
    IconIndex := 0;
    ImageHandle := ExtractAssociatedIcon(hInstance,PChar(OpenDialog1.FileName),IconIndex );
    Edit2.Text := IntToStr(LongInt(ImageHandle));
    If LongInt(ImageHandle) <> 0 Then Begin
      Image1.Picture.Icon.Handle := ImageHandle;
      Edit1.Text := 'Hurra, ein Icon ist da';
    End Else Begin
      Edit1.Text := 'nix gefunden';
    End;
  End;
end;

Icons im SpeedButton benutzen

Q:

Probably need a way to extract the application icon into a physical .ICO file and convert it to a .BMP file.

A:

You can cheat a little and just copyrect the Icon into the Bitmap of a Speed button.

Var
  imgIcon: TIcon;
  imgRect: TRect;
Begin
  imgIcon := TIcon.Create;
  imgIcon.Handle := ExtractIcon( 'EXEFILENAME' );
  With SpeedButton1.Glyph do Begin
    Width := imgIcon.Width;
    Height := imgIcon.Height;
    imgRect := Rect(0,0,Width,Height);
    Canvas.CopyRect(imgRect,imgIcon.Canvas,imgRect );
  End;
End;

ID einer Audio CD ermitteln

Dieses Beispiel zeigt, wie man die ID-Nummer einer Audio-CD ermittelt, die auch der Windows-eigene CD-Player als Identifikation benutzt:

function TForm1.GetCDName : String;
var
  InfoParm : TMCI_Info_Parms;
  lpInfoString : PChar;
const
  lenInfoString = 17;
begin
  playerform.mp.DeviceType := dtCDAudio;
  if not playerform.mp.AutoOpen then playerform.mp.Open;
  GetMem(lpInfoString,lenInfoString);
  InfoParm.dwCallback := 0;
  InfoParm.lpstrReturn := lpInfoString;
  InfoParm.dwRetSize := lenInfoString;
  mciSendCommand(playerform.mp.DeviceID, mci_Info,
                 (mci_Wait or {MCI_INFO_MEDIA_UPC}
                  MCI_INFO_MEDIA_IDENTITY), Longint(@InfoParm) );
  Result := StrPas(lpInfoString);
  FreeMem(lpInfoString,lenInfoString);
end;

verwendete Komponenten :
mp : TMediaPlayer
PlayerForm : TForm

Image (Bitmap) als ICO speichern

Als Transparent Farbe wird der Farbwert des Pixels in der oberen, linken Ecke benutzt (.Pixels[0,0]).

Die Routine CreateIconIndirect scheint einen Fehler zu haben. Wenn man ein Bitmap aus 16 Farben speichert, dann sollte im IconFile an Byte-Position 8 eine 16 stehen, es steht aber eine 4 an dieser Position.

procedure TForm1.Button1Click(Sender: TObject);
var
  IconX : integer;
  IconY : integer;
  AndMask : TBitmap;
  XOrMask : TBitmap;
  IconInfo : TIconInfo;
  Icon : TIcon;
  c,cp,x,y:Integer;
begin
  AndMask := TBitmap.Create;
  XOrMask := TBitmap.Create;
  Icon := TIcon.Create;
  Try
    {Get the icon size}
    IconX := Image1.Width;
    IconY := Image1.Height;

    {Create the "And" mask}
    AndMask.Monochrome := true;
    AndMask.Width := IconX;
    AndMask.Height := IconY;

    {Create the "XOr" mask}
    XOrMask.Width := IconX;
    XOrMask.Height := IconY;

    {Draw on the "And" mask}
    AndMask.Canvas.Brush.Color := clWhite;
    AndMask.Canvas.FillRect(Rect(0,0,IconX,IconY));
    {Draw on the "XOr" mask}
    XOrMask.Canvas.Brush.Color := clBlack;
    XOrMask.Canvas.FillRect(Rect(0,0,IconX,IconY));

    {Copy the Bitmap}
    cp := Image1.Canvas.Pixels[0,0];
    For x := 0 to IconX-1 do Begin
      For y := 0 to IconY-1 do Begin
        c := Image1.Canvas.Pixels[x,y];
        If c = cp Then AndMask.Canvas.Pixels[x,y] := clWhite;
        If c <> cp Then XOrMask.Canvas.Pixels[x,y] := c;
      End;
    End;

    {Create a icon}
    IconInfo.fIcon := true;
    IconInfo.xHotspot := 0;
    IconInfo.yHotspot := 0;
    IconInfo.hbmMask := AndMask.Handle;
    IconInfo.hbmColor := XOrMask.Handle;
    Icon.Handle := CreateIconIndirect(IconInfo);
    Icon.SaveToFile('g:\Buch.ico');
  Finally
    AndMask.Free;
    XOrMask.Free;
    Icon.Free;
  End;
end;

Image <--> BLOB Feld

Loading bitmaps into dBase/Paradox BLOB fields

Question

How can I load bitmaps into dBase / Paradox BLOB fields?

Answer

There are a number of ways to load a bitmap image into the BLOB field of a dBASE or Paradox table. Three of the easier methods involve 1) copying the data from the Windows clipboard into a TDBImage component connected to the BLOB field, 2) using the LoadFromFile method of the TBLOBField component, and 3) using the Assign method to copy an object of type TBitmap into the Picture property of a TBDBImage.

The first method, copying the bitmap from the clipboard, is probably most handy when an application needs to add bitmaps to a table when the enduser is running the application. A TDBImage component is used to act as an interface between the BLOB field in the table and the image stored in the clipboard. The PasteFromClipboard method of the TDBImage component is invoked to copy the bitmap data from the clipboard into the TDBImage. When the record is posted, the image is stored into the BLOB field in the table.

Because the Windows clipboard can contain data in formats othher than just bitmap, it is advisable to check the format prior to calling the CopyFrom-Clipboard method. To do this, a TClipboard object is created and its Has- Format method is used to determine if the data in the clipboard is indeed of bitmap format. Note that to use a TClipboard object, the Clipbrd unit must be included in the Uses section of the unit that will be creating the object.

Here is an example showing the contents of the clipboard being copied into a TDBImage component, if the contents of the clipboard are of bitmap format:

  procedure TForm1.Button1Click(Sender: TObject);
  var
    C: TClipboard;
  begin
    C := TClipboard.Create;
    try
      if Clipboard.HasFormat(CF_BITMAP) then
        DBImage1.PasteFromClipboard
      else
        ShowMessage('Clipboard does not contain a bitmap!');
    finally
      C.Free;
    end;
  end;

The second method of filling a BLOB field with a bitmap involves loading the bitmap directly from a file on dissk into the BLOB field. This method lends itself equally well to uses at run-time for the end-user as for the developer building an application's data.

This method uses the LoadFromFile method of the TBLOBField component, the Delphi representation of a dBASE for Windows Binary field or a Paradox for Windows Graphic field, either of which may be used to store bitmap data in a table.

The LoadFromFile method of the TBLOBField component requires a single parameter: the name of the bitmap file to load, which is of type String. The value for this parameter may come from a number of sources from the end-user manually keying in a valid file name to the program providing a string to the contents of the FileName property of the TOpenDialog component.

Here is an example showing the use of the LoadFromFile method for a TBLOBField component named Table1Bitmap (a field called Bitmap in the table associated with a TTable component named Table1):

  procedure TForm1.Button2Clicck(Sender: TObject);
  begin
    Table1Bitmap.LoadFromFile(
      'c:\delphi\images\splash\16color\construc.bmp');
  end;

The third method uses the Assign method to copy the contents of an object of type TBitmap into the Picture property of a TDBImage component. An object of type TBitmap might be the Bitmap property of the Picture object property of a TImage component or it may be a stand-alone TBitmap object. As with the method copying the data from the clipboard into a TDBImage component, the bitmap data in the TDBImage component is saved into the BLOB field in the table when the record is successfully posted.

Here is an example using the Assign method. In this case, a stand-alone TBitmap object is used. To put a bitmap image into the TBitmap, the LoadFromFile method of the TBitmap component is called.

  procedure TForm1.Button3Click(Sender: TObject);
  var
    B: TBitmap;
  begin
    B := TBitmap.Create;
    try
      B.LoadFromFile('c:\delphi\images\splashh\16color\athena.bmp');
      DBImage1.Picture.Assign(B);
    finally
      B.Free;
    end;
  end;

Extracting a bitmap from a BLOB field

Question

How can I extract a bitmap from a BLOB field?

Answer

Extracting a bitmap from a dBASE or Paradox blob field -- without first saving the bitmap out to a file -- is a simple process of using the Assign method to store the contents of the BLOB field to an object of type TBitmap. A stand-alone TBitmap object or the Bitmap property of the Picture object property of a TIMage component are examples of compatible destinations for this operation.

Here is an example demonstrating using the Assign method to copy a bitmap from a BLOB field into a TImage component.

  procedure TForm1.Button1Click(Sender: TObject);
  begin
    Image1.Picture.Bitmap.Assign(Table1Bitmap);
  end;

In this example, the TBLOBField object Table1Bitmap is a BLOB field in a dBASE table. This TBLOBField object was created using the Fields Editor. If the Fields Editor is not used to create TFields for the fields in the table, the fields must be referenced using either the FieldByName method or the Fields property, both part of the TTable and TQuery componentts. In cases where one of those means is used to reference the BLOB field in a table, the field reference must be type-cast as a TBLOBField object prior to using the Assign method. For example:

  procedure TForm1.Button1Click(Sender: TObject);
  begin
    Image1.Picture.Bitmap.Assign(TBLOBField(Table1.Fields[1]));
  end;

A bitmap stored in a BLOB field may also be copied directly to a standalone TBitmap object. Here is an example showing the creation of a TBitmap object and storing into it a bitmap from a BLOB field.

  procedure TForm1.Button2Click(Sender: TObject);
  var
    B: TBitmap;
  begin
    B := TBitmap.Create;
    try
      B.Assign(Table1Bitmap);
      Image1.Picture.Bitmap.Assign(B);
    finally
      B.Free;
    end;
  end;

Internetverbindung erkennen

Wie kann ich feststellen, ob ich gerade durch eine DFÜ-Verbindung mit dem Internet verbunden bin (oder nicht)?

Verbindungen über das DFÜ-Netzwerk laufen über die Remote Access Services-API. Eine Delphi-Kapselung dieser RAS-API mit einem Beispielprojekt findet man auf meiner Komponentenseite.

Um eine Internetverbindung zu erkennen, kann man außerdem die lokale IP-Adresse des Rechners prüfen. Wenn die lokale IP-Adresse "0.0.0.0" ist, besteht keine TCP/IP-Verbindung, also auch keine Internetverbindung. Dazu benutzt man am einfachsten eine beliebige TCP-Komponente. Ein Beispiel für die delphieigene TCP-Komponente:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if TCP1.LocalIp = '0.0.0.0' then ShowMessage('Your not connected!');
end;

Interrupt Service Routine

I am trying to write code which will install an interrupt service routine for DOS interrupt 21H. I want my ISR to be called ANY time interrupt 21 is call from any running program or the system itself. Using the code below, I don't seem to get any response at all. I can't even get a GPF. Any ideas, suggestions or pointers would be apreciated.

 procedure InitDOS21;
 begin
   PassCount := 0;
   GetIntVec($21, OldInt21);
   NewInt21 := @NewInt21ISR;
   SetIntVec($21, NewInt21);
 end;

 procedure ShutdownDOS21;
 begin
     Inc(PassCount);
     SetIntVec($21, OldInt21);
 end;

 procedure JmpOldISR(OldISR : Pointer);
 begin { This procedure will jump from and ISR to the ISR vector passed.}
                        { Taken from BREAKNOW.PAS. }
        inline($5B/$58/$87/$5E/$0E/$87/$46/$10/$89/
        $EC/$5D/$07/$1F/$5F/$5E/$5A/$59/$CB);
 end;

 procedure NewInt21ISR(Flags, CS, IP, AX, BX, CX, DX, SI,
        DI ,DS, ES, BP: word);
 begin
     Inc(PassCount);
     { Do my processing }
     JmpOldISR( OldInt21);
 end;

A:
In TP6 and BP7 you needed to define your ISR like this:

procedure NewInt21ISR(...registers...); interrupt;

I've also seen people define them like this:

type
  IntRegisters = record
    case Byte of
      1 : (BP, ES, DS, DI, SI, DX, CX, BX, AX, IP, CS, Flags : Word);
      2 : (Dummy : Dummy5; DL, DH, CL, CH, BL, BH, AL, AH : Byte);
      end;

procedure NewInt21ISR(BP : WORD); interrupt;
var
  Regs : IntRegisters absolute BP;
begin
...
end;

JPEG nach Bitmap kopieren

Ich möchte eine JPEG-Datei einem eigenen TBitmap-Objekt zuweisen, damit ich dann im Hintergrund auf das Bild zugreifen und es verändern kann, bzw. Teile davon ausschneiden etc.

Antwort:

Die Unit JPEG in die uses-Liste aufnehmen.

dann ungefähr folgendes:

 var
   xBMPImage : TBitmap;
   xJPEGImage : TJPEGImage;
 begin
   xJPEGImage:=TJPEGImage.Create;
   try
     xBMPImage:=TBitmap.Create;
     try
       xJPEGImage.LoadFromFile('abcd.jpg');
       // -> JPG
       xBMPImage.Assign(xJPEGImage);
       // bearbeiten, z.B. abspeichern
       xBMPImage.SaveToFile('abcd.bmp');
     finally
       xBMPImage.Free;
     end;
   finally
     xJPEGImage.Free;
   end;
 end;

Ein wenig Theorie:

Im Prinzip hält TJPEGImage das JPEG-File im Speicher und gleichzeitig eine nicht bearbeitbare Bitmap, die bei Bedarf erzeugt wird.

TJPEGImage hat nur den Befehl Draw implementiert, d.h. mit Canvas.Draw(X,Y,xJPEGImage); kann man die komplette JPEG auf ein Canvas zeichnen.

Um die Grafik einer JPEG bearbeiten zu können, müssen wir sie einem TBitmap zuordnen:

xBMPImage.Assign(xJPEGImage);

Jetzt kann man mit dem Bitmap machen, was man möchte.

Bug in der Unit JPEG: (mindestens in Delphi 3)

Ein Bug tritt zu Tage, wenn man eine JPEG-Datei lädt, den Bitmap-Teil aktiviert (z.B. durch Assign oder Anzeigen) und anschließend eine andere JPEG-Datei lädt.

Was passiert:

Der Bitmap-Teil wird nicht für ungültig erklärt, so das nach wie vor das alte Bild im Bitmap-Teil steht.

Workaround:

Vor dem Laden des nächsten Bildes folgende Anweisung benutzen:

with xJPEGImage do Smoothing := Not Smoothing;

Das erklärt den Bitmap-Teil für ungültig.

JPEG Vorschau

 var
   j : TJPEGImage;
 begin
   j:=TJPEGImage.Create;
   try
     j.Assign(Image1.Picture.Graphic);
     j.CompressionQuality:=20;
     j.Compress;
     j.Smoothing:=Not j.Smoothing;
     Image2.Picture.Assign(j);
   finally
     j.Free;
   end;
 end;

Knoten im TreeView suchen

Aufgrund der Datenstruktur eines TreeViews bieten sich bei der Arbeit mit TreeNodes grundsätzlich rekursive Routinen an. Diese Routine durchsucht alle Kinder eines vorgegebenen Knotens "Root" rekursiv nach einem Knoten mit dem gesuchten Text "Name":

function FindNode(Root: TTreeNode; Name: string): TTreeNode;
var
  Temp: TTreeNode;
begin
  Result := Root.GetFirstChild;
  while Result <> nil do begin
    if Result.Text = Name then Exit;
    Temp := Find(Result, Name);
    if Temp <> nil then begin
      Result := Temp;
      Exit;
    end;
    Result := Root.GetNextChild(Result);
  end;
end;

Komponenete zur Laufzeit verschieben

Komponente wird durch die Linke gedrückte Maustaste verschoben.

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
const SC_DragMove = $F012; { a magic number }
begin
  ReleaseCapture;
  Panel1.Perform(WM_SysCommand,SC_DragMove,0);
end;

Komponenten Array beschriften

Es gibt zwei Möglichkeiten eine Reihe von Komponenten zu Beschriften:

1. Alles einzeln Eintragen.

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit3.Text := '3';
  Edit4.Text := '4';
  ...
  Edit13.Text := '13';
end;


2. Mit FindComponent die Komponente suchen und dann Eintragen.

procedure TForm1.Button1Click(Sender: TObject);
Var i:Integer;
begin
  For i := 3 to 13 do Begin
    (FindComponent('Edit'+IntToStr(i)) as TEdit).Text := IntToStr(i);
  End;
end;

Komponenten zur Laufzeit erzeugen

Man kann sämtliche Properties aus dem Designer auch im Quelltext setzen. Wichtig ist, daß man als Parent die Form angibt, auf der die Komponente erstellt werden soll.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    // Per Hand hinzugefügt
    Procedure CreateUserLabel;
    Procedure CreateUserLabels;
    procedure xLabelClick(Sender: TObject);
    procedure zLabelClick(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

Var xLabel: TLabel;
    zLabel: Array [0..3] of TLabel;

Procedure TForm1.CreateUserLabel;
Begin
  xLabel := TLabel.Create(self);
  With xLabel do Begin
    Parent := self;
    Caption := 'User Label';
    Left := 10;
    Top := 110;
    Width := 100;
    Height := 21;
    Visible := True;
    OnClick := xLabelClick;
  End;
End;

Procedure TForm1.CreateUserLabels;
Var i:Integer;
Begin
  For i := 0 to 3 do Begin
    zLabel[i] := TLabel.Create(self);
    With zLabel[i] do Begin
      Parent := self;
      Caption := 'User Label ' + IntToStr(i);
      Left := 150;
      Top := 110 + i * 25;
      Width := 100;
      Height := 21;
      Visible := True;
      Tag := i;
      OnClick := zLabelClick;
    End;
  End;
End;


procedure TForm1.Button1Click(Sender: TObject);
begin
  CreateUserLabels;
end;

procedure TForm1.Button2Click(Sender: TObject);
Var i:Integer;
begin
  For i := 0 to 3 do zLabel[i].Free;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  zLabel[3].Caption := 'Hallo umni';
end;

procedure TForm1.xLabelClick(Sender: TObject);
begin
  Edit1.Text := 'Klick User Label';
end;

procedure TForm1.zLabelClick(Sender: TObject);
begin
  Case TLabel(Sender).Tag of
    0: Edit1.Text := 'Klick User Label 0';
    1: Edit1.Text := 'Klick User Label 1';
    2: Edit1.Text := 'Klick User Label 2';
    3: Edit1.Text := 'Klick User Label 3';
  End;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  If zLabel[1] <> nil
    Then Edit2.Text := 'exists'
    Else Edit2.Text := 'non exists';
end;

end.

Hinweis:

Wenn die Labels schon erzeugt wurden, gibt es einen Crash wenn die Labels ein zweites mal erzeugt werden. Mit zLabel[1] <> nil sollte vorher getestet werden, ob die Labels schon existieren. Das funktioniert auch, wenn sie noch nie erzeugt wurden. Sind sie erzeugt und durch Free wieder entfernt worden, dann tut dieser Test so, als ob sie noch vorhanden sind, obwohl in der Dokumentation steht, daß die Komponente entfernt und der zugehörige Speicher freigegeben wurden. Vielleicht ein Bug ?

Konvertierung Base2 zu Base10

Konvertiert 32 bit base2 zu 32 bit base10

Maximale Zahl = 99 999 999

Gibt -1 zurück, wenn die Zahl zu groß ist

function Base10(Base2:Integer) : Integer; assembler;
asm
  cmp eax,100000000 // check upper limit
  jb @1 // ok
  mov eax,-1 // error flag
  jmp @exit // exit with -1
@1:
  push ebx // save registers
  push esi
  xor esi,esi // result = 0
  mov ebx,10 // diveder base 10
  mov ecx,8 // 8 nibbles (10^8-1)
@2:
  mov edx,0 // clear remainder
  div ebx // eax DIV 10, edx mod 10
  add esi,edx // result = result + remainder[I]
  ror esi,4 // shift nibble
  loop @2 // loop for all 8 nibbles
  mov eax,esi // function result
  pop esi // restore registers
  pop ebx
@exit:
end;

Länge und Höhe eines Strings in Pixel

Funktioniert nur über Canvas Methode.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Menus, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    procedure Button1Click(Sender: TObject);
    function GetTextWidth(Text:String;TextFont:TFont):Integer;
    function GetTextHeight(Text:String;TextFont:TFont): Integer;
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}


function TForm1.GetTextWidth(Text:String;TextFont:TFont): Integer;
var TempFont:TFont;
begin
  TempFont := TFont.Create;
  try
    TempFont.Assign(Font);
    Font.Assign(TextFont);
    Result := Canvas.TextWidth(Text);
    Font.Assign(TempFont);
  finally
    TempFont.Free;
  end;
end;

function TForm1.GetTextHeight(Text:String;TextFont:TFont): Integer;
var TempFont:TFont;
begin
  TempFont := TFont.Create;
  try
    TempFont.Assign(Font);
    Font.Assign(TextFont);
    Result := Canvas.TextHeight(Text);
    Font.Assign(TempFont);
  finally
    TempFont.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
Var i:Integer;
begin
  i := GetTextWidth(Edit2.Text,Edit2.Font);
  Edit1.Text := IntToStr(i);
end;

end.

Lasso Kontrolle

Lasso in einer Komponente ziehen. Hier als Beispiel in der Hauptform.

Var bMarquee: Boolean;
    ptOrigin: TPoint;
    ptMove: TPoint;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  bMarquee := True;
  ptOrigin := Point(X,Y); // Startpunkt
  ptMove := Point(X,Y); // Endpunkt initialisieren
  With Canvas do Begin
    Pen.Color := clBlack;
    Pen.Width := 1;
    Pen.Style := psDot;
    Brush.Style := bsClear;
    // Lasso zeichnen
    DrawMarquee(ptOrigin,ptMove,pmNotXor);
  End;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y:
Integer);
begin
  If bMarquee = True Then Begin
    DrawMarquee(ptOrigin,ptMove,pmNotXor);
    DrawMarquee(ptOrigin,Point(X,Y),pmNotXor );
    ptMove := Point(X,Y);
    Canvas.Pen.Mode := pmCopy;
  End;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  If bMarquee = True Then Begin
    bMarquee := False;
    DrawMarquee(ptOrigin,Point(X,Y),pmNotXor );
    ptMove := Point(X,Y);
    // Hier ist das Lasso ziehen beendet.
  End;
end;

procedure TForm1.DrawMarquee(mStart,mStop:TPoint; AMode:TPenMode);
begin
  Canvas.Pen.Mode := AMode;
  Canvas.Rectangle(mStart.X,mStart.Y,mStop.X,mStop.Y);
end;

Laufzeit Messungen

Auflösung bei Win 95, 200 MHz Pentium Pro

QueryPerformanceFrequency(c); c = 1193180 Hz = 838.1 ns

QueryPerformanceFrequency liefert einen Bool Wert zurück, ist er false, dann existiert dieser Counter nicht und zur Zeitmessung muß mit der Funktion GetTickCount gearbeitet werden.

c ist vom Typ TLargeInteger.

Comp = Delphi Type = doppeltlange Ganzzahl (8 Byte) = -263+1 .. 263-1

  TLargeInteger = Record
    Case Integer of
    0: (
      LowPart: DWORD;
      HighPart: Longint);
    1: (
      QuadPart: Comp);
  End;

QueryPerformanceCounter ist eine Funktion aus Kernel32.dll

procedure TForm1.Button2Click(Sender: TObject);
Var c,t1,t2:TLargeInteger; i:Integer;
begin
  QueryPerformanceFrequency(c);
  QueryPerformanceCounter(t1);
  For i := 1 to 100 do Edit1.Text := IntToStr(Random(300));
  QueryPerformanceCounter(t2);
  Edit1.Text := FloatToStr(1000 * (t2.QuadPart - t1.QuadPart) / c.QuadPart);
end;

Antwort: 23,1239209507367 ms bei Pentium Pro 200 MHz

Library Laden und ausführen

type
  TMyProcType = function( X, Y: Integer ): Integer;

  ...
  ...

var
 nHandle: THandle;
 MyProcType: TMyProcType
begin
  nHandle := LoadLibrary( 'MYDLL.DLL' );

  if nHandle < 32 then
    raise EDLLLoadError.Create( 'Cant load the sucker' );

  @MyProcType := GetProcAddress( nHandle, 'MYFUNCNAME' );

  { Now call it like a function, ex:}
  z := MyProcType( 10, 10 );

  FreeLibrary( nHandle );

Link auf Internet Homepage

Dazu nimmt man am besten eine TLabel-Komponente (hier: "URLLabel") und gestaltet diese so, daß sie wie ein Link im Browser erscheint:

With URLLabel1 do Begin
  Caption:='http://pics.webset.de';
  Font.Color:=clBlue;
  Font.Style:=[fsUnderline];
  Cursor:=crHandPoint;
End;

Diese Einstellungen kann man natürlich auch im Objektinspektor zur Entwurfszeit vornehmen. Den Cursorstyle crHandPoint, der aussieht wie die Zeigehand, die auch in Browsern über Links erscheint, gibt es erst ab Delphi 3. Wie man für D1 und D2 selbstgezeichnete Cursor ins Programm einbindet, erfährt man hier in diesem Kapitel der FAQ.

Nun muß man nur noch dafür sorgen, daß nach einem Klick auf URLLabel eine Verbindung zur gewünschten URL aufgebaut wird. Also schreibt man in die OnClick.Methode oder MouseDown.Methode des Labels einen ShellExecute-Aufruf mit der entsprechenden URL. Im Beispiel wird dazu die Beschriftung des Labels hergenommen:

procedure TForm1.URLLabel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  If Button = mbLeft Then Begin
    ShellExecute(Application.Handle,'open',PCHar(Label1.Caption),nil,nil,SW_ShowNormal);
  End;
end;

Markierte Datensätze im TDBGrid ansprechen

Ich habe ein TDBGrid mit dgMultiSelect Enabled. Wie frage ich jetzt ab, welche Records der User gewählt hat?

Idee:

for i := 0 to YourGrid.SelectedRows.Count-1 do begin
  if BookmarkValid (TBookmark(YourGrid.SelectedRows.Items[i])) then
   begin
     GotoBookmark (TBookmark(YourGrid.SelectedRows.Items[i]));
     {Tu_Was_Mit_Daten;}
  end;
end;

Mauscursor automatisch auf einen Button setzen

Procedure CenterMouse(xComp:TButton);
  Var xCenter,yCenter:Integer; p1,p2:TPoint;
Begin
  p1 := Point(xComp.Left,xComp.Top);
  p2 := p1;
  MapWindowPoints(HWND_DESKTOP,xComp.Handle,p2,1);
  xCenter := p1.x + Abs(p2.x) + (xComp.Width div 2);
  yCenter := p1.y + Abs(p2.y) + (xComp.Height div 2);
  SetCursorPos(xCenter,yCenter);
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CenterMouse(Button3);
end;

Mehr als eine Zeile in einer TStringGrid Zelle

Die Anpassung wird im OnDraw Event des StringGrids durchgeführt. In diesem Beispiel werden alle Zellen der obersten Reihe zentriert, Fett und mehrzeilig dargestellt.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
var OldAlign: word;
    YPos,XPos,i: integer;
    s,s1 : string;
    fCol,fRow :longint;
begin
  fCol := Col;
  fRow := Row;
  With Sender as TStringGrid do Begin
    If (fRow = 0) Then Canvas.Font.Style := Canvas.Font.Style + [fsbold];
    If fRow = 0 Then Begin
      OldAlign := SetTextAlign(Canvas.Handle,TA_CENTER);
      XPos := Rect.Left + (Rect.Right - Rect.Left) div 2;
      s := Cells[fCol,fRow];
      While s <> '' do Begin
        If Pos(#13,s) <> 0 Then Begin
          If Pos(#13,s) = 1 Then s1 := '' Else Begin
            s1 := Trim(Copy(s,1,Pred(Pos(#13,s))));
            Delete(s,1,Pred(Pos(#13,s)));
          End;
          Delete(s,1,2);
        End Else Begin
          s1 := trim(s);
          s := '';
        End;
        YPos := Rect.Top + 2;
        Canvas.TextRect(Rect,Xpos,YPos,s1);
        Inc(Rect.Top,RowHeights[fRow] div 3);
      End;
      SetTextAlign(Canvas.Handle,OldAlign);
    End Else Begin
       Canvas.TextRect(Rect,Rect.Left+2,Rect.Top+2,Cells[fCol,fRow]);
    End;
    Canvas.Font.Style := Canvas.Font.Style - [fsbold];
  End;
end;

Mehrere Controls disablen

Um mehrere Komponenten auf einmal zu disablen, kann man sie in eine Eltern-Komponente packen und dann diese Eltern-Komponente disablen. Dann werden jedoch alle Unter-Komponenten nicht Grau geschaltet. Mit der folgenden Procedure kann man das Problen aber umgehen.

procedure EnableControls(Parent: TWinControl; AEnable: Boolean);
var i: Integer;
begin
  With Parent do Begin
    For i := 0 to ControlCount-1 do Begin
      Controls[i].Enabled := Enabled;
    End;
  End;
end;

Menüeinträge erzeugen

Mit dieser Routine kann eine vorhandene Menüleiste um einen Menüeintrag und diversen Untermenüeinträge erweitert werden.

<MainMenu> ist eine Komponente vom Typ TMainMenu

Procedure TForm1.InsertMenue;
Begin
  With MainMenu do Begin
    If Items[3].Caption <> '&Module' Then Begin
      // Eintrag im Hauptmenü erzeugen
      Items.Insert(3,NewItem('&Moduls',0,false,true,mmHandler,0,''));
      // Haupteinträge erzeugen
      Items[3].Add(NewItem('Stations',0,false,true,mmHandler,0,''));
      Items[3].Items[0].Enabled := false;
      Items[3].Add(NewLine);
      Items[3].Add(NewItem('Haupteintrag 1',0,false,true,mmHandler,0,''));
      Items[3].Add(NewItem('Haupteintrag 2',0,false,true,mmHandler,0,''));
      Items[3].Add(NewItem('Haupteintrag 3',0,false,true,mmHandler,0,''));
      Items[3].Add(NewItem('Haupteintrag 4',0,false,true,mmHandler,0,''));
      // Untereinträge erzeugen für 1. Haupteintrag
      Items[3].Items[2].Add(NewItem('Untereinträge 1',0,false,true,mmHandler,0,''));
      Items[3].Items[2].Items[0].Enabled := false;
      Items[3].Items[2].Add(NewLine);
      items[3].Items[2].add(NewItem('Untereintrag 1.1',0,false,true,mmHandler,0,''));
      items[3].Items[2].add(NewItem('Untereintrag 1.2',0,false,true,mmHandler,0,''));
      items[3].Items[2].add(NewItem('Untereintrag 1.3',0,false,true,mmHandler,0,''));
      items[3].Items[2].add(NewItem('Untereintrag 1.4',0,false,true,mmHandler,0,''));
      // Untereinträge erzeugen für 2. Haupteintrag
      Items[3].Items[3].Add(NewItem('Untereinträge 2',0,false,true,mmHandler,0,''));
      Items[3].Items[3].Items[0].Enabled := false;
      Items[3].Items[3].Add(NewLine);
      items[3].Items[3].add(NewItem('Untereintrag 2.1',0,false,true,mmHandler,0,''));
      items[3].Items[3].add(NewItem('Untereintrag 2.2',0,false,true,mmHandler,0,''));
      items[3].Items[3].add(NewItem('Untereintrag 2.3',0,false,true,mmHandler,0,''));
      items[3].Items[3].add(NewItem('Untereintrag 2.4',0,false,true,mmHandler,0,''));
      // Untereinträge erzeugen für 3. Haupteintrag
      Items[3].Items[4].Add(NewItem('Untereinträge 3',0,false,true,mmHandler,0,''));
      Items[3].Items[4].Items[0].Enabled := false;
      Items[3].Items[4].Add(NewLine);
      items[3].Items[4].add(NewItem('Untereintrag 3.1',0,false,true,mmHandler,0,''));
      items[3].Items[4].add(NewItem('Untereintrag 3.2',0,false,true,mmHandler,0,''));
      items[3].Items[4].add(NewItem('Untereintrag 3.3',0,false,true,mmHandler,0,''));
      items[3].Items[4].add(NewItem('Untereintrag 3.4',0,false,true,mmHandler,0,''));
      // Untereinträge erzeugen für 4. Haupteintrag
      Items[3].Items[5].Add(NewItem('Untereinträge 4',0,false,true,mmHandler,0,''));
      Items[3].Items[5].Items[0].Enabled := false;
      Items[3].Items[5].Add(NewLine);
      items[3].Items[5].add(NewItem('Untereintrag 4.1',0,false,true,mmHandler,0,''));
      items[3].Items[5].add(NewItem('Untereintrag 4.2',0,false,true,mmHandler,0,''));
      items[3].Items[5].add(NewItem('Untereintrag 4.3',0,false,true,mmHandler,0,''));
      items[3].Items[5].add(NewItem('Untereintrag 4.4',0,false,true,mmHandler,0,''));
    End;
  End;
End;

Procedure TForm1.mmHandler(Sender: TObject);
Var i:Integer;
Begin
  With Sender as TMenuItem do Begin
    ListBox1.Items.Add(Caption);
  End;
End;

Menüeintrag löschen

Vollständiges Löschen eines Menüeintrages mit allen Untermenüs

<MainMenu> ist eine Komponente vom Typ TMainMenu

Procedure TForm1.DeleteMenue;
Begin
  If MainMenu.Items[3].Caption = '&Module' Then Begin
    MainMenu.Items.Delete(3);
  End;
End;

Message abfangen

Fängt fast alle Meldungen ab, die an und durch die eigene Applikation laufen.

Die zugehörigen Konstanten liegen in Message.pas

Siehe auch Application.Message in der Delphi Hilfe.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    MainMenu1: TMainMenu;
    exit1: TMenuItem;
    procedure FormCreate(Sender: TObject);
  private
    { Private-Deklarationen }
  Protected
    Procedure MyMessage(Var Msg:TMsg; Var Handled:Boolean);
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
Procedure TForm1.MyMessage(Var Msg:TMsg; Var Handled:Boolean);
Begin
  If Msg.Message <> $0118 Then
  If Msg.Message <> WM_MOUSEMOVE Then
  If Msg.Message <> WM_NCMOUSEMOVE Then
  Memo1.Lines.Add(IntToHex(Msg.Message,4));
End;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := MyMessage;
end;

end.

Message von einer Applikation empfangen

Mir dieser Routine können Messages vom Typ WM_Char in einer Application abgefangen werden.

  ...
  private
    { Private-Deklarationen }
    Procedure WMChar(var Message: TWMChar); Message WM_CHAR;
  public
  ...

Abfangen von Zeichen, die durch SendMessage(TaskHandle,WM_CHAR,w1,l1) an dieses Programm gesendet werden.

w1 ist ein Word und wird in diesem Beispiel als Kommando interpretiert
l1 ist ein Long und wird in diesem Beispiel als Parameter interpretiert

w1 erscheint bei der empfangenen Applikation in Message.CharCode
l1 erscheint bei der empfangenen Applikation in Message.KeyData

procedure TForm1.WMChar(var Message: TWMChar);
begin
  Case Message.CharCode of
    // Sendet $55555555 zum rufenden Programm zurück
    // Die Handle des rufenden Programms steht in Message.KeyData
    1001: SendMessage(Message.KeyData,WM_CHAR,2001,$55555555);
    Else inherited;
  End;
end;

Minimize und Maximize Button abfangen

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs;

type
  TForm1 = class(TForm)
    public
      procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
procedure TForm1.WMSysCommand;
begin
  if (Msg.CmdType = SC_MINIMIZE) or
     (Msg.CmdType = SC_MAXIMIZE) then
    MessageBeep(0);
  DefaultHandler(Msg);
end;

end.

Monitor schalten

Monitor ausschalten

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

Monitor einschalten

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);

Nach Klick auf welche Komponente wurde ein Popup-Menü aufgerufen?

Wie ermittelt man die Komponente, auf die mit der rechten Maustaste geklickt wurde, um ein Popup-Menü aufzurufen?

Oft wird ein Popup-Menü mehreren Komponenten zugewiesen, man möchte dann aber wissen, auf welche der Komponenten mit der rechten Maustaste geklickt wurde, um das Popup-Menü aufzurufen. Diese Komponente wird in der Eigenschaft "PopupComponent" des Popup-Menüs gespeichert:

procedure TForm1.PopupMenu1Popup(Sender: TObject);
begin
  Label1.Caption := PopupMenu1.PopupComponent.Name;
end;

Nachfrage beim Windows-Ende


Wenn Windows runtergefahren wird, dann sendet Windows an jede Application eine WM_QueryEndSession Meldung. Diese Meldung wird in der FormCloseQuery Routine der Hauptform abgefangen. Wird die Variable 'CanClose' mit true beantwortet, dann kann Windows runterfahren.

procedure TMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  If MessageDlg('Wirklich ?',mtInformation,[mbOK,mbNo],0) = mrOK
    Then CanClose := true // System darf runterfahren
    Else CanClose := false; // System darf nicht runterfahen
end;

Wenn in FormCloseQuery nichts steht, dann ist CanClose automatisch true.

Netzwerk Usernamen besorgen

Besorgt den Netzwerk-Usernamen.

function GetNetUserName:String;
Var sNetUserName: DbiUserName;
begin
  If DbiGetNetUserName(sNetUserName) = DBIERR_NONE Then Begin
    Result := StrPas(sNetUserName);
  End Else Begin
    Result := '';
  End;
end;


procedure TForm1.GoToFirstButtonClick(Sender: TObject);
begin
  Edit1.Text := GetNetUserName;
end;

Uses dbiErrs;

NT Privilegien setzen

function SetPrivilege(sPrivilegeName:String;bEnabled:Boolean):Boolean;
var
  TPPrev,TP: TTokenPrivileges;
  Token: THandle;
  dwRetLen: DWord;
begin
  Result := False;
  OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,@Token);
  TP.PrivilegeCount := 1;
  If (LookupPrivilegeValue(Nil,PChar(sPrivilegeName),TP.Privileges[0].LUID)) Then Begin
    If (bEnabled) Then Begin
      TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
    End Else Begin
      TP.Privileges[0].Attributes := 0;
    End;
    dwRetLen := 0;
    Result := AdjustTokenPrivileges(Token,False,TP,SizeOf(TPPrev),TPPrev,dwRetLen );
  End;
  CloseHandle(Token);
end;

//
// iFlags:
//
// one of the following must be
// specified
//
// EWX_LOGOFF
// EWX_REBOOT
// EWX_SHUTDOWN
//
// following attributes may be
// combined with above flags
//
// EWX_POWEROFF
// EWX_FORCE : terminate processes
//
function WinExit( iFlags : integer ) : boolean;
begin
  Result := True;
  If(SetPrivilege('SeShutdownPrivilege',True)) Then Begin
    If(not ExitWindowsEx(iFlags,0)) Then Begin
      // handle errors...
      Result := False;
    End;
    SetPrivilege('SeShutdownPrivilege',False);
  End Else Begin
    // handle errors...
    Result := False;
  End;
end;

OCX registrieren

procedure RegistryVCF1;
var hOCX:integer; pReg: procedure;
begin
  hOCX := LoadLibrary('VCF132.OCX');
  if (hOCX <> 0) Then
  begin
    pReg := GetProcAddress(hOCX,'DllRegisterServer');
    pReg; { Call the registration function }
    FreeLibrary(hOCX);
  end;
end;

On Mouse Leave/Enter

Events installieren, die auf den Eintritt und den Austritt auf eine Komponente reagieren:

  private
    { Private-Deklarationen }
    procedure CMMouseEnter(var msg:TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;


procedure TForm1.CMMouseEnter(var msg:TMessage);
Var obj:TObject;
begin
  obj := TObject(Msg.LParam);
  If obj is TLabel Then Begin
    If (obj as TLabel).Caption = Label1.Name Then Begin
      Edit1.Text := 'Entry';
    End;
  End;
end;

procedure TForm1.CMMouseLeave(var msg: TMessage);
Var obj:TObject;
begin
  obj := TObject(Msg.LParam);
  If obj is TLabel Then Begin
    If (obj as TLabel).Caption = Label1.Name Then Begin
      Edit1.Text := 'Leave';
    End;
  End;
end;

Panel in der Titelleiste

Zeichnen eines farbigen Panels in der Titelleiste.

Zum Zeichnen des tiefergelegten Rechtecks wird eine Procedure benutzt:

Wenn die Procedure in einer Unit leigt, dann ist die Variable für die Form notwendig. Sonst ist nicht bekannt, wo das Rechteck gezeichnet werden soll. Liegt die Procedure in der Hauptform, dann kann die Variable ff:TForm weggelassen werden.

Procedure PaintRectangle(ff:TForm;x1,y1,dx,dy,Color:Integer);
Var hOldBrush: hBrush; dc:hDC;
Begin
  dc := Windows.GetWindowDC(ff.Handle);
  Try
    // Inhalt
    hOldBrush := SelectObject(dc,CreateSolidBrush(Color));
    PatBlt(dc,x1,y1,dx,dy,PatCopy);
    DeleteObject(SelectObject(dc,hOldBrush));
    // Rahmen
    hOldBrush := SelectObject(dc,CreateSolidBrush(clWhite));
    PatBlt(dc,x1,y1+13,dx,1,PatCopy);
    PatBlt(dc,x1+dx,y1,1,dy,PatCopy);
    DeleteObject(SelectObject(dc,hOldBrush));
    hOldBrush := SelectObject(dc,CreateSolidBrush(clGray));
    PatBlt(dc,x1,y1,dx,1,PatCopy);
    PatBlt(dc,x1,y1,1,dy,PatCopy);
    DeleteObject(SelectObject(dc,hOldBrush));
  Finally
    // Wichtig !
    Windows.ReleaseDC(ff.Handle,dc);
  End;
End;

Wenn die Form den Focus verliert oder wiederbekommt, dann wird die Titelleiste immer neu gezeichnet, d.h. das Rechteck verschwindet. Um dies zu verhindern muß das Ereignis WMNCActivate installiert werden.

unit CocoTestUnit;

interface

uses
  ...

type
  TMainForm = class(TForm)
    ...
  private
    { Private-Deklarationen }
    procedure WMNCActivate(var Msg: TMessage); message WM_NCActivate;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TMainForm;
  AlertColor: Integer = clGreen;

implementation

procedure TMainForm.WMNCActivate(var Msg: TMessage);
begin
  inherited;
  PaintRectangle(Form1,Width-140,6,80,14,AlertColor);
end;

...

End.

Die Farbe des Rechtecks sollte dazu in einer globalen Variablen liegen.

Wenn die Größe der Hauptform geändert werden soll, dann wird kein Activate Ereignis ausgelöst, aber die Titelleiste wird neu gezeichnet. Damit das Rechteck trotzdem zu sehen ist, muß die Procedure im OnResize Ereignis aufgerufen werden:

procedure TMainForm.FormResize(Sender: TObject);
begin
  PaintRectangle(Form1,Width-140,6,80,14,AlertColor);
end;

Paradox Datenbank mit Passwort schützen

Diese Routine ändert das Masterpaßwort bzw. legt es an oder löscht es. AFlag bestimmt, ob es ein Paßwort geben soll oder nicht. Die Table muß dabei exclusiv geöffnet sein.

Procedure ChangeMasterPassword(Tbl: TTable; const APassword:String; AFlag:Boolean);
Var
  hDb: hDbiDb;
  TblDesc: CRTblDesc;
  szDir : Array[0..dbiMaxNameLen] of Char;
Begin
  Check(DbiGetDirectory(Tbl.DBHandle,False,szDir));
  Try
    FillChar(TblDesc,sizeof(CRTblDesc), #0);
    Tbl.DisableControls;
    Tbl.Close;
    Check(DbiOpenDatabase(nil,nil,dbiReadWrite,dbiOpenExcl,nil,0,nil,nil,hDb));
    Check(DbiSetDirectory(hDb,szDir));
    TblDesc.bProtected := AFlag;
    if AFlag then StrPCopy(TblDesc.szPassword,APassword);
    StrPCopy(TblDesc.szTblName,Tbl.TableName);
    StrCopy(TblDesc.szTblType,szParadox);
    Check(DbiDoRestructure(hDb,1,@TblDesc,nil,nil,nil,false));
  Finally
    Check(DbiCloseDatabase(hDb));
    Tbl.EnableControls;
    Tbl.Open;
  End;
End;

Path eines BDE Alias besorgen

Holt den Path eines Alais aus der BDE.

Function GetAliasPath(fAlias:String):String;
var Desc: DBDesc;
begin
  Result := '';
  If DbiGetDatabaseDesc(PChar(fAlias),@Desc) = DBIERR_NONE Then Begin
    Result := StrPas(Desc.szPhyName) + '\';
  End Else Begin
    If DbiInit(nil) = DBIERR_NONE Then Begin
      DbiGetDatabaseDesc(PChar(fAlias),@Desc);
      Result := StrPas(Desc.szPhyName) + '\';
    End;
  End;
end;

Achtung: uses DBITypes; wird benötigt.

Portzugriffe

Der Port Befehl steht in der 32-Bit-Entwickluungsumgebung nicht mehr zur Verfügung und muß deshalb durch eine Assembler Routine simuliert werden:

Function InPort(PortAddr:Word):Byte;
Assembler; StdCall;
asm
  mov dx,PortAddr
  in al,dx
end;

Procedure OutPort(PortAddr:Word;DataByte:Byte);
Assembler; StdCall;
asm
  mov al,DataByte
  mov dx,PortAddr
  out dx,al
end;

Bei Windows NT darf nur der Micro Kernel auf die Hardware zugreifen.

Positionsänderungen von Fenstern

Auf alles können Sie bei Delphi-Fenstern reagieren. Auf Größenänderung, auf jede Tasten- oder Mausbewegung. Einzig wenn ein Fenster verschoben wird, bietet Ihnen Delphi keinerlei Informationen an. Dem helfen Sie ab, indem Sie einen eigenen Message-Handler einrichten. Deklarieren Sie dazu im Abschnitt Public der Typdefinition des Fensters eine Methode, die auf das WindowsWM_MOVE-Ereignis reagiert:

public
{ Public-Deklarationen }
procedure WMMove(var M: TWMMove); message wm_Move;

// Den zugehörigen Code definierst Du dann im
// Implementation-Abschnitt:

procedure TForm1.WMMove(var M: TWMMove);
Begin
  Caption:='Aktuelle Position: (' + IntToStr(Left) + ',' + IntToStr(Top)+')';
  { Als Beispiel beepen lassen }
  MessageBeep($FFFF);
End;

Diese Prozedur wird automatisch aufgerufen, wenn das Fenster verschoben wird. Sie stellt somit eine sinnvolle Ergänzung zu OnResize dar.

Power Funktion

a^b := Exp(b * ln(a))

Printer Canvas Size

Ein TImage so ausdrucken, daß es auf die Seite paßt.

var GRect : TRect;
    IRatioDif : real;

{First calculate the ration of the height to width of bitmap}

  IRatioDif := Image1.Picture.Height / Image1.Picture.Width;

{Then get the various sizes of the printer canvas}

  GRect.Top := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
  GRect.Left := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
  GRect.Right := Printer.PageWidth - GRect.Left;
  GRect.Bottom := trunc(Printer.PageHeight * IRatioDif) - GRect.Top;

{Then you can start printing}

  with Printer do begin
    BeginDoc;

    {Use StretchDraw to strech the image to the size specified by GRect}

    Canvas.StretchDraw(GRect, Image1.Picture.Graphic);
    EndDoc;
  end;

Programm mit einer Extension verknüpfen

Ich habe ein Delphi-Programm, daß für bestimmte Dateien zuständig sein soll (*.xyz). Wie bringe ich jetzt Windows am einfachsten bei, daß bei einem Doppelklick automatisch mein Programm aufgerufen werden soll ?

Diese Funktion RegistriereAnwendung für 32Bit-Windows von Edmund Matzke nimmt alle erforderlichen Einträge in der Windows-Registrierdatenbank vor.

uses Registry;

function RegistriereAnwendung(extension,
                              typename,
                              commandKey,
                              command: PChar): boolean;
var key: HKey;
begin
  Result := false;
  if RegCreateKey(HKEY_CLASSES_ROOT, extension, key) = ERROR_SUCCESS then begin
    if RegSetValue(key, nil, REG_SZ, typename, 0) = ERROR_SUCCESS then begin
      RegCloseKey(key);
      if RegCreateKey(HKEY_CLASSES_ROOT, commandKey, key) = ERROR_SUCCESS then begin
        if RegSetValue(key, nil, REG_SZ, command, 0) = ERROR_SUCCESS then begin
          RegCloseKey(key);
          Result := true; // hat geklappt
        end
        else begin
          RegCloseKey(key);
          RegDeleteKey(HKEY_CLASSES_ROOT, extension);
        end;
      end
      else
        RegDeleteKey(HKEY_CLASSES_ROOT, extension);
    end
    else begin
      RegCloseKey(key);
      RegDeleteKey(HKEY_CLASSES_ROOT, extension);
    end;
  end;
end;

Und so ruft man die Funktionen auf:

RegistriereAnwendung('.xyz','MeinProggy','MeinProggy\DefaultIcon',PChar(Application.ExeName + ',0'));
yz', Application.ExeName);

Programm starten beim Windows Start, einmal und immer

Beim Start von Windows kann ein Programm immer ausgeführt werden, durch einen Eintrag in die Registry:

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run

Soll das Programm nur einmal gestartet werden und beim nächsten Start von Windows nicht mehr, dann muß der Eintrag hier stattfinden:

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce

Programm vor dem Taskmanager verstecken

Um ein Programm auch im Taskmanager zu verstecken (der mit Strg+Alt+Entf aufgerufen wird), benutzt man die Funktion RegisterServiceProcess, diese Funktionen stehen allerdings unter Windows NT nicht zur Verfügung:

function RegisterServiceProcess(dwProcessID, dwType: DWord): DWord;stdcall;

function RegisterServiceProcess; external 'KERNEL32.DLL' name 'RegisterServiceProcess';

RegisterServiceProcess(0,1); //zum verstecken!
RegisterServiceProcess(0,0); //zum anzeigen !

Rechtsbündiger Menü Eintrag

procedure TDefineStationMenu.FormCreate(Sender: TObject);
begin
  ModifyMenu(MainMenu1.Handle,4,mf_ByPosition or mf_Popup or mf_Help,Help1.Handle,'&Help');
end;

Die 4 bezeichnet die Position des am weitesten Rechts stehenden Menüeintrages. Die Zählung beginnt bei 0.

Siehe Win32.hlp

Rechtsbündiger Text im StringGrid

Der Text in einem Stringgrid wird Standardmäßig linkbündig ausgegeben. Mit dieser Routine, die im 'DrawCell' Event des StringGrids liegt, kann der Text auch rechtsbündig ausgegeben werden. Um Jede Spalte einzeln zu definieren werden die 32 Bit der Tag-Variablen als Speicherzelle benutzt. Bit = 0 = linksbündig und Bit = 1 = rechtsbündig. Dies erlaubt jedoch nur die Definition der ersten 32 Spalten des StringGrids. Sind mehr Spalten erforderlich, dann muß entweder eine globale Variable definiert werden, oder die Information kann in der Hint-Eigenschaft versteckt werden. Die einzelnen Aligns werden durch die Funktion 'SetColAlign' gesetzt. Wird eine Spalte > 31 angegeben, dann werden alle Aligns auf linksbündig gesetzt.

// Grid: Stringgrid Komponente
// Col: 0..31
// TextAlign: 'l' = Linksbündig = Bit ist 0 in Grid.Tag
// 'r' = Rechtsbündig = Bit ist 1 in Grid.Tag
Procedure SetColAlign(Grid:TStringGrid;Col:Integer;TextAlign:String);
Var Shifter: dWord;
Begin
  If Col <= 31 Then Begin
    Shifter := 1;
    If Col > 0 Then Shifter := Shifter shl Col;
    If UpperCase(TextAlign) = 'L' Then Begin
      Shifter := not Shifter;
      Grid.Tag := Grid.Tag and Shifter;
    End Else Begin
      Grid.Tag := Grid.Tag or Shifter;
    End;
  End Else Begin
    Grid.Tag := 0;
  End;
End;

procedure TForm1.Grid1DrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
var OldAlign: Word; Shifter: dWord;
begin
  If Col <= 31 Then Begin
    Shifter := 1;
    If Col > 0 Then Shifter := Shifter shl Col;
    If (Grid1.Tag and Shifter) = Shifter Then Begin
      // Text Rechtsbündig ausgeben
      OldAlign := SetTextAlign(Grid1.Canvas.Handle,TA_RIGHT);
      Grid1.Canvas.TextRect(Rect,Rect.Right-2,Rect.Top+2,Grid1.Cells[Col,Row]);
      SetTextAlign(Grid1.Canvas.Handle,OldAlign);
    End Else Begin
      // Text linksbündig ausgeben
      Grid1.Canvas.TextRect(Rect,Rect.Left+2,Rect.Top+2,Grid1.Cells[Col,Row]);
    End;
  End;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Grid1.Cells[1,0] := 'a';
  Grid1.Cells[2,0] := 'b';
  Grid1.Cells[3,0] := 'c';
  Grid1.Cells[0,1] := '1';
  Grid1.Cells[0,2] := '2';
  Grid1.Cells[0,3] := '3';

  Grid1.Cells[1,1] := 'a1';
  Grid1.Cells[2,1] := 'b1';
  Grid1.Cells[3,1] := 'c1';
  Grid1.Cells[1,2] := 'a2';
  Grid1.Cells[2,2] := 'b2';
  Grid1.Cells[3,2] := 'c2';
  Grid1.Cells[1,3] := 'a3';
  Grid1.Cells[2,3] := 'b3';
  Grid1.Cells[3,3] := 'c3';

  Grid1.Tag := 0;
  SetColAlign(Grid1,0,'r');
  SetColAlign(Grid1,1,'l');
  SetColAlign(Grid1,2,'r');
  SetColAlign(Grid1,3,'l');
end;

Rechtsbündiger Text in TEdit

TEdit1 = class(TEdit)
  public
    procedure CreateParams(var Params: TCreateParams); Override;
  end;

procedure TEdit1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT;
end;

Gilt nur für Komponenten.

Registry Einträge lesen und schreiben

var Reg: TRegistry;

Begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_Local_Machine;
    Reg.OpenKey('/ein/Beispiel',False); // Schlüssel öffnen
    Result := Reg.ReadString('Wert'); // Wert lesen
    Result := Reg.WriteString('Wert','Hallo'); // Wert Schreiben
  Finally
    Reg.Free; // Freigeben
  End;
End;

Analog zur Funktion ReadString gibt es auch ReadBool, ReadInteger etc. und auch WriteString, WriteBool etc.

Um diese Routine zu benutzen, muß die Unit Registry in Uses stehen.

Uses Registry,...;

Runder SplashScreen

37. Round splash screens

Q:

A while ago I saw some emails about round/different splashscreens. I saved this somewhere and now I can't find it.

A:

Also Neil Rubenking author of Delphi for Dummies and other good books posted this one one compuserve. It is donut shaped with a curved title bar and you can see and click on other programs through the hole! Create a new project and save the main unit so its name is RGNU.PAS.

Paste in the following:

unit rgnu;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, Menus;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
    rTitleBar : THandle;
    Center : TPoint;
    CapY : Integer;
    Circum : Double;
    SB1 : TSpeedButton;
    RL, RR : Double;
    procedure TitleBar(Act : Boolean);
    procedure WMNCHITTEST(var Msg: TWMNCHitTest);
      message WM_NCHITTEST;
    procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE);
      message WM_NCACTIVATE;
    procedure WMSetText(var Msg: TWMSetText);
      message WM_SETTEXT;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

CONST
  TitlColors : ARRAY[Boolean] OF TColor =
    (clInactiveCaption, clActiveCaption);
  TxtColors : ARRAY[Boolean] OF TColor =
    (clInactiveCaptionText, clCaptionText);

procedure TForm1.FormCreate(Sender: TObject);
VAR
  rTemp, rTemp2 : THandle;
  Vertices : ARRAY[0..2] OF TPoint;
  X, Y : INteger;
begin
  Caption := 'OOOH! Doughnuts!';
  BorderStyle := bsNone; {required}
  IF Width > Height THEN Width := Height
  ELSE Height := Width; {harder to calc if width <> height}
  Center := Point(Width DIV 2, Height DIV 2);
  CapY := GetSystemMetrics(SM_CYCAPTION)+8;
  rTemp := CreateEllipticRgn(0, 0, Width, Height);
  rTemp2 := CreateEllipticRgn((Width DIV 4), (Height DIV 4),
    3*(Width DIV 4), 3*(Height DIV 4));
  CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
  SetWindowRgn(Handle, rTemp, True);
  DeleteObject(rTemp2);
  rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4);
  rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
  CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
  Vertices[0] := Point(0,0);
  Vertices[1] := Point(Width, 0);
  Vertices[2] := Point(Width DIV 2, Height DIV 2);
  rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
  CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
  DeleteObject(rTemp);
  RL := ArcTan(Width / Height);
  RR := -RL + (22 / Center.X);
  X := Center.X-Round((Center.X-1-(CapY DIV 2))*Sin(RR));
  Y := Center.Y-Round((Center.Y-1-(CapY DIV 2))*Cos(RR));
  SB1 := TSpeedButton.Create(Self);
  WITH SB1 DO
    BEGIN
      Parent := Self;
      Left := X;
      Top := Y;
      Width := 14;
      Height := 14;
      OnClick := Button1Click;
      Caption := 'X';
      Font.Style := [fsBold];
    END;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
End;

procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
begin
  Inherited;
  WITH Msg DO
    WITH ScreenToClient(Point(XPos,YPos)) DO
      IF PtInRegion(rTitleBar, X, Y) AND
       (NOT PtInRect(SB1.BoundsRect, Point(X,Y))) THEN
        Result := htCaption;
end;

procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
begin
  Inherited;
  TitleBar(Msg.Active);
end;

procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
  Inherited;
  TitleBar(Active);
end;

procedure TForm1.TitleBar(Act: Boolean);
VAR
  TF : TLogFont;
  R : Double;
  N, X, Y : Integer;
begin
  IF Center.X = 0 THEN Exit;
  WITH Canvas DO
    begin
      Brush.Style := bsSolid;
      Brush.Color := TitlColors[Act];
      PaintRgn(Handle, rTitleBar);
      R := RL;
      Brush.Color := TitlColors[Act];
      Font.Name := 'Arial';
      Font.Size := 12;
      Font.Color := TxtColors[Act];
      Font.Style := [fsBold];
      GetObject(Font.Handle, SizeOf(TLogFont), @TF);
      FOR N := 1 TO Length(Caption) DO
        BEGIN
          X := Center.X-Round((Center.X-6)*Sin(R));
          Y := Center.Y-Round((Center.Y-6)*Cos(R));
          TF.lfEscapement := Round(R * 1800 / pi);
          Font.Handle := CreateFontIndirect(TF);
          TextOut(X, Y, Caption[N]);
          R := R - (((TextWidth(Caption[N]))+2) / Center.X);
          IF R < RR THEN Break;
        END;
      Font.Name := 'MS Sans Serif';
      Font.Size := 8;
      Font.Color := clWindowText;
      Font.Style := [];
    end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  WITH Canvas DO
    BEGIN
      Pen.Color := clBlack;
      Brush.Style := bsClear;
      Pen.Width := 1;
      Pen.Color := clWhite;
      Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
      Arc((Width DIV 4)-1, (Height DIV 4)-1,
        3*(Width DIV 4)+1, 3*(Height DIV 4)+1, 0, Height, Width, 0);
      Pen.Color := clBlack;
      Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
      Arc((Width DIV 4)-1, (Height DIV 4)-1,
        3*(Width DIV 4)+1, 3*(Height DIV 4)+1, Width, 0, 0, Height);
      TitleBar(Active);
    END;
end;

end.

Runtime Errors

Wandelt einen Error Code in einen erklärenden String um.

Function ErrMeaning(ResultCode:Integer):String;
Const
  NumOfEntries = 108;
Type
  ErrorEntry = Record
    Code: Integer;
    Meaning: String;
  End;
  ErrorMeaningsArray = Array [1..NumOfEntries] of ErrorEntry;
Const
   MeaningsArray: ErrorMeaningsArray =
{DOS errors}
  ((Code: 1; Meaning: 'Invalid DOS function number'),
   (Code: 2; Meaning: 'File not found'),
   (Code: 3; Meaning: 'Path not found'),
   (Code: 4; Meaning: 'Too many open files'),
   (Code: 5; Meaning: 'File access denied'),
   (Code: 6; Meaning: 'Invalid file handle'),
   (Code: 7; Meaning: 'Memory control blocks destroyed'),
   (Code: 8; Meaning: 'Insufficient DOS memory'),
   (Code: 9; Meaning: 'Invalid memory block address'),
   (Code: 10; Meaning: 'Invalid DOS environment'),
   (Code: 11; Meaning: 'Invalid format (DOS)'),
   (Code: 12; Meaning: 'Invalid file access code'),
   (Code: 13; Meaning: 'Invalid data (DOS)'),
   (Code: 15; Meaning: 'Invalid drive number'),
   (Code: 16; Meaning: 'Cannot remove current directory'),
   (Code: 17; Meaning: 'Cannot rename across drives'),
   (Code: 18; Meaning: 'No more files'),
   (Code: 19; Meaning: 'Disk write-protected'),
   (Code: 20; Meaning: 'Unknown unit (DOS)'),
   (Code: 21; Meaning: 'Drive not ready'),
   (Code: 22; Meaning: 'Unknown DOS command'),
   (Code: 23; Meaning: 'CRC error'),
   (Code: 24; Meaning: 'Bad request structure length'),
   (Code: 25; Meaning: 'Seek error'),
   (Code: 26; Meaning: 'Unknown media type'),
   (Code: 27; Meaning: 'Disk sector not found'),
   (Code: 28; Meaning: 'Out of paper'),
   (Code: 29; Meaning: 'Write fault'),
   (Code: 30; Meaning: 'Read fault'),
   (Code: 31; Meaning: 'General failure'),
   (Code: 32; Meaning: 'File sharing violation'),
   (Code: 33; Meaning: 'File lock violation'),
   (Code: 34; Meaning: 'Invalid disk change'),
   (Code: 35; Meaning: 'File control block unavailable'),
   (Code: 36; Meaning: 'Sharing buffer overflow'),
   (Code: 37; Meaning: 'Code page mismatch'),
   (Code: 38; Meaning: 'Error handling EOF'),
   (Code: 39; Meaning: 'Handle disk full'),
   (Code: 50; Meaning: 'Network request not supported'),
   (Code: 51; Meaning: 'Remote computer not listening'),
   (Code: 52; Meaning: 'Duplicate name on network'),
   (Code: 53; Meaning: 'Network name not found'),
   (Code: 54; Meaning: 'Network busy'),
   (Code: 55; Meaning: 'Network device no longer exists'),
   (Code: 56; Meaning: 'NetBIOS command limit exceeded'),
   (Code: 57; Meaning: 'Network adaptor error'),
   (Code: 58; Meaning: 'Incorrect network response'),
   (Code: 59; Meaning: 'Unexpected network error'),
   (Code: 60; Meaning: 'Incompatible remote adaptor'),
   (Code: 61; Meaning: 'Print queue full'),
   (Code: 62; Meaning: 'Not enough space for print file'),
   (Code: 63; Meaning: 'Print file deleted'),
   (Code: 64; Meaning: 'Network name deleted'),
   (Code: 65; Meaning: 'Access denied'),
   (Code: 66; Meaning: 'Network device type incorrect'),
   (Code: 67; Meaning: 'Network name not found'),
   (Code: 68; Meaning: 'Network name limit exceeded'),
   (Code: 69; Meaning: 'NetBIOS session limit exceeded'),
   (Code: 70; Meaning: 'Temporarily paused'),
   (Code: 71; Meaning: 'Network request not accepted'),
   (Code: 72; Meaning: 'Print/disk redirection paused'),
   (Code: 80; Meaning: 'File already exists'),
   (Code: 82; Meaning: 'Cannot make directory entry'),
   (Code: 83; Meaning: 'Fail on interrupt 24'),
   (Code: 84; Meaning: 'Too many redirections'),
   (Code: 85; Meaning: 'Duplicate redirection'),
   (Code: 86; Meaning: 'Invalid password'),
   (Code: 87; Meaning: 'Invalid parameter'),
   (Code: 88; Meaning: 'Network data fault'),
{I/O errors}
   (Code: 100; Meaning: 'Disk read error'),
   (Code: 101; Meaning: 'Disk write error'),
   (Code: 102; Meaning: 'File not assigned'),
   (Code: 103; Meaning: 'File not open'),
   (Code: 104; Meaning: 'File not open for input'),
   (Code: 105; Meaning: 'File not open for output'),
   (Code: 106; Meaning: 'Invalid numeric format'),
{Critical errors (Real or protected mode only)}
   (Code: 150; Meaning: 'Disk is write protected'),
   (Code: 151; Meaning: 'Unknown unit'),
   (Code: 152; Meaning: 'Drive not ready'),
   (Code: 153; Meaning: 'Unknown DOS command'),
   (Code: 154; Meaning: 'CRC error in data'),
   (Code: 155; Meaning: 'Bad drive request struct length'),
   (Code: 156; Meaning: 'Disk seek error'),
   (Code: 157; Meaning: 'Unknown media type'),
   (Code: 158; Meaning: 'Sector not found'),
   (Code: 159; Meaning: 'Printer out of paper'),
   (Code: 160; Meaning: 'Device write fault'),
   (Code: 161; Meaning: 'Device read fault'),
   (Code: 162; Meaning: 'Hardware failure'),
{Fatal errors}
   (Code: 200; Meaning: 'Division by zero'),
   (Code: 201; Meaning: 'Range check error'),
   (Code: 202; Meaning: 'Stack overflow error'),
   (Code: 203; Meaning: 'Heap overflow error'),
   (Code: 204; Meaning: 'Invalid pointer operation'),
   (Code: 205; Meaning: 'Floating point overflow'),
   (Code: 206; Meaning: 'Floating point underflow'),
   (Code: 207; Meaning: 'Invalid floating pt. operation'),
   (Code: 208; Meaning: 'Overlay manager not installed'),
   (Code: 209; Meaning: 'Overlay file read error'),
   (Code: 210; Meaning: 'Object not initialised'),
   (Code: 211; Meaning: 'Call to abstract method'),
   (Code: 212; Meaning: 'Stream registration error'),
   (Code: 213; Meaning: 'TCollection index out of range'),
   (Code: 214; Meaning: 'TCollection overflow error'),
   (Code: 215; Meaning: 'Arithmetic overflow error'),
   (Code: 216; Meaning: 'General Protection Fault'),
   (Code: 217; Meaning: 'Unhandled exception'),
   (Code: 219; Meaning: 'Invalid typecast'));
var
  Low, High, Mid, Diff: Integer;
begin
  Low := 1;
  High := NumOfEntries;
  While Low <= High do Begin
    Mid := (Low + High) div 2;
    Diff := MeaningsArray[Mid].Code - ResultCode;
    If Diff < 0 Then Low := Mid + 1 Else Begin
      If Diff > 0 Then High := Mid - 1 Else Begin {gefunden}
        ErrMeaning := MeaningsArray[Mid].Meaning;
        Exit; {ErrMeaning}
      End;
    End;
  End;
  ErrMeaning := 'Error ' + IntToStr(ResultCode) + ' (meaning unknown)';
end;

Screen Handle

Using the standard Windows API:

use hWnd := GetDesktopWindow to get the Handle to the 'desktop' ;

use hDC := GetDC (hWnd) to get the HDC (handle to a display context) ;

be sure to free the (release the handle of) hDC when you're done with it.

As a TCanvas.Handle is the HDC, you can use regular WinAPI to draw to it etc., or it may be possible to supply the HDC to the Handle property of a TCanvas you create.

[Chris Means, cmeans@intfar.com]

A:

In D1 (should work for D2 also) try this:

I put a TPaintBox object and a TButton on my form.

Procedure TForm1.Button1Click(Sender: TObject);
Var DeskTop : TCanvas ;
Begin
  DeskTop := TCanvas.Create ;
  Try
    With DeskTop do Handle := GetWindowDC (GetDesktopWindow) ;
    With PaintBox1.Canvas do Begin
      CopyRect(Rect(0,0,200,200),DeskTop,Rect(0,0,200,200))
    End;
  Finally
    DeskTop.Free
  End
End;

This will copy the top left area of the desktop, to the top left area of your TPaintBox.

Seriennummer der Festplatte

Seriennummer der Festplatte besorgen:

Function GetDriveSerialNumber(Drive:String):DWord;
Var
  SerialNum,a,b: DWord;
  Buffer: Array [0..255] of Char;
Begin
  If
GetVolumeInformation(PChar(Drive),Buffer,SizeOf(Buffer),@SerialNum,a,b,nil,0) Then Result := SerialNum Else Result := -1;
End;


procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := IntToHex(GetDriveSerialNumber('c:\'),8);
end;

Sound aus dem PC Lautsprecher

Routine OutPort siehe Eintrag 'Portzugriffe'.

Procedure DoSound(Hz:Word);
Var tmp:Byte;
begin
  OutPort($43,182);
  Tmp := InPort($61);
  OutPort($61,Tmp or 3);
  OutPort($42,Lo(1193180 div Hz));
  OutPort($42,Hi(1193180 div Hz));
end;

Procedure DoNoSound;
Var tmp:Byte;
begin
  OutPort($43,182);
  Tmp := InPort($61);
  OutPort($61,Tmp or 3);
end;

Sound aus Resource Datei

1. Voraussetzungen

Sounddatei mit dem Namen: GetMeas.wav

2. Sound Datei in eine Resource Datei bringen

Mit einem Texteditor folgende Datei erstellen:

// WAVES

//

WAVE1 WAVE PRELOAD FIXED PURE "GetMeas.wav"

und unter DoSound.rc speichern. Anschliessend muß aus dieser Datei mit dem Resource-Compiler eine *.res Datei gemacht werden. Der Resource-Compiler brcc32.exe ist ein DOS Programm und liegt im '..\Delphi 3\Bin' Directory. Er muß in der Regel mit seinem kompletten Path aufgerufen werden. Das Ergument muß auch den kompletten Path enthalten. Am besten erzeugt man sich im '..\Delphi 3\Bin' Directory eine Verknüpfung und kopiert sie in sein eigenes Directory. Danach gibt man unter Eigenschaften den kompletten Path als Argument an, z.B. so:

"C:\Programme\Borland\Delphi 3\Bin\BRCC32.EXE" D:\Delphi\Projekte\SoundTest\DoSound.rc

Nach dem Start der Verknüpfung im eigenen Ordner wird die Datei DoSound.RES erzeugt.

3. Sound Datei ins Delphi Programm einbinden

Für dieses Beispiel (getrenntes Laden und Abspielen) sind zwei lokale Variable erforderlich, und die Unit mmSystem. Außerdem wird noch eine Variable für den späteren Sound Zugriff benutzt.

Hinweis: Wichtig ist, das vor dem Abspielen der Sounds der Resource im Speicher gesperrt wird.

  .
  .
  implementation
  
  uses mmSystem;
  
  {$R Sound.res}
  {$R *.DFM}
  
  Var ResHnd: THandle;
      SndPnt: Pointer;
      SndOk: Boolean;
  .
  .

Achtung: der Resource Name darf nicht identisch sein mit dem Projekt Namen, sonst gibt es beim kompilieren die Fehlermeldung 'Duplicate recourses'.

4. Sound Datei beim Programmstart Laden

procedure TForm1.FormCreate(Sender: TObject);
Var Res: THandle;
begin
  .
  .
  // Sound Ressource Laden
  SndOk := false;
  Res := FindResource(HInstance,'WAVE1','WAVE');
  If Res <> 0 Then Begin
    ResHnd := LoadResource(HInstance,Res);
    If ResHnd <> 0 Then Begin
      SndPnt := LockResource(ResHnd);
      SndOk := true;
    End;
  End;
  .
  .
end;

5. Sound Datei Abspielen

Wichtig ist die Option SND_MEMORY.

Procedure TForm1.PlaySound;
Begin
  .
  .
  If SoundOk Then SndPlaySound(SndPnt,SND_ASYNC or SND_MEMORY);
  .
  .
End;

Soll der Sound nicht ständig im Speicher sein, dann ist folgende Alternative zu benutzen:

Procedure TForm1.PlaySound;
Var Res,ResHnd:THandle;
Begin
  .
  .
  Res := FindResource(HInstance,'WAVE1','WAVE');
  If Res <> 0 Then Begin
    ResHnd := LoadResource(HInstance,Res);
    If ResHnd <> 0 Then Begin
      SndPlaySound(LockResource(ResHnd),SND_ASYNC or SND_MEMORY);
      UnlockResource(ResHnd);
      FreeResource(ResHnd);
    End;
  End;
  .
  .
End;

Im Implementationsteil ist dann nur dies hier notwendig:
  uses mmSystem;
  
  {$R Sound.res}


6. Sound Datei beim Programmende Entfernen

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  .
  .
  If SndOk Then Begin
    UnlockResource(ResHnd);
    FreeResource(ResHnd);
  End;
  .
  .
end;

Spalten in TTable vertauschen

I need to swap two columns at run time. For some reason, when I use the

assign method, an extra column is created. Does anyone have a better way

to swap columns in a grid?

A:

table1.fieldbyName('SomeField').index := 0;

table2.fieldbyName('OtherField').index := 1;

Speicher zwischen A000 und FFFF lesen

I just discovered your Delphi page and read the tips section with interest: a lot of usefull stuff.

Some time ago I posted a question on comp.lang.pascal (and got an answer) that I think may fit in: how to access the memory between A000-FFFF.

The answer below was posted by Jeremiah Gilbert, I added the B800 and the D000 descriptors, which he forgot.

{ SEGS.PAS }
{ Segment support unit for Delphi or TPW
Originally from: jgilbert@nyx10.cs.du.edu (Jeremiah Gilbert)
Newsgroups: comp.lang.pascal
Edited by: pybe@cpo.tn.tudelft.nl (Pybe Faber)

  When addressing these functions create a pointer this way:
  ptr(ofs(SegXXXX), Offset);
  unlike DOS's:
  ptr(SegXXXX, Offset);
}

{$I-,D-,S-,R-,Q-,G-,N-,E-,X+}

unit segs;

interface

function Seg0040: word;
function SegA000: word;
function SegB000: word;
function SegB800: word;
function SegC000: word;
function SegD000: word;
function SegE000: word;
function SegF000: word;

implementation

{ Segment declarations for Delphi from Win Kernel }
function Seg0040: word; external 'KERNEL' index 193;
function SegA000: word; external 'KERNEL' index 174;
function SegB000: word; external 'KERNEL' index $B5;
function SegB800: word; external 'KERNEL' index 182;
function SegC000: word; external 'KERNEL' index 195;
function SegD000: word; external 'KERNEL' index $B3;
function SegE000: word; external 'KERNEL' index 190;
function SegF000: word; external 'KERNEL' index 194;
end.

Sprachen ID

Die Sprach-ID gibt an, welche Codeseite auf dem System des Benutzers aktiviert werden muß, damit die Anwendung ausgeführt werden kann. Sie bestimmt also, in welcher Sprache die Anwendung angezeigt wird. Folgende Sprachen werden unterstützt.

Konstante Sprache

$0401 1025 Arabisch
$0402 1026 Bulgarisch
$0403 1027 Katalanisch
$0404 1028 Chinesisch (Traditionell)
$0405 1029 Tschechisch
$0406 1030 Dänisch
$0407 1031 Deutsch
$0408 1032 Griechisch
$0409 1033 Englisch (USA)
$040A 1034 Spanisch (Kastilianisch)
$040B 1035 Finnisch
$040C 1036 Französisch
$040D 1037 Hebräisch
$040E 1038 Ungarisch
$040F 1039 Isländisch
$0410 1040 Italienisch
$0411 1041 Japanisch
$0412 1042 Koreanisch
$0413 1043 Holländisch
$0414 1044 Norwegisch (Bokml)
$0415 1045 Polnisch
$0416 1046 Portugiesisch (Brasilien)
$0417 1047 Rätoromanisch
$0418 1048 Rumänisch
$0419 1049 Russisch
$041A 1050 Serbokroatisch (Latein)
$041B 1051 Slowakisch
$041C 1052 Albanisch
$041D 1053 Schwedisch
$041E 1054 Thailändisch
$041F 1055 Türkisch
$0420 1056 Urdu
$0421 1057 Bahasa
$0804 2052 Chinesisch (Vereinfacht)
$0807 2055 Deutsch (Schweiz)
$0809 2057 Englisch (UK)
$080A 2058 Spanisch (Mexiko)
$080C 2060 Französisch (Belgien)
$0810 2064 Italienisch (Schweiz)
$0813 2067 Flämisch
$0814 2068 Norwegisch (Nynorsk)
$0816 2070 Portugiesisch
$081A 2074 Serbokroatisch (Kyrillisch)
$0C0C 3084 Französisch (Kanada)
$100C 4108 Französisch (Schweiz)

Start Button verstecken

Procedure HideStartbutton(visi:boolean);
Var Tray,Child: hWnd;
    C: Array[0..127] of Char;
    S: String;
Begin
  Tray := FindWindow('Shell_TrayWnd',NIL);
  Child := GetWindow(Tray,GW_CHILD);
  While Child <> 0 do Begin
    If GetClassName(Child, C, SizeOf(C)) > 0 Then Begin
      S := StrPAS(C);
      If UpperCase(S) = 'BUTTON' Then Begin
        If Visi
          Then ShowWindow(Child, 1)
          Else ShowWindow(Child, 0);
      End;
    End;
    Child := GetWindow(Child,GW_HWNDNEXT);
  End;
End;

Statische Variable in Procedure und Function

Funktioniert, wenn die Variable als Konstante deklariert wird. Nach Möglichkeit sollte aber für solche Fälle eine globale Variable genommen werden.

Procedure Test;
Const xxx: Integer = 0;
Begin
  Inc(xxx);
End;

Strg-Alt-Entf verhindern

Task-Manager disablen

SystemParametersInfo(SPI_SCREENSAVERRUNNING,1,Nil,0);

Task-Manager enablen

SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,Nil,0);

Bildschirmschoner Status

Var Flag:Word;

SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,@Flag,0);

Flag = 0 = ausgeschaltet

Flag = 1 = eingeschaltet

Hinweis:

War der Bildschirmschoner ausgeschaltet, dann hat das Einschalten per Software keine Wirkung, weil keine Screen-Saver-Datei definiert wurde.

String aus fremden Fenster lesen

Wie man per WM_GETTEXT einen String aus einem fremden Fenster bekommt.

var
  szBuffer: array[0..256] of char;
begin
  SendMessage(Edit1.Handle, WM_GETTEXT, SizeOf(szBuffer),Integer(@szBuffer));
  Edit2.Text := szBuffer;
end;

String Transport zwischen Programmen

Zwischen zwei Programmen (APP1 und APP2) können über das Windows Message System Strings ausgetauscht werden, wenn man die Verbindung zu einem Fenster aufbaut.

APP1 soll der Sender und APP2 der Empfänger sein:

APP1

- einfügen einer Komponente die Text aufnehmen kann und über ein OnChange Event verfügt, z.B. ein TEdit. Die Komponente kann zur Laufzeit erzeugt werden oder man schiebt einfach ein TEdit auf die Form. Sie sollte aber auf jeden Fall unsichtbar gemacht werden.

APP2 muß jetzt das Handle der TEdit Komponente mitgeteilt werden, denn das Handle ist für APP2 notwendig weil über das Windows Message System ein Text an ein Handle gesendet werden kann.

Das OnChange-Event von TEdit muß gefüllt werden, damit APP1 mitbekommt, das ein String an ihn gesendet wurde und er entsprechend darauf reagieren kann. Deswegen dürfen auch nur Komponenten mit einem OnChange-Event benutzt werden.

APP2

Hier das Beispiel für den Empfänger APP1:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private-Deklarationen }
    procedure ReceiverChange(Sender: TObject);
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

Var Receiver: TEdit; // TEdit erfordert Unit StdCtrls
Var App2Hnd: HWnd; // Handle von APP2

procedure TForm1.FormCreate(Sender: TObject);
begin
  // TEdit Komponente erzeugen
  Receiver := TEdit.Create(Self); // Komponente erzeugen
  Receiver.OnChange := ReceiverChange; // OnChange Ereignis installieren
  Receiver.Visible := false; // Sonst taucht er auf der Form auf
  Receiver.Parent := Self; // Wichtig, Verbindung zur übergeordneten Komponente herstellen
  // Handle an Programm APP2 senden
  App2Hnd := FindWindow('TForm1','APP Server'); // 'APP Server' ist das was in der Titelzeile von APP2 steht
  If App2Hnd > 0 Then Begin
    SendMessage(App2Hnd,WM_CHAR,1000,Receiver.Handle);
  End;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  If App2Hnd > 0 Then Begin
    // Programm APP2 mitteilen, das TEdit nicht mehr existiert
    SendMessage(App2Hnd,WM_CHAR,1001,0);
  End;
  Receiver.Free; // Komponente wieder aus dem Speicher entfernen
end;

procedure TForm1.ReceiverChange(Sender: TObject);
begin
  // Der empfangene String liegt in Receiver.Text
  Edit1.Text := REceiver.Text;
end;

end.


Hier das Beispiel für den Sender APP2:

unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    SendButton: TButton;
    SendText: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure SendButtonClick(Sender: TObject);
  private
    { Private-Deklarationen }
    Procedure WMChar(var Message: TWMChar); Message WM_CHAR;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

Var ReceiverHandle: HWnd;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Caption := 'APP Server';
  ReceiverHandle := 0;
end;

// Abfangen von Zeichen, die durch SendMessage(TaskHandle,WM_CHAR,w1,l1)
// an dieses Programm gesendet werden.
// w1 ist ein Word und liegt in Message.CharCode
// l1 ist ein Long und liegt in Message.KeyData
procedure TForm1.WMChar(var Message: TWMChar);
begin
  Case Message.CharCode of
    1000: ReceiverHandle := Message.KeyData;
    1001: ReceiverHandle := 0;
    Else inherited;
  End;
end;

procedure TForm1.SendButtonClick(Sender: TObject);
Var Buffer: array[0..256] of Char;
begin
  If ReceiverHandle > 0 Then Begin
    StrPCopy(Buffer,SendText.Text);
    SendMessage(ReceiverHandle,WM_SETTEXT,SizeOf(Buffer),Integer(@Buffer));
  End;
end;

end.

Suchen Dialog aufrufen

Das funktioniert per DDE-Konversation mit dem Windows-Explorer:

uses DDEMan;

procedure SearchInFolder(Folder:string);
begin
  with TDDEClientConv.Create(Form1) do begin
    ConnectMode := ddeManual;
    ServiceApplication := 'Explorer.exe';
    SetLink('Folders', 'AppProperties');
    OpenLink;
    ExecuteMacro(PChar('[FindFolder(, '+Folder+')]'), true);
    CloseLink;
    Free;
  end;
end;

Aufruf:

SearchFolder('d:');
SearchFolder('c:\Windows');

Synchronisation zweier Scroll Boxes

Mit diesem Trick lassen sich sehr einfach zwei Scroll-Bars synchronisieren, in dem die eine Scroll-Bar die Position der jeweils anderen einstellt.

procedure TMainForm.ScrollBar1Scroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  ScrollBar2.Position:=ScrollPos;
end;

procedure TMainForm.ScrollBar2Scroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  ScrollBar1.Position := ScrollPos;
end;

System Error Message abfangen

Var SaveErrorMode: Word;
.
.
   SaveErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
.
.
   SetErrorMode(SaveErrorMode);
.
.

SEM_FAILCRITICALERRORS critical-error-handler message box wird nicht gezeigt.

SEM_NOGPFAULTERRORBOX general-protection-fault message box wird nicht gezeigt.

SEM_NOOPENFILEERRORBOX file-not-found message box wird nicht gezeigt.

---------------------------------
constructor TVines.Create(AOwner: TComponent);
var
  LastState : Word;
  ThePtr : Pointer;
begin
  inherited Create(AOwner);
  {Suppress the 'file not found' system error box from Windows}
  LastState := SetErrorMode(sem_NoOpenFileErrorBox);
  {Load the vines API DLL library}
  hVinesDLL := LoadLibrary('Z:\VNSAPI.DLL');
  {Restore the windows system error state}
  SetErrorMode(LastState);
  {If the return value from LoadLibrary is greater than the
   constant HINSTANCE_ERROR, then the load was sucessful.}
  VinesAvailable := (hVinesDLL > HINSTANCE_ERROR);
  {Go get a pointer to the address of the VnsGetUserName procedure}
  ThePtr := GetProcAddress(hVinesDLL,'VnsGetUserName');
  {Typecast the pointer as a procedure of type ProcGetUserName}
  VnsGetUserName := ProcGetUserName(ThePtr);
end;
-----------------------------------

Systemfunktionen starten

In der Systemsteuerung werden Programme für unterschiedliche Dienste zur Verfügung gestellt. Sie haben alle die Endung *.cpl und sind in C:\Windows\System zu finden (C:\Winnt\System32 bei Win NT). Sie können alle über die WinExec Funktion gestartet werden:

Function RunCpl(CplName:String):Boolean;
Begin
  Result := WinExec(PChar('rundll32.exe shell32.dll,Control_RunDLL ' + CplName),SW_SHOWNORMAL) > 32;
End;

Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
  RunCpl('Timedate.cpl');
end;

Die Systemeinstellung zur Eingabe von Datum und Uhrzeit wird aufgerufen.

TabStop in einem Memo Feld ändern

Um die Tab Stop Position einer Multiline Komponente (z.B. TMemo) zu ändern, muß man eine EM_SetTabStops Message an die Komponente senden. Wenn der Parameter 'WParam' in 'Message' 1 ist, dann gilt die Einstelleung für alle Tab Stops einer Zeile. Für TMemo muß die Eigenschaft 'WantTabs' auf true stehen.

procedure TForm1.FormCreate(Sender:TObject);
Var TabWidth:Integer
begin
  TabWidth := 50;
  SendMessage(Memo1.Handle,EM_SetTabStops,1,Longint(@TabWidth));
end;

Taskbar-Icon erzeugen und löschen

Mit der Routine Shell_NotifyIcon kann in der Taskbar ein Icon erzeugt, geändert und wieder gelöscht werden. Das zugehörige Icon wird dabei aus einer TImage Komponente geladen. Es sollte darauf geachtet werden, das das Image eine *.ICO und keine *.BMP Datei ist.

Sollen mehrere Icons angelegt werden, dann ist die Variable tbnaStruct als Array in der Hauptform anzulegen und der Index als Parameter an CreateTaskBarIcon() und DeleteTaskBarIcon() zu übergeben. Die verschiedenen Icons sollten dann sinnvollerweise in einer ImageList Komponente gehalten werden.

procedure TForm1.CreateTaskBarIcon(Image:TImage);
var tbnaStruct: TNotifyIconData;
begin
  With tbnaStruct do Begin
    cbSize := SizeOf(TNotifyIconData);
    Wnd := Form1.handle;
    uID := 0;
    uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
    szTip := 'Traybar Tip';
    hIcon := Image.Picture.Icon.Handle;
    uCallbackMessage := WM_MOUSEMOVE;
  End;
  Shell_NotifyIcon(NIM_ADD,@tbnaStruct);
end;

procedure TForm1.ModifyTaskBarIcon(Image:TImage);
var tbnaStruct: TNotifyIconData;
begin
  With tbnaStruct do Begin
    cbSize := SizeOf(TNotifyIconData);
    Wnd := handle;
    uID := 0;
    uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
    hIcon := Image.Picture.Icon.Handle;
    uCallbackMessage := WM_MOUSEMOVE;
  End;
  Shell_NotifyIcon(NIM_MODIFY,@tbnaStruct);
end;

procedure TForm1.DeleteTaskBarIcon;
var tbnaStruct: TNotifyIconData;
begin
  With tbnaStruct do Begin
    cbSize := SizeOf(TNotifyIconData);
    Wnd := handle;
    uID := 0;
  End;
  Shell_NotifyIcon(NIM_DELETE,@tbnaStruct);
end;

Beispiel:
Eine Applikation entfernt sich vom Bildschirm und macht sich nur noch durch ein Icon in der Taskbar kenntlich. Wird auf das Icon ein Doppelklick gemacht, dann erscheint die Applikation wieder auf dem Bildschirm und entfernt das Icon aus der Taskbar. Der Trick dabei ist, das über die TNotifyIconDate Struktur eine Callback Message definiert werden kann. Sie sendet in diesem Beispiel einen Event an die OnMouseMove Routine der Hauptform. In der X-Koordinate kann dann die Mausfunktion abgelesen werden.

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Icon in der Taskbar erzeugen
  CreateTaskBarIcon(Image1);
  // Applikation minimieren
  Application.Minimize;
  // Button aus der Taskleiste entfernen
  ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  // Icon aus der Taskbar entfernen
  DeleteTaskBarIcon;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  // Icon in der Taskbar ändern
  ModifyTaskBarIcon(Image2);
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  If X = WM_LBUTTONDBLCLK Then Begin
    // Icon aus der Taskbar entfernen
    DeleteTaskBarIcon;
    // Applikation wieder auf den Bildschirm holen
    ShowWindow(Application.Handle,SW_RESTORE);
    SendMessage(Application.Handle,WM_SYSCOMMAND,SC_HOTKEY,Application.Handle);
    SendMessage(Application.Handle,WM_SYSCOMMAND,SC_RESTORE,Application.Handle);
  End;
  Case X of
    WM_LBUTTONDOWN:; // Linke Maustaste gedrückt
    WM_LBUTTONUP:; // Linke Maustaste losgelassen
    WM_RBUTTONDOWN:; // Rechte Maustaste gedrückt
    WM_RBUTTONUP:; // Rechte Maustaste losgelassen
    WM_RBUTTONDBLCLK:; // Rechte Maustaste Doppelklick
    WM_MBUTTONDOWN:; // Mittlere Maustaste gedrückt
    WM_MBUTTONUP:; // Mittlere Maustaste losgelassen
    WM_MBUTTONDBLCLK:; // Mittlere Maustaste Doppelklick
  End;
end;

Um diese Routine zu benutzen, muß die Unit ShellAPI in Uses stehen.

Uses ShellAPI,...;

Testen, ob ein bestimmtes Laufwerktyp vorhanden ist

Diese Funktion erstellt eine Stringliste mit allen Laufwerksbuchstaben eines bestimmten Typs und gibt als Result die Anzahl der vorhandenen Laufwerke zurück. Es spielt keine Rolle, ob sich in dem entsprechenden Datenträger ein Medium befindet.

function GetDrives(DriveType:integer;Var DriveList:TStringList):Integer;
Var Drives : Array [1..255] of char;
    LWListe : TStringList;
    i : Integer;
    Len : DWord;
begin
  LWListe := TStringList.Create;
  {Alle Laufwerke ermitteln}
  Len := GetLogicalDriveStrings(255,@Drives);
  For i := 1 to Len-2 do Begin
    If (i mod 4) = 1 Then LWListe.Add(copy(Drives,i,3));
  End;
  {Laufwerke des angegebenen Typs zählen}
  Result := 0;
  DriveList.Clear;
  For i := 0 to LWListe.Count-1 do Begin
    If GetDriveType(PChar(LWListe[i])) = DriveType Then Begin
      Result := Result + 1;
      DriveList.Add(copy(LWListe[i],1,2))
    End;
  end;
  LWListe.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var DrvList: TStringList;
    DrvCnt: Integer;
begin
  DrvList := TStringLIst.Create;
  {Wechselplatten:}
  DrvCnt := GetDrives(DRIVE_REMOVABLE,DrvList);
  {Festplatten:}
  //DrvCnt := GetDrives(DRIVE_FIXED,DrvList);
  {Netzlaufwerke:}
  //DrvCnt := GetDrives(DRIVE_REMOTE,DrvList);
  {CD-ROM:}
  //DrvCnt := GetDrives(DRIVE_CDROM,DrvList);
  {RAM-Disks:}
  //DrvCnt := GetDrives(DRIVE_RAMDISK,DrvList);
  Memo1.Lines := DrvList;
  DrvList.Free;
end;

Antwort:
A:
F:
H:

Text in ein Memo einfügen

Die Einfügeposition wird mit der Eigenschaft SelStart festgelegt. Der einzufügende Text wird der Eigenschaft SelText übergeben.

Mit der Eigenschaft SelLength kann man die Länge des markierten Textes im Memo festlegen. SelLength muß auf Null gesetzt werden, um keinen Text im Memo zu überschreiben:

Memo.SelStart:=Einfuegeposition;
Memo.SelLength:=0;
Memo.SelText:='Einzufügender Text';

Titelzeile ausblenden

Wird die Titelleiste über die Eigenschaft BorderStyle = bsNone entfernt, dann verschwindet auch der ganze Rahmen.

Procedure TForm1.FormCreate(Sender: TObject);
Begin
  SetWindowLong(Handle,GWL_STYLE,GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
  ClientHeight := Height;
  Refresh;
End;


1. Möglichkeit:
TForm.BorderStyle auf bsNone zu setzen. Leider ergibt das ein Formular, das dann gar keine Begrenzung mehr hat. Abhilfe schafft ein
TBevel, dessen Align man auf alClient setzt.

2. Möglichkeit:
Die Methode CreateParams überschreiben, in der der Parameter-Record für die Fenstererzeugung initialisiert wird:

{ Private Deklaration }
procedure CreateParams(var Params : TCreateParams); override;
...
{ Implementation: }
procedure TForm1.CreateParams(var Params : TCreateParams);
begin
  Inherited Createparams(Params);
  with Params do
    Style := (Style or WS_POPUP) and not WS_DLGFRAME;
end;

Diese Kombination hat den Effekt, daß die Titelleiste entfernt wird, der Begrenzungsstil aber den eingestellten Wert behält.

3. Möglichkeit:
In der OnCreate-Methode des Formulars die API-Funktion "SetWindowLong" aufrufen:

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetWindowLong(Handle,GWL_STYLE, GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
  ClientHeight:=Height;
end;

Ton im PC Lautsprecher ausgeben

Diese Assembler-Routinen von Gerd Kayser realisieren die Klangausgabe über direkte Portzugriffe und funktionieren daher nicht unter Windows NT. Die Prozedur "Sound" erzeugt einen Ton mit der Frequenz "Hz", die Prozedur "NoSound" stoppt die Klangausgabe. Die Funktion der Prozeduren wird in diesem Beispiel-Projekt demonstriert.

function InPort(PortAddr:word): byte; assembler; stdcall;
asm
  mov dx,PortAddr
  in al,dx
end;

procedure OutPort(PortAddr: word; Databyte: byte); assembler; stdcall;
asm
  mov al,Databyte
  mov dx,PortAddr
  out dx,al
end;

Procedure Sound(Hz : Word);
var TmpW : Word;
begin
  OutPort($43,182);
  TmpW :=InPort($61);
  OutPort($61,TmpW or 3);
  OutPort($42,lo(1193180 div hz));
  OutPort($42, hi(1193180 div hz));
end;

Procedure NoSound;
var TmpW : Word;
begin
  OutPort($43,182);
  TmpW := InPort($61);
  OutPort($61,TmpW and 3);
end;

Unter Windows NT geht es wesentlich einfacher mit der Beep-Funktion aus der Windows-Unit:

Windows.Beep(Frequenz, Dauer);

Die Frequenz wird in Hertz angegeben und muß zwischen 37 und 32.767 (0x25 bis 0x7FFF) liegen, Die Dauer wird in Millisekunden angegeben. Wenn als Dauer -1 übergeben wird, wird der Ton asynchron so lange ausgegeben, bis die Funktion erneut aufgerufen wird.

Total System Memory

Diese Funktion besorgt den vorhandenen phyikalischen Speicher in Bytes.

Zusätzlich wird der verfügbare virtuelle Speicher in Bytes geliefert.

Function GetTotalMemory(Var TotalVirtualMem:LongInt):LongInt;
Var MemStatus: TMemoryStatus;
Begin
  MemStatus.dwLength := SizeOf(TMemoryStatus);
  GlobalMemoryStatus(MemStatus);
  TotalVirtualMem := MemStatus.dwTotalPageFile;
  Result := MemStatus.dwTotalPhys;
End;

Diese Funktion besorgt den freien phyikalischen Speicher in Bytes.
Zusätzlich wird der freie virtuelle Speicher in Bytes geliefert.

Function GetFreeMemory(Var FreeVirtualMem:LongInt):LongInt;
Var MemStatus: TMemoryStatus;
Begin
  MemStatus.dwLength := SizeOf(TMemoryStatus);
  GlobalMemoryStatus(MemStatus);
  FreeVirtualMem := MemStatus.dwAvailPageFile;
  Result := MemStatus.dwAvailPhys;
End;

procedure TForm1.Button1Click(Sender: TObject);
Var l1:LongInt;
begin
  TotalPhysMem.Text := IntToStr(GetTotalMemory(l1));
  TotalVirtualMem.Text := IntToStr(l1);
  FreePhysMem.Text := IntToStr(GetFreeMemory(l1));
  FreeVirtualMem.Text := IntToStr(l1);
end;

Treiber eines BDE Alias besorgen

Holt den Path eines Alias aus der BDE.

Function GetAliasDriver(fAlias:String):String;
var Desc: DBDesc;
begin
  Result := '';
  If DbiGetDatabaseDesc(PChar(fAlias),@Desc) = DBIERR_NONE Then Begin
    Result := StrPas(Desc.szDbType);
  End Else Begin
    If DbiInit(nil) = DBIERR_NONE Then Begin
      DbiGetDatabaseDesc(PChar(fAlias),@Desc);
      Result := StrPas(Desc.szDbType);
    End;
  End;
end;

Achtung: uses DBITypes; wird benötigt.

TTable frei für Zugriff?

Q:

If one people is editing the record, the other people cannot view the record. Can I prompt the user that the message " The record is currently edited by other user"?

A:

When you get this or similars error, you can intercept these using the try construct in this way (supposing you are trying to post a record):

  try
     Table1.Post;
  except
     MessageDlg ('Error posting record', etc...
     Table1.Cancel;
  end;

Otherwise, you -shouldn't- get an error if an looks to a record currently viewed by another user (if you are using the Paradox database provided with Delphi) if you had correctly set it. Paradox self-creates a file called pdxusers.lck viewed by every users in the net dir, so every BDE on every local machine can be able to lock a record forbiding other users to post it until he had relased. I can't imagine what kind of things you are doing to get this error, if I don't know some other specs.

Undo in TMemo

In einem TMemo oder TRichEdit kann ein Undo normaleweise über CTRL-Z erreicht werden. Wenn man es vom Programm aus machen möchte, dann bitte so:

Memo1.Perform(EM_UNDO, 0, 0);

Zum testen, ob ein Undo überhaupt möglich ist:

Undo1.Enabled := Memo1.Perform(EM_CANUNDO, 0, 0) <> 0;

Untergeordnete Programm-Fenster in der Taskbar anzeigen

Wie kann ich erreichen, daß ein untergeordnetes Fenster einer Delphi-Anwendung in der Taskbar von Win95/NT erscheint??

Mit CreateParams. Siehe folgenden Sourcecode:

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    private
      procedure CreateParams(var Params : TCreateParams); override;
      { Private-Deklarationen }
      public
      { Public-Deklarationen }
  end;

var
  Form1 : TForm1;

implementation

{$R *.DFM}

procedure TForm1.CreateParams(var Params : TCreateParams);
begin
  inherited CreateParams(Params);
  Params.WndParent := GetDesktopWindow;
  Params.Caption:='Title';
end;

Unterschiedliche Programm Auflösungen

Auf jeden Fall habe ich mal ein Stück Code dafür gekriegt, das zu meiner großen Überraschung bis jetzt jedes Formular mitsamt allem Geraffel drauf prima skaliert hat. Es sind nur ein paar Zeilen im FormCreate des Hauptformulars und dazu zwei Konstanten (global definiert):

const ScreenWidthDev = XXX;

      ScreenHeightDev = YYY;

{statt XXX und YYY die Auflösung zur Entwicklungszeit eintragen. Angeblich soll der Code am besten von der höchsten Auflösung runterskalieren. Ich mußte aber immer von 640/480 (die hohen Auflösungen kommen bei mir nicht so gut) hochskalieren und es ging auch.}

procedure TForm1.FormCreate(Sender: TObject);
var x,y: Integer; // f. Bildschirmauflösung
begin
  Scaled:= true;
  x:= Screen.Width;
  y:= Screen.Height;
  if (x<>ScreenWidthDev) or (y<>ScreenHeightDev) then begin
    Form1.Height:= (Form1.ClientHeight*y div ScreenHeightDev) + Form1.Height - Form1.ClientHeight;
    Form1.Width:= (Form1.ClientWidth*y div ScreenWidthDev) + Form1.Width - Form1.ClientWidth;
    ScaleBy(x,ScreenWidthDev);
  end; // of if
...

Usernamen besorgen

Besorgt den Login-Usernamen.

function GetSystemUserName:String;
Var sUserName: Array [0..127] of Char; i1:Integer;
begin
  If GetUserName(sUserName,i1) Then Begin
    Result := StrPas(sUserName);
  End Else Begin
    Result := '';
  End;
end;


procedure TForm1.GoToFirstButtonClick(Sender: TObject);
begin
  Edit1.Text := GetSystemUserName;
end;

Verhindern, daß ein Programm doppelt gestartet wird

Man muß vor dem Start (also im Projekt-Quelltext vor Application.Run) prüfen, ob schon eine Anwendung mit demselben Namen vorhanden ist:

program Project1;

uses
  Windows,Forms,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

var mHandle: THandle;

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);

  mHandle := CreateMutex(nil,True,'Project1.exe'); // Programmnamen eintragen
  If GetLastError = ERROR_ALREADY_EXISTS Then Begin
    Halt;
    CloseHandle(mHandle);
  End Else Application.Run;

end.

Verknüpfungen auf dem Desktop erzeugen

Für alle die sich nicht extra mit SHGetSpecialFolderLocation, CoCreateInstance, IShellLink, IPersistFile auseinandersetzen möchte kann den untenstehende Quellcode benutzen.

uses ShellAPI, ShlObj, ActiveX, OleCtrls;

Const
  IID_IPersistFile: TGUID = (
    D1:$0000010B;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

function SpecialDirectory(ID:integer):string;
var pidl : PItemIDList;
    Path : PChar;
begin
  if SUCCEEDED(SHGetSpecialFolderLocation(0,ID,pidl)) then begin
    Path:=StrAlloc(max_path);
    SHGetPathFromIDList(pidl,Path);
    Result:=String(Path);
    if Result[length(Result)]<>'\' then Result:=Result+'\';
  end;
end;

Function CreateFolder(Foldername:string):boolean;
begin
  Result:=false;
  SetLastError(0);
  CreateDirectory(PChar(Foldername), nil );
  if (GetLastError()=0) or (GetLastError()=ERROR_ALREADY_EXISTS) then Result:=true;
end;

function CreateLink(lpszPathObj,lpszPathLink,lpszDesc:string):Boolean;
var psl : IShellLink;
    ppf : IPersistFile;
begin
  Result:=false;
  if SUCCEEDED(CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,
IID_IShellLinkA, psl)) then begin
    psl.SetPath(PChar(lpszPathObj));
    psl.SetDescription(PChar(lpszDesc));
    if SUCCEEDED(psl.QueryInterface(IID_IPersistFile,ppf)) then begin
      ppf.Save(StringToOLEStr(lpszPathLink),TRUE);
      Result:=true;
    end;
  end;
end;


Aufrufe:

CreateFolder( <GruppenName> );
Die Funktion CreateFolder legt den Ordner der in <Gruppenname> angegebnen ist an. <Gruppenname> muß eine komplette Pfadangabe sein.

CreateLink( <Dateiname>, <Shortcutname>, <Shortcuttitel> );
CreateLink legt den eigentlichen Link an.
In <Dateiname> ist die Datei angegeben, auf die der Shortcut verweisen soll.
In <Shortcutname> wird der Dateiname des Shortcuts (Endung .lnk) angegeben.
<Shortcuttitel> ist die Beschreibung des Shortcuts (was angezeigt wird).

SpecialDirectory( <ID> );
Diese Funktion gibt ein Verzeichnis zurück.
Sie sollte benutzt werden wenn ein ShortCut in einem Systemordner angelegt werden soll (z.B. auf dem Desktop oder im Startmenü). Man könnte zwar auch den Pfad als Konstante angeben, aber was wenn der Anwerder Windows in c:\win95 und nicht in c:\windows installiert hat? Also sollte man dieseFunktion immer benutzen wenn man etwas in ein Systemverzeichnis hinzufügen möchte.

In <ID> wird das gewünste Verzeichnis angegeben.
Gültige Werte für <ID> sind:
  CSIDL_Startup Autostart-Gruppe
  CSIDL_Startmenu Startmenü
  CSIDL_Programs Programs-Menü
  CSIDL_Favorites Persönliche Favoriten
  CSIDL_Desktopdirectory Desktop
  CSIDL_Sendto "Send an"-Verzeichnis

Beispiel:

1. CreateFolder( SpecialDirectory( CSIDL_Programs ) + 'Neu' );
  ->Erstellt die Programmgruppe "Neu" im Programs-Menü.

2. CreateLink( 'C:\Test\Programm.exe', SpecialDirectory( CSIDL_Startup ) + 'Programm.lnk','Kommentar' );
  ->Erstellt einen Link mit dem Titel "Programm" auf die Datei "C:\Test\Programm.exe" in der Autostart-Gruppe.

WAV-Datei abspielen

<Snd> enthält den kompletten Path der Sounddatei. Wird nur der Dateiname angegeben, dann muß die Sounddatei im gleichen Directory liegen wie die Applikation.

fSoundPlay ist eine globale Variable, die verhindert, daß der Sound abgespielt wird, wenn der alte noch läuft. fSoundPlay wird von einer Timer Routine zurückgesetzt.

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    SoundOnOff: TCheckBox;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    Procedure PlaySound(Snd:String);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

Uses MMSystem; // <----- hier ist 'SndPlaySound' definiert

Var fSoundPlay: Boolean;

Procedure TForm1.PlaySound(Snd:String);
Begin
  If not fSoundPlay Then Begin
    If SoundOnOff.Checked = true Then Begin
      If FileExists(Snd) Then Begin
        fSoundPlay := true;
        SndPlaySound(PChar(snd),SND_ASYNC);
        Edit1.Text := 'Play Sound locked';
      End;
    End;
  End;
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
  PlaySound('d:\NewSdm\SensoFlink\About.wav');
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  fSoundPlay := false;
  Edit1.Text := 'Play Sound unlocked';
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  fSoundPlay := false;
  Edit1.Text := 'Play Sound unlocked';
end;

Windows schalten

Bei WinNT siehe [NT Privilegien setzen].

Windows Neu starten

ExitWindowsEx(EWX_REBOOT,0);

Windows runter fahren

ExitWindowsEx(EWX_SHUTDOWN,0);

Windows runter fahren, auch wenn ein Prozeß nicht mehr reagiert.

ExitWindowsEx(EWX_FORCE,0);

Softwaregesteuerte Abschaltung

ExitWindowsEx(EWX_POWEROFF,0);

Aus einem Netzwerk abmelden und unter anderem Namen anmelden

ExitWindowsEx(EWX_LOGOFF,0);

Genaue Erklärung in 'Mapi.hlp' unter Stichwort 'ExitWindowsEx'.

Windows Spellchecker einbinden

Benutzt die ActiveX Komponente VSSpell um einen Text aus einer RichEdit Komponente zu untersuchen. Steht aber leider nur in englisch zur Verfügung. Das Dictionary heißt American.vtd und liegt in /Windows/System. Die deutsche Version ist im Internet verfügbar und heißt German.vtd (einfach nach german.vtd suchen).

So richtig funktioniert das aber nicht. Es werden nicht sehr viele Worte erkannt und das Ersetzen hat den ganzen Inhalt von RichEdit weggehauen. Da muß noch Arbeit reingesteckt werden, auch in die folgenden Routine:

Procedure TForm1.SpellChkBtnClick(Sender: TObject);
Var
  rc, size: integer;
  buffer: PChar;
  msg: string;
  Cancel: Boolean;
Begin
  Cancel := False;
  VCSpeller1.Clearcounts := 1;
  VCSpeller1.AutoPopUp := False;
  VCSpeller1.AutoReplace := True;
  size := RichEdit1.GetTextLen;
  Inc(Size);
  GetMem(Buffer, Size);
  RichEdit1.GetTextBuf(Buffer, Size);
  VCSpeller1.CheckText := Buffer;
  rc := VCSpeller1.ResultCode;
  While rc <= 0 do Begin
    Case rc of
      0: Break;
      Else Begin
        If (VCSpeller1.ReplaceOccurred = True) Then Begin
          Buffer := PChar(VCSpeller1.Text);
          RichEdit1.SetTextBuf(Buffer);
        End;
        RichEdit1.SelStart := VCSpeller1.WordOffset;
        RichEdit1.SelLength := Length(VCSpeller1.MisspelledWord);
        VCSpeller1.PopUpWordMisspelled := 1;
        rc := VCSpeller1.ResultCode;
        If rc > 0 Then Break;
        If rc = -3 Then Begin
          MessageDlg('SpellCheck Cancelled!',mtInformation,[mbOK],0);
          cancel := True;
          Break;
        End;
        If VCSpeller1.ReplaceOccurred = true Then Begin
          Buffer := PChar(VCSpeller1.Text);
          RichEdit1.SetTextBuf(Buffer);
        End;
        Application.ProcessMessages;
        rc := VCSpeller1.ResumeCheck;
      End;
    End;
  End;
  If cancel = false Then Begin
    msg := 'Spellcheck complete!' + Chr(10);
    msg := msg + IntToStr(VCSpeller1.WordCount) + ' Words Checked' + Chr(10);
    msg := msg + IntToStr(VCSpeller1.ReplaceCount) + ' Words Replaced';
    MessageDlg(msg, mtInformation, [mbOK],0);
  End;
End;

X, Y Position in TRichEdit

Aktuelle Cursor Position in einer TRichEdit Komponente besorgen.

Dir linke obere Ecke hat die Position 1,1.

Function TForm1.GetPosition(Sender:TRichEdit):TPoint;
Var TheRichEdit: TRichEdit;
Begin
  Result.X := 0;
  Result.Y := 0;
  TheRichEdit := TRichEdit(Sender);
  Result.Y := SendMessage(TheRichEdit.Handle,EM_LINEFROMCHAR,TheRichEdit.SelStart,0) + 1;
  Result.X := TheRichEdit.SelStart - SendMessage(TheRichEdit.Handle,EM_LINEINDEX,Result.Y, 0) + 1;
End;

procedure TForm1.RichEdit1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
Var t: TPoint;
begin
  t := GetPosition(RichEdit1);
  Edit1.Text := IntToStr(t.X) + ',' + IntToStr(t.Y);
end;

procedure TForm1.RichEditKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
Var t: TPoint;
begin
  t := GetPosition(RichEdit1);
  Edit1.Text := IntToStr(t.X) + ',' + IntToStr(t.Y);
end;

Zeige alle Datenbanktabellen

How to list all tables in database?

There's a component called TSession, which Delphi always uses, that keeps track of all Databases in uses. Using this it is possible to fill a ListBox or array of all the Tables used by a particular Database. In fact there is a demo that comes with Delphi that does eactly that. We simply took this and expanded it to display Field info and Index names.

Zeilen im Quelltexteditor mit Lesezeichen markieren

Mit folgenden Tastenkombinationen kann man im Quelltexteditor der Delphi-IDE Zeilen mit einem Lesezeichen markien und später direkt wieder anspringen:

Ein Lesezeichen setzen/löschen: [Strg]-[K]-[1..9]

Zu einem Lesezeichen springen: [Strg]-[Q]-[1..9]

Zeit und Datum eines Files setzen

var
  f: file;
begin
  Assign(f, DirInfo.Name);
  Reset(f);
  SetFTime(f, Time);
  Close(f);
end;