home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / BPASCAL.700 / D11 / RWDEMOS.ZIP / RWPDEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-01  |  13.4 KB  |  436 lines
  1. {************************************************}
  2. {                                                }
  3. {   Resource Workshop Demo                       }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. {
  9.    This example can be compiled with either the "standard" windows look
  10.    or the "Borland look". By default, it uses "standard" windows
  11.    controls. To cause it to use Borland Windows Custom Controls, select
  12.    Options.Compiler and enter BWCC in the Conditional defines field.
  13. }
  14.  
  15.  
  16. program RWPDemo;
  17.  
  18. {$ifdef BWCC}
  19. {$R RWPDEMOB.RES}
  20. {$else}
  21. {$R RWPDEMO.RES}
  22. {$endif}
  23. {$D 'Resource Workshop Demo Program. Copyright (c) Borland 1992'}
  24.  
  25. uses WinTypes, WinProcs, Objects, OWindows, ODialogs,
  26. {$ifdef BWCC}
  27.   BWCC,
  28. {$endif}
  29.   Strings,  RWPDemoC, RWPDlgs, RWPWnd, WinDOS;
  30.  
  31. const
  32.   AppName = 'RWPDEMO';
  33.   StatusLineHeight        =  20;
  34.   TextStart               = 200; { Location for hints in status line }
  35.   EditFirst               = cm_EditUndo;
  36.   EnvironmentFirst        = cm_Preferences;
  37.   FileFirst               = cm_New;
  38.   Helpfirst               = cm_Index;
  39.   OptionFirst             = cm_Directories;
  40.   ViewFirst               = cm_All;
  41.   WindowFirst             = cm_TileChildren;
  42.   am_DrawStatusLine       = wm_User + 200;
  43.  
  44. type
  45.   PRWPApplication = ^RWPApplication;
  46.   RWPApplication = object(TApplication)
  47.     constructor Init(AName: PChar);
  48.     procedure InitMainWindow; virtual;
  49.     procedure Error(ErrorCode: Integer); virtual;
  50.   end;
  51.  
  52. type
  53.   PRWPWindow = ^TRWPWindow;
  54.   TRWPWindow = object(TMDIWindow)
  55.     BmpStatusBar: HBitmap;
  56.     BmpStatusLine: HBitmap;
  57.     CurrentID: Word;
  58.     CurrentPopup: HMenu;
  59.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  60.     destructor  Done; virtual;
  61.     procedure AboutRWP(var Msg: TMessage); virtual cm_First + cm_About_RWP;
  62.     procedure BlastStatusLine(PaintDC: HDC);
  63.     procedure ReconstructStatusLine;
  64.     procedure DefCommandProc(var Msg: TMessage); virtual;
  65.     procedure FileNew(var Msg: TMessage); virtual cm_First + cm_New;
  66.     procedure FileOpen(var Msg: TMessage); virtual cm_First + cm_Open;
  67.     procedure FilePrint(var Msg: TMessage); virtual cm_First + cm_Print;
  68.     function  GetClassName: PChar; virtual;
  69.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  70.     procedure OpenAFile(FileType: Integer; FileName: PChar);
  71.     procedure OptionsDirectories(var Msg: TMessage); virtual cm_First+cm_Directories;
  72.     procedure OptionsMouse(var Msg: TMessage); virtual cm_First+cm_Mouse;
  73.     procedure OptionsOpen(var Msg: TMessage); virtual cm_First+cm_Options_Open;
  74.     procedure OptionsPreferences(var Msg: TMessage); virtual cm_First+cm_Preferences;
  75.     procedure OptionsSave(var Msg: TMessage); virtual cm_First+cm_Options_Save;
  76.     procedure OptionsSaveAs(var Msg: TMessage); virtual cm_First+cm_Options_Saveas;
  77.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  78.     procedure StubDialog(ADialog: PRWPDialog; ACaption: PChar);
  79.     procedure WMDrawStatusLine(var Msg: TMessage); virtual wm_First + am_DrawStatusLine;
  80.     procedure WMMenuSelect(var Msg: TMessage); virtual wm_First + wm_MenuSelect;
  81.     procedure WMEnterIdle(var Msg: TMessage); virtual wm_First + wm_EnterIdle;
  82.     procedure WMSize(var Msg: TMessage); virtual wm_First + wm_Size;
  83.   end;
  84.  
  85. {------------------------- TRWPApplication implementation ---------------}
  86.  
  87. constructor RWPApplication.Init(AName: PChar);
  88. begin
  89.   TApplication.Init(AName);
  90.   HAccTable := LoadAccelerators(HInstance, MakeIntResource(Acc_Main));
  91. end;
  92.  
  93.  
  94. procedure RWPApplication.InitMainWindow;
  95. begin
  96.   MainWindow := New(PRWPWindow, Init(nil, 'Resource Workshop Demo Program'));
  97. end;
  98.  
  99. procedure RWPApplication.Error(ErrorCode: Integer);
  100. var
  101.   Title: array [0..40] of char;
  102.   Msg: array [0..80] of char;
  103. begin
  104.   if (ErrorCode > 0) and
  105.      (LoadString(HInstance, ErrorCode, Msg, SizeOf(Msg)) > 0) and
  106.      (LoadString(HInstance, ErrorCode+1, Title, SizeOf(Title)) > 0) then
  107.     MessageBox(0, Msg, Title, mb_IconExclamation or mb_OK)
  108.   else
  109.     TApplication.Error(ErrorCode);
  110. end;
  111.  
  112.  
  113. {--------------------------- TRWPWindow implementation ------------------}
  114.  
  115. constructor TRWPWindow.Init(AParent:PWIndowsObject; ATitle:PChar);
  116. begin
  117.   TMDIWindow.Init('RWP Application', LoadMenu(HInstance,
  118.     MakeIntResource(men_Main)));
  119.   BmpStatusBar := LoadBitmap(HInstance, MakeIntResource(bmp_StatusBar));
  120.   BmpStatusLine := 0;
  121. end;
  122.  
  123. procedure TRWPWindow.AboutRWP(var Msg:TMessage);
  124. begin
  125.   Application^.ExecDialog(New(PRWPDialog, Init(@Self, MakeIntResource(dlg_About))));
  126. end;
  127.  
  128. procedure TRWPWindow.BlastStatusLine(PaintDC: HDC);
  129. var
  130.   ClientRect: TRect;
  131.   MemDC: HDC;
  132.   OldBmp: THandle;
  133. begin
  134.   GetClientRect(HWindow, ClientRect);
  135.   MemDC := CreateCompatibleDC(PaintDC);
  136.   OldBmp := SelectObject(MemDC, BmpStatusLine);
  137.   with ClientRect do
  138.     BitBlt(PaintDC, 0, Bottom - StatusLineHeight, ClientRect.Right,
  139.       StatusLineHeight, MemDC, 0, 0, SrcCopy);
  140.   SelectObject(MemDC, OldBmp);
  141.   DeleteDC(MemDC);
  142. end;
  143.  
  144. procedure TRWPWindow.DefCommandProc(var Msg: TMessage);
  145. var
  146.   DC: HDC;
  147. begin
  148.   TMDIWindow.DefCommandProc(Msg);
  149.   if CurrentPopup <> 0 then
  150.   begin
  151.     CurrentPopup := 0;
  152.     CurrentID := 0;
  153.     DC := GetDC(HWindow);
  154.     BlastStatusLine(DC);
  155.     ReleaseDC(HWindow, DC);
  156.   end;
  157. end;
  158.  
  159. destructor TRWPWindow.Done;
  160. begin
  161.   DeleteObject(BmpStatusLine);
  162.   DeleteObject(BmpStatusBar);
  163.   TMDIWindow.Done;
  164. end;
  165.  
  166. procedure TRWPWindow.FileNew(var Msg:TMessage);
  167. var
  168.   FileName: array[0..128] of Char;
  169.   FileType: Integer;
  170. begin
  171.   if Application^.ExecDialog(New(PFileNew,
  172.     Init(@Self, FileType))) = id_OK then OpenAFile(FileType, nil)
  173. end;
  174.  
  175. procedure TRWPWindow.FileOpen(var Msg:TMessage);
  176. var
  177.   FileName: array[0..128] of Char;
  178.   FileType: Integer;
  179. begin
  180.   FillChar(Filename, sizeof(FileName), #0);
  181.   StrCopy(Filename, '*.txt');
  182.   FileType := FileWindow;
  183.   if Application^.ExecDialog(New(PFileOpen,
  184.     Init(@Self, FileType, FileName))) = id_OK then
  185.     OpenAFile(FileType,FileName)
  186. end;
  187.  
  188. procedure TRWPWindow.FilePrint(var Msg:TMessage);
  189. begin
  190.   StubDialog(New(PRWPDialog, Init(@Self,MakeIntResource(dlg_Print))),'Print');
  191. end;
  192.  
  193. function TRWPWindow.GetClassName: PChar;
  194. begin
  195.   GetClassName := 'RWPWindow';
  196. end;
  197.  
  198. procedure TRWPWindow.GetWindowClass(var WndClass: TWndClass);
  199. begin
  200.   TMDIWindow.GetWindowClass(WndClass);
  201.   WndClass.HIcon := LoadIcon(HInstance, MakeIntResource(ico_RWPDemo));
  202.   WndClass.HBrBackground := color_AppWorkspace + 1;
  203. end;
  204.  
  205. procedure TRWPWindow.OpenAFile(FileType: Integer; FileName: PChar);
  206. begin
  207.   with PRWPApplication(Application)^ do
  208.     case FileType of
  209.       ScribbleWindow:
  210.         MakeWindow(new(PScribbleWindow, Init(@Self, FileName)));
  211.       FileWindow:
  212.         MakeWindow(new(PEditWindow, Init(@Self, FileName)));
  213.       GraphWindow:
  214.         MakeWindow(new(PGraphWindow, Init(@Self, FileName)));
  215.     end;
  216. end;
  217.  
  218. procedure TRWPWindow.OptionsDirectories(var Msg:TMessage);
  219. begin
  220.   StubDialog(new(PDlgDirectories,
  221.     Init(@Self, MakeIntResource(dlg_Options_Directories))), 'Directories');
  222. end;
  223.  
  224. procedure TRWPWindow.OptionsMouse(var Msg:TMessage);
  225. begin
  226.   StubDialog(new(PRWPDialog,
  227.     Init(@Self, MakeIntResource(dlg_MouseDialog))), 'Mouse');
  228. end;
  229.  
  230. procedure TRWPWindow.OptionsOpen(var Msg:TMessage);
  231. begin
  232.   StubDialog(new(PRWPDialog,
  233.     Init(@Self, MakeIntResource(dlg_Options_Open))), 'Options Open');
  234. end;
  235.  
  236. procedure TRWPWindow.OptionsPreferences(var Msg:TMessage);
  237. begin
  238.   StubDialog(new(PRWPDialog,
  239.     Init(@Self, MakeIntResource(dlg_Preferences))), 'Preferences');
  240. end;
  241.  
  242. procedure TRWPWindow.OptionsSave(Var Msg: TMessage);
  243. begin
  244.   MessageBox(HWindow, 'Feature not implemented', 'Options Save', mb_OK);
  245. end;
  246.  
  247. procedure TRWPWindow.OptionsSaveAs(var Msg:TMessage);
  248. begin
  249.   StubDialog(new(PRWPDialog,
  250.     Init(@Self,MakeIntResource(dlg_Options_SaveAs))), 'Options SaveAs');
  251. end;
  252.  
  253. procedure TRWPWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  254. begin
  255.   TMDIWindow.Paint(PaintDC, PaintInfo);
  256.   BlastStatusLine(PaintDC);
  257. end;
  258.  
  259. procedure TRWPWindow.StubDialog(ADialog: PRWPDialog; ACaption: PChar);
  260. begin
  261.   if Application^.ExecDialog(ADialog) = id_Ok then
  262.     MessageBox(HWindow, 'Feature not implemented', ACaption, mb_OK);
  263. end;
  264.  
  265. procedure TRWPWindow.WMDrawStatusLine(var Msg: TMessage);
  266. var
  267.   DC: HDC;
  268.   Rect: TRect;
  269.   Str: array[0..128] of Char;
  270.   StrID: Integer;
  271.   Lf: TLogFont;
  272.   hSmall, hOld: HFont;
  273.   TextHeight: Integer;
  274. begin
  275.   if CurrentID <> 0 then
  276.   begin
  277.     case CurrentID of
  278.       cm_New: StrID := sth_FileNew;
  279.       cm_Open: StrID := sth_FileOpen;
  280.       cm_Save: StrID := sth_FileSave;
  281.       cm_SaveAs: StrID := sth_FileSaveAs;
  282.       cm_Print: StrID := sth_FilePrint;
  283.       cm_Exit: StrID := sth_FileExit;
  284.       cm_EditUndo: StrID := sth_EditUndo;
  285.       cm_EditCut: StrID := sth_EditCut;
  286.       cm_EditCopy: StrID := sth_EditCopy;
  287.       cm_EditPaste: StrID := sth_EditPaste;
  288.       cm_EditDelete: StrID := sth_EditDelete;
  289.       cm_EditClear: StrID := sth_EditClear;
  290.       cm_Options_Open: StrID := sth_OptionsOpen;
  291.       cm_all: StrID := sth_ViewAll;
  292.       cm_By: StrID := sth_ViewBy;
  293.       cm_Some: StrID := sth_ViewSome;
  294.       cm_Directories: StrID := sth_OptionsDirectory;
  295.       cm_Options_Save: StrID := sth_OptionsSave;
  296.       cm_Options_SaveAs: StrID := sth_OptionsSaveAs;
  297.       cm_Preferences: StrID := sth_EnvironmentPreferences;
  298.       cm_Mouse: StrID := sth_EnvironmentMouse;
  299.       cm_TileChildren: StrID := sth_WindowTile;
  300.       cm_CascadeChildren: StrID := sth_WindowCascade;
  301.       cm_ArrangeIcons: StrID := sth_WindowArrange;
  302.       cm_CloseChildren: StrID := sth_WindowCloseAll;
  303.       cm_Index: StrID := sth_HelpIndex;
  304.       cm_Topic_Search: StrID := sth_HelpTopic;
  305.       cm_Glossary: StrID := sth_HelpGlossary;
  306.       cm_Using_Help: StrID := sth_HelpUsing;
  307.       cm_About_RWP: StrID := sth_HelpAbout;
  308.       else
  309.         Exit;
  310.     end
  311.   end
  312.   else
  313.   if CurrentPopup <> 0 then
  314.   begin
  315.     case GetMenuItemID(CurrentPopup, 0) of
  316.       FileFirst: StrID := sth_File;
  317.       EditFirst: StrID := sth_Edit;
  318.       ViewFirst: StrID := sth_View;
  319.       WindowFirst: StrID := sth_Window;
  320.       OptionFirst: StrID := sth_Option;
  321.       EnvironmentFirst: StrID := sth_OptionsEnvironment;
  322.       HelpFirst: StrID := sth_Help;
  323.       else
  324.         Exit;
  325.     end;
  326.   end;
  327.  
  328.   DC := GetDC(HWindow);
  329.   BlastStatusLine(DC);
  330.   if (CurrentPopup <> 0) or (CurrentID <> 0) then
  331.   begin
  332.     hOld := SelectObject(DC, GetStockObject(ANSI_VAR_FONT));
  333.     LoadString(HInstance, StrID, Str, Sizeof(Str));
  334.     GetClientRect(HWindow, Rect);
  335.     SetBKColor(DC, RGB(192, 192, 192));
  336.     TextHeight :=  HiWord( GetTextExtent( DC, Str, 1) );
  337.     TextOut(DC, TextStart+10,
  338.       Rect.bottom - StatusLineHeight + ( ( StatusLineHeight - TextHeight ) div 2),
  339.       Str, strlen(Str));
  340.     SelectObject(DC, hOld);
  341.   end;
  342.   ReleaseDC(HWindow, DC);
  343. end;
  344.  
  345. procedure TRWPWindow.WMMenuSelect(var Msg: TMessage);
  346. var
  347.   CurrentMenu: HWnd;
  348.   Str: array[0..20] of Char;
  349. begin
  350.   if Msg.LParamLo = $FFFF then
  351.   begin
  352.     CurrentPopup := 0;
  353.     CurrentID := 0;
  354.   end
  355.   else
  356.   if (Msg.LParamLo and mf_Popup) <> 0 then
  357.   begin
  358.    CurrentPopup := Msg.WParam;
  359.     CurrentID := 0;
  360.   end
  361.   else
  362.     CurrentID := Msg.WParam;
  363.   PostMessage(HWindow,am_DrawStatusLine, 0, 0);
  364. end;
  365.  
  366. procedure TRWPWindow.WMEnterIdle(var Msg: TMessage);
  367. { If the user pressed the F1 key, and a Dialog box is active (and idle), send
  368.   an ID_Help message to the dialog, to get the behavior associated with
  369.   pressing the help button in that dialog }
  370. begin
  371.  if ( Msg.WParam = Msgf_DialogBox) and ( ( GetKeyState( Vk_F1) and $8000) <> 0) then
  372.    SendMessage( Msg.LParamLo, wm_Command, Id_Help, 0);
  373. end;
  374.  
  375. procedure TRWPWindow.WMSize(var Msg: TMessage);
  376. var
  377.   Rect: TRect;
  378. begin
  379.   TMDIWindow.WMSize(Msg);
  380.   GetClientRect(HWindow, Rect);
  381.   SetWindowPos(ClientWnd^.HWindow, 0, 0, 0, Rect.Right,
  382.     Rect.Bottom - StatusLineHeight, swp_NoZOrder);
  383.   ReconstructStatusLine;
  384. end;
  385.  
  386. procedure TRWPWindow.ReconstructStatusLine;
  387. var
  388.   Bmp: HBitmap;
  389.   DC: HDC;
  390.   DestDC: HDC;
  391.   OldSrc: HBitmap;
  392.   OldDest: HBitmap;
  393.   Rect: TRect;
  394.   SrcDC: HDC;
  395. begin
  396.   GetClientRect(HWindow, Rect);
  397.   DC := GetDC(HWindow);
  398.   SrcDC := CreateCompatibleDC(DC);
  399.   DestDC := CreateCompatibleDC(DC);
  400.   ReleaseDC(HWindow, DC);
  401.  
  402.   Bmp := LoadBitmap(HInstance, MakeIntResource(bmp_StatusLine));
  403.   OldSrc := SelectObject(SrcDC, Bmp);
  404.   if BmpStatusLine <> 0 then
  405.     DeleteObject(BmpStatusLine);
  406.   BmpStatusLine := CreateCompatibleBitmap(DC, Rect.Right, StatusLineHeight);
  407.   OldDest := SelectObject(DestDC, BmpStatusLine);
  408.   BitBlt(DestDC, 0, 0, 5, StatusLineHeight, SrcDC, 0, 0, srcCopy);
  409.   StretchBlt(DestDC, 5, 0, Rect.Right - 5, StatusLineHeight,
  410.              SrcDC, 6, 0, 20, StatusLineHeight, srcCopy);
  411.   BitBlt(DestDC, Rect.Right - 5, 0, 5, StatusLineHeight, SrcDC, 59, 0, srcCopy);
  412.  
  413.   SelectObject(SrcDC, BmpStatusBar);
  414.   BitBlt(DestDC, 40, 0, 10, StatusLineHeight,
  415.          SrcDC, 0, 0, SrcCopy);
  416.   BitBlt(DestDC, 100, 0, 10, StatusLineHeight,
  417.          SrcDC, 0, 0, SrcCopy);
  418.   BitBlt(DestDC, TextStart, 0, 10, StatusLineHeight,
  419.          SrcDC, 0, 0, SrcCopy);
  420.  
  421.   SelectObject(SrcDC, OldSrc);
  422.   BmpStatusLine := SelectObject(DestDC, OldDest);
  423.   DeleteDC(SrcDC);
  424.   DeleteDC(DestDC);
  425.   DeleteObject(Bmp);
  426. end;
  427.  
  428. var
  429.   RWPApp:RWPApplication;
  430.  
  431. begin
  432.   RWPApp.Init(AppName);
  433.   RWPApp.Run;
  434.   RWPApp.Done;
  435. end.
  436.