home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ABOUTBOX.ZIP / ABOUTBOX.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-19  |  9.0 KB  |  327 lines
  1. { About box unit, from PC Mag, June 15, 1993 }
  2.  
  3. unit AboutBox;
  4.  
  5. interface
  6.  
  7. uses WinProcs, WinTypes, Objects, OWindows, ODialogs;
  8.  
  9. {$R About.res }
  10.  
  11. const
  12.      idShade = 100;
  13.      idBump = 101;
  14.      idHotKey = 103;
  15.  
  16. type
  17.     ppCharArray = ^tpCharArray;
  18.     tpCharArray = array[0..65520 div sizeof(pChar)] of pChar;
  19.  
  20.     pCreditWindow = ^tCreditWindow;
  21.     tCreditWindow = object(tWindow)
  22.                       BitMap : hBitmap;
  23.                       BitSize : tBitmap;
  24.                       ScrollUnit : integer;
  25.                       Scrollrate : integer;
  26.                       ScrollPos : integer;
  27.                       Fontheight : integer;
  28.                       StringList : ppCharArray;
  29.                       StringCount : word;
  30.                       constructor Init(Aparent : pWindowsObject;
  31.                                        ABitmapName : pChar;
  32.                                        const AStringList : array of pChar);
  33.                       destructor Done; virtual;
  34.                       function GetClassName : pChar; virtual;
  35.                       procedure GetWindowClass(var AWndClass : tWndClass); virtual;
  36.                       procedure SetUpWIndow; virtual;
  37.                       procedure WMDestroy(var Msg : TMessage);
  38.                                 virtual wm_First + wm_Destroy;
  39.                       procedure Paint(DC : hDC; var PS : tPaintStruct); virtual;
  40.                       procedure ShowCredits; virtual;
  41.                       procedure WMTImer(var Msg : TMessage);
  42.                                 virtual wm_First + wm_Timer;
  43.                     end;
  44.  
  45.     pAboutBox = ^tAboutBox;
  46.     tAboutBox = object(tDialog)
  47.                   Title : pChar;
  48.                   CreditWindow : pCreditWindow;
  49.                   constructor Init(AParent : pWindowsObject;
  50.                                    ATitle,ABitMapName  : pChar;
  51.                                    const AStringList : array of pChar);
  52.                   destructor Done; virtual;
  53.                   procedure SetUpWindow; virtual;
  54.                   function GetResName : pChar; virtual;
  55.                   procedure InitCreditWindow(ABitMapName : pChar;
  56.                                        const AStringList : array of pChar);
  57.                             virtual;
  58.                   procedure ShowCRedits(var Msg : TMessage);
  59.                             virtual id_First + idHotKey;
  60.                 end;
  61.  
  62. implementation
  63.  
  64.   uses Strings;
  65.  
  66. constructor tCreditWindow.Init;
  67.  
  68.   var
  69.      DC : hDC;
  70.      OldFont : hFOnt;
  71.      TM : tTextMetric;
  72.  
  73.   begin
  74.     inherited Init(Aparent,nil);
  75.     Attr.Style := ws_Child or ws_Visible;
  76.     Bitmap := LoadBitMap(hInstance,ABitMapName);
  77.     if BitMap = 0 then
  78.     begin
  79.       Status := em_InvalidWindow;
  80.       Exit;
  81.     end;
  82.     GetObject(Bitmap,sizeof(BitSize),@BitSize);
  83.     ScrollPos := 0;
  84.     DC := GetDC(0);
  85.     ScrollUnit := 2;
  86.     ScrollRate := 80;
  87.     OldFont := SelectObject(DC,GetStockObject(ANSI_VAR_FONT));
  88.     GetTextMetrics(DC,TM);
  89.     FontHeight := TM.tmHeight + TM.tmExternalLeading + 5;
  90.     SelectObject(DC,OldFont);
  91.     ReleaseDC(0,DC);
  92.     StringList := @AStringList;
  93.     StringCount := high(AStringList);
  94.   end;
  95.  
  96. destructor tCreditWIndow.Done;
  97.  
  98.   begin
  99.    inherited Done;
  100.    DeleteObject(Bitmap);
  101.   end;
  102.  
  103. function tCreditWindow.GetClassName : pChar;
  104.  
  105.   begin
  106.     GetClassName := 'TNHAboutMap';
  107.   end;
  108.  
  109. procedure tCreditWindow.GetWindowClass;
  110.  
  111.   begin
  112.     inherited GetWindowClass(AWndClass);
  113.     AWndClass.Style := cs_ByteAlignWindow;
  114.     AWndClass.hbrBackGround := GetStockObject(Black_Brush);
  115.   end;
  116.  
  117. procedure tCreditWindow.SetUpWindow;
  118.  
  119.   begin
  120.     inherited SetUpWindow;
  121.     SetWIndowPos(hWIndow,0,0,0,BitSize.bmWidth,BitSize.bmHeight,
  122.                  swp_NoMove or swp_NoZOrder or swp_NoACtivate or swp_NoRedraw);
  123.   end;
  124.  
  125. procedure tCreditWindow.WMDestroy;
  126.  
  127.   begin
  128.     if SCrollPos <> 0 then
  129.     begin
  130.       KillTimer(HWindow,1);
  131.       SCrollPos := 0;
  132.     end;
  133.     inherited WMDestroy(Msg);
  134.   end;
  135.  
  136. procedure tCreditWindow.Paint;
  137.  
  138.   var
  139.      R : TRect;
  140.      FirstLine,LastLine,Y : integer;
  141.  
  142.   procedure DrawBitMap(Y : integer);
  143.  
  144.     var
  145.        MemDC : hDC;
  146.        OldBits : hBitmap;
  147.  
  148.     begin
  149.       MemDC := CreateCompatibleDC(DC);
  150.       OldBits := SelectObject(MemDC,Bitmap);
  151.       BitBlt(DC,0,Y,Attr.W,Attr.H,MemDC,0,0,srcCopy);
  152.       SelectObject(MemDC,OldBits);
  153.       DeleteDC(DC);
  154.     end;
  155.  
  156.   begin
  157.     SaveDC(DC);
  158.     SetViewPortOrg(DC,0,-ScrollPos);
  159.     OffsetRect(PS.rcPaint,0,SCrollPos);
  160.     with R do
  161.     begin
  162.       Left := 0; Top := 0;
  163.       Right := Attr.W; Bottom := Attr.H;
  164.     end;
  165.     if Bool(IntersectRect(R,PS.rcpaint,R)) then
  166.     begin
  167.       DrawBitmap(0);
  168.       with PS.rcPaint do
  169.       begin
  170.         if (R.Top < Top) and (R.Bottom > Top) then Top := Bottom;
  171.         if (R.Top < Bottom) and (R.Bottom > Bottom) then Bottom := R.Top;
  172.         if Top > Bottom then TOp := Bottom;
  173.       end;
  174.     end;
  175.     if ScrollPos > 0 then
  176.     begin
  177.       FirstLine := (PS.rcPaint.Top - Attr.H) div FontHeight;
  178.       if FirstLine < 0 then FirstLine := 0;
  179.       if FirstLine < StringCount then
  180.       begin
  181.         SetTextAlign(DC,TA_Center);
  182.         SetBKColor(DC,0);
  183.         SetTextColor(DC,RGB($FF,$FF,$FF));
  184.         LastLine := (PS.rcPaint.Bottom - Attr.H) div FOntHeight;
  185.         for Y := FirstLine to LastLine do
  186.           if Y < StringCount then
  187.             TextOut(DC,Attr.W div 2,Y * FontHeight + Attr.H,
  188.                     StringList^[Y],strlen(StringList^[Y]));
  189.       end;
  190.       if PS.rcPaint.Bottom > (Attr.H + Fontheight * StringCount) then
  191.         DrawBitmap(Attr.H + FontHeight * StringCount);
  192.     end;
  193.     RestoreDC(DC, -1);
  194.   end;  { paint }
  195.  
  196. procedure tCreditWindow.ShowCredits;
  197.  
  198.   begin
  199.     SetTimer(HWindow,1,ScrollRate,nil);
  200.   end;
  201.  
  202. procedure tCreditWindow.WMTImer;
  203.  
  204.   begin
  205.     inc(ScrollPos,SCrollUnit);
  206.     if SCrollPos > Attr.H + FontHeight * StringCount then
  207.     begin
  208.       SCrollPos := 0;
  209.       KillTimer(Hwindow,1);
  210.       InvalidateRect(HWindow,nil,FALSE);
  211.     end
  212.     else
  213.       SCrollWindow(HWIndow,0,-SCrollUnit,nil,nil);
  214.     UpDateWindow(HWIndow);
  215.   end;
  216.  
  217. constructor tAboutBox.Init;
  218.  
  219.   begin
  220.     inherited Init(AParent,GetResName);
  221.     Title := Strnew(Atitle);
  222.     InitCreditWindow(ABitMapName,AStringList);
  223.   end;
  224.  
  225. destructor tAboutBox.Done;
  226.  
  227.   begin
  228.     inherited Done;
  229.     if Title <> nil then StrDispose(Title);
  230.   end;
  231.  
  232. procedure tAboutBox.SetUpWindow;
  233.  
  234.   var
  235.      RDialog,R,RBitWnd,RShade,RBump,ROK : TRect;
  236.      X8,Y8 : integer;
  237.      DC : hDc;
  238.  
  239.   begin
  240.     inherited SetUpWindow;
  241.     SetWindowText(Hwindow,Title);
  242.     Dc := GetDC(Hwindow);
  243.     X8 := GetDeviceCaps(DC,LogPixelsX) div 8;
  244.     Y8 := GetDeviceCaps(DC,LogPixelsY) div 8;
  245.     ReleaseDC(Hwindow,DC);
  246.     GetClientRect(GetDlgItem(HWIndow,idShade),RShade);
  247.     GetClientRect(GetDlgItem(HWIndow,idBump),RBump);
  248.     GetClientRect(GetDlgItem(HWIndow,idOK),ROK);
  249.     GetClientRect(CreditWindow^.HWindow,RBitWnd);
  250.     RShade.Top := Y8;
  251.     RShade.Left := X8;
  252.     if RShade.Right < RBitWnd.Right + (2 * X8) then
  253.       RShade.Right := RBitWnd.Right + 2 * X8;
  254.     if RShade.Bottom < rBitWnd.Bottom + 2 * Y8 then
  255.       RShade.Bottom := RBitWnd.Bottom + 2 * Y8;
  256.     with RDialog do
  257.     begin
  258.       GetWindowRect(Hwindow,RDialog);
  259.       GetClientRect(HWindow,R);
  260.       Right := Right - Left - R.Right;
  261.       Bottom := Bottom - Top - R.Bottom;
  262.       Right := Right + X8 + RShade.Right + X8;
  263.       Bottom := Bottom + Y8 + RShade.Bottom
  264.                        + Y8 + RBump.Bottom
  265.                        + Y8 + ROk.Bottom + Y8;
  266.       if Parent <> nil then
  267.       begin
  268.         GetWindowRect(Parent^.Hwindow,R);
  269.         Left := R.Left + (R.Right - R.Left) div 2 - Right div 2;
  270.         Top := R.Top + (R.Bottom - R.Top) div 2 - Bottom div 2;
  271.       end;
  272.       SetWindowPos(HWindow,0,Left,Top,Right,Bottom,swp_NoActivate or swp_NoZOrder);
  273.     end;
  274.     with RShade do
  275.     begin
  276.       SetWindowPos(GetDlgItem(HWindow,idShade),0,Left,Top,Right,Bottom,
  277.                    swp_NoACtivate or swp_NoZOrder);
  278.       SetWindowPos(CreditWindow^.Hwindow,0,Left + X8,TOp + Y8,0,0,
  279.                   swp_NoACtivate or swp_NoSize or swp_NoZOrder);
  280.     end;
  281.     with RBump do
  282.     begin
  283.       Left := -1; Right := RDialog.Right + 2;
  284.       Top := RShade.Top + RShade.Bottom + Y8;
  285.       SetWindowPos(GetDlgItem(HWindow,idBump),0,Left,Top,Right,Bottom,
  286.                   swp_NoACtivate or swp_NoZOrder);
  287.     end;
  288.     GetClientRect(Hwindow,R);
  289.     with ROk do
  290.       SetWindowPos(GetDlgItem(HWindow,idOK),0,
  291.                    R.Right div 2 - Right div 2,
  292.                    RBump.Top + RBump.Bottom + Y8,0,0,
  293.                   swp_NoACtivate or swp_NoSize or swp_NoZOrder);
  294.   end;
  295.  
  296. function tAboutBox.GetResName : pChar;
  297.  
  298.   begin
  299.     GetResName := 'dlgAbout';
  300.   end;
  301.  
  302. procedure tAboutBox.initCreditWindow;
  303.  
  304.   begin
  305.     CreditWindow := new(pCreditWindow,Init(@Self,AbitmapName,AStringList));
  306.   end;
  307.  
  308. procedure tAboutBox.ShowCredits;
  309.  
  310.   begin
  311.     CreditWindow^.ShowCredits;
  312.   end;
  313.  
  314. end.
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  
  327.