Forum > Windows
WINAPI functions are working but their output remains invisible
Pieter:
I brought a classical Pascal program (no objects) to Lazarus 2.2.2, running on an Intel i5 laptop under Windows 11 Pro. It gets its user input and output by means of a window created by the WINAPI function CreateWindow and related WINAPI functions. In this way, the program can migrate to another OS by replacing these input and output functions. In Lazarus, this seems to work properly, if you trace the program, however, no output is visible. Below, I inserted a small program that illustrates the problem. The console output shows the effect of the SendMessage command but the intended window is completely absent. What did I miss?
--- Code: Pascal [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---program SimpleTest3;{$mode objfpc}{$H+} uses Classes, Windows, Messages, SysUtils ;const MyClassName = 'JustAnotherWindow'; DefFntSize=12;type Tsem =(dflt,dbg,key_prw);var{test specif. vars} i: integer; mb_Ok: LongWord; ic: integer; hWindow: HWnd; TheFont1: HFont; TheColor: DWORD; function WindowProc(Window: HWnd; AMessage, WParam, LParam: Longint): Longint; stdcall; export; var dc : hdc; ps : Tpaintstruct; r : rect; bres, speckey:boolean; si:integer; as2:ansistring; sem: Tsem;begin WindowProc := 0; ic:=succ(ic); sem:=dbg; case AMessage of wm_paint: begin InvalidateRgn(Window,0,false); dc:=BeginPaint(Window,ps); case sem of dflt:; dbg: begin GetClientRect(Window,@r); DrawText(dc,'Hello world by Free Pascal',-1,@r, DT_SINGLELINE or DT_CENTER or DT_VCENTER); writeln('Best wishes from FP') end {dbg}; key_prw:; end {case sem}; EndPaint(Window,ps); Exit; end; wm_Destroy: begin PostQuitMessage(0); Exit; end; end {case}; WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);end; { Register the Window Class }function WinRegister: Boolean;var WindowClass: WndClass;begin WindowClass.Style := cs_hRedraw or cs_vRedraw; WindowClass.lpfnWndProc := WndProc(@WindowProc); WindowClass.cbClsExtra := 0; WindowClass.cbWndExtra := 0; WindowClass.hInstance := system.MainInstance; WindowClass.hIcon := LoadIcon(0, idi_Application); WindowClass.hCursor := LoadCursor(0, idc_Arrow); WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH); WindowClass.lpszMenuName := pchar(''); WindowClass.lpszClassName := MyClassName; {Result} WinRegister := RegisterClass(WindowClass) <> 0;end; procedure FontSize(var TLF:TLOGFONT;Height:integer; bold:boolean);begin with TLF do begin lfHeight := Height; // Default logical height of font lfWidth := 0; // Default logical average character width lfEscapement := 0; // angle of escapement lfOrientation := 0; // base-line orientation angle if bold then lfWeight:=800 else lfWeight:= FW_NORMAL; // font weight lfItalic := 0; // italic attribute flag lfUnderline := 0; // underline attribute flag lfStrikeOut := 0; // strikeout attribute flag lfCharSet := DEFAULT_CHARSET; // character set identifier lfOutPrecision := OUT_DEFAULT_PRECIS; // output precision lfClipPrecision := CLIP_DEFAULT_PRECIS; // clipping precision lfQuality := DEFAULT_QUALITY; // output quality lfPitchAndFamily := DEFAULT_PITCH; // pitch and family Strcopy(lfFaceName,'Courier New'); // pointer to typeface name string end; {==}end {FontSize}; function WinCreate: HWnd;var hWaux: HWnd; TheLogFont:TLogFont; begin hWaux := CreateWindow( MyClassName, {Defined in WinRegister} 'aWindow', {Name of window} ws_OverlappedWindow, {Style} cw_UseDefault, {X} cw_UseDefault, {Y} cw_UseDefault, {width} cw_UseDefault, {heighth} 0, {Parent} 0, {Menu} system.MainInstance, {hInstance} nil); {lpVOID} if hWaux <> 0 then begin {Selectfont;} FontSize(TheLogFont,DefFntSize,false); TheColor := GetSysColor(COLOR_WINDOWTEXT); TheFont1 := CreateFontIndirect(TheLogFont); SendMessage(hWaux,WM_SETFONT,TheFont1,1); ShowWindow(hWaux, CmdShow); UpdateWindow(hWaux); end; {Result} WinCreate := hWaux;end; Procedure DestroyWindow;var cont: boolean;begin DeleteObject(TheFont1); sendmessage(hWindow,wm_Destroy,0,0);end {destroywindow}; begin mb_Ok := 0; if Winregister then hWindow:=WinCreate; sendmessage(hWindow,wm_paint,0,0); DestroyWindow;end.
dseligo:
--- Quote from: Pieter on July 15, 2022, 05:30:06 pm ---I brought a classical Pascal program (no objects) to Lazarus 2.2.2, running on an Intel i5 laptop under Windows 11 Pro. It gets its user input and output by means of a window created by the WINAPI function CreateWindow and related WINAPI functions. In this way, the program can migrate to another OS by replacing these input and output functions.
--- End quote ---
I can't help you with your code, but if you want to migrate your program to another OS, why don't you just use Lazarus' forms? Then you don't have to change anything in your code. You just compile it in another OS, or you can also crosscompile to another OS.
440bx:
--- Quote from: Pieter on July 15, 2022, 05:30:06 pm ---Below, I inserted a small program that illustrates the problem. The console output shows the effect of the SendMessage command but the intended window is completely absent. What did I miss?
--- End quote ---
There are a number of deficiencies in the program you posted. For instance, calling InvalidateRgn when processing a WM_PAINT is not a good idea because that will generate another WM_PAINT. Using WM_SETFONT to the window procedure you showed isn't going to cause the window to use that font. The WM_PAINT handler isn't selecting that font in the WM_PAINT and the message loop ignores the WM_SETFONT.
Those are just some of the deficiencies I see just having a quick look at that code.
I recommend you look at the code found in the following examples, they are pure Windows API https://forum.lazarus.freepascal.org/index.php/topic,52984.0.html
That will be a good place for you to start.
HTH.
Thaddy:
Note that this very old code should work in D7 (although I had some issue that I needed to address: too many incorrect @). But I agree about where to put the invalidatergn code. NOT in wm_paint - but it is also harmless-.
But then again, when the code is processing a message.... This is sequential and invalidateXXX just sets a flag and does not force a repaint, it schedules a repaint..
BobDog:
--- Quote from: Pieter on July 15, 2022, 05:30:06 pm ---I brought a classical Pascal program (no objects) to Lazarus 2.2.2, running on an Intel i5 laptop under Windows 11 Pro. It gets its user input and output by means of a window created by the WINAPI function CreateWindow and related WINAPI functions. In this way, the program can migrate to another OS by replacing these input and output functions. In Lazarus, this seems to work properly, if you trace the program, however, no output is visible. Below, I inserted a small program that illustrates the problem. The console output shows the effect of the SendMessage command but the intended window is completely absent. What did I miss?
--- Code: Pascal [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---program SimpleTest3;{$mode objfpc}{$H+} uses Classes, Windows, Messages, SysUtils ;const MyClassName = 'JustAnotherWindow'; DefFntSize=12;type Tsem =(dflt,dbg,key_prw);var{test specif. vars} i: integer; mb_Ok: LongWord; ic: integer; hWindow: HWnd; TheFont1: HFont; TheColor: DWORD; function WindowProc(Window: HWnd; AMessage, WParam, LParam: Longint): Longint; stdcall; export; var dc : hdc; ps : Tpaintstruct; r : rect; bres, speckey:boolean; si:integer; as2:ansistring; sem: Tsem;begin WindowProc := 0; ic:=succ(ic); sem:=dbg; case AMessage of wm_paint: begin InvalidateRgn(Window,0,false); dc:=BeginPaint(Window,ps); case sem of dflt:; dbg: begin GetClientRect(Window,@r); DrawText(dc,'Hello world by Free Pascal',-1,@r, DT_SINGLELINE or DT_CENTER or DT_VCENTER); writeln('Best wishes from FP') end {dbg}; key_prw:; end {case sem}; EndPaint(Window,ps); Exit; end; wm_Destroy: begin PostQuitMessage(0); Exit; end; end {case}; WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);end; { Register the Window Class }function WinRegister: Boolean;var WindowClass: WndClass;begin WindowClass.Style := cs_hRedraw or cs_vRedraw; WindowClass.lpfnWndProc := WndProc(@WindowProc); WindowClass.cbClsExtra := 0; WindowClass.cbWndExtra := 0; WindowClass.hInstance := system.MainInstance; WindowClass.hIcon := LoadIcon(0, idi_Application); WindowClass.hCursor := LoadCursor(0, idc_Arrow); WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH); WindowClass.lpszMenuName := pchar(''); WindowClass.lpszClassName := MyClassName; {Result} WinRegister := RegisterClass(WindowClass) <> 0;end; procedure FontSize(var TLF:TLOGFONT;Height:integer; bold:boolean);begin with TLF do begin lfHeight := Height; // Default logical height of font lfWidth := 0; // Default logical average character width lfEscapement := 0; // angle of escapement lfOrientation := 0; // base-line orientation angle if bold then lfWeight:=800 else lfWeight:= FW_NORMAL; // font weight lfItalic := 0; // italic attribute flag lfUnderline := 0; // underline attribute flag lfStrikeOut := 0; // strikeout attribute flag lfCharSet := DEFAULT_CHARSET; // character set identifier lfOutPrecision := OUT_DEFAULT_PRECIS; // output precision lfClipPrecision := CLIP_DEFAULT_PRECIS; // clipping precision lfQuality := DEFAULT_QUALITY; // output quality lfPitchAndFamily := DEFAULT_PITCH; // pitch and family Strcopy(lfFaceName,'Courier New'); // pointer to typeface name string end; {==}end {FontSize}; function WinCreate: HWnd;var hWaux: HWnd; TheLogFont:TLogFont; begin hWaux := CreateWindow( MyClassName, {Defined in WinRegister} 'aWindow', {Name of window} ws_OverlappedWindow, {Style} cw_UseDefault, {X} cw_UseDefault, {Y} cw_UseDefault, {width} cw_UseDefault, {heighth} 0, {Parent} 0, {Menu} system.MainInstance, {hInstance} nil); {lpVOID} if hWaux <> 0 then begin {Selectfont;} FontSize(TheLogFont,DefFntSize,false); TheColor := GetSysColor(COLOR_WINDOWTEXT); TheFont1 := CreateFontIndirect(TheLogFont); SendMessage(hWaux,WM_SETFONT,TheFont1,1); ShowWindow(hWaux, CmdShow); UpdateWindow(hWaux); end; {Result} WinCreate := hWaux;end; Procedure DestroyWindow;var cont: boolean;begin DeleteObject(TheFont1); sendmessage(hWindow,wm_Destroy,0,0);end {destroywindow}; begin mb_Ok := 0; if Winregister then hWindow:=WinCreate; sendmessage(hWindow,wm_paint,0,0); DestroyWindow;end.
--- End quote ---
You need a while loop (line 133 ish)
Repeat your code:
--- Code: Pascal [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---program SimpleTest3;{$mode objfpc}{$H+} uses Classes, Windows, Messages, SysUtils ;const MyClassName = 'JustAnotherWindow'; DefFntSize=12;type Tsem =(dflt,dbg,key_prw);var{test specif. vars} i: integer; mb_Ok: LongWord; ic: integer; hWindow: HWnd; TheFont1: HFont; TheColor: DWORD; function WindowProc(Window: HWnd; AMessage, WParam, LParam: Longint): Longint; stdcall; export; var dc : hdc; ps : Tpaintstruct; r : rect; bres, speckey:boolean; si:integer; as2:ansistring; sem: Tsem;begin WindowProc := 0; ic:=succ(ic); sem:=dbg; case AMessage of wm_paint: begin InvalidateRgn(Window,0,false); dc:=BeginPaint(Window,ps); case sem of dflt:; dbg: begin GetClientRect(Window,@r); DrawText(dc,'Hello world by Free Pascal',-1,@r, DT_SINGLELINE or DT_CENTER or DT_VCENTER); writeln('Best wishes from FP') end {dbg}; key_prw:; end {case sem}; EndPaint(Window,ps); Exit; end; wm_Destroy: begin PostQuitMessage(0); Exit; end; end {case}; WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);end; { Register the Window Class }function WinRegister: Boolean;var WindowClass: WndClass;begin WindowClass.Style := cs_hRedraw or cs_vRedraw; WindowClass.lpfnWndProc := WndProc(@WindowProc); WindowClass.cbClsExtra := 0; WindowClass.cbWndExtra := 0; WindowClass.hInstance := system.MainInstance; WindowClass.hIcon := LoadIcon(0, idi_Application); WindowClass.hCursor := LoadCursor(0, idc_Arrow); WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH); WindowClass.lpszMenuName := pchar(''); WindowClass.lpszClassName := pchar(MyClassName); {Result} WinRegister := RegisterClass(WindowClass) <> 0;end; procedure FontSize(var TLF:TLOGFONT;Height:integer; bold:boolean);begin with TLF do begin lfHeight := Height; // Default logical height of font lfWidth := 0; // Default logical average character width lfEscapement := 0; // angle of escapement lfOrientation := 0; // base-line orientation angle if bold then lfWeight:=800 else lfWeight:= FW_NORMAL; // font weight lfItalic := 0; // italic attribute flag lfUnderline := 0; // underline attribute flag lfStrikeOut := 0; // strikeout attribute flag lfCharSet := DEFAULT_CHARSET; // character set identifier lfOutPrecision := OUT_DEFAULT_PRECIS; // output precision lfClipPrecision := CLIP_DEFAULT_PRECIS; // clipping precision lfQuality := DEFAULT_QUALITY; // output quality lfPitchAndFamily := DEFAULT_PITCH; // pitch and family Strcopy(lfFaceName,'Courier New'); // pointer to typeface name string end; {==}end {FontSize}; function WinCreate: HWnd;var hWaux: HWnd; TheLogFont:TLogFont; emsg:msg;begin hWaux := CreateWindow( MyClassName, {Defined in WinRegister} 'aWindow', {Name of window} ws_OverlappedWindow, {Style} cw_UseDefault, {X} cw_UseDefault, {Y} cw_UseDefault, {width} cw_UseDefault, {heighth} 0, {Parent} 0, {Menu} system.MainInstance, {hInstance} nil); {lpVOID} if hWaux <> 0 then begin {Selectfont;} FontSize(TheLogFont,DefFntSize,false); TheColor := GetSysColor(COLOR_WINDOWTEXT); TheFont1 := CreateFontIndirect(TheLogFont); SendMessage(hWaux,WM_SETFONT,TheFont1,1); ShowWindow(hWaux, CmdShow); UpdateWindow(hWaux); end; {Result} WinCreate := hWaux;While (GetMessage(@eMsg, 0, 0, 0) <> FALSE) dobegin TranslateMessage(@eMsg); DispatchMessage(@eMsg);end; end; Procedure DestroyWindow;var cont: boolean;begin DeleteObject(TheFont1); sendmessage(hWindow,wm_Destroy,0,0);end {destroywindow}; begin mb_Ok := 0; if Winregister then hWindow:=WinCreate; sendmessage(hWindow,wm_paint,0,0); DestroyWindow;end.
Navigation
[0] Message Index
[#] Next page