123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335 |
- {
- Free Pascal port of the OpenPTC C++ library.
- Copyright (C) 2001-2003 Nikolay Nikolov ([email protected])
- Original C++ version by Glenn Fiedler ([email protected])
- This library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Lesser General Public
- License as published by the Free Software Foundation; either
- version 2.1 of the License, or (at your option) any later version.
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Lesser General Public License for more details.
- You should have received a copy of the GNU Lesser General Public
- License along with this library; if not, write to the Free Software
- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- }
- { $R win32\base\ptcres.res}
- { bug in the compiler???}
- { $LINKLIB ptc.owr}
- Constructor TWin32Window.Create(window : HWND);
- Begin
- LOG('attaching to user managed window');
- defaults;
- m_window := window;
- m_managed := False;
- End;
- Constructor TWin32Window.Create(wndclass, title : String; extra, style : DWord; show, x, y, width, height : Integer; center, _multithreaded : Boolean; data : Pointer);
- Begin
- internal_create(wndclass, title, extra, style, show, x, y, width, height, center, _multithreaded, data);
- End;
- Constructor TWin32Window.Create(wndclass, title : String; extra, style : DWord; show, x, y, width, height : Integer; center, _multithreaded : Boolean);
- Begin
- internal_create(wndclass, title, extra, style, show, x, y, width, height, center, _multithreaded, Nil);
- End;
- Destructor TWin32Window.Destroy;
- Begin
- close;
- Inherited Destroy;
- End;
- Procedure TWin32Window.cursor(flag : Boolean);
- Begin
- If flag Then
- Begin
- SetClassLong(m_window, GCL_HCURSOR, LoadCursor(0, IDC_ARROW));
- End
- Else
- Begin
- SetClassLong(m_window, GCL_HCURSOR, 0);
- End;
- SendMessage(m_window, WM_SETCURSOR, 0, 0);
- End;
- Procedure TWin32Window.resize(width, height : Integer);
- Var
- window_rectangle : RECT;
- rectangle : RECT;
- Begin
- GetWindowRect(m_window, window_rectangle);
- With rectangle Do
- Begin
- left := 0;
- top := 0;
- right := width;
- bottom := height;
- End;
- AdjustWindowRectEx(rectangle, m_style, False, m_extra);
- SetWindowPos(m_window, HWND_TOP, window_rectangle.left,
- window_rectangle.top, rectangle.right - rectangle.left,
- rectangle.bottom - rectangle.top, 0);
- {
- todo: detect if the window is resized off the screen and let windows reposition it correctly... ?
- }
- End;
- Procedure TWin32Window.update(force : Boolean);
- Var
- message : MSG;
- Begin
- If (Not m_managed) And (Not force) Then
- Exit;
- If Not m_multithreaded Then
- Begin
- While PeekMessage(message, m_window, 0, 0, PM_REMOVE) Do
- Begin
- TranslateMessage(message);
- DispatchMessage(message);
- End;
- End
- Else
- Sleep(0);
- End;
- Procedure TWin32Window.update; {force = False}
- Begin
- update(False);
- End;
- Function TWin32Window.handle : HWND;
- Begin
- handle := m_window;
- End;
- Function TWin32Window.thread : DWord;
- Begin
- If m_multithreaded Then
- thread := m_id
- Else
- thread := GetCurrentThreadId;
- End;
- Function TWin32Window.managed : Boolean;
- Begin
- managed := m_managed;
- End;
- Function TWin32Window.multithreaded : Boolean;
- Begin
- multithreaded := m_multithreaded;
- End;
- Function WndProcSingleThreaded(hWnd : HWND; message : UINT; wParam : WPARAM; lParam : LPARAM) : LRESULT; StdCall;
- Begin
- Case message Of
- WM_CLOSE : Begin
- LOG('TWin32Window WM_CLOSE');
- Halt(0);
- End;
- Else
- WndProcSingleThreaded := DefWindowProc(hWnd, message, wParam, lParam);
- End;
- End;
- Function WndProcMultiThreaded(hWnd : HWND; message : UINT; wParam : WPARAM; lParam : LPARAM) : LRESULT; StdCall;
- Begin
- WndProcMultiThreaded := 0;
- Case message Of
- WM_DESTROY : Begin
- LOG('TWin32Window WM_DESTROY');
- PostQuitMessage(0);
- End;
- WM_CLOSE : Begin
- LOG('TWin32Window WM_CLOSE');
- Halt(0);
- End;
- Else
- WndProcMultiThreaded := DefWindowProc(hWnd, message, wParam, lParam);
- End;
- End;
- Procedure TWin32Window.internal_create(wndclass, title : String; extra, style : DWord; show, x, y, width, height : Integer; center, _multithreaded : Boolean; data : Pointer);
- Var
- program_instance{, library_instance} : DWord;
- rectangle : RECT;
- display_width, display_height : Integer;
- wc : WNDCLASSEX;
- Begin
- LOG('creating managed window');
- defaults;
- m_multithreaded := _multithreaded;
- wndclass := wndclass + #0;
- title := title + #0;
- Try
- program_instance := GetModuleHandle(Nil);
- { library_instance := program_instance;}
- wc.cbSize := SizeOf(WNDCLASSEX);
- wc.hInstance := program_instance;
- wc.lpszClassName := @wndclass[1];
- wc.style := CS_VREDRAW Or CS_HREDRAW;
- wc.hIcon := 0{LoadIcon(library_instance, 'IDI_PTC_ICON')};
- wc.hIconSm := 0;
- wc.lpszMenuName := Nil;
- wc.cbClsExtra := 0;
- wc.cbWndExtra := 0;
- wc.hbrBackground := 0;{(HBRUSH) GetStockObject(BLACK_BRUSH)}
- If multithreaded Then
- wc.lpfnWndProc := @WndProcMultiThreaded
- Else
- wc.lpfnWndProc := @WndProcSingleThreaded;
- wc.hCursor := LoadCursor(0, IDC_ARROW);
- RegisterClassEx(wc);
- With rectangle Do
- Begin
- left := 0;
- top := 0;
- right := width;
- bottom := height;
- End;
- AdjustWindowRectEx(rectangle, style, False, extra);
- If center Then
- Begin
- LOG('centering window');
- display_width := GetSystemMetrics(SM_CXSCREEN);
- display_height := GetSystemMetrics(SM_CYSCREEN);
- x := (display_width - (rectangle.right - rectangle.left)) Div 2;
- y := (display_height - (rectangle.bottom - rectangle.top)) Div 2;
- End;
- m_name := wndclass;
- m_title := title;
- m_extra := extra;
- m_style := style;
- m_show := show;
- m_x := x;
- m_y := y;
- m_width := rectangle.right - rectangle.left;
- m_height := rectangle.bottom - rectangle.top;
- m_data := data;
- If multithreaded Then
- Begin
- {...}
- End
- Else
- Begin
- m_window := CreateWindowEx(m_extra, PChar(m_name), PChar(m_title), m_style, m_x, m_y, m_width, m_height, 0, 0, 0, m_data);
- If Not IsWindow(m_window) Then
- Raise TPTCError.Create('could not create window');
- ShowWindow(m_window, m_show);
- SetFocus(m_window);
- SetActiveWindow(m_window);
- SetForegroundWindow(m_window);
- End;
- Except
- On error : TPTCError Do
- Raise TPTCError.Create('could not create window', error);
- End;
- End;
- Procedure TWin32Window.defaults;
- Begin
- m_window := 0;
- m_event := 0;
- m_thread := 0;
- m_id := 0;
- m_name := '';
- m_title := '';
- m_extra := 0;
- m_style := 0;
- m_show := 0;
- m_x := 0;
- m_y := 0;
- m_width := 0;
- m_height := 0;
- m_data := Nil;
- m_managed := True;
- m_multithreaded := False;
- End;
- Procedure TWin32Window.close;
- Begin
- If Not m_managed Then
- Begin
- LOG('detaching from user managed window');
- m_window := 0;
- End
- Else
- Begin
- LOG('closing managed window');
- If m_multithreaded Then
- Begin
- If (m_thread <> 0) And IsWindow(m_window) Then
- Begin
- PostMessage(m_window, WM_DESTROY, 0, 0);
- WaitForSingleObject(m_thread, INFINITE);
- End;
- If m_event <> 0 Then
- CloseHandle(m_event);
- If m_thread <> 0 Then
- CloseHandle(m_thread);
- SetPriorityClass(GetCurrentProcess, NORMAL_PRIORITY_CLASS);
- End
- Else
- If (m_window <> 0) And IsWindow(m_window) Then
- DestroyWindow(m_window);
- m_window := 0;
- m_event := 0;
- m_thread := 0;
- m_id := 0;
- UnregisterClass(PChar(m_name), GetModuleHandle(Nil));
- End;
- End;
- Class Procedure TWin32Window.ThreadFunction(owner : TWin32Window);
- Var
- message : MSG;
- Begin
- With owner Do
- Begin
- m_window := CreateWindowEx(m_extra, PChar(m_name), PChar(m_title), m_style, m_x, m_y, m_width, m_height, 0, 0, 0, m_data);
- If IsWindow(m_window) Then
- Begin
- ShowWindow(m_window, m_show);
- SetFocus(m_window);
- SetForegroundWindow(m_window);
- SetEvent(m_event);
- While GetMessage(message, 0, 0, 0) = True Do
- Begin
- TranslateMessage(message);
- DispatchMessage(message);
- End;
- End
- Else
- SetEvent(m_event);
- End;
- End;
|