/[lcore]/trunk/unitwindowobject.pas
ViewVC logotype

Annotation of /trunk/unitwindowobject.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 61 - (hide annotations)
Thu Feb 4 22:47:07 2010 UTC (9 years, 9 months ago) by plugwash
File size: 3642 byte(s)
set line ending property on files to hopefully avoid line ending problems in future

1 plugwash 44 { Copyright (C) 2005 Bas Steendijk and Peter Green
2     For conditions of distribution and use, see copyright notice in zlib_license.txt
3     which is included in the package
4     ----------------------------------------------------------------------------- }
5    
6     unit unitwindowobject;
7    
8     interface
9    
10     uses
11     classes,
12     {$ifdef win32}
13     windows,messages,wmessages,
14     {$else}
15     lmessages,
16     {$macro on}
17     {$define windows := lmessages}
18     {$endif}
19     sysutils,
20     pgtypes;
21    
22     type
23     twindowobject=class(tobject)
24     hwndmain:hwnd;
25     onmsg:function(msg,wparam,lparam:taddrint):boolean of object;
26     exitloopflag:boolean;
27     function settimer(id,timeout:taddrint):integer;
28     function killtimer(id:taddrint):boolean;
29     procedure postmessage(msg,wparam,lparam:taddrint);
30     procedure messageloop;
31     {$ifdef win32}
32     procedure processmessages;
33     function processmessage:boolean;
34     {$endif}
35     constructor create;
36     destructor destroy; override;
37     end;
38    
39     implementation
40    
41     //uses safewriteln;
42    
43     function WindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
44     var
45     i:taddrint;
46     begin
47     ////swriteln('in unitwindowobject.windowproc');
48     Result := 0; // This means we handled the message
49     if ahwnd <> hwnd(0) then i := getwindowlongptr(ahwnd,0) else i := 0;
50     if i <> 0 then begin
51     if assigned(twindowobject(i).onmsg) then begin
52     if not twindowobject(i).onmsg(aumsg,awparam,alparam) then i := 0;
53     end else i := 0
54     end;
55     if i = 0 then Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
56     end;
57    
58     var
59     twindowobject_Class : TWndClass = (style:0; lpfnWndProc:@WindowProc;
60     cbClsExtra:0; cbWndExtra:sizeof(pointer); hInstance:thinstance(0); hIcon:hicon(0); hCursor:hcursor(0);
61     hbrBackground:hbrush(0);lpszMenuName:nil; lpszClassName:'twindowobject_class');
62    
63     function twindowobject.settimer;
64     begin
65     result := windows.settimer(hwndmain,id,timeout,nil);
66     end;
67    
68     function twindowobject.killtimer;
69     begin
70     result := windows.killtimer(hwndmain,id);
71     end;
72    
73     constructor twindowobject.create;
74     begin
75     inherited;
76     //swriteln('in twindowobject.create, about to call registerclass');
77     Windows.RegisterClass(twindowobject_Class);
78     //swriteln('about to call createwindowex');
79     hWndMain := CreateWindowEx(WS_EX_TOOLWINDOW, twindowobject_Class.lpszClassName,
80     '', WS_POPUP, 0, 0,0, 0, hwnd(0), 0, HInstance, nil);
81     //swriteln('about to check result of createwindowex');
82     if hWndMain = hwnd(0) then raise exception.create('CreateWindowEx failed');
83     //swriteln('about to store reference to self in extra windo memory');
84     setwindowlongptr(hwndmain,0,taddrint(self));
85     //swriteln('finished twindowobject.create , hwndmain='+inttohex(taddrint(hwndmain),16));
86     end;
87    
88     destructor twindowobject.destroy;
89     begin
90     if hWndMain <> hwnd(0) then DestroyWindow(hwndmain);
91     inherited;
92     end;
93    
94     procedure twindowobject.postmessage;
95     begin
96     windows.postmessage(hwndmain,msg,wparam,lparam);
97     end;
98    
99     {$ifdef win32}
100     function twindowobject.ProcessMessage : Boolean;
101     var
102     Msg : TMsg;
103     begin
104     Result := FALSE;
105     if PeekMessage(Msg, hwndmain, 0, 0, PM_REMOVE) then begin
106     Result := TRUE;
107     DispatchMessage(Msg);
108     end;
109     end;
110    
111     procedure twindowobject.processmessages;
112     begin
113     while processmessage do;
114     end;
115     {$endif}
116    
117     procedure twindowobject.messageloop;
118     var
119     MsgRec : TMsg;
120     begin
121     while GetMessage(MsgRec, hwnd(0), 0, 0) do begin
122     DispatchMessage(MsgRec);
123     if exitloopflag then exit;
124     {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}
125     end;
126     end;
127    
128     end.

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.22