home *** CD-ROM | disk | FTP | other *** search
- unit BigText;
- { TBigText 3.1 (c) 1995 by Gerry Skolnik (skolnik@kapsch.co.at)
-
- A big thanx to the following contributors:
-
- (c) 1995 by Danny Thorpe
- original scrolling and keyboard handling
- as he gave no email address, he doesn't
- know about it, I took his stuff from his
- TConsole component :-)
-
- (c) 1995 by David Sampson (dsampson@dca.com) -
- Color, Scroll Bar and Text Attribute enhancements
-
- (c) 1995 by Eric Heverly (erichev@ix.netcom.com)
- Search capability, Positioning, cursor fixes
-
- history:
- TBigText 1.x - first release
- TBigText 2.x - never made it, chaos is not a theory
- TBigText 3.0 - enhancements by David Sampson, Eric Heverly
- TBigText 3.1 - bug fix (horizontal scrolling) by Gerry Skolnik
-
- This component will display up to 32767 lines of text. Each line has its
- own dedicated foreground, background color, text attributes and can be 255
- chars long. If memory permits this is a maximum of about 8MB of data.
- At this time no editing functions are available.
-
- TBigList is still there because at the time I wrote this I didn't know about
- HugeList. Talk about reinventing the wheel.
-
- TBigText is limited to 32767 lines, because the Windows API functions only
- accept integer values. Expect some problems a little earlier, though, at
- about 32740.
-
- TBigText is FreeWare. You may use it freely at your own risk in any
- kind of environment. This component is not to be sold at any charge, and
- must be distributed along with the source code.
-
- If you make modifications or enhancements to this component, please
- contact me via email so that I can include your stuff in the next
- release. As Delphi32 won't produce Win3.x code, and we still will
- have to support Win 3.x, this component may survive a little longer
- longer than I'd expected...
-
- property MaxLines
- if set to 0, as much lines as memory permits are included. The
- absolute maximum, however, is 32767. If set to something else,
- TBigText will limit itself to that many lines.
-
- property PurgeLines
- determines how to handle the situation when no more lines can be
- added (line count reached Maxlines value or we ran out of memory).
- if set to 0, an exception is raised. If set to something different
- (default 200) the number of lines specified by PurgeLines are
- deleted, the TBigList objects are packed, and most likely more
- lines can be added (though the first ones will be lost).
- This option is useful for logging windows.
-
- property Count
- run-time read-only. If the Lines and TextAttrib counts are equal, this
- property holds the number of lines in TBigText. If the two counts are
- unequal, there's something wrong and the property holds a value of -1.
-
- procedure AddLine(LineString: string; FCol, BCol: TColor; UpdateDisplay: boolean);
- The essential routine to insert lines into TBigText.
- LineString : the text to be inserted
- FCol : forground color
- BCol : background color
- UpdateDisplay: if true, TBigText will scroll to the last line
- (where the new line will be added), and update
- its display. This is not recommended if lots of
- lines are to be included in a loop.
-
- procedure LoadFromFile(FileName: TFileName);
- Loads a file into TBigText. Every line will have the default colors
- clWindowText, clWindow.
-
- procedure Print
- prints all lines on the specified printer. Haven't checked this out, though.
-
- procedure ChangeColor(Index: longint; OldFCol, OldBCol, NewFCol, NewBCol: TColor);
- changes the colors of the line at Index, but only if the current colors
- match OldFCol and OldBCol (FCol = foreground color, BCol = background color).
-
- procedure SetColors(Index: longint; NewFCol, NewBCol: TColor);
- changes the colors of the line at Index
-
- the following procedures do pretty much the same as the according TList methods:
-
- procedure Clear;
- procedure Delete(Index: longint);
- procedure Remove(Index: longint);
- procedure Pack;
-
- ============================================================================
- New Stuff added 8/31/95 by David Sampson
-
- Properties:
- ------------------------
-
- property Colors : changed so that it is the window background color
-
- property ForeColor:
- property BackColor: These are the default forground and background colors
- that will be used to display the text in the window.
-
- property FillBack: Fills the background of the whole line with the Backgnd color
-
- property ScrollBars: Let's you select scrollbars
-
- Methods:
- ------------------------
-
- procedure AddString(LineString: string; UpdateDisplay: boolean);
-
- --This adds a string using the default fore and back colors and left
- alignment.
-
- procedure AddStringA(LineString: string; Fore, Back : TColor;
- Align : TTextAlign; Style : TFontStyles; UpdateDisplay: boolean);
-
- --This lets you add a string and specify the colors, alignment, and text style
-
- procedure AlignText(Index : LongInt; Align : TTextAlign; UpdateDisplay: boolean);
-
- --This lets you set the text alignment on an item.
- Updatedisplay set to true refreshes the display
-
- procedure SetColors(Index: longint; NewFCol, NewBCol: TColor);
-
- --Let's you specify a fore and back color for a specific index
-
- procedure SetStyle (Index : LongInt; Style :TFontStyles; UpdateDisplay: boolean);
-
- --Let's you set the text style
- Updatedisplay set to true refreshes the display
-
- Here's some example calls:
-
- BigText1.AddLine('Hello', clWhite, clNavy, True);
- BigText1.AddString('There', True);
- BigText1.AddStringA('Yogi', clYellow, clRed, taRight, [], True);
- BigText1.AddStringA('Bear', clWhite, clGreen, taCenter, [], True);
- BigText1.AddString('This was left aligned', [], False);
- BigText1.AlignText (BigText1.Count -1, taCenter, true);
- BigText1.SetStyle(BigText1.Count -1, [fsBold, fsItalic, fsUnderline, fsStrikeout], true);
-
- ============================================================================
- New Stuff added by Eric Heverly
-
- Function Search - Added EJH 07/04/95
- Search('this text', True, True);
- Parameters:
- SrcWord : String - What to Look for in the array
- SrchDown : Bool - True - Search down; False - Search Up
- MCase : Bool - True - Match Case Exact; False - Disregard Case
-
- Returns: True - Found ; False - Not Found
-
- Note: This is a little screwy because it does not redisplay the
- last page if text is found there when already on the last page.
- Also, during displays of found data, on the last call, if the
- user closes the finddialog, I could not see an automatic way
- for this application to know that it was not visible, so the
- final blue line stays on the screen untill the window scrolls
- beyond it, from then on it is not there. This is sometimes
- useful, othertimes it is just ugly.
-
- Note: To find exact matches if you have the option available to the
- user, put a space on both sides of SrcWord, otherwise partial
- matches are used.
-
- Modifications - Eric Heverly - July 1995 (erichev@ix.netcom.com)
-
- Scroll- Added keys F1-F4 to the Scrool Keys table.
- Print - Added canvas font for the display canvas to the printer
- so the expected printer font was the same. Also added some
- Cursor := crHourGlass to show that the system was busy during
- print cycles.
- Search- Added function.
- GoPosi- GoPosition function added.
- LoadFr- LoadFromFile added some Cursor := crHourGlass to show the
- user that the system is busy. Also I changed the call to the
- addline function to use the dumchar, this keeps the font to
- the defined font in the object editor (ie. I used Courier and
- this way it kept Courier as the display font, with the OEM
- characters, it always used the System font).
-
- }
-
- interface
-
- uses WinTypes, WinProcs, Messages, Classes, Controls, Printers,
- Forms, Graphics, SysUtils, StdCtrls;
-
- type
- {$M+}
-
- { Supporting types & structures for text attributes}
- TTextAlign = (taLeft, taCenter, taRight);
-
- TTextAttributes = class
- public
- FColor : TColor;
- BColor : TColor;
- Align : TTextAlign;
- Style : TFontStyles;
- end;
-
-
- TBigList = class
- private
- function GetCapacity: longint;
- function GetCount: longint;
- function GetItems(Index: longint): pointer;
- procedure SetItems(Index: longint; const Item: pointer);
- protected
- ListCount : integer;
- TheLines : array[0..3] of TList;
- published
- property Capacity: longint read GetCapacity;
- property Count: longint read GetCount;
- public
- property Items[Index: longint]: pointer read GetItems write SetItems;
- constructor Create;
- destructor Destroy;
- class function ClassName: string;
- function Add(Item: Pointer): longint;
- procedure Delete(Index: longint);
- procedure Remove(Index: longint);
- procedure Pack;
- procedure Clear;
- function First: pointer;
- function Last: pointer;
- end;
- {$M-}
-
-
- TBigText = class(TCustomControl)
- private
- FFont: TFont;
- FMaxLines: word;
- FPurgeLines: word;
- FForeColor : TColor;
- FBackColor : TColor;
- FFillBack : Boolean;
- FScrollBars: TScrollStyle; {TScrollStyle = (ssNone, ssHorizontal, ssVertical, ssBoth);}
- procedure DoScroll(Which, Action, Thumb: longint);
- procedure WMHScroll(var M: TWMHScroll); message wm_HScroll;
- procedure WMVScroll(var M: TWMVScroll); message wm_VScroll;
- procedure WMSize(var M: TWMSize); message wm_Size;
- procedure WMGetDlgCode(var M: TWMGetDlgCode); message wm_GetDlgCode;
- function GetCount: longint;
- procedure SetFont(F: TFont);
- protected
- FRange: TPoint;
- FOrigin: TPoint;
- FClientSize: TPoint;
- FCharSize: TPoint;
- FOverhang: longint;
- FPageSize: longint;
- Lines: TBigList;
- TextAttrib : TBigList;
- procedure Paint; override;
- procedure SetScrollbars;
- procedure KeyDown(var Key: Word; Shift: TShiftState); override;
- procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
- X, Y: Integer); override;
- public
- constructor Create(AnOwner: TComponent); override;
- destructor Destroy; override;
- procedure CreateParams(var Params: TCreateParams); override;
- procedure ChangeScrollBars(Value: TScrollStyle);
- procedure ScrollTo(X, Y: longint);
- procedure AddLine(LineString: string; FCol, BCol: TColor; UpdateDisplay: boolean);
- {added by dfs}
- procedure AddString(LineString: string; UpdateDisplay: boolean); {use default attributes}
- procedure AddStringA(LineString: string; Fore, Back : TColor; Align : TTextAlign;
- Style : TFontStyles; UpdateDisplay: boolean);
- procedure AlignText(Index : LongInt; Align : TTextAlign; UpdateDisplay: boolean);
- procedure SetStyle (Index : LongInt; Style :TFontStyles; UpdateDisplay: boolean);
- {end of dfs changes}
- procedure Delete(Index: longint);
- procedure Clear;
- procedure Print;
- {added by EJH }
- function CurPos: longint;
- function GoPosition(GoPos: longint): bool;
- function Search(SrcWord: string; SrchDown, MCase: bool): bool;
- function DoSearch(SrcWord: string; MCase: bool; I: longint): longint;
- procedure LoadFromFileANSI(FileName: TFileName);
- function Printspec(const szWLine: string): bool;
- {end of EJH changes}
- procedure LoadFromFile(FileName: TFileName);
- function GetLine(Index: longint): string;
- procedure ChangeColor(Index: longint; OldFCol, OldBCol, NewFCol, NewBCol: TColor);
- {added by dfs}
- procedure SetColors(Index: longint; NewFCol, NewBCol: TColor);
- {end of dfs changes}
- published
- procedure RecalcRange;
- procedure FontChanged(Sender: TObject);
- property Font: TFont read FFont write SetFont;
- property Align;
- property ParentColor;
- property MaxLines: word read FMaxLines write FMaxLines default 0;
- property PurgeLines: word read FPurgeLines write FPurgeLines default 200;
- property Color;
- property Count: longint read GetCount;
-
- {added by dfs}
- {these are the defaults if a fore and back color isn't specified when a line
- of text is added to the list}
- property ForeColor : TColor read FForeColor write FForeColor default clBlack;
- property BackColor : TColor read FBackColor write FBackColor default clWhite;
- property FillBack : Boolean read FFillBack write FFillBack default False;
- property ScrollBars: TScrollStyle read FScrollBars write ChangeScrollBars default ssNone;
- {end of dfs changes}
- end;
-
- procedure Register;
-
- implementation
-
- { Scroll key definition record }
-
- type
- TScrollKey = record
- sKey: Byte;
- Ctrl: Boolean;
- SBar: Byte;
- Action: Byte;
- end;
-
- { Scroll keys table }
-
- const
- ScrollKeyCount = 16; {modified by EJH from 12}
- ScrollKeys: array[1..ScrollKeyCount] of TScrollKey = (
- (sKey: vk_Left; Ctrl: False; SBar: sb_Horz; Action: sb_LineUp),
- (sKey: vk_Right; Ctrl: False; SBar: sb_Horz; Action: sb_LineDown),
- (sKey: vk_Left; Ctrl: True; SBar: sb_Horz; Action: sb_PageUp),
- (sKey: vk_Right; Ctrl: True; SBar: sb_Horz; Action: sb_PageDown),
- (sKey: vk_Home; Ctrl: False; SBar: sb_Horz; Action: sb_Top),
- (sKey: vk_End; Ctrl: False; SBar: sb_Horz; Action: sb_Bottom),
- (sKey: vk_Up; Ctrl: False; SBar: sb_Vert; Action: sb_LineUp),
- (sKey: vk_Down; Ctrl: False; SBar: sb_Vert; Action: sb_LineDown),
- (sKey: vk_Prior; Ctrl: False; SBar: sb_Vert; Action: sb_PageUp),
- (sKey: vk_Next; Ctrl: False; SBar: sb_Vert; Action: sb_PageDown),
- (sKey: vk_F1; Ctrl: False; SBar: sb_Vert; Action: sb_PageDown),{EJH}
- (sKey: vk_F2; Ctrl: False; SBar: sb_Vert; Action: sb_PageUp), {EJH}
- (sKey: vk_F3; Ctrl: False; SBar: sb_Vert; Action: sb_Top), {EJH}
- (sKey: vk_F4; Ctrl: False; SBar: sb_Vert; Action: sb_Bottom), {EJH}
- (sKey: vk_Home; Ctrl: True; SBar: sb_Vert; Action: sb_Top),
- (sKey: vk_End; Ctrl: True; SBar: sb_Vert; Action: sb_Bottom));
-
- var
- szANSI : String;
-
- function Min(X, Y: longint): longint;
- begin
- if X < Y then Min := X else Min := Y;
- end;
-
- function Max(X, Y: longint): longint;
- begin
- if X > Y then Max := X else Max := Y;
- end;
-
- {<<<<<<<<<<<<<<<<<<<< TBigList >>>>>>>>>>>>>>>>>>>>>>>}
-
- constructor TBigList.Create;
- begin
- ListCount := 0;
- TheLines[ListCount] := TList.Create;
- end;
-
- destructor TBigList.Destroy;
- var
- i: longint;
- begin
- for i := 0 to ListCount do
- TheLines[i].Free;
- end;
-
- class function TBigList.ClassName: string;
- begin
- ClassName := 'TBigList';
- end;
-
- function TBigList.GetCapacity: longint;
- var
- i: longint;
- j: longint;
- begin
- j := 0;
- for i := 0 to ListCount do
- inc(j, TheLines[i].Capacity);
- GetCapacity := j;
- end;
-
- function TBigList.GetCount: longint;
- var
- i: longint;
- j: longint;
- begin
- j := 0;
- for i := 0 to ListCount do
- inc(j, TheLines[i].Count);
- GetCount := j;
- end;
-
- function TBigList.Add(Item: Pointer): longint;
- var
- i: longint;
- j: longint;
- begin
- try
- TheLines[ListCount].Add(Item);
- j := 0;
- for i := 0 to ListCount do
- inc(j, TheLines[ListCount].Count);
- Add := j - 1;
- except
- try
- inc(ListCount);
- TheLines[ListCount] := TList.Create;
- TheLines[ListCount].Add(Item);
- j := 0;
- for i := 0 to ListCount do
- inc(j, TheLines[i].Count);
- Add := j - 1;
- except
- j := 0;
- for i := 0 to (ListCount - 1) do
- inc(j, TheLines[i].Count);
- raise EOutOfResources.Create('Out of Memory at line ' + IntToStr(j));
- Add := -1;
- end;
- end;
- end;
-
- procedure TBigList.Delete(Index: longint);
- var
- i: longint;
- begin
- if Index > Count then
- raise ERangeError.Create('TBigList Index out of bounds')
- else
- begin
- i := 0;
- while Index > (TheLines[i].Count - 1) do
- begin
- dec(Index, TheLines[i].Count);
- inc(i);
- end;
- TheLines[i].Delete(Index);
- end;
- end;
-
- procedure TBigList.Remove(Index: longint);
- begin
- Delete(Index);
- end;
-
- procedure TBigList.Pack;
- var
- i : longint;
- j : longint;
- ListFull: boolean;
- begin
- TheLines[0].Pack;
- i := 0;
- while (i < ListCount) do
- begin
- try
- TheLines[i].Add(TheLines[i + 1].Items[0]);
- TheLines[i + 1].Delete(0);
- except
- inc(i);
- end;
- end;
- TheLines[i].Pack;
- for i := ListCount downto 1 do
- begin
- if TheLines[i].Count = 0 then
- TheLines[i].Free;
- end;
- end;
-
- procedure TBigList.Clear;
- var
- i: longint;
- begin
- for i := 1 to ListCount do
- TheLines[ListCount].Free;
- ListCount := 0;
- TheLines[ListCount].Clear;
- end;
-
- function TBigList.First: pointer;
- begin
- First := TheLines[0].Items[0];
- end;
-
- function TBigList.Last: pointer;
- begin
- Last := TheLines[ListCount].Items[TheLines[ListCount].Count - 1];
- end;
-
- function TBigList.GetItems(Index: longint): pointer;
- var
- i: longint;
- begin
- if Index > Count then
- raise ERangeError.Create('TBigList Index out of bounds')
- else
- begin
- i := 0;
- while Index > (TheLines[i].Count - 1) do
- begin
- dec(Index, TheLines[i].Count);
- inc(i);
- end;
- GetItems := TheLines[i].Items[Index];
- end;
- end;
-
- procedure TBigList.SetItems(Index: longint; const Item: pointer);
- var
- i: longint;
- begin
- if Index > Count then
- raise ERangeError.Create('TBigList Index out of bounds')
- else
- begin
- i := 0;
- while Index > (TheLines[i].Count - 1) do
- begin
- dec(Index, TheLines[i].Count);
- inc(i);
- end;
- TheLines[i].Items[Index] := Item;
- end;
- end;
-
-
-
- {<<<<<<<<<<<<<<<<<<<< TBigText >>>>>>>>>>>>>>>>>>>>>>>}
-
- constructor TBigText.Create(AnOwner: TComponent);
- begin
- inherited Create(AnOwner);
- Width := 320;
- Height := 200;
- ParentColor := False;
- FFont := TFont.Create;
- FFont.Name := 'Courier';
- FFont.OnChange := FontChanged;
- FForeColor := clBlack; {dfs}
- FBackColor := clWhite; {dfs}
- FMaxLines := 0;
- FPurgeLines := 200;
- FOrigin.X := 0;
- FOrigin.Y := 0;
- FontChanged(nil);
- FScrollBars := ssVertical; {dfs}
- FFillBack := False; {dfs}
- Enabled := True;
- Lines := TBigList.Create;
- TextAttrib := TBigList.Create; {dfs}
- end;
-
- destructor TBigText.Destroy;
- begin
- Lines.Free;
- TextAttrib.Free; {dfs}
- FFont.Free;
- inherited Destroy;
- end;
-
- {added by dfs}
- procedure TBigText.CreateParams(var Params: TCreateParams);
- const
- ScrollBar: array[TScrollStyle] of LongInt = (0, WS_HSCROLL, WS_VSCROLL,
- WS_HSCROLL or WS_VSCROLL);
- begin
- inherited CreateParams(Params);
- Params.Style := Params.Style or ScrollBar[FScrollBars];
- end;
-
- procedure TBigText.ChangeScrollBars(Value: TScrollStyle);
- begin
- if FScrollBars <> Value then
- begin
- FScrollBars := Value;
- RecreateWnd;
- end;
- end;
- {end of dfs changes}
-
- procedure TBigText.FontChanged(Sender: TObject);
- var
- DC: HDC;
- Save: THandle;
- Metrics: TTextMetric;
- Temp: String;
- begin
- DC := GetDC(0);
- Save := SelectObject(DC, Font.Handle);
- GetTextMetrics(DC, Metrics);
- SelectObject(DC, Save);
- ReleaseDC(0, DC);
- with Metrics do
- begin
- FCharSize.X := tmAveCharWidth;
- FCharSize.Y := tmHeight + tmExternalLeading;
- FOverhang := Max(tmOverhang, tmMaxCharWidth - tmAveCharWidth);
- RecalcRange;
- Invalidate;
- end;
- end;
-
- procedure TBigText.RecalcRange;
- begin
- if HandleAllocated then
- begin
- FClientSize.X := ClientWidth div FCharSize.X;
- FClientSize.Y := ClientHeight div FCharSize.Y;
- FPageSize := FClientSize.Y;
- FRange.X := Max(0, 255 - FClientSize.X);
- FRange.Y := Max(0, Lines.Count - FClientSize.Y);
- ScrollTo(Min(FOrigin.X, FRange.X), Min(FOrigin.Y, FRange.Y));
- SetScrollBars;
- end;
- end;
-
- procedure TBigText.SetScrollBars;
- begin
- if HandleAllocated then
- begin
- if (FScrollBars = ssHorizontal) or (FScrollBars = ssBoth) then {dfs}
- begin
- SetScrollRange(Handle, sb_Horz, 0, Max(1, FRange.X), False);
- SetScrollPos(Handle, sb_Horz, FOrigin.X, True);
- end;
- if (FScrollBars = ssVertical) or (FScrollBars = ssBoth) then {dfs}
- begin
- SetScrollRange(Handle, sb_Vert, 0, Max(1, FRange.Y), False);
- SetScrollPos(Handle, sb_Vert, FOrigin.Y, True);
- end;
- end;
- end;
-
- procedure TBigText.Paint; {lot's of changes here -- dfs}
- var
- i: longint;
- R: TRect;
- flag : Word;
- begin
- SetViewportOrg(Canvas.Handle, -FOrigin.X * FCharSize.X, 0);
- i := FOrigin.Y;
- while (i < Lines.Count) and (i < ((FOrigin.Y + FPageSize) + 1)) do
- begin
- Canvas.Font := FFont;
- Canvas.Font.Color := TTextAttributes(TextAttrib.Items[i]).FColor;
- Canvas.Brush.Color := TTextAttributes(TextAttrib.Items[i]).BColor;
- Canvas.Font.Style := TTextAttributes(TextAttrib.Items[i]).Style;
- R.Left := 0;
- R.Right := ClientWidth + FOrigin.X + FRange.X * FCharSize.X; { ges }
- R.Top := FCharSize.Y * (i - FOrigin.Y);
- R.Bottom := R.Top + FCharSize.Y;
- flag := DT_TOP or DT_SINGLELINE or DT_EXTERNALLEADING or DT_LEFT;
- case TTextAttributes(TextAttrib.Items[i]).Align of
- taLeft : flag := flag or DT_LEFT;
- taCenter : flag := flag or DT_CENTER;
- taRight : flag := flag or DT_RIGHT;
- end;
- if FFillBack then Canvas.FillRect(R);
- DrawText(Canvas.Handle, Lines.Items[i], StrLen(Lines.Items[i]), R, flag);
- inc(i);
- end;
- end;
-
- procedure TBigText.DoScroll(Which, Action, Thumb: longint);
- var
- X, Y: longint;
- function GetNewPos(Pos, Page, Range: longint): longint;
- begin
- case Action of
- sb_LineUp: GetNewPos := Pos - 1;
- sb_LineDown: GetNewPos := Pos + 1;
- sb_PageUp: GetNewPos := Pos - Page;
- sb_PageDown: GetNewPos := Pos + Page;
- sb_Top: GetNewPos := 0;
- sb_Bottom: GetNewPos := Range;
- sb_ThumbPosition,
- sb_ThumbTrack : GetNewPos := Thumb;
- else
- GetNewPos := Pos;
- end;
- end;
- begin
- X := FOrigin.X;
- Y := FOrigin.Y;
- case Which of
- sb_Horz: X := GetNewPos(X, FClientSize.X div 2, FRange.X);
- sb_Vert: Y := GetNewPos(Y, FClientSize.Y, FRange.Y);
- end;
- ScrollTo(X, Y);
- end;
-
- procedure TBigText.WMHScroll(var M: TWMHScroll);
- begin
- DoScroll(sb_Horz, M.ScrollCode, M.Pos);
- end;
-
- procedure TBigText.WMVScroll(var M: TWMVScroll);
- begin
- DoScroll(sb_Vert, M.ScrollCode, M.Pos);
- end;
-
- procedure TBigText.WMSize(var M: TWMSize);
- begin
- inherited;
- RecalcRange;
- end;
-
- procedure TBigText.ScrollTo(X, Y: longint);
- var
- R: TRect;
- OldOrigin: TPoint;
- begin
- X := Max(0, Min(X, FRange.X)); { check boundaries }
- Y := Max(0, Min(Y, FRange.Y));
- if (X <> FOrigin.X) or (Y <> FOrigin.Y) then
- begin
- OldOrigin := FOrigin;
- FOrigin.X := X;
- FOrigin.Y := Y;
- if HandleAllocated then
- begin
- R := Parent.ClientRect; {EJH added Parent }
- ScrollWindowEx(Handle, (OldOrigin.X - X) * FCharSize.X, (OldOrigin.Y - Y) * FCharSize.Y,
- nil, @R, 0, @R, 0);
- if Y <> OldOrigin.Y then
- SetScrollPos(Handle, sb_Vert, Y, True);
- if X <> OldOrigin.X then
- SetScrollPos(Handle, sb_Horz, X, True);
- InvalidateRect(Handle, @R, true);
- Update;
- end;
- end;
- end;
-
- procedure TBigText.AddLine(LineString: string; FCol, BCol: TColor; UpdateDisplay: boolean);
- var
- DumChar: array[0..255] of char;
- WhereY : longint;
- i : longint;
- attrib : TTextAttributes;
- R : TRect;
- flag : Word;
- begin
- if FMaxLines <> 0 then
- begin
- if (Lines.Count >= FMaxLines) or (Lines.Count > 32000) then
- begin
- if PurgeLines <> 0 then
- begin
- for i := 1 to PurgeLines do
- begin
- Lines.Delete(0);
- TextAttrib.Delete(0);
- end;
- Lines.Pack;
- TextAttrib.Pack;
- end
- else
- raise ERangeError.Create('Maximum line count at line ' + IntToStr(Lines.Count))
- end;
- end;
-
- try
- Lines.Add(StrNew(StrPCopy(DumChar, LineString)));
- attrib := TTextAttributes.Create; {dfs stuff}
- attrib.FColor := FCol;
- attrib.BColor := BCol;
- attrib.Align := taLeft;
- attrib.Style := [];
- TextAttrib.Add(attrib);
- except
- if PurgeLines <> 0 then
- begin
- for i := 1 to PurgeLines do
- begin
- Lines.Delete(0);
- TextAttrib.Delete(0); {dfs}
- end;
- Lines.Pack;
- TextAttrib.Delete(0);
- try
- Lines.Add(StrNew(StrPCopy(DumChar, LineString)));
- attrib := TTextAttributes.Create; {dfs stuff}
- attrib.FColor := FCol;
- attrib.BColor := BCol;
- attrib.Align := taLeft;
- attrib.Style := [];
- TextAttrib.Add(attrib);
- except
- raise EOutOfResources.Create('Out of Memory at line ' + IntToStr(Lines.Count))
- end;
- end
- else
- raise EOutOfResources.Create('Out of Memory at line ' + IntToStr(Lines.Count))
- end;
-
- if UpdateDisplay then
- begin
- SetViewportOrg(Canvas.Handle, 0, 0);
- RecalcRange;
- WhereY := Min(Lines.Count - 1, FPageSize);
- Canvas.Font := FFont; {more dfs changes below}
- Canvas.Font.Color := TTextAttributes(TextAttrib.Items[Lines.Count -1]).FColor;
- Canvas.Brush.Color := TTextAttributes(TextAttrib.Items[Lines.Count -1]).BColor;
- Canvas.Font.Style := TTextAttributes(TextAttrib.Items[Lines.Count -1]).Style;
- R.Left := 0;
- R.Right := ClientWidth + FOrigin.X + FRange.X * FCharSize.X; { ges }
- R.Top := FCharSize.Y * WhereY;
- R.Bottom := R.Top + FCharSize.Y;
- flag := DT_TOP or DT_SINGLELINE or DT_EXTERNALLEADING or DT_LEFT;
- case TTextAttributes(TextAttrib.Items[Lines.Count -1]).Align of
- taLeft : flag := flag or DT_LEFT;
- taCenter : flag := flag or DT_CENTER;
- taRight : flag := flag or DT_RIGHT;
- end;
- if FFillBack then Canvas.FillRect(R);
- DrawText(Canvas.Handle, Lines.Items[Lines.Count - 1],
- StrLen(Lines.Items[Lines.Count -1]), R, flag);
- ScrollTo(0, FRange.Y);
- end;
- end;
-
- {dfs additions}
-
- procedure TBigText.AddString(LineString: string; UpdateDisplay: boolean);
- begin
- AddLine(LineString, FForeColor, FBackColor, UpdateDisplay);
- end;
-
- procedure TBigText.AddStringA(LineString: string; Fore, Back : TColor;
- Align : TTextAlign; Style : TFontStyles; UpdateDisplay: boolean);
- begin
- AddLine(LineString, Fore, Back, True);
- TTextAttributes(TextAttrib.Items[Count -1]).Align := Align;
- TTextAttributes(TextAttrib.Items[Count -1]).Style := Style;
- SetStyle(Count-1, Style, False);
- AlignText(Count-1, Align, True);
- end;
-
- procedure TBigText.AlignText(Index : LongInt; Align : TTextAlign; UpdateDisplay: boolean);
- begin
- TTextAttributes(TextAttrib.Items[Index]).Align := Align;
- if UpdateDisplay then Refresh;
- end;
-
- procedure TBigText.SetStyle (Index : LongInt; Style :TFontStyles; UpdateDisplay: boolean);
- begin
- TTextAttributes(TextAttrib.Items[Index]).Style := Style;
- if UpdateDisplay then Refresh;
- end;
-
- {end of dfs additions}
-
- procedure TBigText.Delete(Index: longint);
- begin
- Lines.Delete(Index);
- TextAttrib.Delete(Index);
- end;
-
- procedure TBigText.Clear;
- begin
- Lines.Clear;
- TextAttrib.Clear;
- RecalcRange;
- Invalidate;
- end;
-
- procedure TBigText.Print;
- var
- i: longint;
- f: Textfile;
- begin
- cursor := crHourGlass; { Added EJH 7/5/95 }
- AssignPrn(f);
- Rewrite(f);
- cursor := crHourGlass; { Added EJH 7/5/95 }
- Printer.Canvas.Font := FFont; { Added EJH 7/5/95 }
- for i := 0 to (Lines.Count - 1) do
- WriteLn(f, StrPas(Lines.Items[i]));
- System.Close(f);
- cursor := crDefault; { Added EJH 7/5/95 }
- end;
-
- {
- Added - EJH
- }
- function TBigText.CurPos : longint;
- begin
- Result := Forigin.Y;
- end;
- {
- Function GoPosition - Added EJH 07/11/95
- Parameters:
- GoPos : Integer - Position to go to 1-N.
-
- Returns False if GoPos is > maximum lines. True otherwise.
- }
- function TBigText.GoPosition(GoPos: longint): bool;
- var
- Y : longint;
- X : longint;
- LC: longint;
- begin
- Y := FOrigin.Y;
- X := FOrigin.X;
- LC := Lines.Count;
- result := False;
- if GoPos > 0 then
- begin
- if LC > GoPos then
- begin
- Y := GoPos;
- ScrollTo(X, Y);
- result := true;
- end;
- end;
- end;
-
- {
- Function Search - Added EJH 07/04/95
- Parameters:
- SrcWord : String - What to Look for in the array
- SrchDown : Bool - True - Search down; False - Search Up
- MCase : Bool - True - Match Case Exact; False - Disregard Case
-
- Note: This is a little screwy because it does not redisplay the
- last page if text is found there, the re-drawn then found
- again on that line.
- }
- function TBigText.Search(SrcWord: string; SrchDown : Bool; MCase : Bool): bool;
- var
- Y: longint;
- X: longint;
- fnd: longint;
- index: longint;
- I: longint;
- LC: longint;
- SavCol:TColor;
- begin
- Y := FOrigin.Y;
- X := FOrigin.X;
- fnd := 0;
- I := Y;
- LC := Lines.Count;
- if SrchDown then
- begin
- while I < (LC - 1) do
- begin
- I := I + 1;
- fnd := DoSearch(SrcWord, MCase, I);
- if fnd > 0 then
- begin
- index := I;
- I := Lines.Count;
- end;
- end;
- end
- else
- begin
- while I > 0 do
- begin
- I := I - 1;
- fnd := DoSearch(SrcWord, MCase, I);
- if fnd > 0 then
- begin
- index := I;
- I := 0;
- end;
- end;
- end;
- if fnd > 0 then
- begin
- Y := index;
- SavCol := TTextAttributes(TextAttrib.Items[Index]).BColor;
- ChangeColor(Y,
- (TTextAttributes(TextAttrib.Items[Index]).FColor),
- SavCol,
- (TTextAttributes(TextAttrib.Items[Index]).FColor),
- $00FF0000);
- invalidate;
- ScrollTo(X, Y);
- ChangeColor(Y,
- (TTextAttributes(TextAttrib.Items[Index]).FColor),
- $00FF0000,
- (TTextAttributes(TextAttrib.Items[Index]).FColor),
- SavCol);
- result := true;
- end
- else
- begin
- result := false;
- end;
- end;
-
- function TBigText.DoSearch(SrcWord:String; MCase:Bool; I:longint ): longint;
- begin
- if MCase then
- result := pos(SrcWord, StrPas(Lines.Items[I]))
- else
- result := pos(UpperCase(SrcWord),
- UpperCase(StrPas(Lines.Items[I])));
- end;
-
- procedure TBigText.LoadFromFile(FileName: TFileName);
- var
- f: TextFile;
- i: integer;
- ReadLine: string;
- DumChar: array[0..255] of char;
- OEMDumChar: array[0..255] of char;
- begin
- Clear;
- Cursor := crHourGlass; { EJH 07/04/95 }
- AssignFile(f, FileName);
- Reset(f);
- while not eof(f) do
- begin
- ReadLn(f, ReadLine);
- while pos(#$9, ReadLine) > 0 do
- begin
- i := pos(#$9, ReadLine);
- System.delete(ReadLine, i, 1);
- while (i mod 8) <> 0 do
- begin
- insert(' ', ReadLine, i);
- inc(i);
- end;
- end;
- StrPCopy(DumChar, ReadLine);
- {OEMToAnsi(DumChar, OEMDumChar);
- AddLine(StrPas(OEMDumChar), clWindowText, clWindow, false);}
- AddLine(StrPas(DumChar), clWindowText, clWindow, false); {EJH}
- end;
- CloseFile(f);
- Cursor := crDefault; {EJH}
- RecalcRange;
- Invalidate;
- end;
-
- procedure TBigText.LoadFromFileANSI(FileName: TFileName);
- var
- f: TextFile;
- i: LongInt;
- ReadLine: string;
- DumChar: array[0..255] of char;
- OEMDumChar: array[0..255] of char;
- ansil : string;
- begin
- Clear;
- Cursor := crHourGlass; { EJH 07/04/95 }
- AssignFile(f, FileName);
- Reset(f);
- while not eof(f) do
- begin
- ReadLn(f, ReadLine);
- ansil := Copy (ReadLine, 2, Length(Readline) - 1);
-
- if Readline[1] = '@' then
- begin
- Printspec(ansil);
- ReadLine := Copy(szANSI, 1, Length(szANSI) - 1);
- end
- else
- begin
- ReadLine := Copy(ansil, 1, Length(ansil));
- end;
-
- while pos(#$9, ReadLine) > 0 do
- begin
- Cursor := crHourGlass;
- i := pos(#$9, ReadLine);
- System.delete(ReadLine, i, 1);
- while (i mod 8) <> 0 do
- begin
- insert(' ', ReadLine, i);
- inc(i);
- end;
- end;
- StrPCopy(DumChar, ReadLine);
- OEMToAnsi(DumChar, OEMDumChar);
- AddLine(StrPas(OEMDumChar), clWindowText, clWindow, false);
- end;
- CloseFile(f);
- Cursor := crDefault; {EJH}
- RecalcRange;
- Invalidate;
- end;
-
- {
- Function Clears up the @@ line markers
- }
- function TBigText.Printspec(const szWLine: String): Bool;
- var
- szFont : String;
- cCh : Char;
- iPos : LongInt;
- iTrail : LongInt;
- iLength : LongInt;
- bDouble : Bool;
- szLine : String;
- begin
- iPos := 0;
- szANSI := '';
- szLine := '';
- bDouble:= False;
- iLength := Length(szWLine);
- while iPos < iLength - 1 do
- begin
- iPos := iPos + 1;
- if iPos < 255 then
- begin
- if szWLine[iPos] = '@' then
- begin
- iTrail := iPos + 1; { Use next byte for check }
- if szWLine[iTrail] = '@' then { Found Signal }
- begin
- iPos := iPos + 2; { Reset pointer }
- case szWLine[iPos] of
- 'N', '1' : begin { N0, N2, N7, 10, 12, 17 cpi}
- iPos := iPos + 2;
- bDouble := False;
- end;
- 'D' : begin { D0, D2, D7 - Double Wide }
- bDouble := True;
- iPos := iPos + 2;
- end;
- '6', '8' : begin { @@6L & @@8L }
- bDouble := False;
- iPos := iPos + 2;
- end;
- else { Do nothing...}
- end;
- end;
- end;
- if bDouble then
- begin
- AppendStr(szLine, ' ');
- AppendStr(szLine, szWLine[iPos]);
- end
- else
- AppendStr(szLine, szWline[iPos]);
- end; { End of while statement }
- end; { End of if ipos < 255 }
- AppendStr(szANSI, szLine);
- end;
-
- function TBigText.GetLine(Index: longint): string;
- begin
- if Index < Lines.Count then
- GetLine := StrPas(Lines.Items[Index])
- else
- GetLine := '';
- end;
-
- procedure TBigText.SetFont(F: TFont);
- begin
- FFont.Assign(F);
- end;
-
- procedure TBigText.KeyDown(var Key: Word; Shift: TShiftState);
- var
- I: Integer;
- begin
- inherited KeyDown(Key, Shift);
- if Key <> 0 then
- begin
- for I := 1 to ScrollKeyCount do
- with ScrollKeys[I] do
- if (sKey = Key) and (Ctrl = (Shift = [ssCtrl])) then
- begin
- DoScroll(SBar, Action, 0);
- Exit;
- end;
- end;
- end;
-
- procedure TBigText.MouseDown(Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- begin
- SetFocus;
- inherited MouseDown(Button, Shift, X, Y);
- end;
-
- procedure TBigText.WMGetDlgCode(var M: TWMGetDlgCode);
- begin
- M.Result := dlgc_WantArrows or dlgc_WantChars;
- end;
-
- procedure TBigText.ChangeColor(Index: longint; OldFCol, OldBCol, NewFCol, NewBCol: TColor);
- begin
- if (TTextAttributes(TextAttrib.Items[Index]).FColor = OldFCol) and {dfs}
- (TTextAttributes(TextAttrib.Items[Index]).BColor = OldBCol) then
- begin
- TTextAttributes(TextAttrib.Items[Index]).FColor := NewFCol;
- TTextAttributes(TextAttrib.Items[Index]).BColor := NewBCol;
- end;
- end;
-
- procedure TBigText.SetColors(Index: longint; NewFCol, NewBCol: TColor);
- begin
- TTextAttributes(TextAttrib.Items[Index]).FColor := NewFCol; {dfs}
- TTextAttributes(TextAttrib.Items[Index]).BColor := NewBCol;
- end;
-
- function TBigText.GetCount: longint;
- begin
- if Lines.Count = TextAttrib.Count then
- GetCount := Lines.Count
- else
- GetCount := -1;
- end;
-
- procedure Register;
- begin
- RegisterComponents('FreeWare', [TBigText]);
- end;
-
- end.
-