rvfuncs.pas

richview1.7 full.source

unit RVFuncs;

interface

{$I RV_Defs.inc}

uses SysUtils, Windows, Classes, RVStyle,
     {$IFNDEF RVDONOTUSEJPEGIMAGE}
     Jpeg,
    {$ENDIF}
     Graphics;

procedure RV_SetPaletteToPicture(gr: TGraphic; PLogPal: PLogPalette);
function RV_CopyTag(SourceTag: Integer; TagsArePChars: Boolean): Integer;
procedure RV_PictureToDeviceOld(Canvas: TCanvas; x,y, width, height: Integer; sad:TRVScreenAndDevice;
                             gr: TGraphic;
                             ToScreen: Boolean);
procedure RV_PictureToDevice(Canvas: TCanvas; x,y, width, height: Integer; sad:TRVScreenAndDevice;
                             gr: TGraphic;
                             ToScreen: Boolean);
function RV_ReplaceTabsA(const s: String; SpacesInTab: Integer): String;
function RV_ReplaceTabsW(const s: String; SpacesInTab: Integer): String;
function RV_CompareTags(Tag1, Tag2: Integer; TagsArePChars: Boolean): Boolean;
procedure RV_InfoAboutSaD(var sad:TRVScreenAndDevice; Canvas: TCanvas);
function RV_GetHTMLRGBStr(Color: TColor): String;
function RV_GetHTMLPath(const Path: String): String;
function RV_GetHTMLFontCSS(Font: TFont): String;
function RV_PointInRect(X,Y: Integer; Left,Top,Width,Height: Integer): Boolean;
function RV_HTMLGetFontSize(pts: Integer): Integer;
function RV_HTMLOpenFontTag(ts, normalts: TFontInfo; Relative: Boolean): String;
function RV_HTMLOpenFontTag2(fnt: TFont; normalts: TFontInfo): String;
function RV_HTMLCloseFontTag(ts: TFontInfo; normalts: TFontInfo; Relative: Boolean):String;
function RV_HTMLCloseFontTag2(fnt: TFont; normalts: TFontInfo):String;

function RV_CreateGraphicsDefault(GraphicClass: TGraphicClass): TGraphic;
procedure RV_AfterImportGraphicDefault(Graphic: TGraphic);
function RV_CharPos(const Str: PChar; Chr: Char; Length: Integer): Integer; assembler;

type
  TRV_CreateGraphicsFunction = function (GraphicClass: TGraphicClass): TGraphic;
  TRV_AfterImportGraphicsProc = procedure(Graphic: TGraphic);
var
  RV_CreateGraphics: TRV_CreateGraphicsFunction;
  RV_AfterImportGraphic: TRV_AfterImportGraphicsProc;

implementation

{------------------------------------------------------------------------------}
// Perform something only on D3+, CB3+
procedure RV_SetPaletteToPicture(gr: TGraphic; PLogPal: PLogPalette);
{$IFDEF RICHVIEWCBDEF3}
var Palette: HPALETTE;
{$ENDIF}
begin
  if PLogPal<>nil then begin
    {$IFNDEF RVDONOTUSEJPEGIMAGE}
    if gr is TJpegImage then
      TJpegImage(gr).PixelFormat := jf8Bit;
    {$ENDIF}
    {$IFDEF RICHVIEWCBDEF3}
      Palette := CreatePalette(PLogPal^);
      gr.Palette := Palette;
      if gr.Palette<>Palette then
        DeleteObject(Palette);
    {$ENDIF}
  end;
end;
{------------------------------------------------------------------------------}
function RV_CopyTag(SourceTag: Integer; TagsArePChars: Boolean): Integer;
begin
  if (SourceTag<>0) and TagsArePChars then
    Result := Integer(StrNew(PChar(SourceTag)))
  else
    Result := SourceTag;
end;
{------------------------------------------------------------------------------}
procedure RV_PictureToDeviceOld(Canvas: TCanvas; x,y, width, height: Integer; sad:TRVScreenAndDevice;
                             gr: TGraphic;
                             ToScreen: Boolean);
var
  Info: PBitmapInfo;
  InfoSize: DWORD;
  Image: Pointer;
  ImageSize: DWORD;
  Bits: HBITMAP;
  DIBWidth, DIBHeight: Longint;
  PrintWidth, PrintHeight: Longint;
{
  PrintMaxWidth, PrintMaxHeight: Longint;
  RestWidth, RestHeight, PrintRestWidth, PrintRestHeight: Longint;
  ix,iy: Integer;

const MAXWIDTH  = 400;
      MAXHEIGHT = 400;
}
begin
 if width<0 then
   width := gr.Width;
 if height<0 then
   height := gr.Height;
 if ToScreen then begin
   with sad do
     Canvas.StretchDraw(Bounds(x,y,
                               MulDiv(width, ppixDevice, ppixScreen),
                               MulDiv(height, ppiyDevice, ppiyScreen)),
                         gr);
   exit;
 end;
 if gr is TBitmap then begin
     Bits := TBitmap(gr).Handle;
     GetDIBSizes(Bits, InfoSize, ImageSize);
     Info := AllocMem(InfoSize);
     try
        Image := AllocMem(ImageSize);
        try
          GetDIB(Bits, 0, Info^, Image^);
          with Info^.bmiHeader do
            begin
              DIBWidth := biWidth;
              DIBHeight := biHeight;
            end;

           {
            // Some very large pictures are not printed.
            // Below is the experiment to fix (failed)

            PrintMaxWidth := MulDiv(MAXWIDTH,  sad.ppixDevice, sad.ppixScreen);
            PrintMaxHeight:= MulDiv(MAXHEIGHT, sad.ppiyDevice, sad.ppiyScreen);

            for ix := 0 to DIBWidth div MAXWIDTH-1 do
              for iy := 0 to DIBHeight div MAXHEIGHT-1 do
                StretchDIBits(Canvas.Handle,
                              x+ix*PrintMaxWidth, y+iy*PrintMaxHeight,
                              PrintMaxWidth, PrintMaxHeight,
                              ix*MAXWIDTH, iy*MAXHEIGHT, MAXWIDTH, MAXHEIGHT,
                              Image, Info^, DIB_RGB_COLORS, SRCCOPY);

            RestWidth := DIBWidth mod MAXWIDTH;
            RestHeight := DIBHeight mod MAXHEIGHT;
            if (RestWidth<>0) or (RestHeight<>0) then begin
              PrintRestWidth := MulDiv(RestWidth,  sad.ppixDevice, sad.ppixScreen);
              PrintRestHeight:= MulDiv(RestHeight, sad.ppiyDevice, sad.ppiyScreen);

              PrintWidth := MulDiv(DIBWidth, sad.ppixDevice, sad.ppixScreen);
              PrintHeight:= MulDiv(DIBHeight, sad.ppiyDevice, sad.ppiyScreen);

              if RestWidth<>0 then
                for iy := 0 to DIBHeight div MAXHEIGHT-1 do
                  StretchDIBits(Canvas.Handle,
                              x+PrintWidth-PrintRestWidth, y+iy*PrintMaxHeight,
                              PrintRestWidth, PrintMaxHeight,
                              DIBWidth-RestWidth, iy*MAXHEIGHT, RestWidth, MAXHEIGHT,
                              Image, Info^, DIB_RGB_COLORS, SRCCOPY);

              if RestHeight<>0 then
                for ix := 0 to DIBWidth div MAXWIDTH-1 do
                  StretchDIBits(Canvas.Handle,
                              x+ix*PrintMaxWidth, y+PrintHeight-PrintRestHeight,
                              PrintMaxWidth, PrintRestHeight,
                              ix*MAXWIDTH, DIBHeight-RestHeight, MAXWIDTH, RestHeight,
                              Image, Info^, DIB_RGB_COLORS, SRCCOPY);

              if (RestWidth<>0) and (RestHeight<>0) then
                StretchDIBits(Canvas.Handle,
                            x+PrintWidth-PrintRestWidth, y+PrintHeight-PrintRestHeight,
                            PrintRestWidth, PrintRestHeight,
                            DIBWidth-RestWidth, DIBHeight-RestHeight,
                            RestWidth, RestHeight,
                            Image, Info^, DIB_RGB_COLORS, SRCCOPY);
            end;
            }
            PrintWidth := MulDiv(width, sad.ppixDevice, sad.ppixScreen);
            PrintHeight:= MulDiv(height, sad.ppiyDevice, sad.ppiyScreen);

            StretchDIBits(Canvas.Handle, x, y, PrintWidth, PrintHeight, 0, 0,
              DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
        finally
          FreeMem(Image, ImageSize);
        end;
     finally
        FreeMem(Info, InfoSize);
     end;
 end;
end;
{------------------------------------------------------------------------------}
procedure RV_PictureToDevice(Canvas: TCanvas; x,y, width, height: Integer; sad:TRVScreenAndDevice;
                             gr: TGraphic;
                             ToScreen: Boolean);
var
  Info: PBitmapInfo;
  InfoSize: DWORD;
  Image: Pointer;
  ImageSize: DWORD;
  Bits: HBITMAP;
  DIBWidth, DIBHeight: Longint;
  PrintWidth, PrintHeight: Longint;
  palHalftone, palOrig: HPALETTE;
  nOldStretchBltMode: Integer;
begin
 if width<0 then
   width := gr.Width;
 if height<0 then
   height := gr.Height;
 if ToScreen then begin
   with sad do
     Canvas.StretchDraw(Bounds(x,y,
                               MulDiv(width, ppixDevice, ppixScreen),
                               MulDiv(height, ppiyDevice, ppiyScreen)),
                         gr);
   exit;
 end;

 if gr is TBitmap then begin
     palHalftone := CreateHalftonePalette(Canvas.Handle);
     palOrig := SelectPalette(Canvas.Handle, palHalftone, False);
     RealizePalette(Canvas.Handle);
     nOldStretchBltMode := GetStretchBltMode(Canvas.Handle);
     SetStretchBltMode(Canvas.Handle, HALFTONE);

     try
       Bits := TBitmap(gr).Handle;
       GetDIBSizes(Bits, InfoSize, ImageSize);
       Info := AllocMem(InfoSize);
       try
          Image := AllocMem(ImageSize);
          try
            GetDIB(Bits, 0, Info^, Image^);
            with Info^.bmiHeader do
              begin
                DIBWidth := biWidth;
                DIBHeight := biHeight;
              end;

              PrintWidth := MulDiv(width, sad.ppixDevice, sad.ppixScreen);
              PrintHeight:= MulDiv(height, sad.ppiyDevice, sad.ppiyScreen);

              StretchDIBits(Canvas.Handle, x, y, PrintWidth, PrintHeight, 0, 0,
                DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
          finally
            FreeMem(Image, ImageSize);
          end;
       finally
          FreeMem(Info, InfoSize);
       end;
     finally
       SetStretchBltMode(Canvas.Handle, nOldStretchBltMode);
       SelectPalette(Canvas.Handle, palOrig, FALSE);
     end;
 end;
end;
{------------------------------------------------------------------------------}
function RV_ReplaceTabsA(const s: String; SpacesInTab: Integer): String;
var p: Integer;
    spaces: String;
begin
  Result := s;
  p := Pos(#9,Result);
  if p<>0 then begin
    SetLength(spaces,SpacesInTab);
    FillChar(PChar(spaces)^, SpacesInTab, ' ');
  end;
  while p<>0 do begin
    Delete(Result,p,1);