unit wPopupWindow0;

{ Feel free to use this unit as you want.
  First developped by Bernard Gisin
  This unit uses object programming to simplify the developpment
  of programs.

  This unit helps creating and manipulating simple popup windows
  to show a help text givent in the  .msg  file.
  example is given in tEx037.pp
----------------------------------}

// To tell FreePascal that the application is a Graphical User Interface
// i.e. is running in windows, not in text mode.
{$APPTYPE GUI}

INTERFACE
//"""""""

uses  wWindowBase0, wVariableNumLink2, wGlobals2, windows;

type
  PPopupWindow0 = ^TPopupWindow0;
  TPopupWindow0 = object(TWindowBase)
  //"""""""""""""""""""""""""""""""""
  // Handle on the window. (=0 when not created)
//  hWin     : HWND;  // Handle on the window, got from TWindowBase
//  hParent : HWND;  // Handle on the parent, got from TWindowBase
//  poParent: PWindowBase0;  // Pointer on the parent, got from TWindowBase

  lPreviousAddress : longint;
  // Memorise the address of the previous window message handler.

  // positions and sizes in pixels are integers
  nXPosPix,   // X position in pixels in the parent window, = 0 if not used
  nYPosPix,   // Y position in pixels in the parent window, = 0 if not used
  nXSizePix,  // X size in pixels, = 0 if not used
  nYSizePix   // Y size in pixels, = 0 if not used
              : int32;

  nLeftMargine,   // Little margines, between the text and the window.
  nTopMargine,
  nRightMargine,
  nBottomMargine,
  nYIncrementPix : int32;
  // Line height

  colWinText,
  colWinBack  : word32;
  // Color of the text, and of the back of the popup window

  strClassName : TSTRLabel;
  // Class name of the PopupWindow.

  dwExStyle,  // extended style, redefined in the descendents
  dwStyle     // style of the PopupWindow, redefined in the descendents.
              : word32;

  poGrParent : PWindowBase;
  // Pointer on the grand parent, if it has any.
  // if the PopupWindow is in a dialog box, owned by a window,
  // it points to that window object.

  msgTextPopup : word32;
  // if non zero, indicates a popup menu in the message file
  // which should be opened if contextual menu is wanted
  // by clicking with the right button.
  // Will be set at creation of the popup window

  constructor Init(poParentW:PWindowBase0);
  // Call Init; at the beggining of a new Init constructor.

  destructor  Done; virtual;
  // Call Done; at the end of a new destructor.

  procedure AutoComputeSize; virtual;
  // Compute the size of the window, such that the text fits exacly inside.

  procedure PopupWindowCreate(msgTextL:word32); virtual;
  // Create the window of the PopupWindow.
  // Must have a parent object window, defined in the init.
  // msgTextL is a number refering the  .msg  file, for the
  // text to be displayed in the window.

  function WMPaint(hWindow:HWND):LRESULT; virtual;
  // Paint the popup window

  function PopupWindowProc(hWindow:HWND; wMsg:UINT; wPar:WPARAM; lPar:LPARAM):LRESULT; virtual;
  // Handles the window messages
  // A SendMessage(hWin, ...) must not be called from here,
  // to avoid calling loops. (SendMessage(hWin...) calls this function

  end; // TPopupWindow0 = object(TWindowBase)
  TPopupWindow =  TPopupWindow0;
  PPopupWindow = ^TPopupWindow;

procedure PopupWindowMessage(wMsgNum:Word32; nXPosL,nYPosL:int32; poParentL:PWindowBase);
// ================================================================================
// To open a popup window with the text contained in the message number wMsgNum
// appairing at position nXPos, nYPos in pixels.
// If they are set to (-1, -1) then the mouse cursor position is taken

IMPLEMENTATION
//""""""""""""

uses wParamApplic2, wMessages2, wErrors0, wDebug0, wObjectCreatorLOW2;

var glnNotUsed : integer; // To avoid an error in the DevPascal 1.9 environment

procedure PopupWindowMessage(wMsgNum:Word32; nXPosL,nYPosL:int32; poParentL:PWindowBase);
// ======================================================================================
// To open a popup window with the text contained in the message number wMsgNum
// appairing at position nXPos, nYPos in pixels.
// If they are set to (-1, -1) then the mouse cursor position is taken
var
  poPop       : PPopupWindow;
begin
poPop:=gglpoObjCreate^.CreatePopupWindow(poParentL);

if (nXPosL <> -1) then poPop^.nXPosPix :=nXPosL;
if (nYPosL <> -1) then poPop^.nYPosPix :=nYPosL;

poPop^.PopupWindowCreate(wMsgNum);
end;  //  PopupWindowMessage

Function MainPopupWindowProc(hWindow:HWND; wMsg:UINT; wPar:WPARAM; lPar:LPARAM):LRESULT; stdcall; export;
//=======================================================================================================
// This is the message handle function, which calls the
// PopupWindow  'PopupWindowProc' function
var
  // corresponding object PopupWindow
  poPopup      : PPopupWindow0;

Begin
// Gets the adress of the object corresponding to this PopupWindow.
poPopup:=Pointer(GetWindowLong(hWindow, GWL_USERDATA));

// If we arrived here, the pointer is correct, since it has been modified
// in the same place where the PopupWindow window procedure message handling
// has been changed. This could be verified knowing that
// poPopup^.hWin = hWindow always.
// Thus call the event handler of the object.
MainPopupWindowProc:=poPopup^.PopupWindowProc(hWindow, wMsg, wPar, lPar);
End;  // MainPopupWindowProc

//***************************************************
// TPopupWindow0 = object(TWindowBase)
//***************************************************

constructor TPopupWindow0.Init(poParentW:PWindowBase0);
//=====================================================
var
  rPts        : POINT; // where is the mouse cursor ?
begin
inherited Init(poParentW);

// Memorise who is the parent object window.
poParent:=poParentW;

wWindowType:=GGLCTE_POPUP_WINDOW;

// This will be set by a descendent.
lPreviousAddress:=0;

// Get the position of the mouse
GetCursorPos(rPts);

// Set the upper left position at the mouse cursor position.
nXPosPix :=rPts.x;
nYPosPix :=rPts.y;

// Sizes will be determined juste after window's creation.
nXSizePix  := 10;
nYSizePix  := 10;

// Some default margines.
nLeftMargine   :=4;
nTopMargine    :=4;
nRightMargine  :=4;
nBottomMargine :=4;

// Default line increment
nYIncrementPix:=gglpoPrm^.wHeightPix_Ch;

// Normal className of a normal window.
strClassName  :=gglstrClassWinName;

// Default text and background colors.
colWinText :=RGB(  0,  0,  0); // Black
colWinBack :=RGB(255,255,192); // Yellow

dwExStyle :=0;  // no extra styles by default, modified in the descendent
dwStyle   :=  WS_POPUP or WS_BORDER;

msgTextPopup:=0;
end;  // TPopupWindow0.Init

destructor TPopupWindow0.Done;
//============================
begin
inherited Done;
end;  // TPopupWindow0.Done

procedure TPopupWindow0.AutoComputeSize;
//======================================
// Compute the size of the window, such that the text fits exacly inside.
var
  strSFirst,
  strS        : ShortString;
  hDCWin      : HDC;
  wSecurity,
  wMaxWidthL,  // will be the width of the window.
  wMaxHeightL
              : word;
  rSize       : SIZE;  // width and heigth of the text, in pixels

begin
strSFirst:=GetMsg(msgTextPopup); // get first line, ignored if the line really exist,
                                 // if not, show an error in the popup window
strS:=GetMsg(msgNext);      // get first line to display

// Gets a device context, to compute the width of the window
hDCWin :=GetDC(hWin);

wMaxWidthL  :=0;
wMaxHeightL :=0;

// Loop over all the text, to compute the size of the window,
// such that the text fits in.
wSecurity:=50;

if (Copy(strSFirst,1,3)= '???') then begin
   // line not valide, idicate it.
   strS:=strSFirst + '  Line not found';
   wSecurity:=1; // to display only one line
   end;

while (strS <> '...END') and (wSecurity > 0) do begin
   strS[length(strS)+1]:=#0; // probably useless
   GetTextExtentPoint32(hDCWin, @strS[1], length(strS), @rSize);

   if (wMaxWidthL < rSize.cx) then wMaxWidthL:=rSize.cx;
   wMaxHeightL :=wMaxHeightL + nYIncrementPix;

   strS:=GetMsg(msgNext);
   dec(wSecurity);
   end;

ReleaseDC(hWin, hDCWin);

nXSizePix  :=wMaxWidthL  + nLeftMargine + nRightMargine;
nYSizePix  :=wMaxHeightL + nTopMargine  + nBottomMargine;
end;  // TPopupWindow0.AutoComputeSize

procedure TPopupWindow0.PopupWindowCreate(msgTextL:word32);
//=========================================================
Begin // TPopupWindow0.PopupWindowCreate
if (msgTextL = 0) then exit; // nothing to display

msgTextPopup:=msgTextL;

if (poParent = NIL) or (poParent = @Self) then begin
   // If no parent then the main window is the parent and the
   // PopupWindow becomes a popup window.
   poParent:=gglpoMainWindowCopy;
   end;

if (poParent = NIL) or (poParent^.hWin = 0) then begin
   ErrorWrite( 1, 'in TPopupWindow0.PopupCreate');
   ErrorComment( 1, 'PopupWindows must have a valid parent.');
   ErrorComment( 1, 'Parent pointer = ' + IntToStr(word32(poParent), 0));
   if (poParent <> NIL) then
      ErrorComment( 1, 'Parent handle  = ' + IntToStr(poParent^.hWin, 0));
   ErrorComment( 1, 'ClassName = ' + strClassName);
   exit;  // can't do anything more
   end;

// Creates the PopupWindow
hParent :=poParent^.hWin; // both are always the same

strClassName[length(strClassName)+1]:=#0;

hWin := CreateWindowEx ( dwExStyle, @strClassName[1], NIL,
                         dwStyle, nXPosPix, nYPosPix, 100, 30,
                         hParent, 0, // PopupWindows don't have menus.
                         System.MainInstance, NIL);

If (hWin = 0) Then Begin
   ErrorWrite( 3, 'in TPopupWindow0.PopupCreate');
   ErrorComment( 3, 'Handle on PopupWindow could not be created,');
   ErrorComment( 3, 'ClassName = ' + strClassName);
   exit;  // can't do anything more
   end;

// Compute the sizes, such that the text fits exactly in.
AutoComputeSize;
MoveWindow(hWin, nXPosPix, nYPosPix, nXSizePix, nYSizePix, FALSE);

ShowWindow(hWin, SW_SHOWNORMAL);

// Changes the function which handles the windows messages and
// memorise the address of the previous function which handle the messages
// If the return value is 0, there was an error.
// The new handling function will never be called.
lPreviousAddress:=SetWindowLong( hWin, GWL_WNDPROC,
                                 longint(@MainPopupWindowProc));

If (lPreviousAddress = 0) Then Begin
   ErrorWrite( 4, 'in TPopupWindow0.CtrlCreate');
   ErrorComment( 4, 'Handle on PopupWindow could not be created,');
   ErrorComment( 4, 'ClassName = ' + strClassName);
   exit;  // can't do anything more
   end;

// Memorises the pointer on the object PopupWindow, in the
// PopupWindow created by windows, in order to reuse it
SetWindowLong(hWin, GWL_USERDATA, longint(@Self));

// Capture the mouse
SetCapture(hWin);
End;  // TPopupWindow0.PopupWindowCreate

function TPopupWindow0.WMPaint(hWindow:HWND):LRESULT;
//===================================================
// Paint the popup window
var
  hDCPaint    : HDC;
  rPaint      : PAINTSTRUCT;
  rRec        : RECT;
  hBr         : HBRUSH;  // needed to paint
  rLogBr      : LOGBRUSH;
  nXPosL,     // where should the text come
  nYPosL,
  nSecurity   : integer; // to not loop forever
  strSFirst,
  strS        // Text to show in the popup window
              : ShortString;

Begin
if (msgTextPopup = 0) then exit;

strSFirst:=GetMsg(msgTextPopup); // get first line, ignored, if it is a valide one
strS:=GetMsg(msgNext);      // get first line to display

// Gets the info to paint.
hDCPaint :=BeginPaint(hWindow, @rPaint);

// Sets the text colors.
SetTextColor(hDCPaint, colWinText);
SetBkColor(hDCPaint,  colWinBack);
SetBkMode(hDCPaint, OPAQUE);

// must fill the complete Win window.
rLogBr.lbStyle :=BS_Solid;
rLogBr.lbColor :=colWinBack;
rLogBr.lbHatch :=HS_VERTICAL; // not important since BS_Solid
hBr:=CreateBrushIndirect(rLogBr);

// get the region to be filled
GetClientRect(hWindow, @rRec);

FillRect(hDCPaint, rRec, hBr);

// must delete the brush to free Windows resources.
DeleteObject(hBr);

// Loop to display the text.
nXPosL:=nLeftMargine;
nYPosL:=nTopMargine;
nSecurity:=50;

if (Copy(strSFirst,1,3)= '???') then begin
   // line not valide, idicate it.
   strS:=strSFirst + '  Line not found';
   nSecurity:=1; // to display only one line
   end;

while (strS <> '...END') and (nSecurity > 0) do begin
   strS[length(strS)+1]:=#0; // probably useless
   TextOut(hDCPaint, nXPosL, nYPosL, @strS[1], length(strS));
   strS:=GetMsg(msgNext);
   dec(nSecurity);
   nYPosL:=nYPosL + nYIncrementPix;
   end;

EndPaint(hDCPaint, @rPaint);

WMPaint:=0;
end;  //  TPopupWindow0.WMPaint

function TPopupWindow0.PopupWindowProc(hWindow:HWND; wMsg:UINT; wPar:WPARAM; lPar:LPARAM):LRESULT;
//===========================================================================================
// Handles the window messages
// A SendMessage(hWin, ...) must not be called from here,
// to avoid calling loops. (SendMessage(hWin...) calls this function
var
  poPopup     : PPopupWindow;
  nDiff       : int32; // Store the address of Child - Parent

begin
// Call the previous window proc of a PopupWindow
if (lPreviousAddress = 0) then begin
   ErrorWrite( 1, 'in TPopupWindow0.PopupWindowProc');
   ErrorComment( 1,'IMPOSSIBLE, Cannot call the original message handler of the PopupWindow');
   ErrorComment( 1,'PopupWindow window name = ' + strWindowName);
   ErrorComment( 1,'PopupWindow class = ' + strClassName);
   exit;
   end;

{if (wMsg <> WM_MouseMove)   and (wMsg <> WM_NCMouseMove) and
   (wMsg <> WM_MENUSELECT )   and (wMsg <> WM_ENTERIDLE ) and
   (wMsg <> WM_SetCursor)   and (wMsg <> WM_NCHittest) and
//   (wMsg <> WM_SetFocus) and (wMsg <> WM_KillFocus) and
//   (wMsg <> WM_KEYDOWN) and (wMsg <> WM_KEYUP) and
   (wMsg <> WM_Move)        and (wMsg <> WM_NCActivate) then
   DBW0(64, DBMsgToStr(wMsg) + ITS(wPar) + ITS(lPar)); }


// The popup window's life is short.
if (wMsg = WM_RBUTTONDOWN) or (wMsg = WM_LBUTTONDOWN) or
   (wMsg = WM_KEYDOWN) then begin
   ReleaseCapture;
   destroyWindow(hWin);
   end;

if (wMsg = WM_Paint) then PopupWindowProc:=WMPaint(hWindow)
else // Default handling of the PopupWindow
     PopupWindowProc:=CallWindowProc( WNDPROC(lPreviousAddress), hWindow,
                                      wMsg, wPar, lPar);

if (wMsg = WM_NCDestroy) and (wIsDone = 1) then begin
   // Window has still not been destroyed
   hWin:=0; // Do not call destroy again
   // Dispose the object window.
   // Verify if it was created with New of if its a member of its parent object
   nDiff:=int32(@Self) - int32(poParent);
   if (nDiff > 0) and (nDiff < SizeOf(poParent^)) then Done
   else begin
      // normal case, the popup window has been created with the  new(..  procedure
      poPopup:=@Self;
      dispose(poPopup, Done);
      end;
   end;
end; // TPopupWindow0.PopupWindowProc

end.  // unit wPopupWindow0;

