mmdibcv.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]               =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.html               =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 11.11.98 - 16:02:52 $                                        =}
{========================================================================}
unit MMDIBCv;

{$I COMPILER.INC}

{$IFNDEF WIN32}
   {$DEFINE USEWING}
{$ENDIF}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Classes,
    Controls,
    Graphics,
    Dialogs,
    SysUtils,
    MMObj,
    MMUtils,
    MMDIB,
    CRightC
{$IFDEF USEWING}
    ,MMWinG
{$ENDIF};

const
     { different DIB Orientations }
     DIB_TOPDOWN  = -1;
     DIB_BOTTOMUP =  1;
     { DIB_TOPDOWN is the fastest, but many drivers can't work with    }
     { this STANDARD format. For example the ATI driver causes a GPF   }
     { in BitBlt. NEVER buy a ATI card, if you would have trouble do it!}
     DIB_ORIENT: integer = DIB_BOTTOMUP;   { Bottom - Up DIB !! }

type
    EMMDIBError = class(Exception);

    {-- TMMDIBCanvas ----------------------------------------------------}
    TMMDIBCanvas = class(TCanvas)
    private
           FOwner       : TComponent;
           FHDIBDC      : THandle;
           FBits        : integer;
           FHOrigBitmap : HBitmap;
           FHBitmap     : HBitmap;
           FHBackGround : HBitmap;
           FPBitMapInfo : PBitMapInfo;
           FHPalette    : HPalette;
           FPLogPalette : PLogPalette;
           FRealize     : Boolean;
           FMapped      : Boolean;
           FPSurface    : Pointer;
           FPBackSurface: Pointer;
           FWidth       : integer;
           FHeight      : integer;
           FClipRect    : TRect;
           FBackBitmap  : TBitmap;
           FStretchBgnd : Boolean;
           FNeedUpdate  : Boolean;
           FCanUpdate   : Boolean;

           FAnimFirst   : Integer;
           FAnimColors  : TList;
           FAnimLock    : Integer;
           FAnimValues  : TList;
           FAnimCount   : Integer;

           procedure SetBPP(aValue: integer);
           procedure SetWidth(aWidth: integer);
           procedure SetHeight(aHeight: integer);
           procedure SetBackBitmap(aBitmap: TBitmap);
           procedure SetRealize(Value: Boolean);
           procedure SetMapped(Value: Boolean);
           procedure SetStretchBgnd(Value: Boolean);
           procedure BackGroundChanged(Sender: TObject);
           procedure CheckDIB;
           procedure CreateDIB;
           procedure DestroyDIB;
           procedure RecreateDIB;

           function  GetAnimCount: Integer;
           procedure SetAnimCount(Value: Integer);
           function  GetAnimColor(Index: Integer): TColor;
           function  GetAnimColorValue(Index: Integer): TColor;
           procedure SetAnimColorValue(Index: Integer; Value: TColor);
           function  GetAnimColorIndex(Index: Integer): Integer;
           procedure FreeColors;

    protected
           procedure CreateHandle; override;

    public
           constructor Create(aOwner: TComponent); virtual;
           destructor  Destroy; override;

           procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); virtual;
           procedure SetLogPalette(pLogPal: PLogPalette);

           procedure DIB_Init;
           procedure DIB_InitDrawing;
           procedure DIB_DoneDrawing;

           procedure DIB_SetTColor(Color: TColor);
           procedure DIB_SetColorRef(ColorRef: Longint);
           function  DIB_ColorToIndex(Color: TColor): Longint;
           procedure DIB_SetColor(Index: Longint);

           procedure DIB_SetClipRect(R: TRect);
           function  DIB_GetClipRect: TRect;

           function  DIB_GetPixelAddress(aSurface: Pointer; X, Y: integer): Pointer;

           procedure DIB_SetPixel(X, Y: integer; Color: Longint);{$IFDEF WIN32}pascal;{$ENDIF}
           function  DIB_GetPixel(X, Y: integer): Longint;{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_Line(X1, Y1, X2, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_LineNotXor(X1, Y1, X2, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_MoveTo(X,Y: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_LineTo(X,Y: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_HLine(X1, X2, Y: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_HLineDashed(X1, X2, Y: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_HLineDoted(X1, X2, Y, Steps: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_VLine(X, Y1, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_VLineXor(X, Y1, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_VLineNotXor(X, Y1, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_VLineDashed(X, Y1, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_VLineDoted(X, Y1, Y2, Steps: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_VLineMultiColor(X, Y: integer; Colors: PByte; Cnt: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_Rectangle(X1, Y1, X2, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_FillRect(Rect: TRect);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_FillRectXor(Rect: TRect);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_FillRectDoted(Rect: TRect; Doted: Boolean);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_Ellipse(X, Y: integer; StAngle, EndAngle, XRadius, YRadius: Word);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_FillEllipse(X, Y: integer; XRadius, YRadius: Word);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_Clear;{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_CopyDIBBits(Source:Pointer;XDst,YDst,Width,Height,XSrc,YSrc: integer);{$IFDEF WIN32}pascal;{$ENDIF}
           procedure DIB_BitBlt(DestDC: THandle; Dest: TRect; X, Y: integer);
           procedure DIB_StretchBlt(DestDC: THandle; Dest: TRect; Src: TRect);

           procedure BeginAnimate;
           procedure EndAnimate;

           property Surface: Pointer read FPSurface;
           property BackSurface: Pointer read FPBackSurface;
           property BitmapInfo: PBitmapInfo read FPBitmapInfo;
           property Bitmap: HBitmap read FHBitmap;
           property Palette: HPalette read FHPalette;

           property AnimatedColorCount: Integer read GetAnimCount write SetAnimCount;
           property AnimatedColor[i: Integer]: TColor read GetAnimColor;
           property AnimatedColorValue[i: Integer]: TColor read GetAnimColorValue write SetAnimColorValue;
           property AnimatedColorIndex[i: Integer]: Integer read GetAnimColorIndex ;

    published
           property BitsPerPixel: integer read FBits write SetBPP stored True;
           property PaletteRealize: Boolean read FRealize write SetRealize default False;
           property PaletteMapped: Boolean read FMapped write SetMapped default False;
           property BackGroundBitmap: TBitmap read FBackBitmap write SetBackBitmap;
           property StretchBackGround: Boolean read FStretchBgnd write SetStretchBgnd default True;
           property Width: integer read FWidth write SetWidth default 1;
           property Height: integer read FHeight write SetHeight default 1;
    end;

    TMMDIBDrawProc = procedure(Clear: Boolean) of object;

    {-- TMMDIBGraphicControl --------------------------------------------------}
    TMMDIBGraphicControl = class(TMMGraphicControl)
    private
           FTag2      : integer;
           FDIBCanvas : TMMDIBCanvas;
           FBackGround: TBitmap;
           FUseBackDIB: Boolean;
           FTempUseDIB: Boolean;

           function  GetBPP: integer;
           procedure SetRealize(aValue: Boolean);
           function  GetRealize: Boolean;
           procedure SetMapped(aValue: Boolean);
           function  GetMapped: Boolean;
           procedure BackGroundChanged(Sender: TObject);
           procedure SetBackGround(aBitmap: TBitmap);
           procedure SetUseBackDIB(aValue: Boolean);


    protected
           procedure FastDraw(DrawProc: TMMDIBDrawProc; Clear: Boolean);

           procedure SetBPP(aValue: integer); virtual;
           procedure Loaded; override;
           function  GetPalette: HPALETTE; override;
           property  UseBackGroundDIB: Boolean read FUseBackDIB write SetUseBackDIB default False;
           property  BackGroundDIB: TBitmap read FBackGround write SetBackGround;
           property  PaletteRealize: Boolean read GetRealize write SetRealize default False;
           property  PaletteMapped: Boolean read GetMapped write SetMapped default False;

    public
           constructor Create(AOwner: TComponent); override;
           destructor  Destroy; override;

           procedure   SetBounds(aLeft, aTop, aWidth, aHeight: integer); override;
           procedure   DrawBackGround; virtual;
           property    DIBCanvas: TMMDIBCanvas read FDIBCanvas write FDIBCanvas;
           property    BitsPerPixel: integer read GetBPP write SetBPP default 8;
    published
           property    Tag2: integer read FTag2 write FTag2;
    end;

{------------------------------------------------------------------------}
{ !!! DO NOT TOUCH !!! THIS IS INTERNAL, BUT MUST BE GLOBAL !!!          }
{------------------------------------------------------------------------}
var
   DataSection: TRtlCriticalSection;

   { filled by DIB_InitDrawing and used by the asm stuff }
   biBits: Longint;        { DIB Bits per Pixel          }
   biBPP: Longint;         { DIB Bytes per Pixel         }
   biWidth: Longint;       { DIB Width                   }
   biHeight: Longint;      { DIB Height                  }
   biScanWidth: Longint;   { Real Width for one scanLine }
   biLineDiff: Longint;    { Real differenz to next line }
   biColor: Longint;       { temp. color value           }
   biSurface: Pointer;     { pointer to bitmap data      }
   biPenPos: TPoint;       { internal pen position       }
   biClipRect: TRect;      { clipping rectangle          }

implementation

{$IFDEF WIN32}{$L MMDIB32.OBJ}{$ELSE}{$L MMDIB16.OBJ}{$ENDIF}
{$F+}
procedure TMMDIBCanvas.DIB_Init; external;
procedure TMMDIBCanvas.DIB_SetPixel(X, Y: integer; Color: Longint); external;
function  TMMDIBCanvas.DIB_GetPixel(X, Y: integer): Longint; external;
procedure TMMDIBCanvas.DIB_Line(X1, Y1, X2, Y2: integer); external;
procedure TMMDIBCanvas.DIB_LineNotXor(X1, Y1, X2, Y2: integer); external;
procedure TMMDIBCanvas.DIB_MoveTo(X, Y: integer); external;
procedure TMMDIBCanvas.DIB_LineTo(X, Y: integer); external;
procedure TMMDIBCanvas.DIB_HLine(X1, X2, Y: integer); external;
procedure TMMDIBCanvas.DIB_HLineDashed(X1, X2, Y: integer); external;
procedure TMMDIBCanvas.DIB_HLineDoted(X1, X2, Y, Steps: integer); external;
procedure TMMDIBCanvas.DIB_VLine(X, Y1, Y2: integer); external;
procedure TMMDIBCanvas.DIB_VLineXor(X, Y1, Y2: integer); external;
procedure TMMDIBCanvas.DIB_VLineNotXor(X, Y1, Y2: integer); external;
procedure TMMDIBCanvas.DIB_VLineDashed(X, Y1, Y2: integer); external;
procedure TMMDIBCanvas.DIB_VLineDoted(X, Y1, Y2, Steps: integer); external;
procedure TMMDIBCanvas.DIB_VLineMultiColor(X, Y: integer; Colors: PByte; Cnt: integer); external;
procedure TMMDIBCanvas.DIB_Rectangle(X1, Y1, X2, Y2: integer); external;
procedure TMMDIBCanvas.DIB_FillRect(Rect: TRect); external;
procedure TMMDIBCanvas.DIB_FillRectXor(Rect: TRect); external;
procedure TMMDIBCanvas.DIB_FillRectDoted(Rect: TRect; Doted: Boolean); external;
procedure TMMDIBCanvas.DIB_Ellipse(X, Y: integer; StAngle, EndAngle, XRadius, YRadius: Word); external;
procedure TMMDIBCanvas.DIB_FillEllipse(X, Y: integer; XRadius, YRadius: Word);external;
procedure TMMDIBCanvas.DIB_Clear; external;
procedure TMMDIBCanvas.DIB_CopyDIBBits(Source:Pointer;XDst,YDst,Width,Height,XSrc,YSrc: integer); external;
{$F-}

{-- TMMDIBCanvas --------------------------------------------------------}
constructor TMMDIBCanvas.Create(aOwner: TComponent);
begin
     inherited Create;

     FOwner := aOwner;

{$IFDEF USEWING}
     if (NOT WinGDLLLoaded) then
     {$IFDEF WIN32}
        raise EMMDIBError.Create(LoadResStr(IDS_DLLERROR)+' WING32.DLL');
     {$ELSE}
        raise EMMDIBError.Create(LoadResStr(IDS_DLLERROR)+' WING.DLL');
     {$ENDIF}
{$ENDIF}

     DIB_Init;

     FBits := 8;
     FHDIBDC := 0;
     FHBitmap := 0;
     FHOrigBitmap := 0;
     FHPalette := 0;
     FPSurface := NIL;
     FPBitmapInfo := NIL;
     FPLogPalette := Nil;
     FRealize := False;
     FMapped := False;
     FCanUpdate := True;
     FStretchBgnd := True;

     FPBackSurface := NIL;
     FHBackGround := 0;
     FBackBitmap := TBitmap.Create;
     FBackBitmap.OnChange := BackGroundChanged;

     FWidth := 1;
     FHeight := 1;
     CreateHandle;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
Destructor TMMDIBCanvas.Destroy;
begin
     DestroyDIB;
     FBackBitmap.Free;
     Handle := 0;
     DeleteDC(FHDIBDC);
     FHDIBDC := 0;
     if (FPLogPalette <> nil) then GlobalFreeMem(Pointer(FPLogPalette));

     FreeColors;
     FAnimValues.Free;

     inherited Destroy;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.CheckDIB;
begin
   if FNeedUpdate then RecreateDIB;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.CreateHandle;
begin
     if (FHDIBDC = 0) then
     begin
          {$IFDEF USEWING}
          FHDIBDC := WinGCreateDC;
          if (FHDIBDC = 0) then
             raise EMMDIBError.Create('Unable to access WinG device context');
          {$ELSE}
          FHDIBDC := CreateCompatibleDC(0);
          if (FHDIBDC = 0) then
             raise EMMDIBError.Create('Unable to access DIB device context');
          {$ENDIF}
          FNeedUpdate := True;
     end;

     CheckDIB;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetWidth(aWidth: integer);
begin
   SetBounds(0,0,aWidth,FHeight);
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetHeight(aHeight: integer);
begin
   SetBounds(0,0,FWidth,aHeight);
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetBounds(aLeft, aTop, aWidth, aHeight: Integer);
begin
   if (aWidth <> FWidth) or (aHeight <> FHeight) then
   begin
      FWidth := aWidth;
      FHeight := aHeight;
      FClipRect := Rect(0,0,FWidth,FHeight);
      Handle := 0;
      FNeedUpdate := True;
   end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetBPP(aValue: integer);
begin
   if (aValue <> FBits) then
   begin
      if (aValue <> 8) and (aValue <> 24) then
         raise EMMDIBError.Create('Bitlength not supported yet');

      FBits := aValue;
      RecreateDIB;
   end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetBackBitmap(aBitmap: TBitmap);
begin
     if (aBitmap <> FBackBitmap) then FBackBitmap.Assign(aBitmap);
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.BackGroundChanged(Sender: TObject);
begin
     RecreateDIB;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetStretchBgnd(Value: Boolean);
begin
     if (Value <> FStretchBgnd) then
     begin
        FStretchBgnd := Value;
        if not FBackBitmap.Empty then RecreateDIB;
     end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetLogPalette(pLogPal: PLogPalette);
begin
   if (FPLogPalette <> nil) then
   begin
      GlobalFreeMem(Pointer(FPLogPalette));
      FPLogPalette := nil;
   end;
   if (pLogPal <> nil) then
   with pLogPal^ do
   if (palVersion >= $300) and (palNumEntries <= 256) then
   begin
      FPLogPalette := GlobalAllocMem(sizeOf(TLogPalette)+sizeOf(TPaletteEntry)*256);
      Move(pLogPal^,FPLogPalette^,sizeOf(TLogPalette)+sizeOf(TPaletteEntry)*palNumEntries);
   end;
   RecreateDIB;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetRealize(Value: Boolean);
begin
     if (Value <> FRealize) then
     begin
        FRealize := Value;
        RecreateDIB;
     end;
end;