home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l040 / 10.ddi / CHESS.ZIP / OWABOUT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  9.1 KB  |  320 lines
  1. {************************************************}
  2. {                                                }
  3. {   ObjectWindows Chess Demo                     }
  4. {   About box unit                               }
  5. {   Copyright (c) 1992 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. unit OWAbout;
  10.  
  11. interface
  12.  
  13. uses Winprocs, Wintypes, OWindows, ODialogs;
  14.  
  15. {$R OWAbout.res}
  16.  
  17.   { This about box currently only supports BWCC style dialogs. }
  18. const
  19.   idShade = 100;
  20.   idBump  = 101;
  21.   idHotKey = 103;
  22.  
  23. type
  24.   PCreditWindow = ^TCreditWindow;
  25.   TCreditWindow = object(TWindow)
  26.     Bitmap: HBitmap;
  27.     BitSize: TBitmap;
  28.     ScrollUnit: Integer;
  29.     ScrollRate: Integer;
  30.     ScrollPos: Integer;
  31.     FontHeight: Integer;
  32.     constructor Init(AParent: PWindowsObject; ABitmapName: PChar);
  33.     destructor Done; virtual;
  34.     function  GetClassName: PChar; virtual;
  35.     procedure GetWindowClass(var WC: TWndClass); virtual;
  36.     procedure SetupWindow; virtual;         { First place HWindow is valid }
  37.     procedure WMDestroy(var Msg: TMessage); { Last place HWindow is valid  }
  38.       virtual wm_First + wm_Destroy;
  39.     procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
  40.     procedure ShowCredits; virtual;
  41.     procedure WriteLine(DC: HDC; Y: Word; const S: array of Char); virtual;
  42.     procedure WMTimer(var Msg: TMessage);
  43.       virtual wm_First + wm_Timer;
  44.   end;
  45.  
  46.   PAboutBox = ^TAboutBox;
  47.   TAboutBox = object(TDialog)
  48.     Title: PChar;
  49.     CreditWindow: PCreditWindow;
  50.     constructor Init(AParent: PWindowsObject;
  51.                      ATitle, ABitmapName: PChar);
  52.     destructor Done; virtual;
  53.     procedure SetupWindow; virtual;
  54.     function  GetResName: PChar; virtual;
  55.     procedure InitCreditWindow(ABitmapName: PChar); virtual;
  56.     procedure ShowCredits(var Msg: TMessage);
  57.       virtual id_First + idHotKey;
  58.   end;
  59.  
  60. implementation
  61.  
  62. uses Strings;
  63.  
  64. constructor TCreditWindow.Init(AParent: PWindowsObject;
  65.                                ABitmapName: PChar);
  66. var
  67.   DC: HDC;
  68.   OldFont: HFont;
  69.   TM: TTextMetric;
  70. begin
  71.   inherited Init(AParent, nil);
  72.   Attr.Style := ws_Child or ws_Visible;
  73.   Bitmap := LoadBitmap(HInstance, ABitmapName);
  74.   if Bitmap = 0 then
  75.   begin
  76.     Status := em_InvalidWindow;
  77.     Exit;
  78.   end;
  79.   GetObject(Bitmap, SizeOf(BitSize), @BitSize);
  80.   ScrollPos := 0;
  81.   DC := GetDC(0);
  82.   ScrollUnit := 2;
  83.   ScrollRate := 80;
  84.   OldFont := SelectObject(DC, GetStockObject(ANSI_VAR_FONT));
  85.   GetTextMetrics(DC, TM);
  86.   FontHeight := TM.tmHeight + TM.tmExternalLeading + 5;
  87.   SelectObject(DC, Oldfont);
  88.   ReleaseDC(0, DC);
  89. end;
  90.  
  91. destructor TCreditWindow.Done;
  92. begin
  93.   inherited Done;
  94.   DeleteObject(Bitmap);
  95. end;
  96.  
  97. function TCreditWindow.GetClassName: PChar;
  98. begin
  99.   GetClassName := 'OWLAboutCredits';
  100. end;
  101.  
  102. procedure TCreditWindow.GetWindowClass(var WC: TWndClass);
  103. begin
  104.   inherited GetWindowClass(WC);
  105.   WC.Style := cs_ByteAlignWindow;
  106.   WC.hbrBackground := GetStockObject(Black_Brush);
  107. end;
  108.  
  109. procedure TCreditWindow.SetupWindow;
  110. begin
  111.   inherited SetupWindow;
  112.   SetWindowPos(HWindow, 0, 0, 0, BitSize.bmWidth, BitSize.bmHeight,
  113.                swp_NoMove or swp_NoZOrder or swp_NoActivate or swp_NoRedraw);
  114. end;
  115.  
  116. procedure TCreditWindow.WMDestroy(var Msg: TMessage);
  117. begin
  118.   if ScrollPos <> 0 then { We're scrolling and need to kill the timer }
  119.   begin
  120.     KillTimer(HWindow, 1);
  121.     ScrollPos := 0;
  122.   end;
  123.   inherited WMDestroy(Msg);
  124. end;
  125.  
  126. const
  127.   CreditText: array[1..8] of PChar = (
  128.     '',
  129.     'OWLChess''s Chess engine,',
  130.     'contained in CHESS.DLL, is',
  131.     'a modernized version of the',
  132.     'Chess program supplied in',
  133.     'Borland''s GameWorks Toolbox.',
  134.     '',
  135.     '');
  136.  
  137. procedure TCreditWindow.Paint(DC: HDC; var PS: TPaintStruct);
  138. var
  139.   R: TRect;
  140.   FirstLine, LastLine: Integer;
  141.   S: array [0..50] of Char;
  142.   CryptMark: Longint;
  143.   Y: Integer;
  144.  
  145.   procedure DrawBitmap(Y: Integer);
  146.   var
  147.     MemDC: HDC;
  148.     OldBits: HBitmap;
  149.   begin
  150.     MemDC:= CreateCompatibleDC(DC);
  151.     OldBits := SelectObject(MemDC, Bitmap);
  152.     BitBlt(DC, 0, Y, Attr.W, Attr.H, MemDC, 0, 0, srcCopy);
  153.     SelectObject(MemDC, OldBits);
  154.     DeleteDC(MemDC);
  155.   end;
  156.  
  157. begin
  158.   SaveDC(DC);
  159.   SetViewportOrg(DC, 0, -ScrollPos);
  160.   OffsetRect(PS.rcPaint, 0, ScrollPos);
  161.   with R do
  162.   begin
  163.     Left := 0;
  164.     Top := 0;
  165.     Right := Attr.W;
  166.     Bottom := Attr.H;
  167.   end;
  168.   if Bool(IntersectRect(R, PS.rcPaint, R)) then
  169.   begin
  170.     DrawBitmap(0);
  171.     with PS.rcPaint do
  172.     begin
  173.       if (R.Top < Top) and (R.Bottom > Top) then Top := R.Bottom;
  174.       if (R.Top < Bottom) and (R.Bottom > Bottom) then Bottom := R.Top;
  175.       if Top > Bottom then Top := Bottom;
  176.     end;
  177.   end;
  178.   if ScrollPos > 0 then    { we're scrolling }
  179.   begin
  180.     FirstLine := (PS.rcPaint.Top - Attr.H) div FontHeight;
  181.     if FirstLine < 0 then FirstLine := 0;
  182.     if FirstLine < High(CreditText) then
  183.     begin                             { we have text to draw }
  184.       SetTextAlign(DC, TA_Center);
  185.       SetBkColor(DC, 0);
  186.       SetTextColor(DC, RGB($ff,$ff,$ff));
  187.       LastLine := (PS.rcPaint.Bottom - Attr.H) div FontHeight;
  188.       for Y := FirstLine to LastLine do
  189.         if Y < High(CreditText) then
  190.           WriteLine(DC, Y*FontHeight + Attr.H, CreditText[Y + 1]^);
  191.     end;
  192.                             { Paint second image of bitmap at bottom }
  193.     if PS.rcPaint.Bottom > (Attr.H+FontHeight*High(CreditText)) then
  194.       DrawBitmap(Attr.H + FontHeight * High(CreditText));
  195.   end;
  196.   RestoreDC(DC, -1);
  197. end;
  198.  
  199. procedure TCreditWindow.ShowCredits;
  200. begin
  201.   SetTimer(HWindow, 1, ScrollRate, nil);
  202. end;
  203.  
  204. procedure TCreditWindow.WriteLine(DC: HDC; Y: Word; const S: array of Char);
  205. begin
  206.   TextOut(DC, Attr.W div 2, Y, @S, StrLen(@S));
  207. end;
  208.  
  209. procedure TCreditWindow.WMTimer(var Msg: TMessage);
  210. begin
  211.   Inc(ScrollPos, ScrollUnit);
  212.   { Check to see if it's time to stop scrolling }
  213.   if ScrollPos > Attr.H + FontHeight * High(CreditText) then
  214.   begin
  215.     ScrollPos := 0;
  216.     KillTimer(HWindow, 1);
  217.     InvalidateRect(HWindow, nil, False);
  218.   end
  219.   else
  220.     ScrollWindow(HWindow, 0, -ScrollUnit, nil, nil);
  221.   UpdateWindow(HWindow);
  222. end;
  223.  
  224. constructor TAboutBox.Init(AParent: PWindowsObject;
  225.                            ATitle, ABitmapName: PChar);
  226. begin
  227.   inherited Init(AParent, GetResName);
  228.   Title := StrNew(ATitle);
  229.   InitCreditWindow(ABitmapName);
  230. end;
  231.  
  232. destructor TAboutBox.Done;
  233. begin
  234.   inherited Done;
  235.   if Title <> nil then
  236.     StrDispose(Title);
  237. end;
  238.  
  239. procedure TAboutBox.SetupWindow;
  240. var
  241.   RDialog,R,RBitWnd,RShade,RBump,ROk: TRect;
  242.   X8, Y8: Integer;
  243.   DC: HDC;
  244. begin
  245.   inherited SetupWindow;
  246.   SetWindowText(HWindow, Title);
  247.   DC := GetDC(HWindow);
  248.   X8 := GetDeviceCaps(DC,LogPixelsX) div 8;   { 1/8 inch }
  249.   Y8 := GetDeviceCaps(DC,LogPixelsY) div 8;
  250.   ReleaseDC(HWindow, DC);
  251.   GetClientRect(GetDlgItem(HWindow, idShade), RShade);
  252.   GetClientRect(GetDlgItem(HWindow, idBump), RBump);
  253.   GetClientRect(GetDlgItem(HWindow, idOK), ROk);
  254.   GetClientRect(CreditWindow^.HWindow, RBitWnd);
  255.   RShade.Top := Y8;
  256.   RShade.Left := X8;
  257.   if RShade.Right < RBitWnd.Right + 2*X8 then
  258.     RShade.Right := RBitWnd.Right + 2*X8;
  259.   if RShade.Bottom < RBitWnd.Bottom + 2*Y8 then
  260.     RShade.Bottom := RBitWnd.Bottom + 2*Y8;
  261.  
  262.   with  RDialog do
  263.   begin
  264.     GetWindowRect(HWindow, RDialog);
  265.     GetClientRect(HWindow, R);
  266.     Right := Right - Left - R.Right;
  267.     Bottom := Bottom - Top - R.Bottom;
  268.     Right := Right + X8 + RShade.Right + X8;   { 1/8 inch margins }
  269.     Bottom := Bottom + Y8 + RShade.Bottom
  270.                      + Y8 + RBump.Bottom
  271.                      + Y8 + ROk.Bottom + Y8;
  272.     if Parent <> nil then
  273.     begin
  274.       GetWindowRect(Parent^.HWindow, R);
  275.         { Center dialog in parent's window }
  276.       Left := R.Left + (R.Right - R.Left) div 2 - Right div 2;
  277.       Top := R.Top + (R.Bottom - R.Top) div 2 - Bottom div 2;
  278.     end;
  279.     SetWindowPos(HWindow, 0, Left, Top, Right, Bottom,
  280.                  swp_NoActivate or swp_NoZOrder);
  281.   end;
  282.   with RShade do
  283.   begin
  284.     SetWindowPos(GetDlgItem(HWindow, idShade), 0, Left, Top,
  285.                  Right, Bottom, swp_NoActivate or swp_NoZOrder);
  286.     SetWindowPos(CreditWindow^.HWindow, 0,  Left + X8, Top + Y8, 0, 0,
  287.                  swp_NoActivate or swp_NoSize or swp_NoZOrder);
  288.   end;
  289.   with RBump do
  290.   begin
  291.     Left := -1;
  292.     Right := RDialog.Right + 2;
  293.     Top := RShade.Top + RShade.Bottom + Y8 ;
  294.     SetWindowPos(GetDlgItem(HWindow, idBump), 0, Left, Top, Right, Bottom,
  295.                  swp_NoActivate or swp_NoZOrder);
  296.   end;
  297.   GetClientRect(HWindow, R);
  298.   with ROk do
  299.     SetWindowPos(GetDlgItem(HWindow, idOk), 0,
  300.                  R.Right div 2 - Right div 2,
  301.                  RBump.Top + RBump.Bottom + Y8, 0, 0,
  302.                  swp_NoActivate or swp_NoZOrder or swp_NoSize);
  303. end;
  304.  
  305. function TAboutBox.GetResName: PChar;
  306. begin
  307.   GetResName := 'dlgAbout';
  308. end;
  309.  
  310. procedure TAboutBox.InitCreditWindow(ABitmapName: PChar);
  311. begin
  312.   CreditWindow := New(PCreditWindow, Init(@Self, ABitmapName));
  313. end;
  314.  
  315. procedure TAboutBox.ShowCredits(var Msg: TMessage);
  316. begin
  317.   CreditWindow^.ShowCredits;
  318. end;
  319.  
  320. end.