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.
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,...;
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;
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.
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;
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;
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,...;
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;
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);
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;
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,...;
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.
In Registry:
Im Dateisystem:
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'
Ö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.
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.
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;
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;
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.
TImage.Picture.Bitmap.Handle := LoadBitmap(Handle,'BITMAPNAMEHERE');
SpeedButton.Glyph.Handle := LoadBitmap(HInstance,'BITMAP_NAME');
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.
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
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 ö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:
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 aufklappen:
SendMessage(combobox1.Handle,CB_SHOWDROPDOWN,1,0);
Combo Box zuklappen:
SendMessage(combobox1.Handle,CB_SHOWDROPDOWN,0,0);
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}
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.
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)
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.
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;
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,...;
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;
...
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;
Auslesen des Datums 'Geändert am' aus einer Datei.
s1 := 'C:\Autoexec.bat';
s2 := FormatDateTime('MM/DD/YYYY hh:mm:ss',FileDateToDateTime(FileAge(s1)));
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;
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:
Der komplette Assemblercode (mit Rahmen um der aktuellen Zeile), alle Register und ein Speicherauszug werden dargestellt.
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 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!
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;
Eine Tabellenseite in einer TPageControl Komponente unsichtbar machen:
TabSheet1.TabVisible := false;
und wieder sichtbar machen:
TabSheet1.TabVisible := true;
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
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;
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.
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
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,...;
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,...;
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;
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;
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.
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.
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.
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
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;
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;
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.
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;
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;
Folgende Ereignisse werden in dieser Reihenfolge abgefeuert:
- OnCreate
- OnShow
- OnPaint
- OnActivate
- OnResize
- und nocheinmal OnPaint
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)
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);
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;
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.
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);
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.
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.
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);
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;
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;
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 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,...;
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;
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
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;
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;
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.
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:
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;
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.
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;
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);
...
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;
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;
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,...;
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.
Ü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;
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;
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;
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
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
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);
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;
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;
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;
Ü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
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;
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;
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
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;
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;
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;
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;
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.
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;
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;
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;
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;
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 ?
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;
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 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;
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
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 );
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;
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;
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;
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;
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;
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;
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;
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.
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;
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 ausschalten
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
Monitor einschalten
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
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;
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.
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;
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;
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;
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;
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;
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;
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.
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.
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.
a^b := Exp(b * ln(a))
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;
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);
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
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 !
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
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;
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.
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,...;
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.
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;
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 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;
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;
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;
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;
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.
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)
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;
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;
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.
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;
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.
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');
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;
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;
-----------------------------------
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.
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;
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,...;
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:
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';
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;
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.
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;
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.
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.
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;
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;
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
...
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;
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.
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.
<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;
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'.
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;
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;
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.
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]
var
f: file;
begin
Assign(f, DirInfo.Name);
Reset(f);
SetFTime(f, Time);
Close(f);
end;