richeditbrowser.pas

Delphi VCL Component Pack

   Font.Handle := GetStockObject(OEM_FIXED_FONT);
   CharToOem(@Key, @ch[1]);
   Key := ch[1];
end;

procedure TRichEditWB.GetMemStatus;
var
   memory: TMemoryStatus;
begin
   memory.dwLength := SizeOf(memory);
   GlobalMemoryStatus(memory);
   ShowMessage('Total memory: ' + IntToStr(memory.dwTotalPhys) + ' Bytes'
      + #10 + #13 + 'Available memory: ' + IntToStr(memory.dwAvailPhys) + ' Bytes');
end;

function TRichEditWB.IsSeparator(Car: Char): Boolean;
begin
   case Car of
      '.', ';', ',', ':', '!', '"', '''', '^', '+', '-', '*', '/', '\', ' ',
         '`', '[', ']', '(', ')', '{', '}', '?', '%', '=': Result := True;
      else
         Result := False;
   end;
end;

function TRichEditWB.GetNextWord(var s: string; var PrevWord: string): string;
begin
   Result := '';
   PrevWord := '';
   if s = '' then
      Exit;
   while (s <> '') and IsSeparator(s[1]) do
      begin
         PrevWord := PrevWord + s[1];
         Delete(s, 1, 1);
      end;
   while (s <> '') and not IsSeparator(s[1]) do
      begin
         Result := Result + s[1];
         Delete(s, 1, 1);
      end;
end;

function TRichEditWB.IsNumber(s: string): Boolean;
var
   i: Integer;
begin
   Result := False;
   for i := 1 to Length(s) do
      case s[i] of
         '0'..'9': ;
         else
            Exit;
      end;
   Result := True;
end;

function TRichEditWB.GetVisibleLines: Integer;
begin
   Result := Height div (Abs(Self.Font.Height) + 2);
end;

procedure TRichEditWB.DoHighlightHtml;
var
   ms: TMemoryStream;
begin
   if HighlightHTML then
      begin
         HTMLSyn := THighlightHTML.Create;
         HTMLSyn.SetText(Text);
         ms := TMemoryStream.Create;
         HTMLSyn.ConvertToRTFStream(ms);
         PlainText := false;
         ms.Position := 0;
         Lines.LoadFromStream(ms);
         PlainText := true;
         ms.Free;
         HTMLSyn.Free;
      end;
end;

procedure TRichEditWB.DoHighlightXML;
var
   ms: TMemoryStream;
begin
   if HighlightXML then
      begin
         XMLSyn := THighlightXML.Create;
         XMLSyn.SetText(Text);
         ms := TMemoryStream.Create;
         XMLSyn.ConvertToRTFStream(ms);
         PlainText := false;
         ms.Position := 0;
         Lines.LoadFromStream(ms);
         PlainText := true;
         ms.Free;
         XMLSyn.Free;
      end;
end;

procedure TRichEditWB.CreateSnapShot(Pic: TBitmap);
var
   psd: TSaveDialog;
   Range: TFormatRange;
   TextBounary: TRect;
begin
   Pic.Width := Width;
   Pic.Height := Height;
   if (Pic.Width <> 0) and (Pic.Height <> 0) then
      Pic.Canvas.Draw(0, 0, Pic)
   else
      with Pic.Canvas do
         begin
            Brush.Color := Color;
            FillRect(ClipRect);
         end;
   Pic.Canvas.Brush.Style := bsClear;
   TextBounary := Rect(0, 0, Width * Screen.PixelsPerInch, Height * Screen.PixelsPerInch);
   with Range do
      begin
         hdc := Pic.Canvas.Handle;
         hdcTarget := Pic.Canvas.Handle;
         rc := TextBounary;
         rcPage := TextBounary;
         chrg.cpMin := 0;
         chrg.cpMax := -1;
      end;
   SendMessage(Handle, EM_FORMATRANGE, 1, Longint(@Range));
   SendMessage(Handle, EM_FORMATRANGE, 0, 0);
   if not Assigned(fImage) then
      begin
         psd := TSaveDialog.Create(Self);
         psd.FileName := 'EditorImage.bmp';
         psd.Filter := 'BMP file | (*.bmp)';
         try
            if psd.Execute then
               if FileExists(psd.FileName) then
                  if MessageDlg(Format(sOverWrite, [psd.FileName]), mtConfirmation, mbYesNoCancel, 0)
                     <> idYes then
                     Exit;
            Pic.SaveToFile(psd.FileName + '.bmp');
         finally
            psd.Free;
         end;
      end;
end;

procedure TRichEditWB.CutSel(Sender: TObject);
begin
   if not ReadOnly then
      CutToClipboard;
end;

procedure TRichEditWB.Prnt(Sender: TObject);
begin
   Print(Text);
end;

procedure TRichEditWB.CopySel(Sender: TObject);
begin
   CopyToClipboard;
end;

procedure TRichEditWB.ClearSel(Sender: TObject);
begin
   if not ReadOnly then
      ClearSelection;
end;

procedure TRichEditWB.PasteSel(Sender: TObject);
begin
   if not ReadOnly then
      PasteFromClipboard;
end;

procedure TRichEditWB.SelAll(Sender: TObject);
begin
   SelectAll;
end;

procedure TRichEditWB.ClearAll(Sender: TObject);
begin
   if not ReadOnly then
      Clear;
end;

procedure TRichEditWB.UndoLast(Sender: TObject);
begin
   Undo;
end;

procedure TRichEditWB.SetHyperLink(Setlink: Boolean; wParam: Integer);
var
   cf: TCharFormat;
begin
   FillChar(cf, SizeOf(cf), 0);
   cf.cbSize := SizeOf(cf);
   cf.dwMask := CFM_LINK or CFM_COLOR or CFM_UNDERLINE;

   if Setlink then
      begin
         cf.dwEffects := CFE_LINK or CFE_UNDERLINE;
         cf.crTextColor := COLORREF(clBlue);
      end
   else
      cf.crTextColor := Font.Color;
   SendMessage(Handle, EM_SETCHARFORMAT, wParam, integer(@cf));
end;

procedure TRichEditWB.SetSelectionHyperLink(Hyperlink: Boolean);
begin
   SetHyperlink(Hyperlink, SCF_SELECTION);
end;

procedure TRichEditWB.SetWordHyperLink(Hyperlink: Boolean);
begin
   SetHyperlink(Hyperlink, SCF_WORD or SCF_SELECTION);
end;

procedure TRichEditWB.DoURLClick(const URL: string);
var
   X: Olevariant;
begin
   if fAutoNavigate then
      begin
         if Assigned(FOnURLClick) then
            OnURLClick(Self, URL)
         else
            if Assigned(fEmbeddedWB) then
               begin
                  fEmbeddedWB.Navigate(Url, X, X, X, X);
                  fEmbeddedWB.SetFocusToDoc;
               end;
      end;
end;

procedure TRichEditWB.CNNotify(var Msg: TWMNotify);
var
   p: TENLink;
   sURL: string;
begin
   if fHighlightURL then
      begin
         if (Msg.NMHdr^.code = EN_LINK) then
            begin
               p := TENLink(Pointer(Msg.NMHdr)^);
               if (p.Msg = WM_LBUTTONDOWN) then
                  begin
                     try
                        SendMessage(Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));
                        sURL := SelText;
                        DoURLClick(sURL);
                     except
                     end;
                  end;
            end;
         inherited;
      end;
end;

procedure TRichEditWB.CreateWnd;
var
   mask: Word;
begin
   inherited CreateWnd;
   Modified := FModified;
   if fHighlightURL then
      SendMessage(Handle, EM_AUTOURLDETECT, 1, 0);
   mask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0);
   SendMessage(Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
   SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color));

   DoSetMaxLength(MaxLength);
end;

procedure TRichEditWB.DestroyWnd;
begin
   FModified := Modified;
   inherited DestroyWnd;
end;

procedure TRichEditWB.WndProc(var Msg: TMessage);

   procedure Scroll(Msg, ScrollCode: Integer);
   begin
      Perform(Msg, ScrollCode, 0);
      Perform(Msg, SB_endSCROLL, 0);
   end;

begin
   if FHideCaret and not (csDesigning in ComponentState) then
      begin
         case Msg.Msg of
            WM_LBUTTONDOWN, WM_LBUTTONUP, WM_MOUSEMOVE,
               WM_LBUTTONDBLCLK, WM_CHAR, WM_KEYUP:
               begin
                  Msg.Result := 0;
                  if Msg.Msg = WM_LBUTTONDOWN then
                     if not Focused then
                        SetFocus;
                  Exit;
               end;
            WM_KEYDOWN:
               begin
                  case Msg.WParam of
                     VK_DOWN:
                        Scroll(WM_VSCROLL, SB_LINEDOWN);
                     VK_UP:
                        Scroll(WM_VSCROLL, SB_LINEUP);
                     VK_LEFT:
                        Scroll(WM_HSCROLL, SB_LINELEFT);
                     VK_RIGHT:
                        Scroll(WM_HSCROLL, SB_LINERIGHT);
                     VK_NEXT:
                        Scroll(WM_VSCROLL, SB_PAGEDOWN);
                     VK_PRIOR:
                        Scroll(WM_VSCROLL, SB_PAGEUP);
                     VK_HOME:
                        Scroll(WM_VSCROLL, SB_TOP);
                     VK_end:
                        Scroll(WM_VSCROLL, SB_BOTTOM);
                  end;
                  Msg.Result := 0;
                  Exit;
               end;
         end;
      end;
   inherited WndProc(Msg);
end;

constructor TRichEditWB.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   if AcceptDragComponnents then
      begin
         ControlStyle := ControlStyle + [csAcceptsControls];
      end;
   CompCount := 0;
   fAcceptDragComponnents := true;
   fAcceptDragFiles := true;
   fAutoNavigate := true;
   FBottomGap := 0;
   fFileName := sUntitled;
   fHideCaret := false;
   fHighlightURL := true;
   fHTMLHighlight := true;
   fLeftGap := 0;
   fMoreThen64KB := false;
   fRightGap := 0;
   fStream := TMemoryStream.Create;
   fTopGap := 0;
   fXMLHighlight := true;
   ScrollBars := ssBoth;
   ShowHint := true;
   WordWrap := true;
   FAutoVerbMenu := true;
   FMax := 0;
   FSelection.cpMin := 0;
   FSelection.cpMax := 0;
end;

function TRichEditWB.GetPopupMenu: TPopupMenu;
var
   canCopy: Boolean;
begin
   Result := inherited GetPopupMenu;
   if SelText <> '' then
      canCopy := true
   else
      canCopy := false;
   if FAutoVerbMenu and not Assigned(PopupMenu) then
      begin
         FPopupVerbMenu := TPopupMenu.Create(Self);
         with FPopupVerbMenu do
            begin
               Items.Clear;
               CleanupInstance;
               with Items do
                  begin
                     Add(NewItem('Undo', 0, False, CanUndo, UndoLast, 0, 'MenuItem0'));
                     Add(NewLine);
                     Add(NewItem('Cut', 0, False, canCopy, CutSel, 2, 'MenuItem2'));
                     Add(NewItem('Copy', 0, False, canCopy, CopySel, 3, 'MenuItem3'));
                     Add(NewItem('Paste', 0, False, True, PasteSel, 4, 'MenuItem4'));
                     Add(NewItem('Select All', 0, False, True, SelAll, 5, 'MenuItem5'));
                     Add(NewLine);
                     Add(NewItem('Clear', 0, False, True, ClearAll, 6, 'MenuItem6'));
                     Add(NewItem('Clear Selection', 0, False, canCopy, ClearSel, 7, 'MenuItem7'));
                     Add(NewLine);
                     Add(NewItem('Find', 0, False, True, FindDialog, 8, 'MenuItem8'));
                     Add(NewLine);
                     if fXMLHighlight then
                        Add(NewItem('HighLight XML', 0, False, True, DoXMLrc, 9, 'MenuItem9'));
                     if fHTMLHighlight then
                        Add(NewItem('HighLight HTML',