weblogo.txt
-----------

{ Authors: Ann Lynnworth and Michael Ax, HREF Tools Corp.
  Copyright (c) 1995,1996 HREF Tools Corp.  All Rights Reserved.

  For updates & other news, please visit our web site at http://www.href.com/.

  Our License Agreement for Free and Trial-Basis items is posted on the web.
  Please <A HREF="http://www.href.com/pub/freelicn.html">Read It Now</A>.
  If you agree to be bound to all its terms you may use our software,
  otherwise you may not.  Expiration dates do apply to the usage of some
  files.
}



TWebLogo Sample
===============

This page represents a *before* and *after* lesson on creating those custom logos 
which you may have seen on our site ("WebHub for you"...in black and red...).

The BEFORE example is how Ann wrote it, just using procedures inside a 
webhub application.  The AFTER code is how Michael wrote it as a component.
(The component ships as part of WebHub.)  We're showing it to you in this form 
to help you learn more about component writing, and specifically, about writing 
components that will work well inside WebHub.  The logo component is a TWebAction 
component, which gives it all sorts of special abilities.

Note: the most recent code for the AFTER version is included with the trial 
download of WebHub.  There have been, and may continue to be, changes.  So you 
should study this for ideas; use the current component file for any further work 
you need to do.


=====================================================================
=====================================================================
                                 BEFORE
=====================================================================
=====================================================================

{ note -- this uses gifbmp.dcu }

procedure TForm1.HRefSite_EXECSUMMSection(Sender: TObject;
  Section: Integer; var Chunk, Options: OpenString);
var
  shortfile:String;
begin
  if section > 1 then exit;

    shortFile:=getNextGifFilename;
    with WebAppHREFSITE do begin
    if THREFSessionVars( WebSession.Vars ).customLogoFile = defaultLogoFile then begin
      { run proc to get nice unique filename }
      THREFSessionVars( WebSession.Vars ).customLogoFile := shortFile;
      makeLogoFile( 'c:\website\htdocs\href\custlogo\'+shortFile );
      end;
    end;
end;

function TForm1.getNextGifFilename:String;
var
  n:integer;
begin
  { not multiuser safe here }
  with tableNextGif do begin
    n:=fields[0].asInteger;
    try
      edit;
      if n=100 then
        n:=0;
      fields[0].asInteger:=n+1;
      post;
    except
      cancel;  {baby multiuser safety}
      n:=9999;
    end;
    end;
  result:='logo'+intToStr(n)+'.gif';
end;

procedure TForm1.makeLogoFile( const fname : string );
var
  theRect:TRect;
  TW,TH:Integer;
  s:String;
  newBitMap:TBitMap;
  fs:TFileStream;
  forWhom:String;
const
  frameWidth=5;
begin

 forWhom:=WebAppHREFSite.Literal[ 'CustCompany' ];
 if forWhom='' then
   forWhom:=WebAppHREFSite.Literal[ 'firstname' ];
 if forWhom='' then
   s:='WebHub'
 else
   s:='WebHub for ' + forWhom;

 newBitMap:=TBitMap.create;

 with newBitMap, newBitMap.Canvas do begin
   font.color:=clBlue;
   font.size:=24;
   font.style:=[fsBold,fsItalic];
   font.name:='Arial';
   brush.color:=clBlack;

   TW:=TextWidth(s)+5;
   TH:=TextHeight(s)+2;

   newBitMap.height:=TH+(frameWidth*2);
   newBitMap.width:=TW+(frameWidth*2);

   theRect.Top:=0;
   theRect.left:=0;
   theRect.bottom:=TH+(frameWidth*2);
   theRect.right:=TW+(frameWidth*2);

   TextRect( theRect, frameWidth, frameWidth, s );
   pen.width:=framewidth-1;
   pen.color:=clRed;
   brush.style:=bsClear;
   Rectangle(frameWidth,frameWidth,TW+framewidth+1,TH+framewidth+1);

   fs:=TFileStream.create( fname, fmOpenWrite OR fmCreate );
   BmpToTransparentGifStream( newBitMap, fs, 0, 0, 255 );
   fs.free;
   newBitMap.free;
   end;

end;


=====================================================================
=====================================================================
                                 AFTER 
=====================================================================
=====================================================================


unit WebLogo;

interface

uses Classes, SysUtils, WinTypes, Graphics
, GifBmp
, ucString
, WebTypes;

const
  cFrameWidth=5;
const
  cLogoCaption='Copyright  1995  HREF Tools Corp. '
   +'All Rights Reserved.     Thank you for considering WEBHUB.';


----------------------------------------------------------------------------------------

type
  TWebLogo = class;

  TLogoBitMap = class(TBitMap)
  public
    constructor CreateLogo(Owner:TWebLogo);
    end;

  TLogoTransparent = (tgSolid,tgBrush,tgFont,tgPen);

  TWebLogoAction = (wloMakeOne,wloSlideLeft);

  note that..
  AutoWidth=True will ignore the Width setting without changing it
  the default filename is the componentname+'.gif'
  LogoOptions controls what will happen when you execute or test
  the 'slide options' all (one right now :) generate sequences based on the filename
  sequence numbers can be prefixed with zeros but the default is false
  better not use a number in the component name when creating sequences


  TWebLogo = class(TWebCommand)
  private
     Private declarations 
    fAutoSize: Boolean;
    fAction: TWebLogoAction;
    fWidth: word;
    fTransparent: TLogoTransparent;
    fCaption: String;
    fFileName: String;
    fFrameWidth: Byte;
    fBrush: TBrush;
    fFont: TFont;
    fPen:TPen;
  protected
    procedure Execute; override;
    procedure DoExecute; override;
    function  DoUpdate: Boolean; override;
    procedure StreamImage(Logo:TLogoBitMap;Stream:TFileStream);
    procedure SetAction(Value:TWebLogoAction);
  public
     Public declarations 
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   ScrollLeft;
  published
    property AutoWidth: Boolean read fAutoSize write fAutoSize default true;
    property Action: TWebLogoAction read fAction write SetAction;
    property LogoTransparent: TLogoTransparent read fTransparent write fTransparent;
    property Caption: String read fCaption write fCaption;
    property FileName: String read fFileName write fFileName;
    property FrameWidth: Byte read fFrameWidth write fFrameWidth default cFrameWidth;
    property Brush: TBrush read fBrush write fBrush;
    property Font: TFont read fFont write fFont;
    property Pen: TPen read fPen write fPen;
    property Width: word read fWidth write fWidth;
    end;

----------------------------------------------------------------------------------------

implementation

----------------------------------------------------------------------------------------

constructor TLogoBitMap.CreateLogo(Owner:TWebLogo);
var
  Frame: TRect;
  i,TextX,TextY:Integer;
begin
 Create;
 with Canvas do begin
   Font.Assign(Owner.Font);
   Brush.Assign(Owner.Brush);
   TextX:=TextWidth(Owner.Caption)+5;
   TextY:=TextHeight(Owner.Caption)+2;
   end;

 with Owner do begin
   i:=FrameWidth;
   if not AutoWidth then
     TextX:=Width-(i*2)
   end;

 Width:=TextX+(i*2);
 Height:=TextY+(i*2);

 with Frame do begin
   Top:=0;
   Left:=0;
   Right:=Width;
   Bottom:=Height;
   end;

 with Canvas do begin
   TextRect( Frame, succ(i), succ(i), Owner.Caption );
   Pen.Assign(Owner.Pen);
   Brush.Style:=bsClear;
   Rectangle( i, i, TextX+succ(i), TextY+succ(i) );
   end;

end;

----------------------------------------------------------------------------------------

constructor TWebLogo.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  fAutoSize:= true;
  fFrameWidth:=cFrameWidth;
  fBrush:= TBrush.Create;
  fFont:= TFont.Create;
  fPen:= TPen.Create;
  with Brush do begin
    style:=bsClear;
    color:=clBlack;
    end;
  with Font do begin
    color:=clBlue;
    size:=24;
    style:=[fsBold,fsItalic];
    name:='Arial';
    end;
  with Pen do begin
    color:=clRed;
    Width:=Framewidth-1;
    end;
end;

destructor TWebLogo.Destroy;
begin
  fPen.Free;
  fFont.Free;
  fBrush.Free;
  inherited Destroy;
end;

procedure TWebLogo.SetAction(Value:TWebLogoAction);
begin
  if fAction<>Value then begin
    fAction:=Value;
    case fAction of sets the default. can be changed
      wloMakeOne: AutoWidth:=True;
      wloSlideLeft: AutoWidth:=False;
      end;
    end;
end;

function TWebLogo.DoUpdate:Boolean;
begin
  Result:=inherited DoUpdate;
  if Caption='' then
    Caption:=cLogoCaption;
  if FileName='' then
    FileName:=copy(Name,1,8)+'.gif';
end;

procedure TWebLogo.Execute;
begin
  case fAction of
    wloMakeOne: inherited Execute;
    wloSlideLeft: ScrollLeft;
    end;
end;

procedure TWebLogo.DoExecute;
var
  Logo:TLogoBitMap;
  Stream:TFileStream;
begin
  if not Updated then
    exit;
  inherited DoExecute;
  Logo:=TLogoBitMap.CreateLogo(Self);
  try
    Stream:=TFileStream.Create(FileName, fmOpenWrite OR fmCreate);
    try
      StreamImage(Logo,Stream);
    finally
      Stream.free;
      end;
  finally
    Logo.free;
    end;
end;

procedure TWebLogo.StreamImage(Logo:TLogoBitMap;Stream:TFileStream);
var
  i,r,g,b:longint;
begin
  if fTransparent=tgSolid then
    BmpToGifStream(Logo, Stream)
  else begin
    case fTransparent of
    tgBrush: i:=ColorToRGB(Brush.Color);
    tgFont:  i:=ColorToRGB(Font.Color);
    tgPen:   i:=ColorToRGB(Pen.Color);
      end;
    r:=i and $FF;
    g:=(i shr 8) and $FF;
    b:=i shr 16;
    BmpToTransparentGifStream(Logo, Stream, r,g,b);
    end;
end;

procedure TWebLogo.ScrollLeft;
var
  a1,a2,a3,a4:string;
  i:integer;
begin
  SplitString(FileName,'.',a1,a2);
  a3:=caption;
  a4:='/'+inttostr(length(a3))+' as ';
  i:=0;
  repeat
    filename:=a1+inttostr(i)+'.'+a2;
    Status:='Writing Frame #'+inttostr(succ(i))+'/'+a4+filename;
    DoExecute;
    if caption='' then
      break;
    inc(i);
    caption:=copy(caption,2,255);
  until 1>2;
  filename:=a1+'.'+a2;
  caption:=a3;
end;

----------------------------------------------------------------------------------------

end.