Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/nastroje/d3456/KBMWABD.ZIP/WABD_Graphics.pas

Pascal/Delphi Source File | 2001-07-12 | 6KB | 214 lines

unit WABD_Graphics;

// TWAPBitmap created by Kim Madsen/Optical Services - Scandinavia.
// Copyright 2001 (C) All rights reserved.
//
// TWAPBitmap may not be used in part or whole to create commercial
// or shareware programs/tools, unless in combination with kbmWABD or unless
// a specific written agreement has been made between the author Kim Madsen
// and the user. It cannot be included in whole or part, in other development
// packages without specific written agreement with the author Kim Madsen.
//
// The use of this code is _FULLY_ your responsibility, and the author can
// never be made responsible for any problems (legal or other) or injuries caused
// directly or indirectly by the use of this code.
//
// You MUST send an email to [e-mail] specifying what you are using this
// code for!
//
// By using this code, the user agrees to this license agreement.
//

interface

uses SysUtils,Windows,Classes,Graphics;

type
   TkbmWAPBitmapHeader = record
      wbhTypeField:byte;
      wbhFixHeaderField:byte;
      wbhWidth:integer;
      wbhHeight:integer;
   end;

   TkbmWAPBitmap = class(TBitmap)
   protected
      FHeader:TkbmWAPBitmapHeader;

      function BytesPerRow:integer;

      function ReadCh(AStream:TStream):integer;
      function ReadInt(AStream:TStream):integer; virtual;
      procedure WriteCh(AStream:TStream; Value:integer);
      procedure WriteInt(AStream:TStream; Value:integer); virtual;
      procedure ReadHeader(AStream:TStream); virtual;
      procedure ReadBitmap(AStream:TStream); virtual;
      procedure WriteHeader(AStream:TStream); virtual;
      procedure WriteBitmap(AStream:TStream); virtual;

   public
      constructor Create; override;

      procedure LoadFromStream(Stream: TStream); override;
      procedure SaveToStream(Stream: TStream); override;
      procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override;
      procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); override;
   end;

// WBMP Clipboard format identifier for use by LoadFromClipboardFormat and SaveToClipboardFormat.
var
  CF_WBMP: WORD;

implementation

const
  sDescription='WAP Bitmap Image';

constructor TkbmWAPBitmap.Create;
begin
     inherited;
end;

function TkbmWAPBitmap.BytesPerRow:integer;
begin
     // Assumes 1 bit/pixel.
     Result:=(Width+7) div 8;
end;

function TkbmWAPBitmap.ReadCh(AStream:TStream):integer;
var
   b:byte;
begin
     AStream.Read(b,sizeof(byte));
     Result:=b;
end;

function TkbmWAPBitmap.ReadInt(AStream:TStream):integer;
var
   c,p,s:integer;
begin
     p:=0;
     s:=0;
     repeat
       c:=ReadCh(AStream);
       s:=(s shl p) or (c and $7F);
       inc(p,7);
     until (c and $80)=0;
     Result:=s;
end;

procedure TkbmWAPBitmap.ReadHeader(AStream:TStream);
begin
     FHeader.wbhTypeField:=ReadCh(AStream);
     if FHeader.wbhTypeField<>0 then
        raise Exception.CreateFmt('WAP Bitmap type %d not supported.',[FHeader.wbhTypeField]);

     FHeader.wbhFixHeaderField:=ReadCh(AStream);
     if FHeader.wbhFixHeaderField<>0 then
        raise Exception.CreateFmt('WAP Bitmap Fixed Header %d not supported.',[FHeader.wbhFixHeaderField]);

     FHeader.wbhWidth:=ReadInt(AStream);
     FHeader.wbhHeight:=ReadInt(AStream);
     Width:=FHeader.wbhWidth;
     Height:=FHeader.wbhHeight;

     PixelFormat:=pf1Bit;
end;

procedure TkbmWAPBitmap.ReadBitmap(AStream:TStream);
var
   p:PByte;
   w,x,y:integer;
begin
     w:=BytesPerRow;
     for y:=0 to FHeader.wbhHeight-1 do
     begin
          p:=ScanLine[y];
          for x:=0 to w-1 do
          begin
               p^:=Byte((ReadCh(AStream) and $FF));
               inc(p);
          end;
     end;
end;

procedure TkbmWAPBitmap.WriteCh(AStream:TStream; Value:integer);
var
   b:Byte;
begin
     b:=Value and $FF;
     AStream.Write(b,sizeof(byte));
end;

procedure TkbmWAPBitmap.WriteInt(AStream:TStream; Value:integer);
var
   s:integer;
begin
     s:=Value;
     repeat
       WriteCh(AStream,s and $FF);
       s:=s shr 7;
     until s=0;
end;

procedure TkbmWAPBitmap.WriteHeader(AStream:TStream);
begin
     WriteCh(AStream,FHeader.wbhTypeField);
     WriteCh(AStream,FHeader.wbhFixHeaderField);
     WriteInt(AStream,FHeader.wbhWidth);
     WriteInt(AStream,FHeader.wbhHeight);
end;

procedure TkbmWAPBitmap.WriteBitmap(AStream:TStream);
var
   p:PByte;
   w,x,y:integer;
begin
     w:=BytesPerRow;
     for y:=0 to FHeader.wbhHeight-1 do
     begin
          p:=ScanLine[y];
          for x:=0 to w-1 do
          begin
               WriteCh(AStream,p^);
               inc(p);
          end;
     end;
end;

procedure TkbmWAPBitmap.LoadFromStream(Stream: TStream);
begin
     ReadHeader(Stream);
     ReadBitmap(Stream);
end;

procedure TkbmWAPBitmap.SaveToStream(Stream: TStream);
begin
     if PixelFormat<>pf1Bit then
        raise Exception.Create('Only monochrome bitmapformats supported.');
     FHeader.wbhTypeField:=0;
     FHeader.wbhFixHeaderField:=0;
     FHeader.wbhWidth:=Width;
     FHeader.wbhHeight:=Height;
     WriteHeader(Stream);
     WriteBitmap(Stream);
end;

procedure TkbmWAPBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE);
begin
end;

procedure TkbmWAPBitmap.SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE);
begin
end;

initialization
  TPicture.RegisterFileFormat('WBMP',sDescription,TkbmWAPBitmap);
  CF_WBMP := RegisterClipboardFormat(PChar(sDescription));
  TPicture.RegisterClipboardFormat(CF_WBMP, TkbmWAPBitmap);

finalization
    TPicture.UnregisterGraphicClass(TkbmWAPBitmap);

end.