X000X-Btn.pas

X000X-Btn.pas

Ich habe hier mal ein paar ältere Delphi sourcen eingearbeitet. Die Originale findet Ihr immer noch hier:

X000XBtn.pas
X000XSysUtils.pas
X000XActiveX.pas

(*******************************************************************************
*
* Unit: X000XBtn.pas
* Author: (c) 2004, 2005 – Peter Welz
* Mail: delphi[at]gods4u[dot]de
* Web : delphi.gods4u.de
*
* Information: Diese Unit stellt in WinAPI Programmen eine Button-Klasse zur
* Verf�gung.
* Hilfreich beim Entwickeln von kleineren Tools, die ohne die
* VCL von Borland geschrieben werden, da sich Funktionen einfach
* dem OnClick Ereignis zuweisen lassen.
*
* History:
*******************************************************************************
* Author: Peter Welz
* 2005-08-29: Ein Jpeg kann jetzt aus einer Datei bzw. aus einer Resource
* geladen werden.
* Kleine �nderung an X000XActiveX – hMem in funktionen LoadPicture…
* wird jetzt nicht mehr �ber CreateStreamOnHGlobalX freigegeben,
* sondern es wird im finally block erledigt
* Der MemDC wird jetzt auch wieder freigegeben –
* Doppelte Funktionsaufrufe in den funktionen *JpegResource* und
* *JpegFromFile* habe ich zusammnengefasst
* Kommentar: Um ein Jpeg aus einer Datei zu laden, einfach Property
* Jpeg := ‚filename.jpg‘ setzen. Pfadangaben sind notwendig ;o)
* Um ein Jpeg aus einer Resource zu laden, muss die Resource
* vom Typ ‚JPEGDATA‘ sein und dem Property Jpeg muss der Name
* der Resource zugeordnet werden z.B.: Jpeg := ‚BILD‘;
* TODO: – TabOrder
* – Der „Klick“ gef�llt mir noch nicht (bei schnellen Mausklicks
* wirkt der Klick verz�gert)
* – OnMouseOver
* – Property BtnType der Art (Standard-, Color-, Paint-Button)
*******************************************************************************
* weitere Infos am Ende der Unit
*******************************************************************************)

unit X000XBtn;

{.$DEFINE ATOM}

interface

uses Windows, Messages, X000XActiveX;

const
DEBUG = (1=0);

type
TNotifyEvent = procedure(Sender: TObject) of object;

{$IFNDEF ATOM}

{$MESSAGE ‚ATOM ist nicht definiert. Self-Pointer wird im Fenster gespeichert! ‚}

(****************************************************************************)
(* Ich hatte zuerst folgendes implementiert, dann aber irgenwo im Internet *)
(* gelesen, dass es umst�ndlich/nicht richtig ist, sowas im Fenster mit ab- *)
(* zuspeichern. Dort wurde empfohlen, es mit GlobalAddAtom zu l�sen. *)
(* *)
(* Ich habe jetzt beide M�glichkeiten eingebaut, es kann mit Hilfe der *)
(* $DEFINE ATOM Directive zwischen den beiden Methoden ausgew�hlt werden *)
(* *)
(* Die Idee war folgende: *)
(* Ich kann zu jedem Window einen 32-Bit Wert mit abspeichern, der mitge- *)
(* f�hrt wird. (GWL_USERDATA) *)
(* Da ich f�r das Subclassing (WndProc) eine Referenz auf mein Object *)
(* brauchte, habe ich mir gedacht, ich speicher im Fenster (GWL_USERDATA) *)
(* einfach einen Pointer auf eine Datenstruktur ab. Diese Datenstruktur *)
(* enth�lt wiederum Zeiger auf evtl. Objecteigenschaften, oder �hnliches… *)
(* *)
(* Wie an diese Daten kommen? *)
(* PWinProperty(GetWindowLong(hWnd, GWL_USERDATA))^.Self *)
(* Wie diesen Zeiger im Fenster speichern? *)
(* SetWindowLong(hWnd, GWL_USERDATA, Integer(PWinProperty-Struct)); *)
(****************************************************************************)

type
PWinProperty = ^TWinProperty;
TWinProperty = packed Record
Self : Pointer;
//OldWndProc : Pointer;
(* hier eventuell noch mehr Pointer auf Daten/Propertys *)
(* die mit dem Object mitgef�hrt werden sollen… *)
end;
{$ENDIF}

type
TBtnState = (bsUp, bsDown);

type
TX000XBtn = class

private
{$IFNDEF ATOM}
FWinProp : PWinProperty;
{$ENDIF}
FCaption : String;
FHandle : THandle;
FOwner : THandle;
FName : String;
FLeft : Integer;
FTop : Integer;
FWidth : Integer;
FHeight : Integer;
FOnClick : TNotifyEvent;
FBtnState : TBtnState;
FTabStop : Boolean;
FOldWndProc : Pointer;
FIsFocused : Boolean;
FColor : COLORREF;
FdcMemory : HDC;
FJpeg : String;
FFont : HFONT;
FFontName : String;
FFontColor : COLORREF;
FFontSize : Integer;
function GetWidth: Integer;
function GetHeight: Integer;
procedure SetCaption(const Value: String);
procedure SetWidth(const Value: Integer);
procedure SetHeight(const Value: Integer);
function GetTabStop: Boolean;
procedure SetTabStop(const Value: Boolean);
procedure ButtonDraw(ps : PPaintStruct = nil);
procedure WndProc(var Msg: TMessage);
procedure SetColor(const Value: COLORREF);
function SetMethod(Value: Pointer; Data: Pointer = nil): TMethod;
procedure SetupMemDC;
procedure DrawFromMemDC(var pPic: IPicture);
procedure _SetMemDCFromFile(const JpegFileName: String);
procedure _SetMemDCFromRes(const szResName: String);
procedure SetMemDCFromX(const szName: String);
procedure SetFontName(const Value: String);
procedure SetFontColor(const Value: COLORREF);
public
constructor Create(hWndParent: THandle; Position: TPoint);
destructor Destroy; override;
function SetNotifyEvent(Proc: Pointer): TNotifyEvent;
published
property Handle : THandle read FHandle;
property Width : Integer read GetWidth write SetWidth;
property Height : Integer read GetHeight write SetHeight;
property Name : String read FName write FName;
property Caption : String read FCaption write SetCaption;
property OnClick : TNotifyEvent read FOnClick write FOnClick;
property TabStop : Boolean read GetTabStop write SetTabStop;
property Color : COLORREF read FColor write SetColor;
property Jpeg : String read FJpeg write SetMemDCFromX;
property FontColor: COLORREF read FFontColor write SetFontColor;
property FontName : String read FFontName write SetFontName;
end;

{$IFDEF ATOM}
var
FAtom : TAtom;
{$ENDIF}

const
CWIDTH = 100;
CHEIGHT = 27;

implementation

{ TX000XBtn }

uses X000XSysUtils;

type
PFontNameExists = ^TFontNameExists;
TFontNameExists = packed record
Name : String;
Exists : Boolean;
end;

(* function f�r SubClassen des Buttons. Hiermit werden die Nachrichten an das *)
(* Object weitergeleitet. *)
function SetWndProc(hWnd: hWnd; Msg: UINT; wParam: wParam; lParam: lParam): lResult; stdcall;
var
mMsg : TMessage;
Self : TX000XBtn;
begin
(* Parameter in die Message schreiben *)
mMsg.Msg := Msg;
mMsg.wParam := wParam;
mMsg.lParam := lParam;
mMsg.Result := 0;
(* Wir brauchen den Self-Pointer des Objectes, damit wir die Nachrichten an*)
(* selbiges weiterleiten k�nnen. *)
Self := TX000XBtn({$IFDEF ATOM}
GetProp(hWnd, PChar(FAtom))
{$ELSE}
PWinProperty(GetWindowLong(hWnd, GWL_USERDATA))^.Self
{$ENDIF});
(* Und die Nachricht/en an die WndProc des Objectes weiterleiten. *)
Self.WndProc(mMsg);
(* Die WndProc des Objectes setzt das Result, welches wir einfach zur�ck- *)
(* geben. *)
Result := mMsg.Result;
end;

procedure TX000XBtn.WndProc(var Msg: TMessage);
var
ps : TPaintStruct;
dMsg : TMsg;
function InRect: Boolean;
var re : TRect;
pt : TPoint;
begin
pt.X := Msg.LParamLo;
pt.Y := Msg.LParamHi;
GetClientRect(FHandle, re);
Result := ptInRect(re, pt);
end;
begin
(* Result erstmal auf 0 setzen, somit braucht beim behandeln der Nachricht *)
(* nur noch ein Exit mitgegeben werden *)
Msg.Result := 0;
case Msg.Msg of
WM_LBUTTONDOWN:
begin
(* Einmal die Message SETFOCUS rausschicken, damit die anderen *)
(* Buttons auch richtig gezeichnet werden k�nnen *)
SetFocus(FHandle);
(* Alle Mausenachrichten empfangen, auch wenn die Maus nicht *)
(* mehr �ber unserem Control ist. Ist hier n�tig, da wir sonst *)
(* nicht mitbekommen, wenn die Maus losgelassen wird und sich *)
(* nicht mehr �ber unserem Control befindet. *)
SetCapture(FHandle);
(* Nur wenn Maus noch im Bereich des Buttons ist, den Click merken *)
if InRect then begin
FBtnState := bsDown;
//ButtonPaint;
ButtonDraw;
end;
Exit;
end;
WM_MOUSEMOVE:
begin
(* ToDo: andere Farbe zeichnen… OnMouseOver Effekt *)
end;
WM_LBUTTONUP:
begin
(* Nur wenn Maus noch im Bereich des Buttons ist, ist es ein Click *)
if InRect then begin
if Assigned(Self.FOnClick) then begin
FOnClick(Self);
end;
end;
(* Hier auf jedenfall den Click wieder zur�cksetzen, damit die *)
(* Nachrichten wieder an die jeweiligen Controls geschickt werden *)
FBtnState := bsUp;
//ButtonPaint;
ButtonDraw;
(* Und die Maus wieder freigeben, jetzt empfangen elle Controls *)
(* wieder die entsprechenden Nachrichten *)
ReleaseCapture;
Exit;
end;
WM_PAINT:
begin
(* Button zeichnen *)
BeginPaint(FHandle, ps);
(* ToDo: PaintStruct mit �bergeben, somit m�sste nicht das gesamte *)
(* Fenster neu gezeichnet werden *)
ButtonDraw(@ps);
EndPaint(FHandle, ps);
Exit;
end;
WM_KEYDOWN:
begin
if Msg.WParam = 32 then begin
SendMessage(FHandle, WM_LBUTTONDOWN, 0, 0);
Exit;
end;
end;
WM_KEYUP:
begin
if Msg.WParam = 32 then begin
SendMessage(FHandle, WM_LBUTTONUP, 0, 0);
Exit;
end;
end;
WM_SETFOCUS:
begin
FIsFocused := True;
//ButtonPaint;
ButtonDraw;
(* MsgBeep entfernen *)
PeekMessage(dMsg, 0, WM_CHAR, WM_CHAR, PM_REMOVE);
Exit;
end;
WM_KILLFOCUS:
begin
FIsFocused := False;
//ButtonPaint;
ButtonDraw;
Exit;
end;
end;
(* Nachricht an das Hauptfenster zur�ckgeben *)
Msg.Result := CallWindowProc(FOldWndProc, FHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;

(* Hilfsfunktion, die eine Struktur vom Type TMethod f�llt und zur�ckliefert *)
(* Wird gebraucht, um externe funktionen/proceduren an ein Object �bergeben *)
(* zu k�nnen. (Geh�rt nicht zwingend zu der Klasse) *)
function TX000XBtn.SetMethod(Value: Pointer; Data: Pointer = nil): TMethod;
var Method : TMethod;
begin
Method.Code := Value;
if Assigned(Data) then
Method.Data := Data
else
Method.Data := Self;
Result := Method;
end;

(* Hilfsfunktion, die eine externe function/procedure vom Type TNotifyEvent *)
(* einem Klasseninternen property vom gleichen Type zuweist. *)
(*******************************************************************************
(* Beispiel: *
* *
* procedure Test(Sender: Pointer); *
* begin *
* MessageBox(0, PChar(TX000XBtn(Sender).Caption), ‚Test‘, 0); *
* end; *
* *
* // .. *
* *
* Button3 := TX000XBtn.Create(hWnd, Position); *
* Button3.OnClick := Button3.SetNotifyEvent(@Test); *
* *
* // .. *
* *
*******************************************************************************)
function TX000XBtn.SetNotifyEvent(Proc: Pointer): TNotifyEvent;
begin
Result := nil;
if Assigned(Proc) then
Result := TNotifyEvent(SetMethod(Proc));
end;

(* Zeichnet den Button *)
procedure TX000XBtn.ButtonDraw(ps : PPaintStruct = nil);
type
PHDC = ^HDC;
var
Brush : HBRUSH;
dc : PHDC;
cRect : PRect;
begin
(* Initialisieren *)
dc := nil;
cRect := nil;
try
(* Wenn ps <> nil dann benutzen wir HDC und Rect von der �bergebenen *)
(* PaintStruct *)
if Assigned(ps) then begin
cRect := @ps^.rcPaint;
dc := @ps^.hdc;
end else begin
(* Wenn ps = nil dann die Vars erzeugen und Zeiger zuweisen *)
New(dc); New(cRect);
(* und display device context vom Button holen *)
dc^ := GetDC(FHandle);
end;

(* cRect mit Abmessungen vom Button f�llen *)
GetClientRect(FHandle, cRect^);
(* Brush mit Farbe FColor erzeugen *)
Brush := CreateSolidBrush(FColor);
(* F�lle Button mit FColor *)
FillRect(dc^, cRect^, Brush);
(* zum Schluss Freigeben der Resourcen *)
DeleteObject(Brush);
if FJpeg <> “ then begin
(* Kopiere das Bitmap vom Speicher auf den Button (mit Gr��enanpassung) *)
if FBtnState = bsDown then
StretchBlt(dc^, 5, 5, cRect^.Right-10, cRect^.Bottom-10, FdcMemory, 0, 0, CWIDTH, CHEIGHT, SRCCOPY)
else
StretchBlt(dc^, 3, 3, cRect^.Right-6, cRect^.Bottom-6, FdcMemory, 0, 0, CWIDTH, CHEIGHT, SRCCOPY);
end;

(* Button gedr�ckt bzw. oben… dementsprechend die R�nder zeichen *)
if FBtnState = bsDown then
DrawEdge(dc^, cRect^, EDGE_SUNKEN, BF_RECT)
else
DrawEdge(dc^, cRect^, EDGE_RAISED, BF_RECT );

(* Um bei die Textausgabe auch zu animieren, hier das Rechteck versetzen *)
if FBtnState = bsDown then begin
cRect^.Left := -2;
cRect^.Top := -2;
cRect^.Right := cRect^.Right – 2;
cRect^.Bottom := cRect^.Bottom – 2;
end;

(* Textausgabe *)
SelectObject(dc^, FFont);
SetBKMode(dc^, {OPAQUE}TRANSPARENT);
SetTextAlign(dc^, TA_CENTER);
SetTextColor(dc^, FFontColor);
TextOut(dc^, cRect^.Right div 2, cRect^.Top + 6, Pointer(Self.Caption), Length(Self.Caption));

(* FocusRect zeichnen, wenn Button den Focus besitzt *)
if FIsFocused then begin
if FBtnState = bsDown then begin
cRect^.Left := -1;
cRect^.Top := -1;
InflateRect(cRect^, -4, -4);
DrawFocusRect(dc^, cRect^);
end else begin
cRect^.Right := cRect^.Right +1;
cRect^.Bottom := cRect^.Bottom +1;
InflateRect(cRect^, -5, -5);
DrawFocusRect(dc^, cRect^);
end;
end;
finally
(* Wenn ps nil war, haben wir ja Speicher reserviert, den wir jetzt freigeben *)
if Not Assigned(ps) then begin
Dispose(cRect);
ReleaseDC(FHandle, dc^);
Dispose(dc);
end;
end;
end;

(* Initialisieren der Variablen und Erstellen des Buttons; zuweisen der WndProc *)
constructor TX000XBtn.Create(hWndParent: THandle; Position: TPoint);
var TmpHwnd : THandle;
i : Integer;
begin
{$IFDEF ATOM}
FAtom := GlobalAddAtom(‚X000XBtn‘);
{$ELSE}
FWinProp := GetMemory(SizeOf(TWinProperty));
FillChar(FWinProp^, SizeOf(TWinProperty), #0);
{$ENDIF}

FOnClick := nil;
FBtnState := bsUp;
FOwner := hWndParent;
FLeft := Position.X;
FTop := Position.Y;
FWidth := CWIDTH;
FHeight := CHEIGHT;
FIsFocused := False;
FColor := $00656059; //$00D4A062;
FJpeg := “;
FdcMemory := 0;
FFontName := ‚Courier New‘;
FFontColor := $00FFFFFF;
FFontSize := -12;
FFont := CreateFont(FFontSize, 0, 0, 0, FW_NORMAL, 0, 0, 0, ANSI_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
DEFAULT_PITCH, Pointer(FFontName));
i := 1;
(* Alle bisher erstellten Buttons z�hlen, damit der Defaultname durch- *)
(* nummeriert gesetzt werden kann. z.B. Button1, Button2 usw. *)
//EnumChildWindows(hWndParent)
TmpHwnd := FindWindowEx(Self.FOwner, 0, ‚BUTTON‘, nil);
while (TmpHwnd <> 0) do begin
TmpHwnd := FindWindowEx(Self.FOwner, TmpHwnd, ‚BUTTON‘, nil);
inc(i)
end;
FName := ‚X000XButton‘ + IntToStr(i);

FCaption := FName;
(* Erstellen des Fensters *)
FHandle := CreateWindowEx(0, ‚BUTTON‘, Pointer(FName), WS_VISIBLE or WS_CHILD or BS_OWNERDRAW or BS_CENTER,
FLeft, FTop,
FWidth, FHeight, hWndParent, 0, hInstance, nil);

(* Neue WndProc f�r dieses Fenster setzen und dabei den Zeiger auf die *)
(* originale WndProc merken (Entweder im Fenster selber, bzw. als Property *)
(* (zu Identifizieren �ber FAtom) *)
FOldWndProc := Pointer(SetWindowLong(FHandle, GWL_WNDPROC, Integer(@SetWndProc)));

{$IFDEF ATOM}
SetProp(FHandle, PChar(FAtom), Cardinal(Self));
{$ELSE}
FWinProp.Self := Self;

SetWindowLong(FHandle, GWL_USERDATA, Integer(FWinProp));
{$ENDIF}
end;

(* Reservierten Speicher etc. frei geben, Fenster zerst�ren *)
destructor TX000XBtn.Destroy;
begin
(* Schriftenhandle freigeben *)
DeleteObject(FFont);

(* MemoryDC wieder freigeben *)
if FdcMemory <> 0 then
DeleteDc(FdcMemory);

{$IFDEF ATOM}
(* Zuerst die WndProc vom Mainwindow wieder benutzen, damit wir *)
(* gefahrlos das Property entfernen k�nnen… *)
(* ( Unsere BtnWndProc w�rde das Property ja ben�tigen, um *)
(* das Fenster zu zerst�ren ) *)
SetWindowLongPtr(FHandle, GWLP_WNDPROC, Integer(FOldWndProc));
(* Jetzt k�nnen wir auch gefahrlos das Property entfernen, es *)
(* wird ja nicht mehr gebraucht *)
RemoveProp(FHandle, PChar(FAtom));
{$ENDIF}

(* Handle/Fenster zerst�ren *)
DestroyWindow(FHandle);

{$IFDEF ATOM}
(* und zum Schluss auch noch den Referenzz�hler decrementieren *)
(* bzw. das Atom aus der GlobalAtomTable l�schen *)
GlobalDeleteAtom(FAtom);
{$ELSE}
FreeMemory(FWinProp);
{$ENDIF}
inherited;
end;

(*******************************************************************************
* *
* Folgende Funktionen dienen dem Setzen der Propertys und sind *
* selbsterkl�rend *
* *
*******************************************************************************)
function TX000XBtn.GetHeight: Integer;
begin
Result := FHeight;
end;

function TX000XBtn.GetTabStop: Boolean;
begin
FTabSTop := (GetWindowLong(FHandle, GWL_STYLE) and WS_TABSTOP) = WS_TABSTOP;
Result := FTabStop;
end;

function TX000XBtn.GetWidth: Integer;
begin
Result := FWidth;
end;

procedure TX000XBtn.SetCaption(const Value: String);
begin
if FCaption <> Value then begin
FCaption := Value;
SendMessage(FHandle, WM_SETTEXT, 0, LPARAM(FCaption));
end;
end;

procedure TX000XBtn.SetHeight(const Value: Integer);
begin
if FHeight <> Value then begin
FHeight := Value;
MoveWindow(FHandle, FLeft, FTop, FWidth, FHeight, True);
end;
end;

procedure TX000XBtn.SetTabStop(const Value: Boolean);
begin
if FTabStop <> Value then begin
if Value then begin
(* WS_TABSTOP setzen *)
SetWindowLong(FHandle, GWL_STYLE, GetWindowLong(FHandle, GWL_STYLE) or WS_TABSTOP);
end else
(* WS_TABSTOP entfernen *)
SetWindowLong(FHandle, GWL_STYLE, GetWindowLong(FHandle, GWL_STYLE) xor WS_TABSTOP);
FTabStop := Value;
end;
end;

procedure TX000XBtn.SetWidth(const Value: Integer);
begin
if FWidth <> Value then begin
FWidth := Value;
MoveWindow(FHandle, FLeft, FTop, FWidth, FHeight, True);
end;
end;

procedure TX000XBtn.SetColor(const Value: COLORREF);
begin
if Value <> FColor then begin
FColor := Value;
UpdateWindow(FHandle);
end;
end;

procedure TX000XBtn.SetupMemDC;
var dc : HDC;
hBmp : HBITMAP;
begin
(* Den MemDC nur einmal erstellen/initialisieren *)
if FdcMemory = 0 then begin
(* Erstelle „Zeichenger�t“ im Speicher (kompatibel zur Anzeige) *)
FdcMemory := CreateCompatibleDC(0);
(* Hole Zeichenger�t vom Button *)
dc := GetDC(FHandle);
(* Erstelle Bitmap (kompatibel zum Zeichenger�t des Buttons) *)
hBmp := CreateCompatibleBitmap(dc, FWidth, FHeight);
(* wir wollen ein Bitmap im Speicher abbilden *)
SelectObject(FdcMemory, hBmp);
(* Das originale Bitmap brauchen wir nicht mehr, also freigeben *)
DeleteObject(hBmp);
(* Das Zeichenger�t vom Button auch nicht, also auch freigeben *)
ReleaseDC(FHandle, dc);
end;
end;

procedure TX000XBtn.DrawFromMemDC(var pPic: IPicture);
var
hmWidth,
hmHeight : Integer;
rc : TRect;
begin
if Assigned(pPic) then begin
(* originale Ma�e vom Picture holen *)
if (pPic.get_Width(hmWidth) = S_OK) then
if (pPic.get_Height(hmHeight) = S_OK) then begin
(* Ein Rechteck erstellen, mit den Abma�en vom Button *)
GetWindowRect(FHandle, rc);
(* und letztendlich das Bild „in den Speicher zeichnen“ *)
pPic.Render(FdcMemory, 0, 0, FWidth, FHeight, 0, hmHeight, hmWidth, -hmHeight, rc);
(* damit gleich aktualisiert wird *)
ButtonDraw;
end;
end;
end;

procedure TX000XBtn._SetMemDCFromFile(const JpegFileName: String);
var pPic : IPicture;
begin
(* mit dem laden des Bildes anfangen *)
if (LoadPictureFromFile(JpegFileName, pPic)) then begin
SetupMemDC;
DrawFromMemDC(pPic);
end;
end;

procedure TX000XBtn._SetMemDCFromRes(const szResName: String);
var pPic : IPicture;
begin
(* mit dem laden des Bildes anfangen *)
if (LoadPictureFromRes(hInstance, szResName, ‚JPEGDATA‘, pPic)) then begin
SetupMemDC;
DrawFromMemDC(pPic);
end;
end;

procedure TX000XBtn.SetMemDCFromX(const szName: String);
begin
if FJpeg <> szName then begin
FJpeg := szName;
if FileExists(szName) then
_SetMemDCFromFile(szName)
else
_SetMemDCFromRes(szName);
end;
end;

procedure TX000XBtn.SetFontName(const Value: String);
(* CallBack function von EnumFonts… Mit Hilfe des Typs TFontNameExists *)
(* erkennen wir, ob die gew�nschte Schrifft �berhaupt verf�gbar ist *)
function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
FontType: Integer; Data: Pointer): Integer; stdcall;
begin
if lstrcmpi(Pointer(TFontNameExists(Data^).Name), LogFont.lfFaceName) = 0 then begin
TFontNameExists(Data^).Exists := True;
(* Der Name wurde gefunden, also aussteigen *)
Result := 0;
end else
(* Der Name wurde noch nicht gefunden, also mit dem n�chsten Fontname weitermachen *)
(* solange jedenfalls noch welche zum vergleichen da sind… *)
Result := 1;
end;
var
Tmp : PFontNameExists;
dc : HDC;
begin
if (FFontName <> Value) and (Value <> “) then begin
(* Neue Variable erzeugen *)
New(Tmp);
try
(* Unsren Typ mit dem Fontnamen den wir suchen f�llen *)
Tmp.Name := Value;
(* und auf False setzen *)
Tmp.Exists := False;
dc := GetDC(0);
(* steht hiernach die BooleanVar unsres Typs auf True, gibt es die Schrift im System *)
EnumFonts(dc, nil, @EnumFontsProc, Pointer(Tmp));
ReleaseDC(0, dc);
(* und nur in diesem fall �ndern wir die Schrift *)
if Tmp.Exists then begin
(* Altes Object zerst�ren *)
DeleteObject(FFont);
(* Neuen Namen setzen *)
FFontName := Value;
(* und ein Handle auf die Schrift holen *)
FFont := CreateFont(FFontSize, 0, 0, 0, FW_BOLD, 0, 0, 0, ANSI_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
DEFAULT_PITCH, Pointer(FFontName));
end;
(* damit wir auch sofort was sehen, den Button neu zeichnen lassen *)
ButtonDraw;
finally
(* Speicher von Tmp freigeben *)
Dispose(Tmp);
end;
end;
end;

procedure TX000XBtn.SetFontColor(const Value: COLORREF);
begin
if FFontColor <> Value then begin
FFontColor := value;
ButtonDraw;
end;
end;

{$WARNINGS OFF}
end.
(*******************************************************************************
* Author: Peter Welz
* 2005-08-18: X000XActiveX angef�gt, um Pictures in die Buttons laden zu
* k�nnen
* FJpeg eingef�hrt, d.h. dem Button kann jetzt ein Jpeg Image
* zugewiesen werden.
* Procedure ButtonDraw um FJpeg erweitert
* Kommentar: X000XActiveX beinhaltet einen Teil der Delphi �bersetzung
* von OCIDL.H bzw. OBJIDL.H speziell IPicture und IStream
* wird aber dynamisch geladen.
* TODO: – TabOrder
* – Der „Klick“ gef�llt mir noch nicht (bei schnellen Mausklicks
* wirkt der Klick verz�gert)
* – Bilder aus Resource (im Moment nur aus Datei)
* – OnMouseOver
* – Property BtnType der Art (Standard-, Color-, Paint-Button)
*******************************************************************************
* Author: Peter Welz
* 2005-08-15: Proceduren ButtonDraw und ButtonPaint zu einer zusammengefasst
* –> ButtonDraw
* Kommentar:
* TODO: – TabOrder
* – Bilder
* – OnMouseOver
* – Property BtnType der Art (Standard-, Color-, Paint-Button)
*******************************************************************************
* Author: Peter Welz
* 2005-08-14: Quelltext Kommentierung vervollst�ndigt, unn�tige Kommentare
* entfernt.
* Kommentar:
* TODO: – TabOrder
* – Bilder
* – OnMouseOver
* – Property BtnType der Art (Standard-, Color-, Paint-Button)
*******************************************************************************
* Author: Peter Welz
* 2005-07-12: OnClick Ereignis kann jetzt von Aussen zugewiesen werden…
* Kommentar: Endlich bin ich dazu mal gekommen, jetzt macht der ganze
* Quatsch erst richtig Sinn…
* procedure Test(Sender: Pointer);
* begin
* MessageBox(hWnd, PChar(TX000XBtn(Sender).Caption), ‚Test‘, 0);
* end;
*
* // ..
*
* Button3 := TX000XBtn.Create(hWnd, Position);
* Button3.OnClick := Button3.SetNotifyEvent(@Test);
*
* // ..
* TODO: – TabOrder
* – Bilder
* – Property BtnType der Art (Standard-, Color-, Paint-Button)
*******************************************************************************
* Author: Peter Welz
* 2005-01-17: FColor, FTabStop implementiert, hierbei ist der Standard
* Button rausgeflogen
* Kommentar:
* TODO: – TabOrder
* – Bilder
* – Property BtnType der Art (Standard-, Color-, Paint-Button)
* – OnClick Ereignis von Au�en zuweisen
*******************************************************************************
* Author: Peter Welz
* 2004-09-18: Das Speichern des Self-Pointers umgestellt.
* OldWndProc aus TWinProperty in den gesch�tzten Teil der Klasse
* gesteckt (FOldWndProc)
* Globale VAR FAtom eingef�hrt
* Anhand der Compilerdirective $DEFINE ATOM wird unterschieden,
* welche Variante zum speichern des Self-Pointers genutzt wird.
* Kommentar: Der pointer wird jetzt nicht mehr in GWL_USERDATA gehalten,
* sondern in der „Fenstereigenschaften Liste“
* (siehe MSDN —> Set/GetProp)
* Den Zeiger auf die Originale WndProc brauchte ich nicht mehr
* in TWinProperty speichern, da ich ja sowieso an die Klassen-
* eigenschaften rankomme. Somit brauche ich nur einen Zeiger
* mitf�hren, ich denke mal, die PropertyList ist genau daf�r
* gedacht.
* TODO: – OnClick Ereignis von Au�en zuweisen
* – Farben
* – Bilder
* – TabStop
* – TabOrder
*******************************************************************************
* Author: Peter Welz
* 2004-09-16: Implementierung einer Fensterprocedure die anhand des Self-
* Pointers die richtige Objectinstanz erkennt… Jetzt macht die
* Klasse erst Sinn, da jetzt „unendlich“ viele Buttons erzeugt
* und deren Messages verarbeitet werden k�nnen.
* Kommentar: Zu jedem Fenster (Buttons sind auch nur Fenster) kann der
* Entwickler einen eigenen 32-Bit Wert (4 Byte) abspeichern.
* —> Stichwort: GWL_USERDATA (siehe: MSDN) <—
* Solange das Fenster existiert, existiert auch dieser Wert.
* Genau sowas hatte mir gefehlt, um an die Referenz des Objectes
* zu kommen. Ich speicher jetzt einfach den Selfpointer und
* den Pointer auf die Original WndProc in einer Struktur (siehe
* TWinProperty). In dem Fenster selber speicher (s.o.) ich einen
* Pointer auf diese Struktur. Somit bin ich in der Lage,
* jeder Zeit an mein Object zu kommen, also auch in der WndProc.
* TODO: – OnClick Ereignis von Au�en zuweisen
* – Farben
* – Bilder
* – TabStop
* – TabOrder
*******************************************************************************
* Author: Peter Welz
* 2004-08-14: Erstellen der Klasse, Windows Standard-Button
* Kommentar: Es kann bis jetzt nur ein Button erstellt werden, da die
* Nachrichten f�r den Button noch nicht �ber die Klasse ge-
* h�ndelt werden. Habe noch keinen Weg gefunden, wie ich
* in der WndProc Funktion des Buttons an die Referenz des
* Objektes rankomme.
* TODO: – Eigene WndProc f�r die Klasse (WICHTIG, da sonst Sinnlos)
* – OnClick Ereignis von Au�en zuweisen
* – Farben
* – Bilder
* – TabStop
* – TabOrder
*******************************************************************************)

Gefallen Euch meine sourcen – freue ich mich über Eure Spende – Danke!





Comments are closed.