X000XBtn.pas
markieren
(*******************************************************************************
*
* 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
*******************************************************************************)