home *** CD-ROM | disk | FTP | other *** search
/ Media Share 13 / mediashare_13.zip / mediashare_13 / ZIPPED / PROGRAM / WTJ9403.ZIP / FUNHOUSE / FUNHOUSE.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-14  |  4KB  |  173 lines
  1. program FunHouse;
  2.  
  3. { define right_way}    { Define this term to make the dlg box display }
  4.                        { properly at various resolutions and sysfont sizes }
  5.  
  6. uses
  7.    Win31,
  8.    WinTypes,
  9.    WinProcs,
  10.    Strings,
  11.    Objects,
  12.    OMemory,
  13.    OWindows,
  14.    ODialogs;
  15.  
  16. {$R funhouse.res}
  17.  
  18. const
  19.    AppName   = 'FunHouse';
  20.    id_bitmap = 100;
  21.    id_mode   = 100;
  22.    id_icon   = 101;
  23.  
  24.    { DLU's! }
  25.    map_rect: TRect = ( left: 75; top: 33; right: 50; bottom: 50);
  26.  
  27.    { Pixels! }
  28.    bad_map_rect: TRect = ( left: 150; top: 66; right: 100; bottom: 100);
  29.  
  30. type
  31.    PFunHouseApp = ^TFunHouseApp;
  32.    TFunHouseApp = object(TApplication)
  33.       procedure InitMainWindow; virtual;
  34.    end;
  35.  
  36.    PFunHouse = ^TFunHouse;
  37.    TFunHouse = object(TDlgWindow)
  38.       constructor Init;
  39.       procedure   SetupWindow; virtual;
  40.       procedure   WMPaint(var Msg: TMessage); virtual wm_First + wm_Paint;
  41.    end;
  42.  
  43. { -------------------------------------------- }
  44.  
  45. procedure TFunHouseApp.InitMainWindow;
  46.  
  47. begin
  48.    MainWindow := New(PFunHouse,Init);
  49. end;
  50.  
  51. { -------------------------------------------- }
  52.  
  53. constructor TFunHouse.Init;
  54.  
  55. begin
  56.   TDlgWindow.Init(nil,PChar(100));
  57. end;
  58.  
  59. { -------------------------------------------- }
  60.  
  61. procedure TFunHouse.SetupWindow;
  62.  
  63. var
  64.    s: array[0..100] of char;
  65.    temp: array[0..20] of char;
  66.    the_rect: TRect;
  67.    scale_x, scale_y: real;
  68.    inc_x, inc_y: integer;
  69.  
  70. begin
  71.    TDlgWindow.SetupWindow;
  72.  
  73.    StrCopy(s,'Display mode: ');
  74.  
  75.    Str(GetSystemMetrics(sm_CXScreen),temp);
  76.    StrCat(s,temp);
  77.    StrCat(s,'x');
  78.    Str(GetSystemMetrics(sm_CYScreen),temp);
  79.    StrCat(s,temp);
  80.    StrCat(s,', ');
  81.    Str(LoWord(GetDialogBaseUnits),temp);
  82.    StrCat(s,temp);
  83.    StrCat(s,'x');
  84.    Str(HiWord(GetDialogBaseUnits),temp);
  85.    StrCat(s,temp);
  86.    StrCat(s,' system font');
  87.    SetWindowText(GetDlgItem(HWindow,id_mode),s);
  88.  
  89. {$ifdef right_way}
  90.    SetWindowText(HWindow,'Corrected Version');
  91.  
  92.    { Correct the icon's position }
  93.  
  94.    GetClientRect(GetDlgItem(HWindow,id_icon),the_rect);
  95.  
  96.    { Translate the client coords from icon relative to dlg relative }
  97.  
  98.    MapWindowPoints(GetDlgItem(HWindow,id_icon),HWindow,the_rect,2);
  99.  
  100.    { The following 2 lines assume that the dialog uses the standard
  101.      system font! }
  102.  
  103.    scale_x := LoWord(GetDialogBaseUnits) /  8 - 1;
  104.    scale_y := HiWord(GetDialogBaseUnits) / 16 - 1;
  105.  
  106.    with the_rect do
  107.       begin
  108.          inc_x := Round(Int((right - left) div 2 * scale_x));
  109.          Inc(left,inc_x);
  110.          Inc(right,inc_x);
  111.  
  112.          inc_y := Round(Int((bottom - top) div 2 * scale_y));
  113.          Inc(top,inc_y);
  114.          Inc(bottom,inc_y);
  115.  
  116.          MoveWindow(GetDlgItem(HWindow,id_icon),left,top,right - left,
  117.            bottom - top,false);
  118.      end;
  119. {$else}
  120.    SetWindowText(HWindow,'Uncorrected Version');
  121. {$endif}
  122. end;
  123.  
  124. { -------------------------------------------- }
  125.  
  126. procedure TFunHouse.WMPaint(var Msg: TMessage);
  127.  
  128. var
  129.    PaintStruct: TPaintStruct;
  130.    my_dc, MemDC: HDC;
  131.    OldBitmap: HBitmap;
  132.    BmpInfo: TBitmap;
  133.    the_map: HBitmap;
  134.    the_rect: TRect;
  135.  
  136. begin
  137.    the_map := LoadBitmap(HInstance,PChar(id_bitmap));
  138.  
  139.    my_dc := BeginPaint(HWindow,PaintStruct);
  140.    MemDC := CreateCompatibleDC(my_dc);
  141.    OldBitmap := SelectObject(MemDC,the_map);
  142.    GetObject(the_map,SizeOf(TBitmap),@BmpInfo);
  143.  
  144. {$ifdef right_way}
  145.    { Convert DLU's to pixels before use }
  146.    the_rect := map_rect;
  147.    MapDialogRect(HWindow,the_rect);
  148.  
  149.    with the_rect do
  150.       StretchBlt(my_dc,left,top,right,bottom,MemDC,
  151.         0,0,BmpInfo.bmWidth,BmpInfo.bmHeight,srcCopy);
  152. {$else}
  153.    { Do a naive BitBlt }
  154.    with bad_map_rect do
  155.       BitBlt(my_dc,left,top,right,bottom,MemDC,0,0,srcCopy);
  156. {$endif}
  157.  
  158.    DeleteObject(SelectObject(MemDC,OldBitmap));
  159.    DeleteDC(MemDC);
  160.  
  161.    EndPaint(HWindow,PaintStruct);
  162. end;
  163.  
  164. { -------------------------------------------- }
  165.  
  166. var
  167.   my_app: TFunHouseApp;
  168.  
  169. begin
  170.    my_app.Init(AppName);
  171.    my_app.Run;
  172.    my_app.Done;
  173. end.