home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast.iso / pcmag / vol11n19.zip / CDDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-30  |  24KB  |  824 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1992 by Pat Ritchey            }
  6. {                                                }
  7. {************************************************}
  8. {$B-,I-,V-,R+}
  9. program CDDemo;
  10.  
  11. {$R CDDEMO}
  12.  
  13. uses WinProcs, WinTypes, Strings, WinDOS,
  14.  
  15. {$IFDEF VER10}     { If we're compiling with TPW 1.0, some special      }
  16.                    { branching is needed:                               }
  17.   {$IFDEF BWCC}
  18.     WObjectB,      { TPW 1.0 - Use units shipped with Resource Workshop }
  19.     BWCC,
  20.   {$ELSE}
  21.     WObjects,      { TPW 1.0 - Don't use BWCC dialogs at all            }
  22.   {$ENDIF}
  23.   Xtra31,          { TPW 1.0 - Some Win 3.1 functions this demo needs   }
  24.  
  25. {$ELSE}       { If we're compiling with TPW 1.5 or later, no            }
  26.               { special branching is required.                          }
  27.   WObjects,
  28.   BWCC,       { TPW 1.5 - Activates TPW 1.5's Wobjects' BWCC support    }
  29.   Win31,      { TPW 1.5 - New Win 3.1 functions defined here.           }
  30. {$ENDIF}
  31.  
  32.  COMMDLG,     { CommDlg functions - same as TPW 1.5's Commdlg.pas       }
  33.  CDOWL;       { OWL object layer for CommDlg dialogs, the feature of    }
  34.               { this demo program.                    }
  35.  
  36.  
  37. {$I cddemo.inc }
  38.  
  39. const
  40.    AppName = 'CDDEMO';
  41.    MaxLines = 16000;  { The maximum number of text lines that can be loaded.
  42.             Due to the implementation of a TCollection, the
  43.             absolute maximum is 16384 }
  44.  
  45. var
  46.    UserAbort : boolean;
  47.  
  48. type
  49.   PBrowseWindow = ^TBrowseWindow;
  50.   TBrowseWindow = object(TWindow)
  51.     CurColor : longint;
  52.     CurFont  : hFont;
  53.     CurBkGndColor : longint;
  54.     CurBkgnd : hBrush;
  55.     LF  : TLogFont;
  56.     CCA : CustColorArray;
  57.     TextCol : PStrCollection;
  58.     LastFound : integer;
  59.     FRDlg     : PFindReplaceDlg;
  60.     DevNames  : PDevNames;
  61.     DevMode   : PDevMode;
  62.     PrintDC   : hDC;
  63.     FileIsDirty : boolean;
  64.     CurrentFile : array[0..fsPathName] of char;
  65.     constructor Init;
  66.     Destructor Done; virtual;
  67.     Procedure GetWindowClass(var WndClass : TWndClass); virtual;
  68.     Procedure SetupWindow; virtual;
  69.     Function  CanClose : boolean; virtual;
  70.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  71.     Procedure WMKeyDown(var Msg : TMessage); virtual wm_first+wm_KeyDown;
  72.     procedure CMChangeFont(var Msg: TMessage);
  73.       virtual cm_First + cm_ChangeFont;
  74.     procedure CMChangeEffects(var Msg : TMessage);
  75.       virtual cm_first + cm_ChangeEffects;
  76.     Procedure CMChangeColor(var Msg : TMessage);
  77.       virtual cm_first + cm_ChangeColor;
  78.     procedure CMAbout(var Msg: TMessage);
  79.       virtual cm_First + cm_About;
  80.     Procedure CMFileOpen(var Msg : TMessage);
  81.       virtual cm_First + cm_FileOpen;
  82.     Procedure CMFileSaveAs(var Msg : TMessage);
  83.       virtual cm_First + cm_FileSaveAs;
  84.     Procedure CMFindText(var Msg : TMessage);
  85.       virtual cm_First + cm_EditFind;
  86.     Procedure CMReplaceText(var Msg : TMessage);
  87.       virtual cm_First + cm_EditReplace;
  88.     Procedure CMPrint(var Msg : Tmessage);
  89.       virtual cm_first+cm_Print;
  90.     Procedure CMPrintSetup(var Msg : TMessage);
  91.       virtual cm_first+cm_PrintSetup;
  92.     Procedure DefWndProc(var Msg : TMessage); virtual;
  93.     private
  94.      FileLines  : word;
  95.      Procedure LoadFile(FileName : pchar);
  96.      Procedure SetScrollUnits;
  97.      Procedure FindReplaceMessage(var Msg : TMessage);
  98.      Function  SaveFile(Ask : boolean) : boolean;
  99.      Procedure PrintTheText(FromI,ToI : integer);
  100.   end;
  101.  
  102. PMyFileDlg = ^TMyFileDlg;
  103. TMyFileDlg = object(TFileDlg)
  104.    Function GetFileFilter : Pchar; virtual;
  105.    end;
  106.  
  107. PMyPrintDlg = ^TMyPrintDlg;
  108. TMyPrintDlg = object(TPrintInitDlg)
  109.    Procedure SetupWindow; virtual;
  110.    end;
  111.  
  112. PAbortDialog = ^TAbortDialog;
  113. TAbortDialog = object(TDialog)
  114.    Procedure Cancel(var Msg : TMessage); virtual id_first+id_Cancel;
  115.    Procedure UpdateStatus(Total,Printed : integer);
  116.    end;
  117.  
  118. { Application object }
  119.  
  120. TBrowseApp = object(TApplication)
  121.   procedure InitMainWindow; virtual;
  122.   end;
  123.  
  124. Function Min(i1,i2 : integer) : integer;
  125. begin
  126.   if i1 < i2 then Min := i1 else Min := i2;
  127. end;
  128.  
  129. Function Max(i1,i2 : integer) : integer;
  130. begin
  131.   if i1 > i2 then Max := i1 else Max := i2;
  132. end;
  133.  
  134. Function StrIPos(TargetStr,SubStr : Pchar) : Pchar;
  135. var
  136.   i,SLen,TLen : integer;
  137. begin
  138.   SLen := StrLen(SubStr);
  139.   TLen := StrLen(TargetStr);
  140.   for i := 0 to TLen-SLen do
  141.      if StrLIComp(SubStr,@TargetStr[i],SLen) = 0 then
  142.         begin
  143.         StrIPos := @TargetStr[i];
  144.         exit;
  145.         end;
  146.   StrIPos := nil;
  147. end;
  148.  
  149. { TMyFileDlg is a descendant of TFileDlg.  A descendant is created and used
  150.   by this app so that a GetFileFilter method (specific to this app) can be
  151.   created. }
  152. Function TMyFileDlg.GetFileFilter : pchar;
  153. begin
  154.   GetFileFilter :=
  155.   'Pascal Files'#0'*.pas;*.inc'#0+
  156.   'C Files'#0'*.c;*.h;*.cpp;*.hpp'#0+
  157.   'Resources'#0'*.rc;*.dlg'#0+
  158.   'All Files'#0'*.*'#0;
  159. end;
  160.  
  161. { TMyPrintDlg is a descendant of TPrintInitDlg.  This object overrides the
  162.   SetupWindow method so that the checkbox that normally is displayed as
  163.   "[ ] Pages" can be changed to  "[ ] Lines".  This is done because this
  164.   application prints on a line by line basis rather than a page by page basis.
  165. }
  166.  
  167. Procedure TMyPrintDlg.SetupWindow;
  168. begin
  169.   TPrintInitDlg.SetupWindow;
  170.   SendDlgItemMsg(1058,WM_SETTEXT,0,longint(pchar('&Lines')));
  171. end;
  172.  
  173. Procedure TAbortDialog.UpdateStatus(Total,Printed : integer);
  174. var
  175.   TextStr : array[0..30] of char;
  176. begin
  177.   if (Printed mod 10) = 0 then
  178.      begin
  179.      wvsprintf(TextStr,'Printed %d of %d lines',Printed);
  180.      SendDlgItemMsg(101,WM_SETTEXT,0,longint(@TextStr));
  181.      end;
  182. end;
  183.  
  184. Procedure TAbortDialog.Cancel;
  185. begin
  186.   UserAbort := true;
  187.   SendDlgItemMsg(101,WM_SETTEXT,0,longint(pchar('Printing Aborted')));
  188. end;
  189.  
  190. { Constructor for main window object. }
  191.  
  192. constructor TBrowseWindow.Init;
  193. var
  194.   i : integer;
  195. begin
  196.   TWindow.Init(nil, 'File Browser');
  197.   Attr.Menu := LoadMenu(HInstance, 'MAIN');
  198.   Attr.Style := Attr.Style or WS_HSCROLL or WS_VSCROLL;
  199.  
  200.   { Initialize the font and colors to some default values }
  201.   CurFont := GetStockObject(System_Fixed_FONT);
  202.   GetObject(CurFont,Sizeof(LF),@LF);
  203.   CurFont := CreateFontIndirect(LF);
  204.   CurColor := 0;
  205.   CurBkgndColor := GetSysColor(COLOR_Window);
  206.   CurBkgnd := CreateSolidBrush(CurBkgndColor);
  207.   for i := 0 to 15 do CCA[i] := $FFFFFF;
  208.  
  209.   { initialize the file and printer fields of the window.  The DevNames and
  210.     DevMode fields will actually be initialized in this window's SetupWindow
  211.     method (when the hWindow field is valid). }
  212.   LastFound := -1;
  213.   PrintDC := 0;
  214.   FileIsDirty := false;
  215.   CurrentFile[0] := #0;
  216.   DevNames := nil;
  217.   DevMode := nil;
  218.   New(TextCol,Init(100,100));
  219.  
  220.   Scroller := New(PScroller,Init(@Self,0,0,0,0));
  221.   Scroller^.AutoOrg := false;
  222. end;
  223.  
  224. Destructor TBrowseWindow.Done;
  225. begin
  226.   if CurFont <> 0 then DeleteObject(CurFont);
  227.   Dispose(TextCol,Done);
  228.   if PrintDC <> 0 then DeleteDC(PrintDC);
  229.   TWindow.Done;
  230. end;
  231.  
  232. Procedure TBrowseWindow.GetWindowClass;
  233. begin
  234.   TWindow.GetWindowClass(WndClass);
  235.   WndClass.hIcon := LoadIcon(hInstance,'MAIN');
  236.   WndClass.hbrBackGround := CurBkgnd;
  237. end;
  238.  
  239. Procedure TBrowseWindow.SetupWindow;
  240. begin
  241.    TWindow.SetupWindow;
  242.    {executing a TPrintInitDlg dialog with the PD_ReturnDefault flag cause the
  243.     "PrintDC", "DevNames" and "DevMode" structures to be initialized without
  244.     actually displaying a dialog. }
  245.    Application^.ExecDialog(NEw(PPrintInitDlg,Init(@Self,PD_PRINTSETUP or PD_ReturnDefault,
  246.                       PrintDC,DevNames,DevMode)));
  247.    SetScrollUnits;
  248. end;
  249.  
  250. Function TBrowseWindow.CanClose;
  251. begin
  252.   If FileIsDirty then
  253.      CanClose := SaveFile(True)
  254.   else
  255.      CanClose := true;
  256. end;
  257.  
  258. Procedure TBrowseWindow.SetScrollUnits;
  259. var
  260.   DC : hDC;
  261.   OldFont : hFont;
  262.   TM : TTextMetric;
  263. begin
  264.   DC := GetDC(0);
  265.   OldFont := SelectObject(DC,CurFont);
  266.   GetTextMetrics(DC,TM);
  267.   SelectObject(DC,OldFont);
  268.   ReleaseDC(0,DC);
  269.   Scroller^.SetUnits(TM.tmAveCharWidth,TM.tmHeight);
  270. end;
  271.  
  272. Procedure TBrowseWindow.LoadFile(FileName : pchar);
  273. { Loads a text file into a collection.  This demo program will handle text
  274.   files with up to 16,000 lines.  }  
  275. const
  276.   TextBufSize = 32768;
  277. var
  278.   f : text;
  279.   FText : array[0..255] of char;
  280.   TextBuf : pointer;
  281.  Procedure CloseFile;
  282.    begin
  283.    Close(f);
  284.    if IOResult = 0 then;
  285.    FreeMem(TextBuf,TextBufSize);
  286.    end;
  287.  begin
  288.  
  289.  GetMem(TextBuf,TextBufSize);
  290.  Assign(f,FileName);
  291.  SetTextBuf(f,TextBuf^,TextBufSize); { optimize the text buffer for fast loading }
  292.  Reset(f);
  293.  if IOResult <> 0 then
  294.     begin
  295.     FreeMem(TextBuf,TextBufSize);
  296.     MessageBox(hWindow,'Unable to open the file',AppName,MB_OK or MB_ICONSTOP);
  297.     exit;
  298.     end;
  299.  TextCol^.FreeAll;  { get rid of any text lines that may be present from a
  300.                       previously loaded file }
  301.  FileLines := 0;
  302.  FileIsDirty := true;
  303.  LastFound := -1;
  304.  While (FileLines < MaxLines) and (not Eof(f)) do
  305.    begin
  306.    Readln(f,FText);
  307.    if IOResult <> 0 then
  308.       begin
  309.       CloseFile;
  310.       MessageBox(hWindow,'Error reading the file',AppName,MB_OK or MB_ICONSTOP);
  311.       exit;
  312.       end;
  313.    if FText[0] = #0 then
  314.       begin
  315.       { StrNew won't create a zero length string.  Modify the string so that
  316.         it's a string with a length of one. }
  317.       FText[0] := ' ';
  318.       FText[1] := #0;
  319.       end;
  320.    With TextCol^ do AtInsert(Count,StrNew(FText));
  321.    Inc(FileLines);
  322.    end;
  323.  If not EOF(f) then
  324.     MessageBox(hWindow,'File too large, trucation has occured',AppName,MB_OK or MB_ICONINFORMATION)
  325.  else
  326.     FileIsDirty := false;
  327.  CloseFile;
  328.  StrCopy(CurrentFile,FileName);
  329.  
  330.  StrCopy(FText,'File Browser - ');
  331.  StrCat(FText,StrLower(FileName));
  332.  SetWindowText(hWindow,FText);
  333.  
  334.  Scroller^.SetRange(120,FileLines);
  335.  InvalidateRect(hWindow,nil,true);
  336.  Scroller^.ScrollTo(0,0);
  337. end;
  338.  
  339. Function TBrowseWindow.SaveFile(Ask : boolean) : boolean;
  340. var
  341.   FileName : array[0..fsPathName] of char;
  342. begin
  343.   SaveFile := false;
  344.   If Ask then
  345.      if MessageBox(hWindow,'File has been modified, Save it?',AppName,
  346.                 MB_OKCANCEL or MB_ICONQUESTION) = id_Cancel then exit;
  347.   StrCopy(FileName,CurrentFile);
  348.   if Application^.ExecDialog(New(PMyFileDlg,
  349.     Init(@Self,OFN_HIDEREADONLY,Save,FileName,fsPathName))) = id_Cancel then exit;
  350.   { Code to write text to disk would go here.  This demo program does not
  351.     support file writing.}
  352.   MessageBox(hWindow,'This function is not implemented','File Save',MB_OK or
  353.              MB_ICONSTOP);
  354.   SaveFile := true;
  355. end;
  356.  
  357. Procedure TBrowseWindow.CMFileOpen(var Msg : TMessage);
  358. var
  359.   FileName : array[0..fsPathName] of char;
  360. begin
  361.   If FileIsDirty then
  362.      If not SaveFile(true) then exit;
  363.   StrCopy(FileName,'');  
  364.   if Application^.ExecDialog(New(PMyFileDlg,
  365.     Init(@Self,OFN_FILEMUSTEXIST,
  366.           Open,FileName,fsPathName))) = id_ok then
  367.           LoadFile(FileName);
  368. end;
  369.  
  370. Procedure TBrowseWindow.CMFileSaveAs(var Msg : TMessage);
  371. begin
  372.   SaveFile(false);
  373. end;
  374.  
  375. procedure TBrowseWindow.CMChangeFont(var Msg: TMessage);
  376. var
  377.   P : PChooseFontDlg;
  378.   FontFlags : word;
  379. begin
  380.   FontFlags := CF_SCREENFONTS or CF_SHOWHELP; 
  381.   { check if this is a "Change Effects" menu selection or a simple
  382.     "Change Font" message. } 
  383.   if Msg.wParam = cm_ChangeEffects then
  384.      FontFlags := FontFlags or CF_EFFECTS;
  385.   P := New(PChooseFontDlg,Init(@Self,FontFlags,@LF,CurColor));
  386.   P^.SetPrinterDC(PrintDC);
  387.   if Application^.ExecDialog(P) = id_OK then
  388.      begin
  389.      If CurFont <> 0 then
  390.         DeleteObject(CurFont);           { get rid of the "old" font }
  391.      CurFont := CreateFontIndirect(lf);  { create the new font       } 
  392.      SetScrollUnits;                     { adjust the scroller for the new font }
  393.      InvalidateRect(hWindow,nil,true);   { cause a repaint using the new font }
  394.      end;
  395. end;
  396.  
  397. procedure TBrowseWindow.CMChangeEffects;
  398. begin
  399.   { direct the message to CMChangeFont.  Code in that method will determine
  400.     the actual source of the message. }
  401.   CMChangeFont(Msg);
  402. end;
  403.  
  404. procedure TBrowseWindow.CMChangeColor(var Msg: TMessage);
  405. begin
  406.   if Application^.ExecDialog(New(PChooseColorDlg,
  407.                Init(@Self,CC_SHOWHELP,CCA,CurBkgndColor))) = id_OK then
  408.      begin
  409.      CurBkgnd := CreateSolidBrush(CurBkgndColor);
  410.      DeleteObject(SetClassWord(hWindow,GCW_hbrBackground,CurBkgnd));
  411.      InvalidateRect(hWindow,nil,true);
  412.      end;
  413. end;
  414.  
  415. procedure TBrowseWindow.CMAbout(var Msg: TMessage);
  416. var
  417.   AboutResID : PChar;
  418. begin
  419. {$IFDEF VER10}
  420.   {$IFDEF BWCC}
  421.     AboutResId := 'ABOUT';
  422.   {$ELSE}
  423.     AboutResID := 'ABOUT_PLAIN';
  424.   {$ENDIF}
  425. {$ELSE}
  426.   if BWCCClassNames then AboutResId := 'ABOUT' else AboutResID := 'ABOUT_PLAIN';
  427. {$ENDIF}
  428.   Application^.ExecDialog(New(PDialog, Init(@Self, AboutResID)));
  429. end;
  430.  
  431. Procedure TBrowseWindow.CMFindText(var Msg : TMessage);
  432. begin
  433.   LastFound := -1;
  434.   FRDlg := New(PFindReplaceDlg,Init(@Self,0,nil,nil));
  435.   if Application^.MakeWindow(FRDlg) <> nil then;
  436. end;
  437.  
  438. Procedure TBrowseWindow.CMReplaceText(var Msg : TMessage);
  439. begin
  440.   LastFound := -1;
  441.   FRDlg := New(PFindReplaceDlg,Init(@Self,FR_REPLACE,nil,nil));
  442.   Application^.MakeWindow(FRDlg);
  443. end;
  444.  
  445. { Abort procedure used for printing }
  446. function AbortProc(Prn: HDC; Code: Integer): Boolean; export;
  447. var
  448.   Msg: TMsg;
  449. begin
  450.   while not UserAbort and PeekMessage(Msg, 0, 0, 0, pm_Remove) do
  451.     if not Application^.ProcessAppMsg(Msg) then
  452.     begin
  453.       TranslateMessage(Msg);
  454.       DispatchMessage(Msg);
  455.     end;
  456.   AbortProc := not UserAbort;
  457. end;
  458.  
  459. Procedure TBrowseWindow.PrintTheText(FromI,ToI : integer);
  460. var
  461.   i : integer;
  462.   di : TDocInfo;
  463.   LinesPrinted,
  464.   LineHeight,
  465.   LinesPerPage : integer;
  466.   TM : TTextMetric;
  467.   OldFont : hFont;
  468.   Item : Pchar;
  469.   PrevMode : word;
  470.   vExt,wExt : longint;
  471.   PrintLF : TLogFont;
  472.   PrintFont : hFont;
  473.   DisplayDC : hDC;
  474.   AbortDlg : PAbortDialog;
  475.   AbortProcInst : function (DC: HDC; Error: Integer): Boolean;
  476.   Error : integer;
  477. begin
  478.   LinesPrinted := 0;
  479.  
  480.   { Create a font scaled to the printer }
  481.   PrintLF := LF;
  482.   DisplayDC := GetDC(0);
  483.   PrintLF.lfHeight := -MulDiv(Abs(LF.lfHeight),
  484.                           GetDeviceCaps(PrintDC,LOGPIXELSY),
  485.                           GetDeviceCaps(DisplayDC,LOGPIXELSY));
  486.   ReleaseDC(0,DisplayDC);
  487.   PrintFont := CreateFontIndirect(PrintLF);
  488.   OldFont := SelectObject(PrintDC,PrintFont);
  489.   GetTextMetrics(PrintDC,TM);
  490.   LineHeight := TM.tmHeight+TM.tmExternalLeading;
  491.   LinesPerPage := GetDeviceCaps(PrintDC,VERTRES) div LineHeight;
  492.   with di do
  493.       begin
  494.       cbSize := sizeof(DI);
  495.       lpszDocName := AppName;
  496.       lpszOutput := nil;
  497.       end;
  498.  
  499.   UserAbort := false;
  500.  
  501.   AbortDlg := New(PAbortDialog,Init(@Self,'ABORTDLG'));
  502.   Application^.MakeWindow(AbortDlg);
  503.   @AbortProcInst := MakeProcInstance(@AbortProc,hInstance);
  504.   SetAbortProc(PrintDC,AbortProcInst);
  505.   UpdateWindow(hWindow);
  506.   EnableWindow(hWindow,false);
  507.   AbortDlg^.UpdateStatus(Succ(ToI-FromI),0);
  508.   Error := StartDoc(PrintDC,DI);
  509.   If error >= 0 then StartPage(PrintDC);
  510.   i := Pred(FromI);
  511.   While (Error >= 0) and (i < ToI) do
  512.      begin
  513.      if LinesPrinted >= LinesPerPage then
  514.     begin
  515.     EndPage(PrintDC);
  516.     StartPage(PrintDC);
  517.     LinesPrinted := 0;
  518.     end;
  519.      Item := TextCol^.At(i);
  520.      TabbedTextOut(PrintDC,0,LinesPrinted*LineHeight,Item,StrLen(Item),
  521.                    0,mem[0:0],0);
  522.      AbortDlg^.UpdateStatus(Succ(ToI-FromI),(Succ(Succ(i)-FromI)));
  523.      Inc(LinesPrinted);
  524.      Inc(i);
  525.      if UserAbort then Error := -1;
  526.      end;
  527.   if Error >= 0 then
  528.      begin
  529.      EndPage(PrintDC);
  530.      EndDoc(PrintDC);
  531.      end
  532.   else
  533.      AbortDoc(PrintDC);
  534.  
  535.   FreeProcInstance(@AbortProcInst);
  536.   EnableWindow(hWindow,true);
  537.   Dispose(AbortDlg,Done);
  538.  
  539.   SelectObject(PrintDC,OldFont);
  540.   DeleteObject(PrintFont);
  541.   UserAbort := false;
  542. end;
  543.  
  544.  
  545. Procedure TBrowseWindow.CMPrint;
  546. var
  547.   P : PPrintInitDlg;
  548.   PD : TPrintDlg;
  549.   OldPrintDC : hDC;
  550. begin
  551.   OldPrintDC := PrintDC;
  552.   P := New(PMyPrintDlg,Init(@Self,PD_NOSELECTION,
  553.            PrintDC,DevNames,DevMode));
  554.   P^.SetMinMaxPage(1,TextCol^.Count);
  555.   P^.SetCDTransferBuffer(@PD);
  556.   if Application^.ExecDialog(P) = id_ok then
  557.      begin
  558.      if OldPrintDC <> 0 then DeleteDC(OldPrintDC);
  559.      With PD do begin
  560.      if (Flags and PD_PAGENUMS) = 0 then
  561.         begin
  562.         nFromPage := 1;
  563.         nToPage := TextCol^.Count;
  564.         end;
  565.      PrintTheText(nFromPage,nToPage);
  566.      end; end;
  567. end;
  568.  
  569. Procedure TBrowseWindow.CMPrintSetup;
  570. var
  571.   OldPrintDC : hDC;
  572. begin
  573.   OldPrintDC := PrintDC;
  574.   if Application^.ExecDialog(NEw(PPrintInitDlg,Init(@Self,PD_PRINTSETUP,
  575.                       PrintDC,DevNames,DevMode))) = id_ok then
  576.      if OldPrintDC <> 0 then DeleteDC(OldPrintDC);
  577. end;
  578.  
  579.  
  580. Procedure TBrowseWindow.WMKeyDown;
  581. { a simple keyboard handler that causes the window to respond to
  582.   keystrokes in a manner similar to the TPW IDE. }
  583. var
  584.   CtrlPress : boolean;
  585. begin
  586.   CtrlPress := GetKeyState(VK_CONTROL) < 0;
  587.   if Scroller <> nil then
  588.   With Scroller^ do
  589.     case Msg.wParam of
  590.     VK_Up    : ScrollBy(0,-1);
  591.     VK_Down  : ScrollBy(0,1);
  592.     VK_Left  : If CtrlPress then ScrollBy(-10,0) else ScrollBy(-1,0);
  593.     VK_Right : If CtrlPress then ScrollBy(10,0) else ScrollBy(1,0);
  594.     VK_Home  : ScrollTo(0,Ypos);
  595.     VK_End   : ScrollTo(XRange,YPos);
  596.     VK_Prior : If not CtrlPress then ScrollBy(0,-YPage) else ScrollTo(0,0);
  597.     VK_Next  : If not CtrlPress then ScrollBy(0,YPage) else ScrollTo(0,YRange);
  598.     end;
  599. end;
  600.  
  601.  
  602. Procedure TBrowseWindow.FindReplaceMessage(var Msg : TMessage);
  603. { Process a message sent from a Find/Replace modeless dialog to the
  604.   parent Window }
  605. var
  606.   SearchString : pchar;
  607.   WholeWord,
  608.   MatchCase : boolean;
  609.   SearchLen : integer;
  610.  
  611.   {$IFOPT R+}  {$DEFINE RestoreR} {$ENDIF}
  612.   {$IFOPT B+}  {$DEFINE RestoreB} {$ENDIF}
  613.   {$R-,B-}
  614.   Function ISWholeWord(SubStr,TargetStr : Pchar; Len : integer) : boolean;
  615.     {- This function determines if the preceding or following character
  616.        of the substring is alphanumeric.  For the function to work properly
  617.        it is required that the $B- and $R- options are set.}
  618.     var
  619.       i : integer;
  620.     begin
  621.       i := -1;
  622.       IsWholeWord :=
  623.          ((SubStr = TargetStr) or (not IscharAlphaNumeric(SubStr[i]))) and
  624.          (not (IsCharAlphaNumeric(SubStr[Len])));
  625.     end;
  626.   {$IFDEF RestoreR} {$R+} {$UNDEF RestoreR} {$ENDIF}
  627.   {$IFDEF RestoreB} {$B+} {$UNDEF RestoreB} {$ENDIF}
  628.  
  629.   Function GetSubString(i : integer; SrchOfs : integer) : Pchar;
  630.   var
  631.     SubString,
  632.     TargetStr : Pchar;
  633.   begin
  634.   TargetStr := TextCol^.At(i);
  635.   Inc(TargetStr,SrchOfs);
  636.   if MatchCase then
  637.      SubString := StrPos(TargetStr,SearchString)
  638.   else
  639.      SubString := StrIPos(TargetStr,SearchString);
  640.   if SubString <> nil then
  641.      if WholeWord then
  642.         if not IsWholeWord(SubString,TextCol^.At(i),SearchLen) then
  643.            SubString := nil;
  644.   GetSubString := SubString;
  645.   end;
  646.  
  647.   Function FindNextOccurance : boolean;
  648.   var
  649.     i,
  650.     Dir : integer;
  651.   begin
  652.   FindNextOccurance := true;
  653.   if FRDlg^.FindOptionSet(FR_Down) then Dir := 1 else Dir := -1;
  654.   if LastFound = -1 then
  655.      i := Scroller^.YPos
  656.   else
  657.      i := LastFound+Dir;
  658.   while (i < TextCol^.Count) and (i >= 0) do
  659.     begin
  660.     if GetSubString(i,0) <> nil then
  661.        begin
  662.        LastFound := i;
  663.        exit;
  664.        end;
  665.     Inc(i,Dir);
  666.     end;
  667.   FindNextOccurance := false;
  668.   end;
  669.  
  670. Procedure ReplaceText(FirstLine,LastLine : integer);
  671. Var
  672.   SubStr,
  673.   TargetStr,
  674.   NewStr,
  675.   ReplaceStr : Pchar;
  676.   NextOfs,
  677.   ReplaceLen,
  678.   NewLen,
  679.   i : integer;
  680.  
  681. begin
  682.   ReplaceStr := FRDlg^.ReplaceWith;
  683.   ReplaceLen := StrLen(ReplaceStr);
  684.   for i := FirstLine to LastLine do
  685.       begin
  686.       SubStr := GetSubString(i,0);
  687.       while Substr <> nil do
  688.         begin
  689.         TargetStr := TextCol^.At(i);
  690.         NewLen := StrLen(TargetStr)-SearchLen+ReplaceLen;
  691.         GetMem(NewStr,NewLen+1);
  692.         StrLCopy(NewStr,TargetStr,(SubStr-TargetStr));
  693.         Inc(TargetStr,StrLen(NewStr)+SearchLen);
  694.         StrCat(NewStr,ReplaceStr);
  695.         NextOfs := StrLen(NewStr);
  696.         StrCat(NewStr,TargetStr);
  697.         StrDispose(TextCol^.At(i));
  698.         TextCol^.Items^[i] := NewStr;
  699.         FileIsDirty := true;
  700.         LastFound := i;
  701.         SubStr := GetSubString(i,NextOfs);
  702.         end;
  703.       end;
  704.   InvalidateRect(hWindow,nil,true);
  705.   With Scroller^ do
  706.      ScrollTo(0,Max(LastFound-(YPage div 2),0));
  707. end;
  708.  
  709. begin  { FindReplaceMessage }
  710.   with FRDlg^ do begin
  711.     MatchCase := FindOptionSet(FR_MATCHCASE);
  712.     WholeWord := FindOptionSet(FR_WHOLEWORD);
  713.     SearchString := FindWhat;
  714.     SearchLen := StrLen(SearchString);
  715.     end;
  716.   If FRDlg^.FindOptionSet(FR_FINDNEXT) then
  717.      begin
  718.      If not FindNextOccurance then
  719.         begin
  720.         { the hWindow field in the MessageBox call is the dialogs
  721.           window handle.  This is the desired window handle. }
  722.         MessageBox(FRDlg^.hWindow,'No further occurances',AppName,
  723.                    MB_ICONINFORMATION or MB_OK);
  724.         LastFound := -1;
  725.         InvalidateRect(hWindow,nil,true);
  726.         end
  727.      else
  728.       With Scroller^ do
  729.       begin
  730.       InvalidateRect(hWindow,nil,true);
  731.       ScrollTo(0,Max(LastFound-(YPage div 2),0));
  732.       end;
  733.      end
  734.   else
  735.   If FRDlg^.FindOptionSet(FR_Replace) then
  736.      begin
  737.      if LastFound = -1 then
  738.         begin
  739.         MessageBox(FRDlg^.hWindow,'No Item is selected',AppName,MB_OK);
  740.         exit;
  741.         end;
  742.      ReplaceText(LastFound,LastFound);
  743.      end
  744.   else
  745.   IF FRDlg^.FindOptionSet(FR_ReplaceAll) then
  746.      begin
  747.      if LastFound = -1 then
  748.         begin
  749.         MessageBox(FRDlg^.hWindow,'No Item is selected',AppName,MB_OK);
  750.         exit;
  751.         end;
  752.      ReplaceText(LastFound,Pred(TextCol^.Count));
  753.      end;
  754. end;
  755.  
  756. Procedure TBrowseWindow.DefWndProc(Var Msg : TMessage);
  757. {- Messages sent to the parent window by COMMDLG have message IDs
  758.    which are registered dynamically (via RegisterWindowMessage).  This
  759.    prevents the abiltity to create of dynamic methods, so they must be
  760.    handled here.  }
  761. begin
  762.   if Msg.Message = IDC_FindReplace then
  763.      FindReplaceMessage(Msg)
  764.   else
  765.      TWindow.DefWndProc(Msg);
  766. end;
  767.  
  768. procedure TBrowseWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  769. var
  770.   OldFont : hFont;
  771.   OldBrush : hBrush;
  772.   x,y,
  773.   FirstLine,LastLine,idx : integer;
  774.   Item : Pchar;
  775.   R : TRect;
  776. begin
  777.   OldFont  := SelectObject(PaintDC,CurFont);
  778.   OldBrush := SelectObject(PaintDC,CurBkgnd);
  779.   SetBKMode(PaintDC,Transparent);
  780.   SetTextColor(PaintDC,CurColor);
  781.   With Scroller^,PaintInfo.RCPaint do begin
  782.     FirstLine := (Top div YUnit);
  783.     y := FirstLine*YUnit;
  784.     x := -(Xpos*XUnit)+XUnit;
  785.     FirstLine := FirstLine+YPos;
  786.     LastLine := FirstLine+(Bottom div YUnit);
  787.     end;
  788.   For idx := FirstLine to LastLine do
  789.      begin
  790.      if (idx >= 0) and (idx < TextCol^.Count) then
  791.         begin
  792.         Item := TextCol^.At(idx);
  793.         TabbedTextOut(PaintDC,x,y,Item,StrLen(Item),0,mem[0:0],x);
  794.         { "mem[0:0]" is a technique that can be used to pass a "NULL pointer"
  795.           to a Windows function when the TPW prototype is a VAR parameter. }
  796.         if LastFound = idx then
  797.           begin
  798.           R.top := y; R.Bottom := y+Scroller^.YUnit;
  799.           R.Left := 0; R.Right := MaxLines;
  800.           InvertRect(PaintDC,R);
  801.           end;
  802.         end;
  803.      Inc(y,Scroller^.YUnit);
  804.      end;
  805.   SelectObject(PaintDC,OldFont);
  806.   SelectObject(PaintDC,OldBrush);
  807. end;
  808.  
  809. { Create the application's main window. }
  810.  
  811. procedure TBrowseApp.InitMainWindow;
  812. begin
  813.   MainWindow := New(PBrowseWindow, Init);
  814. end;
  815.  
  816. var
  817.   BrowseApp: TBrowseApp;
  818.  
  819. begin
  820.   BrowseApp.Init(AppName);
  821.   BrowseApp.Run;
  822.   BrowseApp.Done;
  823. end.
  824.