{***************************************************************************}
{ TMS IntraWeb Component Pack Pro                                           }
{ for Delphi & C++Builder                                                   }
{                                                                           }
{ written by TMS Software                                                   }
{            copyright © 2002 - 2007                                        }
{            Email : info@tmssoftware.com                                   }
{            Web : http://www.tmssoftware.com                               }
{                                                                           }
{ The source code is given as is. The author is not responsible             }
{ for any possible damage done due to the use of this code.                 }
{ The component can be freely used in any application. The complete         }
{ source code remains property of the author and may not be distributed,    }
{ published, given or sold in any form as such. No parts of the source      }
{ code can be included in any other component or application without        }
{ written authorization of the author.                                      }
{***************************************************************************}

unit IWScrollPanel;

interface

{$I TMSDEFS.INC}
uses
  {$IFDEF LINUX}
  QGraphics,
  {$ELSE}
  Windows, Graphics,
  {$ENDIF}
  {$IFDEF DELPHI6_LVL}
  Types,
  {$ENDIF}
  Classes,
  {$IFDEF TMSIW51}
  IWGridCommon,
  {$ENDIF}
  IWControl, IWFont, IWTypes, IWGrids, SysUtils, IWHTMLTag, IWTMSBase
  {$IFDEF TMSIW6}
  , IWRenderContext, IWColor
  {$ENDIF} 
  ;

type
  TScrollStyle = (ssHover, ssClick);

  TTIWScrollPanel= class(TIWControl)
  private
    FAutoScroll: Boolean;
    FText: TStringList;
    FBorderColors: TIWGridBorderColors;
    FBorderSize: Integer;
    FSpeed: Integer;
    FWordWrap: Boolean;
    FScrollButtonTextDown: string;
    FScrollButtonTextUp: string;
    FScrollButtonColor: TColor;
    FScrollStyle: TScrollStyle;
    FFont: TIWfont;
    FColor: TColor;
    FScrollButtonFont: TIWFont;
    FScrollButtonGlyphUp: TBitmap;
    FScrollButtonGlyphUpURL: string;
    FScrollButtonGlyphDown: TBitmap;
    FScrollButtonGlyphDownURL: string;
    procedure SetTextEx(Value: TStringList);
    procedure SetFont(const Value: TIWFont);
    procedure SetScrollButtonFont(const Value: TIWFont);
    procedure SetScrollButtonGlyphUp(const Value: TBitmap);
    procedure SetScrollButtonGlyphDown(const Value: TBitmap);
    procedure SetScrollButtonColor(const AValue: TColor);
    procedure SetScrollButtonTextUp(const AValue: string);
    procedure SetScrollButtonTextDown(const AValue: string);
    function Htmlbmp(var bmp: TBitmap; var url: string):string;
  protected
    function HTMLClr(color: TColor): string;
    procedure TextChanged(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    {$IFDEF TMSIW6}
    procedure IWPaint; override;
    function RenderHTML(AContext: TIWBaseComponentContext): TIWHTMLTag; override;
    {$ELSE}
    procedure Paint; override;
    function RenderHTML: TIWHTMLTag; override;
    {$ENDIF}
  published
    property AutoScroll: Boolean read FAutoScroll write FAutoScroll;
    property BorderColors :TIWGridBorderColors read FBorderColors write FBorderColors;
    property BorderSize: Integer read FBorderSize Write FBorderSize default 2;
    property Color: TColor read FColor write FColor default clYellow;
    property Font: TIWfont read FFont write SetFont;
    property ScrollButtonFont: TIWFont read FScrollButtonFont write SetScrollButtonFont;
    property ScrollButtonColor: TColor read FScrollButtonColor write SetScrollButtonColor;
    property ScrollButtonTextDown: string read FScrollButtonTextDown write  SetScrollButtonTextDown;
    property ScrollButtonTextUp: string read FScrollButtonTextUp write  SetScrollButtonTextUp;
    property ScrollStyle: TScrollStyle read FScrollStyle write FScrollStyle default ssClick;
    property ScrollButtonGlyphUp: TBitmap read FScrollButtonGlyphUp write SetScrollButtonGlyphUp;
    property ScrollButtonGlyphUpURL: string read FScrollButtonGlyphUpURL write FScrollButtonGlyphUpURL;
    property ScrollButtonGlyphDown: TBitmap read FScrollButtonGlyphDown write SetScrollButtonGlyphDown;
    property ScrollButtonGlyphDownURL: string read FScrollButtonGlyphDownURL write FScrollButtonGlyphDownURL;
    property Speed: Integer read FSpeed write FSpeed default 4;
    property Text: TStringList Read Ftext Write SetTextEx;
    property WordWrap: Boolean read FWordWrap write FWordWrap default true;
  end;

implementation

uses
  IWApplication, IWForm, IWAppForm, IWServerControllerBase, SWSystem, SWStrings;

{$R tmsiwsp.res}

{ TTIWScrollPanel }

constructor TTIWScrollPanel.Create(AOwner: TComponent);
begin
  inherited;
  Width := 200;
  Height := 150;
  FText := TStringList.Create;
  FText.OnChange := TextChanged;
  FFont := TIWFont.Create;
  FFont.FontName := 'Arial';
  FFont.Color := clBlack;
  FColor := clWhite;
  FFont.Size := 10;
  FFont.OnChange := TextChanged;
  FFont.Enabled := True;
  FScrollButtonFont := TIWFont.Create;
  FScrollButtonFont.FontName := 'Arial';
  FScrollButtonFont.Color := clWhite;
  FScrollButtonFont.Size := 10;
  FScrollButtonFont.OnChange := TextChanged;

  FScrollButtonColor := clNavy;
  FBorderColors := TIWGridBorderColors.Create;
  FBorderSize := 1;
  {$IFDEF TMSIW6}
  SetRenderSize(True);
  {$ELSE}
  FRenderSize := True;
  {$ENDIF}
  FSpeed := 4;
  FWordWrap := True;
  FAutoScroll := True;
  FScrollButtonTextDown := 'Down';
  FScrollButtonTextUp := 'Up';
  FScrollStyle := ssClick;
  FScrollButtonGlyphUp := TBitmap.Create;
  FScrollButtonGlyphDown := TBitmap.Create;
  if (csDesigning in ComponentState) then
  begin
    FScrollButtonGlyphUp.LoadFromResourceName(hInstance,'IWSCRLPNLUP');
    FScrollButtonGlyphDown.LoadFromResourceName(hInstance,'IWSCRLPNLDOWN');
  end;  
end;

destructor TTIWScrollPanel.destroy;
begin
  inherited;
  FText.Free;
  FFont.Free;
  FScrollButtonFont.Free;
  FScrollButtonGlyphUp.Free;
  FScrollButtonGlyphDown.Free;
  FBorderColors.Free;
end;

procedure Draw3DCtrl(FCanvas: TCanvas; Left,Top,Right,Bottom: Integer; Color: TColor);
begin
  with FCanvas do
  begin
    Pen.Color := Color;
    MoveTo(Left,Bottom);
    LineTo(Left,Top);
    LineTo(Right,Top);
    LineTo(Right,Bottom);
    LineTo(Left,Bottom);
  end;
end;

{$IFDEF TMSIW6}
procedure TTIWScrollPanel.IWPaint;
{$ELSE}
procedure TTIWScrollPanel.Paint;
{$ENDIF}
var
  r: Trect;
  left: Integer;
begin
  inherited;
  Canvas.Pen.Color := clRed;
  Canvas.Brush.Color := FScrollButtonColor;
  Canvas.Font.Color := FScrollButtonFont.Color;
  Canvas.Font.Name := FScrollButtonFont.FontName;
  Canvas.Font.Size := FScrollButtonFont.Size;
  Canvas.Font.Style := FScrollButtonFont.Style;

  Canvas.Rectangle(0,0,Width,25);
  Canvas.Rectangle(0,Height-25,Width,Height);

  Draw3DCtrl(Canvas,0,0,Width,Height,FBorderColors.Color);

  Draw3DCtrl(Canvas,0,0,Width,25,FBorderColors.Color);

  Left := 0;

  if Assigned(FScrollButtonGlyphUp) then
  begin
    Left := FScrollButtonGlyphUp.Width;
    Canvas.Draw(2,2,FScrollButtonGlyphUp);
  end;

  r := Rect(Left + 2,2,Width - 2,23);
  Canvas.TextRect(r,2 + Left,2,FScrollButtonTextUp);

  Draw3DCtrl(Canvas,0,Height-25,Width,Height,FBorderColors.Color);
  Left := 0;

  if Assigned(FScrollButtonGlyphDown) then
  begin
    Left := FScrollButtonGlyphDown.Width;
    Canvas.Draw(2,height-23,FScrollButtonGlyphDown);
  end;
  r := Rect(Left + 2,Height - 23,Width - 2,Height - 2);
  Canvas.TextRect(r,Left + 2,Height - 23,FScrollButtonTextDown);

  Canvas.Brush.Color := FColor;

  Canvas.Font.Color := FFont.Color;
  Canvas.Font.Name := FFont.FontName;
  Canvas.Font.Size := FFont.Size;

  Canvas.Rectangle(2,25,Width - 2,Height - 25);
  r := Rect(4,27,Width - 4,Height - 27);
  {$IFNDEF LINUX}
  DrawText(Canvas.Handle, PChar(Text.Text),Length(Text.Text),r,DT_WORDBREAK);
  {$ENDIF}
end;

function TTIWScrollPanel.HTMLClr(Color: TColor):string;
begin
  Result := ColorToRGBString(Color);
end;

function TTIWScrollPanel.Htmlbmp(var bmp:TBitmap; var url:string):string;
var
  LimageTag: TIWHTMLTag;
  spath: string;
begin
  Result := '';

  if (not Assigned(bmp)) and (url = EmptyStr) then
    Exit;
  if (bmp.Empty) and (url = EmptyStr) then
    Exit;

  if url = EmptyStr then
  begin
    {$IFDEF TMSIW71}
    spath := TIWServerControllerBase.NewCacheFile('bmp',true);
    {$ELSE}
    spath := TIWServerControllerBase.NewCacheFile('bmp');
    {$ENDIF}

    bmp.SaveToFile(spath);
    spath := GetCacheDir(Self) + ExtractFileName(spath);
  end
  else
    spath := url;

  LImageTag := TIWHTMLTag.CreateTag('IMG');
  try
    LImageTag.AddStringParam('SRC',spath);
    LImageTag.AddIntegerParam('BORDER',0);
    LImageTag.AddIntegerParam('WIDTH',bmp.Width);
    LImageTag.AddIntegerParam('HEIGHT',FScrollButtonGlyphup.Height);
    LImageTag.Params.Add('style=left'+inttostr(width-bmp.Width-5)+
      'POSITION: absolute; TOP:"'+inttostr(bmp.Height div 2));
    Result := MakeHTMLTag(LImageTag);
  finally
    FreeAndNil(LImageTag)
  end;
end;

procedure TTIWScrollPanel.TextChanged;
begin
  Invalidate;
end;

{$IFDEF TMSIW6}
function TTIWScrollPanel.RenderHTML(AContext: TIWBaseComponentContext): TIWHTMLTag;
{$ELSE}
function TTIWScrollPanel.RenderHTML: TIWHTMLTag;
{$ENDIF}
var
  LTableTag: TIWHTMLTag;
  s,stmp,bodytxt: string;
  i: Integer;
begin
  if FScrollStyle = ssClick then
    stmp := ' OnClick="'
  else
    stmp := ' OnMouseMove="';

  LTableTag := TIWHTMLTag.CreateTag('TABLE');
  try
    LTableTag.AddIntegerParam('Width',Width);
    LTableTag.AddIntegerParam('Border',BorderSize);
    LTableTag.AddIntegerParam('Cellpadding',0);
    LTableTag.AddIntegerParam('Cellspacing',0);

    LTableTag.AddColor('BORDERCOLOR',BorderColors.Color);
    LTableTag.AddColor('BORDERCOLORLIGHT',BorderColors.Light);
    LTableTag.AddColor('BORDERCOLORDARK', BorderColors.Dark);

    //    s := MakeHTMLTag(LTableTag)
    s := ''
     + '<TR bgcolor='+HTMLClr(FScrollButtonColor)+'><TD '
     + stmp + HTMLName+'moveup()">'
     + Htmlbmp(FScrollButtonGlyphUp, FScrollButtonGlyphUpURL)
     + FScrollButtonFont.FontToStringTag(FScrollButtonTextUp).Render

     + '</TD></TR><TR><TD>';

       //--- Scripts part
      s := s + #13
      + '<SCRIPT language="JavaScript1.2"> ' + #13
      + 'var speed'+HTMLName+'='+Inttostr(FSpeed) + #13
      + 'iens6=document.all||document.getElementById ' + #13
      + 'ns4=document.layers ' + #13
      + 'if (iens6){ ' + #13
      + 'document.write('+#39+'<div id="'+HTMLName+'container" style="position:relative;width:'+
                       IntToStr(Width)+
                      ';height:'+IntToStr(Height- ScrollButtonGlyphDown.Height - ScrollButtonGlyphUp.Height - 8)+'; top:0'+
                      ';overflow:hidden;'{border:'+inttostr(FBorderSize)+'px ridge '+HTMLClr(BorderColors.Color)+' '}+'">'+#39+
                      ') '+#13+
        'document.write('+#39+'<div id="'+HTMLName+'content" style="position:absolute; width:'+IntToStr(width)+';left:0;top:0">'+#39+') '+#13+
                      '}'+#13+
        '</script> '+#13;

        //Layser part
        s := s + '<layer name="'+
          HTMLName + 'nscontent" width=' + IntToStr(Width) + ' height=' + IntToStr(Height)+
          ' visibility = hidden> '+#13+
          '<ilayer name="' + HTMLName + 'nscontainer" width=' + IntToStr(Width) +
          ' height=' + IntToStr(Height)+
          ' clip="0,0,' + IntToStr(Width) + ',' + IntToStr(Height) + '"> '+#13;

        bodytxt := '';
        // Body
        if FWordWrap then
        begin
           for i := 1 to FText.Count do
             bodytxt := bodytxt + FText.Strings[i - 1] + '<BR>'
        end
        else
          bodytxt := bodytxt + FText.Text;

        bodytxt := FFont.FontToStringTag(bodytxt).Render;

        s := s + bodytxt + #13 + '</layer> ' + #13 + '</ilayer></div></div></td></tr>' + #13; //tag Div close (1)

        //Other scripts
        s := s + '<script language="JavaScript1.2"> ' + #13
        +  'if (iens6){ '+ #13
        +  'var crossobj'+HTMLName+'=document.getElementById? document.getElementById("'+HTMLName+'content") : document.all.content ' + #13
        +  'var contentheight'+HTMLName+'=crossobj'+HTMLName+'.offsetHeight ' + #13
        +  '} ' + #13
        +  'else if (ns4){ ' + #13
        + 'var crossobj'+HTMLName+'=document.'+HTMLName+'nscontainer.document.'+HTMLName+'nscontent ' + #13
        + 'var contentheight'+HTMLName+'=crossobj'+HTMLName+'.clip.height ' + #13
        +  '} ' + #13
          // Real part of moveDown
        +  'IsMoving'+HTMLName+'=0;' + #13
        +  'function realmovedown'+HTMLName+'()' + #13
        +  '{' + #13
        + IIF(FAutoScroll,'IsMoving'+HTMLName+'=1;'+#13,'')
        + IIF(FAutoScroll,'if (window.'+HTMLName+'moveupvar) clearTimeout('+HTMLName+'moveupvar) '+#13,'')
        + 'var ofs = document.getElementById("'+HTMLName+'content").offsetHeight;' + #13
        + 'if (iens6&&parseInt(crossobj'+HTMLName+'.style.top)>= -ofs + '+IntToStr(Height)+')' + #13
        + 'crossobj'+HTMLName+'.style.top=parseInt(crossobj'+HTMLName+'.style.top)-speed' + HTMLName + ' ' + #13
        + 'else if (ns4&&crossobj'+HTMLName+'.top>=(contentheight'+HTMLName+'*(-1)+100)) ' + #13
        + 'crossobj'+HTMLName+'.top-=speed'+HTMLName + #13
        + IIF(FAutoScroll,HTMLName+'movedownvar=setTimeout("realmovedown'+HTMLName+'()",100) '+#13,'')
        + '}' + #13
        + 'function '+HTMLName+'movedown(){ '+#13
        + IIF(FAutoScroll,'if (IsMoving'+HTMLName+'==1) {IsMoving'+HTMLName+ '= 0; clearTimeout('+HTMLName+'movedownvar); return; }'+#13,'')
        + 'if (IsMoving'+HTMLName+'==1) return;' + #13
        + 'realmovedown'+HTMLName+'()' + #13
        + '} ' + #13
        + '' + #13
        //-----------------
        + 'function realmoveup'+HTMLName+'()' + #13
        + '{' + #13
        + IIF(FAutoScroll,'IsMoving'+HTMLName+'=2;'+#13,'')
        + IIF(FAutoScroll,'if (window.'+HTMLName+'movedownvar) clearTimeout('+HTMLName+'movedownvar)'+#13,'')
        + 'if (iens6&&parseInt(crossobj'+HTMLName+'.style.top)<=0) ' + #13
        + 'crossobj'+HTMLName+'.style.top=parseInt(crossobj'+HTMLName+'.style.top)+speed'+HTMLName+' ' + #13
        + 'else if (ns4&&crossobj'+HTMLName+'.top<=0) ' + #13
        + 'crossobj'+HTMLName+'.top+=speed'+HTMLName+' ' + #13
        + IIF(FAutoScroll,''+HTMLName+'moveupvar=setTimeout("realmoveup'+HTMLName+'()",100) '+#13,'')
        + '}'+#13

        + 'function '+HTMLName+'moveup(){ ' + #13
        + IIF(FAutoScroll,'if (IsMoving'+HTMLName+'==2) {IsMoving'+HTMLName+ '= 0; clearTimeout('+HTMLName+'moveupvar); return; }'+#13,'')
        + 'if (IsMoving'+HTMLName+'==2) return;' + #13
        + 'realmoveup'+HTMLName+'()' + #13
        + '}' + #13
        + 'function '+HTMLName+'getcontent_height(){ ' + #13
        + 'if (iens6) ' + #13
        + 'contentheight'+HTMLName+'=crossobj'+HTMLName+'.offsetHeight ' + #13
        + 'else if (ns4) '+#13
        + 'document.'+HTMLName+'nscontainer.document.'+HTMLName+'nscontent.visibility="show"' + #13
        + '}' + #13
        + '</script>' + #13;
        // End Script Part

        s := s {+  MakeHTMLTag(LTableTag) } +
          '<TR bgcolor='+HTMLClr(FScrollButtonColor)+'><TD ';
        s := s + stmp + HTMLName+'movedown()">'+
        Htmlbmp(FScrollButtonGlyphDown, FScrollButtonGlyphDownURL)+
        FScrollButtonFont.FontToStringTag(FScrollButtonTextDown).Render+
        '</TD></TR>';

        LTableTag.Contents.AddText(s);
        s := LTableTag.Render;

    Result := TIWHTMLTag.CreateTag('DIV');
    Result.Contents.AddText(s);
  finally
    FreeAndNil(LTableTag);
  end;
end;

procedure TTIWScrollPanel.SetScrollButtonColor(const AValue: TColor);
begin
  FScrollButtonColor := AValue;
  Invalidate;
end;

procedure TTIWScrollPanel.SetScrollButtonTextUp(const AValue: string);
begin
  FScrollButtonTextUp := AValue;
  Invalidate;
end;

procedure TTIWScrollPanel.SetScrollButtonTextDown(const AValue: string);
begin
  FScrollButtonTextDown := AValue;
  Invalidate;  
end;

procedure TTIWScrollPanel.SetScrollButtonGlyphDown(const Value: Tbitmap);
begin
  FScrollButtonGlyphDown.Assign(Value);
  Invalidate;
end;

procedure TTIWScrollPanel.SetScrollButtonGlyphUp(const Value: Tbitmap);
begin
  FScrollButtonGlyphUp.Assign(Value);
  Invalidate;
end;

procedure TTIWScrollPanel.SetFont(const Value: TIWfont);
begin
  FFont.Assign(Value);
  Invalidate;
end;

procedure TTIWScrollPanel.SetScrollButtonFont(const Value: TIWfont);
begin
  FScrollButtonFont.Assign(Value);
  Invalidate;
end;

procedure TTIWScrollPanel.SetTextEx(Value: TStringList);
begin
  FText.Assign(value);
  Invalidate;
end;


End.

