
{*******************************************************}
{                                                       }
{       RichView                                        }
{       Demo: URL detection                             }
{                                                       }
{       Copyright (c) Sergey Tkachenko                  }
{       svt@trichview.com                               }
{       http://www.trichview.com                        }
{                                                       }
{*******************************************************}

{
  This demo shows:
  - how to detect all URLs in text;
  - how to detect URLs in pasted text;
  - how to detect URLs on typing;
  - how to close hyperlink when user presses Space, Enter or punctuation character;
  - how to remove hyperlink using popup menu;
  - how to implement hypertext in editor without using Ctrl key;
  - how to modify hyperlink's tag when its visible text is changed;
  - how to remove hyperlink when its visible text was changed to non-URL;
  - how to display hyperlinks targets in hints.
}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, ExtCtrls, ShellApi,
  RVStyle, RVScroll, RichView, RVEdit, CRVData, CRVFData,
  RVUni, RVFuncs, RVItem, RVLinear,
  URLScan, Menus, RVTypes;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    btnOpen: TButton;
    btnScan: TButton;
    rve: TRichViewEdit;
    RVStyle1: TRVStyle;
    od: TOpenDialog;
    cbAutodetect: TCheckBox;
    cbAutoremove: TCheckBox;
    StatusBar1: TStatusBar;
    cbUseCtrl: TCheckBox;
    PopupMenu1: TPopupMenu;
    mitRemoveHyperlink: TMenuItem;
    cbPasteDetect: TCheckBox;
    procedure btnOpenClick(Sender: TObject);
    procedure btnScanClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure rveJump(Sender: TObject; id: Integer);
    procedure rveItemTextEdit(Sender: TCustomRichViewEdit;
      const OldText: TRVRawByteString; RVData: TCustomRVData; ItemNo: Integer;
      var NewTag, NewStyleNo: Integer);
    procedure rveItemHint(Sender: TCustomRichView; RVData: TCustomRVData;
      ItemNo: Integer; var HintText: String);
    procedure cbUseCtrlClick(Sender: TObject);
    procedure rveRVMouseUp(Sender: TCustomRichView; Button: TMouseButton;
      Shift: TShiftState; ItemNo, X, Y: Integer);
    procedure rveKeyPress(Sender: TObject; var Key: Char);
    procedure PopupMenu1Popup(Sender: TObject);
    procedure mitRemoveHyperlinkClick(Sender: TObject);
    procedure rvePaste(Sender: TCustomRichViewEdit;
      var DoDefault: Boolean);
    procedure rveGetItemCursor(Sender: TCustomRichView;
      RVData: TCustomRVData; ItemNo: Integer; var Cursor: TCursor);
  private
    { Private declarations }
    SimpleClickHypertext: Boolean;    
    procedure URLScanEvent(OldStyleNo: Integer; var NewStyleNo: Integer;
      ToHypertext: Boolean);
    procedure DisplayHint(Sender: TObject);
  public
    { Public declarations }

  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{------------------------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
begin
  // Uncomment this line to test working with Unicode
  // RVStyle1.TextStyles[0].Unicode := True;
  rve.Clear;
  rve.AddNL('This demo shows how to implement URL scanning',0,0);
  rve.AddNL('Click the button, and URLs (like this - "www.richedit.com/") will be highlighted.',0,0);
  rve.AddNL('Ctrl+click URL to launch browser or e-mail client',0,0);
  rve.Format;
  Application.OnHint := DisplayHint;
end;
{------------------------------------------------------------------------------}
{ Opening text or RTF file }
procedure TForm1.btnOpenClick(Sender: TObject);
var r: Boolean;
begin
  if not od.Execute then
    exit;
  Screen.Cursor := crHourglass;
  rve.Clear;
  rve.DeleteUnusedStyles(True,True,True);
  case od.FilterIndex of
   1: r := rve.LoadText(od.FileName,0,0,False);
   2: r := rve.LoadRTF(od.FileName);
   else r := False;
  end;
  rve.Format;
  Screen.Cursor := crDefault;
  if not r then
    Application.MessageBox('Error loading file', 'Error', MB_OK or MB_ICONSTOP);
end;
{------------------------------------------------------------------------------}
{ Removing all hyperlinks, then rescanning the whole document for URLs.
  Clearing undo buffers. }
procedure TForm1.btnScanClick(Sender: TObject);
var r: Boolean;
begin
  Screen.Cursor := crHourglass;
  // Moving caret to the beginning
  rve.SetSelectionBounds(0, rve.GetOffsBeforeItem(0), 0, rve.GetOffsBeforeItem(0));
  // Clearing undo/redo buffers
  rve.ClearUndo;
  // removing old hypertext links
  r := ClearHypertext(rve.RVData, URLScanEvent, True);
  // scanning for URLs
  r := ScanURLs(rve.RVData, URLScanEvent, True) or r;
  if r then
    rve.Format;
  Screen.Cursor := crDefault;
  rve.SetFocus;
end;
{------------------------------------------------------------------------------}
{ Callback procedure, called from ClearHypertext and ScanURLs. Also used in
  rve.OnItemTextEdit and OnPaste events.
  Returns index of style (NewStyleNo) for converting the original style
  (OldStyleNo) to.
  If ToHypertext=True, this procedure converts style to hyperlink.
  If ToHypertext=False, this procedure converts style to normal text. }
procedure TForm1.URLScanEvent(OldStyleNo: Integer; var NewStyleNo: Integer;
  ToHypertext: Boolean);
var Style: TFontInfo;
begin
  // Constructing the desired style
  Style := TFontInfo.Create(nil);
  Style.Assign(RVStyle1.TextStyles[OldStyleNo]);
  Style.Jump := ToHypertext;
  if ToHypertext then begin
    // Hypertext links will be blue and underlined
    Style.Style := Style.Style+[fsUnderline];
    Style.Color := clBlue;
    Style.JumpCursor := crJump;
    end
  else begin
    // Plain text will be black and not underlined
    Style.Style := Style.Style-[fsUnderline];
    Style.Color := clWindowText;
  end;
  // May be such style already exists?
  NewStyleNo := RVStyle1.TextStyles.FindSuchStyle(OldStyleNo,Style,RVAllFontInfoProperties);
  if NewStyleNo=-1 then begin
    // Does not exist, adding...
    RVStyle1.TextStyles.Add.Assign(Style);
    NewStyleNo := RVStyle1.TextStyles.Count-1;
    RVStyle1.TextStyles[NewStyleNo].Standard := False;
  end;
  Style.Free;
end;
{------------------------------------------------------------------------------}
{ STANDARD HIPERTEXT PROCESSING.
  OnJump event. Called when the user clicks hyperlink in standard hypertext mode
  (holding Ctrl key) }
procedure TForm1.rveJump(Sender: TObject; id: Integer);
var RVData: TCustomRVFormattedData;
    ItemNo: Integer;
    url: String;
begin
  if SimpleClickHypertext then
    exit;
  rve.GetJumpPointLocation(id, RVData, ItemNo);
  url := PChar(RVData.GetItemTag(ItemNo));
  ShellExecute(0, 'open', PChar(url), nil, nil, SW_SHOW);
end;
{------------------------------------------------------------------------------}
{ ALTERNATIVE HYPERTEXT PROCESSING
  OnRVMouseUp event. We use it to process click on hyperlink in the simple click
  mode (without using Ctrl key) }
procedure TForm1.rveRVMouseUp(Sender: TCustomRichView;
  Button: TMouseButton; Shift: TShiftState; ItemNo, X, Y: Integer);
var LRVData: TCustomRVFormattedData;
    LItemNo, LOffs: Integer;
    url: String;
    pt: TPoint;
begin
  if not SimpleClickHypertext or (Button<>mbLeft) or
     Sender.SelectionExists then
   exit;
  pt := Sender.ClientToDocument(Point(X,Y));
  if Sender.GetItemAt(pt.X, pt.Y, LRVData, LItemNo, LOffs, True) and
     LRVData.GetItem(LItemNo).GetBoolValueEx(rvbpJump, Sender.Style) then begin
    url := PChar(LRVData.GetItemTag(LItemNo));
    ShellExecute(0, 'open', PChar(url), nil, nil, SW_SHOW);
  end;
end;
{------------------------------------------------------------------------------}
{ ALTERNATIVE HYPERTEXT PROCESSING
  Returning hypertext cursor }
procedure TForm1.rveGetItemCursor(Sender: TCustomRichView;
  RVData: TCustomRVData; ItemNo: Integer; var Cursor: TCursor);
begin
  if SimpleClickHypertext and
    RVData.GetItem(ItemNo).GetBoolValueEx(rvbpJump, Sender.Style) then
    if RVData.GetItemStyle(ItemNo)>=0 then
      Cursor := Sender.Style.TextStyles[RVData.GetItemStyle(ItemNo)].JumpCursor
    else
      Cursor := Sender.Style.JumpCursor;
end;
{------------------------------------------------------------------------------}
{ OnKeyPress. Detecting URLs on typing (if cbAutodetect is checked).
  URL is detected when the user presses Space, Enter, Tab, semicolon, comma.
  This procedure also closes hyperlink (sets current style to normal text) }
procedure TForm1.rveKeyPress(Sender: TObject; var Key: Char);
begin
  if Key in [' ', #13, #9, ';', ','] then begin
    // url detection
    if cbAutodetect.Checked then
      DetectURL(rve, URLScanEvent, True);
    // closing url if necessary
    TerminateHyperlink(rve, URLScanEvent, Key in [' ', #9, ';', ',']);
  end;
end;
{------------------------------------------------------------------------------}
{ OnItemTextEdit. Updating tag when text of hyperlink is edited.
  Removing hyperlink when the text is not an URL any more (if cbAutoremove is
  checked) }
procedure TForm1.rveItemTextEdit(Sender: TCustomRichViewEdit;
  const OldText: TRVRawByteString; RVData: TCustomRVData; ItemNo: Integer;
  var NewTag, NewStyleNo: Integer);
var OldText2, NewText: String;
    StyleNo: Integer;
begin
  if NewTag=0 then
    exit;
  StyleNo := RVData.GetItemStyle(ItemNo);
  if Sender.Style.TextStyles[StyleNo].Unicode then
    OldText2 := RVU_UnicodeToAnsi(RVData.GetStyleCodePage(StyleNo), OldText)
  else
    OldText2 := OldText;
  NewText := RVData.GetItemText(ItemNo);
  if cbAutoremove.Checked and (NewText='') then begin
    // If new text is empty, removing hyperlink
    NewTag := 0;
    URLScanEvent(NewStyleNo, NewStyleNo, False);
    exit;
  end;
  if (StrComp(PChar(OldText2), PChar(NewTag))=0) then begin
    // If text before editing was equal to tag ...
    if cbAutoremove.Checked and
       (RVIsURL(OldText2) or RVIsEmail(OldText2)) and
       not (RVIsURL(NewText) or RVIsEmail(NewText)) then begin
      // ... if text is not URL any more, removing hyperlink
      NewTag := 0;
      URLScanEvent(NewStyleNo, NewStyleNo, False);
      exit;
    end;
    // ... update tag to new text
    NewTag := Integer(StrNew(PChar(NewText)));
  end;
end;
{------------------------------------------------------------------------------}
{ OnItemHint. Displaying tag strings in hints }
procedure TForm1.rveItemHint(Sender: TCustomRichView;
  RVData: TCustomRVData; ItemNo: Integer; var HintText: String);
begin
  HintText := PChar(RVData.GetItemTag(ItemNo));
end;
{------------------------------------------------------------------------------}
{ Switching the standard and the simple-click hypertext modes }
procedure TForm1.cbUseCtrlClick(Sender: TObject);
begin
  SimpleClickHypertext := not cbUseCtrl.Checked;
end;
{------------------------------------------------------------------------------}
{ Disabling/enabling the popup menu items on popup }
procedure TForm1.PopupMenu1Popup(Sender: TObject);
begin
  mitRemoveHyperlink.Enabled := rve.TopLevelEditor.GetItem
    (rve.TopLevelEditor.CurItemNo).GetBoolValueEx(rvbpJump, RVStyle1);
end;
{------------------------------------------------------------------------------}
{ Removing hyperlink at the caret position }
procedure TForm1.mitRemoveHyperlinkClick(Sender: TObject);
var LStyleNo: Integer;
    LPos: Integer;
begin
  with rve.TopLevelEditor do begin
    if not GetItem(CurItemNo).GetBoolValueEx(rvbpJump, RVStyle1) then
      exit;
    LPos := RVGetLinearCaretPos(rve.TopLevelEditor);
    SetSelectionBounds(CurItemNo, GetOffsBeforeItem(CurItemNo),
      CurItemNo, GetOffsAfterItem(CurItemNo));
    BeginUndoGroup(rvutTag);
    SetUndoGroupMode(True);
    try
      SetCurrentTag(0);
      URLScanEvent(CurItemStyle, LStyleNo, False);
      ApplyTextStyle(LStyleNo);
    finally
      SetUndoGroupMode(False);
    end;
    RVSetLinearCaretPos(rve.TopLevelEditor, LPos);
  end;
end;
{------------------------------------------------------------------------------}
{ Displaying hints in status bar }
procedure TForm1.DisplayHint(Sender: TObject);
begin
  StatusBar1.SimpleText := GetLongHint(Application.Hint);
end;
{------------------------------------------------------------------------------}
{ Detecting URLs on pasting plain text (only if RVF or RTF is not available) }
procedure TForm1.rvePaste(Sender: TCustomRichViewEdit;
  var DoDefault: Boolean);
begin
  if cbPasteDetect.Checked then
    DoDefault := not PasteTextWithURLs(Sender, URLScanEvent);
end;


end.
