开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
MMDIBCv.pas
资源名称：qqdelphiprog.rar　[点击查看]
上传用户：hylc_2004
上传日期：2014-01-23
资源大小：46800k
文件大小：45k
源码类别：

Delphi控件源码

开发平台：

Delphi

MMDIBCv.pas：源码内容
  1. {========================================================================}
  2. {=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
  3. {========================================================================}
  4. {=                          All Rights Reserved                         =}
  5. {========================================================================}
  6. {=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
  7. {=  Loewenstr.7a                = info@swiftsoft.de                     =}
  8. {========================================================================}
  9. {=  Actual versions on http://www.swiftsoft.de/index.html               =}
  10. {========================================================================}
  11. {=  This code is for reference purposes only and may not be copied or   =}
  12. {=  distributed in any format electronic or otherwise except one copy   =}
  13. {=  for backup purposes.                                                =}
  14. {=                                                                      =}
  15. {=  No Delphi Component Kit or Component individually or in a collection=}
  16. {=  subclassed or otherwise from the code in this unit, or associated   =}
  17. {=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
  18. {=  without express permission from SwiftSoft.                          =}
  19. {=                                                                      =}
  20. {=  For more licence informations please refer to the associated        =}
  21. {=  HelpFile.                                                           =}
  22. {========================================================================}
  23. {=  $Date: 11.11.98 - 16:02:52 $                                        =}
  24. {========================================================================}
  25. unit MMDIBCv;
  27. {$I COMPILER.INC}
  29. {$IFNDEF WIN32}
  30.    {$DEFINE USEWING}
  31. {$ENDIF}
  33. interface
  35. uses
  36. {$IFDEF WIN32}
  37.     Windows,
  38. {$ELSE}
  39.     WinTypes,
  40.     WinProcs,
  41. {$ENDIF}
  42.     Classes,
  43.     Controls,
  44.     Graphics,
  45.     Dialogs,
  46.     SysUtils,
  47.     MMObj,
  48.     MMUtils,
  49.     MMDIB,
  50.     CRightC
  51. {$IFDEF USEWING}
  52.     ,MMWinG
  53. {$ENDIF};
  55. const
  56.      { different DIB Orientations }
  57.      DIB_TOPDOWN  = -1;
  58.      DIB_BOTTOMUP =  1;
  59.      { DIB_TOPDOWN is the fastest, but many drivers can't work with    }
  60.      { this STANDARD format. For example the ATI driver causes a GPF   }
  61.      { in BitBlt. NEVER buy a ATI card, if you would have trouble do it!}
  62.      DIB_ORIENT: integer = DIB_BOTTOMUP;   { Bottom - Up DIB !! }
  64. type
  65.     EMMDIBError = class(Exception);
  67.     {-- TMMDIBCanvas ----------------------------------------------------}
  68.     TMMDIBCanvas = class(TCanvas)
  69.     private
  70.            FOwner       : TComponent;
  71.            FHDIBDC      : THandle;
  72.            FBits        : integer;
  73.            FHOrigBitmap : HBitmap;
  74.            FHBitmap     : HBitmap;
  75.            FHBackGround : HBitmap;
  76.            FPBitMapInfo : PBitMapInfo;
  77.            FHPalette    : HPalette;
  78.            FPLogPalette : PLogPalette;
  79.            FRealize     : Boolean;
  80.            FMapped      : Boolean;
  81.            FPSurface    : Pointer;
  82.            FPBackSurface: Pointer;
  83.            FWidth       : integer;
  84.            FHeight      : integer;
  85.            FClipRect    : TRect;
  86.            FBackBitmap  : TBitmap;
  87.            FStretchBgnd : Boolean;
  88.            FNeedUpdate  : Boolean;
  89.            FCanUpdate   : Boolean;
  91.            FAnimFirst   : Integer;
  92.            FAnimColors  : TList;
  93.            FAnimLock    : Integer;
  94.            FAnimValues  : TList;
  95.            FAnimCount   : Integer;
  97.            procedure SetBPP(aValue: integer);
  98.            procedure SetWidth(aWidth: integer);
  99.            procedure SetHeight(aHeight: integer);
  100.            procedure SetBackBitmap(aBitmap: TBitmap);
  101.            procedure SetRealize(Value: Boolean);
  102.            procedure SetMapped(Value: Boolean);
  103.            procedure SetStretchBgnd(Value: Boolean);
  104.            procedure BackGroundChanged(Sender: TObject);
  105.            procedure CheckDIB;
  106.            procedure CreateDIB;
  107.            procedure DestroyDIB;
  108.            procedure RecreateDIB;
  110.            function  GetAnimCount: Integer;
  111.            procedure SetAnimCount(Value: Integer);
  112.            function  GetAnimColor(Index: Integer): TColor;
  113.            function  GetAnimColorValue(Index: Integer): TColor;
  114.            procedure SetAnimColorValue(Index: Integer; Value: TColor);
  115.            function  GetAnimColorIndex(Index: Integer): Integer;
  116.            procedure FreeColors;
  118.     protected
  119.            procedure CreateHandle; override;
  121.     public
  122.            constructor Create(aOwner: TComponent); virtual;
  123.            destructor  Destroy; override;
  125.            procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); virtual;
  126.            procedure SetLogPalette(pLogPal: PLogPalette);
  128.            procedure DIB_Init;
  129.            procedure DIB_InitDrawing;
  130.            procedure DIB_DoneDrawing;
  132.            procedure DIB_SetTColor(Color: TColor);
  133.            procedure DIB_SetColorRef(ColorRef: Longint);
  134.            function  DIB_ColorToIndex(Color: TColor): Longint;
  135.            procedure DIB_SetColor(Index: Longint);
  137.            procedure DIB_SetClipRect(R: TRect);
  138.            function  DIB_GetClipRect: TRect;
  140.            function  DIB_GetPixelAddress(aSurface: Pointer; X, Y: integer): Pointer;
  142.            procedure DIB_SetPixel(X, Y: integer; Color: Longint);{$IFDEF WIN32}pascal;{$ENDIF}
  143.            function  DIB_GetPixel(X, Y: integer): Longint;{$IFDEF WIN32}pascal;{$ENDIF}
  144.            procedure DIB_Line(X1, Y1, X2, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  145.            procedure DIB_LineNotXor(X1, Y1, X2, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  146.            procedure DIB_MoveTo(X,Y: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  147.            procedure DIB_LineTo(X,Y: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  148.            procedure DIB_HLine(X1, X2, Y: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  149.            procedure DIB_HLineDashed(X1, X2, Y: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  150.            procedure DIB_HLineDoted(X1, X2, Y, Steps: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  151.            procedure DIB_VLine(X, Y1, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  152.            procedure DIB_VLineXor(X, Y1, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  153.            procedure DIB_VLineNotXor(X, Y1, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  154.            procedure DIB_VLineDashed(X, Y1, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  155.            procedure DIB_VLineDoted(X, Y1, Y2, Steps: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  156.            procedure DIB_VLineMultiColor(X, Y: integer; Colors: PByte; Cnt: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  157.            procedure DIB_Rectangle(X1, Y1, X2, Y2: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  158.            procedure DIB_FillRect(Rect: TRect);{$IFDEF WIN32}pascal;{$ENDIF}
  159.            procedure DIB_FillRectXor(Rect: TRect);{$IFDEF WIN32}pascal;{$ENDIF}
  160.            procedure DIB_FillRectDoted(Rect: TRect; Doted: Boolean);{$IFDEF WIN32}pascal;{$ENDIF}
  161.            procedure DIB_Ellipse(X, Y: integer; StAngle, EndAngle, XRadius, YRadius: Word);{$IFDEF WIN32}pascal;{$ENDIF}
  162.            procedure DIB_FillEllipse(X, Y: integer; XRadius, YRadius: Word);{$IFDEF WIN32}pascal;{$ENDIF}
  163.            procedure DIB_Clear;{$IFDEF WIN32}pascal;{$ENDIF}
  164.            procedure DIB_CopyDIBBits(Source:Pointer;XDst,YDst,Width,Height,XSrc,YSrc: integer);{$IFDEF WIN32}pascal;{$ENDIF}
  165.            procedure DIB_BitBlt(DestDC: THandle; Dest: TRect; X, Y: integer);
  166.            procedure DIB_StretchBlt(DestDC: THandle; Dest: TRect; Src: TRect);
  168.            procedure BeginAnimate;
  169.            procedure EndAnimate;
  171.            property Surface: Pointer read FPSurface;
  172.            property BackSurface: Pointer read FPBackSurface;
  173.            property BitmapInfo: PBitmapInfo read FPBitmapInfo;
  174.            property Bitmap: HBitmap read FHBitmap;
  175.            property Palette: HPalette read FHPalette;
  177.            property AnimatedColorCount: Integer read GetAnimCount write SetAnimCount;
  178.            property AnimatedColor[i: Integer]: TColor read GetAnimColor;
  179.            property AnimatedColorValue[i: Integer]: TColor read GetAnimColorValue write SetAnimColorValue;
  180.            property AnimatedColorIndex[i: Integer]: Integer read GetAnimColorIndex ;
  182.     published
  183.            property BitsPerPixel: integer read FBits write SetBPP stored True;
  184.            property PaletteRealize: Boolean read FRealize write SetRealize default False;
  185.            property PaletteMapped: Boolean read FMapped write SetMapped default False;
  186.            property BackGroundBitmap: TBitmap read FBackBitmap write SetBackBitmap;
  187.            property StretchBackGround: Boolean read FStretchBgnd write SetStretchBgnd default True;
  188.            property Width: integer read FWidth write SetWidth default 1;
  189.            property Height: integer read FHeight write SetHeight default 1;
  190.     end;
  192.     TMMDIBDrawProc = procedure(Clear: Boolean) of object;
  194.     {-- TMMDIBGraphicControl --------------------------------------------------}
  195.     TMMDIBGraphicControl = class(TMMGraphicControl)
  196.     private
  197.            FTag2      : integer;
  198.            FDIBCanvas : TMMDIBCanvas;
  199.            FBackGround: TBitmap;
  200.            FUseBackDIB: Boolean;
  201.            FTempUseDIB: Boolean;
  203.            function  GetBPP: integer;
  204.            procedure SetRealize(aValue: Boolean);
  205.            function  GetRealize: Boolean;
  206.            procedure SetMapped(aValue: Boolean);
  207.            function  GetMapped: Boolean;
  208.            procedure BackGroundChanged(Sender: TObject);
  209.            procedure SetBackGround(aBitmap: TBitmap);
  210.            procedure SetUseBackDIB(aValue: Boolean);
  213.     protected
  214.            procedure FastDraw(DrawProc: TMMDIBDrawProc; Clear: Boolean);
  216.            procedure SetBPP(aValue: integer); virtual;
  217.            procedure Loaded; override;
  218.            function  GetPalette: HPALETTE; override;
  219.            property  UseBackGroundDIB: Boolean read FUseBackDIB write SetUseBackDIB default False;
  220.            property  BackGroundDIB: TBitmap read FBackGround write SetBackGround;
  221.            property  PaletteRealize: Boolean read GetRealize write SetRealize default False;
  222.            property  PaletteMapped: Boolean read GetMapped write SetMapped default False;
  224.     public
  225.            constructor Create(AOwner: TComponent); override;
  226.            destructor  Destroy; override;
  228.            procedure   SetBounds(aLeft, aTop, aWidth, aHeight: integer); override;
  229.            procedure   DrawBackGround; virtual;
  230.            property    DIBCanvas: TMMDIBCanvas read FDIBCanvas write FDIBCanvas;
  231.            property    BitsPerPixel: integer read GetBPP write SetBPP default 8;
  232.     published
  233.            property    Tag2: integer read FTag2 write FTag2;
  234.     end;
  236. {------------------------------------------------------------------------}
  237. { !!! DO NOT TOUCH !!! THIS IS INTERNAL, BUT MUST BE GLOBAL !!!          }
  238. {------------------------------------------------------------------------}
  239. var
  240.    DataSection: TRtlCriticalSection;
  242.    { filled by DIB_InitDrawing and used by the asm stuff }
  243.    biBits: Longint;        { DIB Bits per Pixel          }
  244.    biBPP: Longint;         { DIB Bytes per Pixel         }
  245.    biWidth: Longint;       { DIB Width                   }
  246.    biHeight: Longint;      { DIB Height                  }
  247.    biScanWidth: Longint;   { Real Width for one scanLine }
  248.    biLineDiff: Longint;    { Real differenz to next line }
  249.    biColor: Longint;       { temp. color value           }
  250.    biSurface: Pointer;     { pointer to bitmap data      }
  251.    biPenPos: TPoint;       { internal pen position       }
  252.    biClipRect: TRect;      { clipping rectangle          }
  254. implementation
  256. {$IFDEF WIN32}{$L MMDIB32.OBJ}{$ELSE}{$L MMDIB16.OBJ}{$ENDIF}
  257. {$F+}
  258. procedure TMMDIBCanvas.DIB_Init; external;
  259. procedure TMMDIBCanvas.DIB_SetPixel(X, Y: integer; Color: Longint); external;
  260. function  TMMDIBCanvas.DIB_GetPixel(X, Y: integer): Longint; external;
  261. procedure TMMDIBCanvas.DIB_Line(X1, Y1, X2, Y2: integer); external;
  262. procedure TMMDIBCanvas.DIB_LineNotXor(X1, Y1, X2, Y2: integer); external;
  263. procedure TMMDIBCanvas.DIB_MoveTo(X, Y: integer); external;
  264. procedure TMMDIBCanvas.DIB_LineTo(X, Y: integer); external;
  265. procedure TMMDIBCanvas.DIB_HLine(X1, X2, Y: integer); external;
  266. procedure TMMDIBCanvas.DIB_HLineDashed(X1, X2, Y: integer); external;
  267. procedure TMMDIBCanvas.DIB_HLineDoted(X1, X2, Y, Steps: integer); external;
  268. procedure TMMDIBCanvas.DIB_VLine(X, Y1, Y2: integer); external;
  269. procedure TMMDIBCanvas.DIB_VLineXor(X, Y1, Y2: integer); external;
  270. procedure TMMDIBCanvas.DIB_VLineNotXor(X, Y1, Y2: integer); external;
  271. procedure TMMDIBCanvas.DIB_VLineDashed(X, Y1, Y2: integer); external;
  272. procedure TMMDIBCanvas.DIB_VLineDoted(X, Y1, Y2, Steps: integer); external;
  273. procedure TMMDIBCanvas.DIB_VLineMultiColor(X, Y: integer; Colors: PByte; Cnt: integer); external;
  274. procedure TMMDIBCanvas.DIB_Rectangle(X1, Y1, X2, Y2: integer); external;
  275. procedure TMMDIBCanvas.DIB_FillRect(Rect: TRect); external;
  276. procedure TMMDIBCanvas.DIB_FillRectXor(Rect: TRect); external;
  277. procedure TMMDIBCanvas.DIB_FillRectDoted(Rect: TRect; Doted: Boolean); external;
  278. procedure TMMDIBCanvas.DIB_Ellipse(X, Y: integer; StAngle, EndAngle, XRadius, YRadius: Word); external;
  279. procedure TMMDIBCanvas.DIB_FillEllipse(X, Y: integer; XRadius, YRadius: Word);external;
  280. procedure TMMDIBCanvas.DIB_Clear; external;
  281. procedure TMMDIBCanvas.DIB_CopyDIBBits(Source:Pointer;XDst,YDst,Width,Height,XSrc,YSrc: integer); external;
  282. {$F-}
  284. {-- TMMDIBCanvas --------------------------------------------------------}
  285. constructor TMMDIBCanvas.Create(aOwner: TComponent);
  286. begin
  287.      inherited Create;
  289.      FOwner := aOwner;
  291. {$IFDEF USEWING}
  292.      if (NOT WinGDLLLoaded) then
  293.      {$IFDEF WIN32}
  294.         raise EMMDIBError.Create(LoadResStr(IDS_DLLERROR)+' WING32.DLL');
  295.      {$ELSE}
  296.         raise EMMDIBError.Create(LoadResStr(IDS_DLLERROR)+' WING.DLL');
  297.      {$ENDIF}
  298. {$ENDIF}
  300.      DIB_Init;
  302.      FBits := 8;
  303.      FHDIBDC := 0;
  304.      FHBitmap := 0;
  305.      FHOrigBitmap := 0;
  306.      FHPalette := 0;
  307.      FPSurface := NIL;
  308.      FPBitmapInfo := NIL;
  309.      FPLogPalette := Nil;
  310.      FRealize := False;
  311.      FMapped := False;
  312.      FCanUpdate := True;
  313.      FStretchBgnd := True;
  315.      FPBackSurface := NIL;
  316.      FHBackGround := 0;
  317.      FBackBitmap := TBitmap.Create;
  318.      FBackBitmap.OnChange := BackGroundChanged;
  320.      FWidth := 1;
  321.      FHeight := 1;
  322.      CreateHandle;
  323. end;
  325. {-- TMMDIBCanvas --------------------------------------------------------}
  326. Destructor TMMDIBCanvas.Destroy;
  327. begin
  328.      DestroyDIB;
  329.      FBackBitmap.Free;
  330.      Handle := 0;
  331.      DeleteDC(FHDIBDC);
  332.      FHDIBDC := 0;
  333.      if (FPLogPalette <> nil) then GlobalFreeMem(Pointer(FPLogPalette));
  335.      FreeColors;
  336.      FAnimValues.Free;
  338.      inherited Destroy;
  339. end;
  341. {-- TMMDIBCanvas --------------------------------------------------------}
  342. procedure TMMDIBCanvas.CheckDIB;
  343. begin
  344.    if FNeedUpdate then RecreateDIB;
  345. end;
  347. {-- TMMDIBCanvas --------------------------------------------------------}
  348. procedure TMMDIBCanvas.CreateHandle;
  349. begin
  350.      if (FHDIBDC = 0) then
  351.      begin
  352.           {$IFDEF USEWING}
  353.           FHDIBDC := WinGCreateDC;
  354.           if (FHDIBDC = 0) then
  355.              raise EMMDIBError.Create('Unable to access WinG device context');
  356.           {$ELSE}
  357.           FHDIBDC := CreateCompatibleDC(0);
  358.           if (FHDIBDC = 0) then
  359.              raise EMMDIBError.Create('Unable to access DIB device context');
  360.           {$ENDIF}
  361.           FNeedUpdate := True;
  362.      end;
  364.      CheckDIB;
  365. end;
  367. {-- TMMDIBCanvas --------------------------------------------------------}
  368. procedure TMMDIBCanvas.SetWidth(aWidth: integer);
  369. begin
  370.    SetBounds(0,0,aWidth,FHeight);
  371. end;
  373. {-- TMMDIBCanvas --------------------------------------------------------}
  374. procedure TMMDIBCanvas.SetHeight(aHeight: integer);
  375. begin
  376.    SetBounds(0,0,FWidth,aHeight);
  377. end;
  379. {-- TMMDIBCanvas --------------------------------------------------------}
  380. procedure TMMDIBCanvas.SetBounds(aLeft, aTop, aWidth, aHeight: Integer);
  381. begin
  382.    if (aWidth <> FWidth) or (aHeight <> FHeight) then
  383.    begin
  384.       FWidth := aWidth;
  385.       FHeight := aHeight;
  386.       FClipRect := Rect(0,0,FWidth,FHeight);
  387.       Handle := 0;
  388.       FNeedUpdate := True;
  389.    end;
  390. end;
  392. {-- TMMDIBCanvas --------------------------------------------------------}
  393. procedure TMMDIBCanvas.SetBPP(aValue: integer);
  394. begin
  395.    if (aValue <> FBits) then
  396.    begin
  397.       if (aValue <> 8) and (aValue <> 24) then
  398.          raise EMMDIBError.Create('Bitlength not supported yet');
  400.       FBits := aValue;
  401.       RecreateDIB;
  402.    end;
  403. end;
  405. {-- TMMDIBCanvas --------------------------------------------------------}
  406. procedure TMMDIBCanvas.SetBackBitmap(aBitmap: TBitmap);
  407. begin
  408.      if (aBitmap <> FBackBitmap) then FBackBitmap.Assign(aBitmap);
  409. end;
  411. {-- TMMDIBCanvas --------------------------------------------------------}
  412. procedure TMMDIBCanvas.BackGroundChanged(Sender: TObject);
  413. begin
  414.      RecreateDIB;
  415. end;
  417. {-- TMMDIBCanvas --------------------------------------------------------}
  418. procedure TMMDIBCanvas.SetStretchBgnd(Value: Boolean);
  419. begin
  420.      if (Value <> FStretchBgnd) then
  421.      begin
  422.         FStretchBgnd := Value;
  423.         if not FBackBitmap.Empty then RecreateDIB;
  424.      end;
  425. end;
  427. {-- TMMDIBCanvas --------------------------------------------------------}
  428. procedure TMMDIBCanvas.SetLogPalette(pLogPal: PLogPalette);
  429. begin
  430.    if (FPLogPalette <> nil) then
  431.    begin
  432.       GlobalFreeMem(Pointer(FPLogPalette));
  433.       FPLogPalette := nil;
  434.    end;
  435.    if (pLogPal <> nil) then
  436.    with pLogPal^ do
  437.    if (palVersion >= $300) and (palNumEntries <= 256) then
  438.    begin
  439.       FPLogPalette := GlobalAllocMem(sizeOf(TLogPalette)+sizeOf(TPaletteEntry)*256);
  440.       Move(pLogPal^,FPLogPalette^,sizeOf(TLogPalette)+sizeOf(TPaletteEntry)*palNumEntries);
  441.    end;
  442.    RecreateDIB;
  443. end;
  445. {-- TMMDIBCanvas --------------------------------------------------------}
  446. procedure TMMDIBCanvas.SetRealize(Value: Boolean);
  447. begin
  448.      if (Value <> FRealize) then
  449.      begin
  450.         FRealize := Value;
  451.         RecreateDIB;
  452.      end;
  453. end;
  455. {-- TMMDIBCanvas --------------------------------------------------------}
  456. procedure TMMDIBCanvas.SetMapped(Value: Boolean);
  457. begin
  458.      if (Value <> FMapped) then
  459.      begin
  460.         FMapped := Value;
  461.      end;
  462. end;
  464. {------------------------------------------------------------------------}
  465. { It is possible, because number palette entries <= 256 }
  466. function FindUniqueColor(Pal: PLogPalette): TColorRef;
  467. var
  468.     N : Integer;
  469.     C : TColorRef;
  471.     function Unique: Boolean;
  472.     var
  473.        i: Integer;
  474.     begin
  475.        Result := False;
  476.        for i := 0 to N - 1 do
  477.        with Pal^.palPalEntry[i] do
  478.        if RGB(peRed,peGreen,peBlue) = C then
  479.           Exit;
  480.        Result := True;
  481.     end;
  482. begin
  483.    N := Pal^.palNumEntries;
  484.    C := 0;
  485.    while not Unique do Inc(C);
  486.    Result := C;
  487. end;
  489. {------------------------------------------------------------------------}
  490. function ColorToPalEntry(C: TColorRef): TPaletteEntry;
  491. begin
  492.    with Result do
  493.    begin
  494.       peRed   := GetRValue(C);
  495.       peGreen := GetGValue(C);
  496.       peBlue  := GetBValue(C);
  497.       peFlags := PC_RESERVED;
  498.    end;
  499. end;
  501. {-- TMMDIBCanvas --------------------------------------------------------}
  502. procedure TMMDIBCanvas.CreateDIB;
  503. Var
  504.    LogPal: PLogPalette;
  505.    {$IFDEF WIN32}
  506.    BackBitImageSize: DWord;
  507.    BackBitInfoSize: DWord;
  508.    {$ELSE}
  509.    BackBitImageSize: Longint;
  510.    BackBitInfoSize: Longint;
  511.    {$ENDIF}
  512.    BackBitInfo: PBitmapInfo;
  513.    BackBitImage: Pointer;
  514.    i,j,H,W,aWidth,aHeight: integer;
  515.    C: TColorRef;
  517. begin
  518.      if (FHDIBDC = 0) then exit;
  519.      LogPal := nil;
  520.      BackBitInfo := nil;
  521.      BackBitImage := nil;
  523.      {$IFNDEF WIN32}
  524.      FBits := 8;
  525.      {$ENDIF}
  527.      { create the bitmap header }
  528.      FPBitmapInfo := PBitmapInfo(DIB_Create(FBits,DIB_ORIENT,FWidth,FHeight,False));
  529.      with FPBitMapInfo^.bmiHeader do
  530.      begin
  531.           {$IFDEF USEWING}
  532.           if WinGRecommendDIBFormat(FPBitMapInfo) then
  533.           begin        { make sure it's 8bpp and remember the orientation }
  534.                biBitCount := FBits;
  535.                biCompression := BI_RGB;
  536.           end;
  537.           {$ENDIF}
  538.           biWidth := Max(FWidth,1);
  539.           biHeight := Max(FHeight,1) * DIB_ORIENT;
  540.      end;
  542.      LogPal := CreateSystemColorPalette;
  543.      try
  544.         with LogPal^ do
  545.         begin
  546.            if (FBackBitmap <> nil) and (not FBackBitmap.Empty) then
  547.            begin
  548.               GetDIBSizes(FBackBitmap.Handle, BackBitInfoSize, BackBitImageSize);
  549.               BackBitInfo:= GlobalAllocMem(BackBitInfoSize);
  550.               BackBitImage:= GlobalAllocMem(BackBitImageSize);
  551.               GetDIB(FBackBitmap.Handle, FBackBitmap.Palette, BackBitInfo^, BackBitImage^);
  552.               i := 10;
  553.               GetPaletteEntries(FBackBitmap.Palette, i, 235, palPalEntry[i]);
  554.            end
  555.            else if (FPLogPalette <> nil) then
  556.            begin
  557.               for i := 10 to 246 do
  558.               with FPLogPalette^.palPalEntry[i] do
  559.               begin
  560.                  palPalEntry[i].peRed := peRed;
  561.                  palPalEntry[i].peGreen := peGreen;
  562.                  palPalEntry[i].peBlue := peBlue;
  563.                  palPalEntry[i].peFlags := PC_NOCOLLAPSE;
  564.               end;
  565.            end;
  567.            FreeColors;
  568.            if FAnimCount <> 0 then
  569.            begin
  570.               FAnimColors := TList.Create;
  571.               { For now let's alloc upper colors for animation }
  572.               for i := 246 - FAnimCount + 1 to 246 do
  573.               begin
  574.                  C := FindUniqueColor(LogPal);
  575.                  palPalEntry[i] := ColorToPalEntry(C);
  576.                  FAnimColors.Add(Pointer(LongInt(C)));
  577.               end;
  578.               FAnimFirst := 246 - FAnimCount + 1;
  579.            end
  580.            else FAnimFirst := 256;
  582.            { copy from the palette to the DIB bitmap color table }
  583.            for i := 0 to 255 do
  584.            with FPBitmapInfo^.bmiColors[i], palPalEntry[i] do
  585.            begin
  586.               rgbRed := peRed;
  587.               rgbGreen := peGreen;
  588.               rgbBlue := peBlue;
  589.               { Set the PC_NOCOLLAPSE flag for each of our colors so }
  590.               { that GDI won't merge them together.  Be careful not  }
  591.               { to set PC_NOCOLLAPSE for the sys color entries or    }
  592.               { we'll get multpile copies of these colors in the     }
  593.               { palette when we realize it.                          }
  594.               if (i > 9) and (i < 246) and not (i >= FAnimFirst) then
  595.                  rgbReserved := PC_NOCOLLAPSE
  596.               else
  597.                  rgbReserved := 0;
  598.            end;
  600.            { create the palette }
  601.            FHPalette := CreatePalette(LogPal^);
  602.         end;
  604.         if (FBackBitmap <> NIL) and (not FBackBitmap.Empty) then
  605.         begin
  606.            {$IFDEF USEWING}
  607.            FHBackGround := WinGCreateBitmap(FHDIBDC, FPBitMapInfo, @FPBackSurface);
  608.            {$ELSE}
  609.            FHBackGround := CreateDIBSection(FHDIBDC, FPBitMapInfo^, DIB_RGB_Colors,
  610.                                             FPBackSurface, {$IFDEF DELPHI3}0{$ELSE}Nil{$ENDIF}, 0);
  611.            {$ENDIF}
  612.            FHOrigBitmap := SelectObject(FHDIBDC, FHBackGround);
  614.            aWidth  := BackBitInfo^.bmiHeader.biWidth;
  615.            aHeight := BackBitInfo^.bmiHeader.biHeight;
  616.            SetStretchBltMode(FHDIBDC, STRETCH_DELETESCANS);
  618.            if FStretchBgnd then
  619.            begin
  620.               StretchDIBits(FHDIBDC,
  621.                             0, 0,
  622.                             FWidth,
  623.                             FHeight,
  624.                             0, 0,
  625.                             aWidth,
  626.                             aHeight,
  627.                             BackBitImage,
  628.                             BackBitInfo^,
  629.                             DIB_RGB_Colors,
  630.                             SRCCOPY);
  631.            end
  632.            else
  633.            begin
  634.               i := 0;
  635.               H := FHeight;
  636.               while H > 0 do
  637.               begin
  638.                  j := 0;
  639.                  W := FWidth;
  640.                  while W > 0 do
  641.                  begin
  642.                     StretchDIBits(FHDIBDC,
  643.                                   j*aWidth, i*aHeight,
  644.                                   aWidth,aHeight,
  645.                                   0, 0,
  646.                                   aWidth,
  647.                                   aHeight,
  648.                                   BackBitImage,
  649.                                   BackBitInfo^,
  650.                                   DIB_RGB_Colors,
  651.                                   SRCCOPY);
  652.                     dec(W,aWidth);
  653.                     inc(j);
  654.                  end;
  655.                  dec(H,aHeight);
  656.                  inc(i);
  657.               end;
  658.            end;
  660.            FHBackGround := SelectObject(FHDIBDC, FHOrigBitmap);
  661.         end;
  663.      finally
  664.         GlobalFreeMem(Pointer(BackBitInfo));
  665.         GlobalFreeMem(Pointer(BackBitImage));
  666.         GlobalFreeMem(Pointer(LogPal));
  667.      end;
  669.      {$IFDEF USEWING}
  670.      FHBitmap := WinGCreateBitmap(FHDIBDC, FPBitMapInfo, @FPSurface);
  671.      {$ELSE}
  672.      FHBitmap := CreateDIBSection(FHDIBDC, FPBitMapInfo^, DIB_RGB_Colors,
  673.                                   FPSurface, {$IFDEF DELPHI3}0{$ELSE}nil{$ENDIF}, 0);
  674.      {$ENDIF}
  675.      FHOrigBitmap := SelectObject(FHDIBDC, FHBitmap);
  676.      PatBlt(FHDIBDC, 0, 0, FWidth, FHeight, BLACKNESS);
  678.      Handle := FHDIBDC;
  679.      FNeedUpdate := False;
  680. end;
  682. {-- TMMDIBCanvas --------------------------------------------------------}
  683. procedure TMMDIBCanvas.DestroyDIB;
  684. begin
  685.      if (FHBackGround <> 0) then
  686.      begin
  687.           DeleteObject(FHBackGround);
  688.           FHBackGround := 0;
  689.           FPBackSurface := NIL;
  690.      end;
  691.      if (FHBitmap <> 0) then
  692.      begin
  693.           SelectObject(FHDIBDC, FHOrigBitmap);
  694.           DeleteObject(FHBitmap);
  695.           FHBitmap := 0;
  696.           FPSurface := NIL;
  697.      end;
  698.      if (FHPalette <> 0) then
  699.      begin
  700.           DeleteObject(FHPalette);
  701.           FHPalette := 0;
  702.      end;
  703.      if (FPBitmapInfo <> nil) then
  704.         GlobalFreeMem(Pointer(FPBitmapInfo));
  705. end;
  707. {-- TMMDIBCanvas --------------------------------------------------------}
  708. procedure TMMDIBCanvas.RecreateDIB;
  709. begin
  710.      if not FCanUpdate then
  711.         raise EMMDIBError.Create(FOwner.ClassName +': Attempt to create new DIB while initialized for drawing');
  713.      DestroyDIB;
  714.      CreateDIB;
  715. end;
  717. {-- TMMDIBCanvas --------------------------------------------------------}
  718. procedure TMMDIBCanvas.DIB_BitBlt(DestDC: THandle; Dest: TRect; X, Y: integer);
  719. Var
  720.    oldPalette: HPalette;
  722. begin
  723.      if (Handle <> 0) and (DestDC <> 0) then
  724.      with Dest do
  725.      begin
  726.           if FRealize then
  727.           begin
  728.                oldPalette := SelectPalette(DestDC, FHPalette, not FMapped);
  729.                RealizePalette(DestDC);
  730.                {$IFDEF USEWING}
  731.                WinGBitBlt(DestDC, Left, Top, Right, Bottom, FHDIBDC, X, Y);
  732.                {$ELSE}
  733.                BitBlt(DestDC, Left, Top, Right, Bottom, FHDIBDC, X, Y, SRCCOPY);
  734.                {$ENDIF}
  735.                SelectPalette(DestDC, OldPalette, not FMapped);
  736.                RealizePalette(DestDC);
  737.           end
  738.           else
  739.           begin
  740.               {$IFDEF USEWING}
  741.               WinGBitBlt(DestDC, Left, Top, Right, Bottom, FHDIBDC, X, Y);
  742.               {$ELSE}
  743.               BitBlt(DestDC, Left, Top, Right, Bottom, FHDIBDC, X, Y, SRCCOPY);
  744.               {$ENDIF}
  745.           end;
  746.           {$IFDEF WIN32}
  747.           GDIFlush;
  748.           {$ENDIF}
  749.      end;
  750. end;
  752. {-- TMMDIBCanvas --------------------------------------------------------}
  753. procedure TMMDIBCanvas.DIB_StretchBlt(DestDC: THandle; Dest: TRect; Src: TRect);
  754. Var
  755.    oldPalette: HPalette;
  757. begin
  758.      if (Handle <> 0) and (DestDC <> 0) then
  759.      with Dest do
  760.      begin
  761.           if FRealize then
  762.           begin
  763.                oldPalette := SelectPalette(DestDC, FHPalette, not FMapped);
  764.                RealizePalette(DestDC);
  765.                {$IFDEF USEWING}
  766.                WinGStretchBlt(DestDC, Left, Top, Right, Bottom,
  767.                               FHDIBDC, Src.Left, Src.Top, Src.Right, Src.Bottom);
  768.                {$ELSE}
  769.                StretchBlt(DestDC, Left, Top, Right, Bottom,
  770.                           FHDIBDC, Src.Left, Src.Top, Src.Right, Src.Bottom, SRCCOPY);
  771.                {$ENDIF}
  772.                SelectPalette(DestDC, OldPalette, not FMapped);
  773.                RealizePalette(DestDC);
  774.           end
  775.           else
  776.           begin
  777.               {$IFDEF USEWING}
  778.               WinGStretchBlt(DestDC, Left, Top, Right, Bottom,
  779.                              FHDIBDC, Src.Left, Src.Top, Src.Right, Src.Bottom);
  780.               {$ELSE}
  781.               StretchBlt(DestDC, Left, Top, Right, Bottom,
  782.                          FHDIBDC, Src.Left, Src.Top, Src.Right, Src.Bottom, SRCCOPY);
  783.               {$ENDIF}
  784.           end;
  785.           {$IFDEF WIN32}
  786.           GDIFlush;
  787.           {$ENDIF}
  788.      end;
  789. end;
  791. {-- TMMDIBCanvas --------------------------------------------------------}
  792. function TMMDIBCanvas.DIB_GetPixelAddress(aSurface: Pointer; X, Y: integer): Pointer;
  793. var
  794.    biScanWidth,BPP: integer;
  796. begin
  797.    { make sure it's in range and if not return nil }
  798.    if (X >= FWidth) or (Y >= FHeight) then
  799.       raise EMMDIBError.Create('Attempt to get out of range pixel address');
  801.    BPP := FBits shr 3;
  803.    { Calculate the scan line storage width }
  804.    biScanWidth := (FWidth*BPP + 3) and not 3;
  806.    if (DIB_ORIENT = DIB_TOPDOWN) then
  807.       Result := PChar(aSurface) + (Y * biScanWidth) + (X*BPP)
  808.    else
  809.       Result := PChar(aSurface) + ((FHeight-1-Y) * biScanWidth) + (X*BPP);
  810. end;
  812. {-- TMMDIBCanvas --------------------------------------------------------}
  813. function TMMDIBCanvas.DIB_ColorToIndex(Color: TColor): Longint;
  814. begin
  815.      Result := ColorToRGB(Color);
  816.      if FBits <= 8 then
  817.         Result := GetNearestPaletteIndex(FHPalette, Result);
  818. end;
  820. {-- TMMDIBCanvas --------------------------------------------------------}
  821. procedure TMMDIBCanvas.DIB_SetClipRect(R: TRect);
  822. begin
  823.      FClipRect.Left  := Max(R.Left,0);
  824.      FClipRect.Top   := Max(R.Top,0);
  825.      FClipRect.Right := Min(R.Right,FWidth);
  826.      FClipRect.Bottom:= Min(R.Bottom,FHeight);
  827.      biClipRect := FClipRect;
  828. end;
  830. {-- TMMDIBCanvas --------------------------------------------------------}
  831. function TMMDIBCanvas.DIB_GetClipRect: TRect;
  832. begin
  833.     Result := FClipRect;
  834. end;
  836. {-- TMMDIBCanvas --------------------------------------------------------}
  837. procedure TMMDIBCanvas.DIB_SetTColor(Color: TColor);
  838. var
  839.    Temp: Longint;
  841. begin
  842.      Temp := ColorToRGB(Color);
  843.      if FBits = 24 then
  844.      begin
  845.         biColor := Temp;
  846.      end
  847.      else
  848.      begin
  849.         Temp := GetNearestPaletteIndex(FHPalette, Temp);
  850.         asm
  851.            mov  al, Temp.Byte[0]
  852.            mov  ah, al
  853.            mov  biColor.Word[0], ax
  854.            mov  biColor.Word[2], ax
  855.         end;
  856.      end;
  857. end;
  859. {-- TMMDIBCanvas --------------------------------------------------------}
  860. procedure TMMDIBCanvas.DIB_SetColorRef(ColorRef: Longint);
  861. var
  862.    Temp: integer;
  864. begin
  865.      if FBits = 24 then
  866.      begin
  867.         biColor := ColorRef;
  868.      end
  869.      else
  870.      begin
  871.         Temp := GetNearestPaletteIndex(FHPalette, ColorRef);
  872.         asm
  873.            mov  al, Temp.Byte[0]
  874.            mov  ah, al
  875.            mov  biColor.Word[0], ax
  876.            mov  biColor.Word[2], ax
  877.         end;
  878.      end;
  879. end;
  881. {-- TMMDIBCanvas --------------------------------------------------------}
  882. procedure TMMDIBCanvas.DIB_SetColor(Index: Longint);
  883. begin
  884.    if FBits = 24 then
  885.    begin
  886.       biColor := Index;
  887.    end
  888.    else
  889.    begin
  890.       asm
  891.          {$IFDEF WIN32}
  892.          mov  dh, dl
  893.          mov  biColor.Word[0], dx
  894.          mov  biColor.Word[2], dx
  895.          {$ELSE}
  896.          mov  al, byte ptr [Index]
  897.          mov  ah, al
  898.          mov  biColor.Word[0], ax
  899.          mov  biColor.Word[2], ax
  900.          {$ENDIF}
  901.       end;
  902.    end;
  903. end;
  905. {-- TMMDIBCanvas --------------------------------------------------------}
  906. procedure TMMDIBCanvas.DIB_InitDrawing;
  907. begin
  908.      EnterCriticalSection(DataSection);
  910.      Changing;
  911.      CheckDIB;
  912.      biPenPos.X := 0;
  913.      biPenPos.Y := 0;
  914.      biBits := FBits;
  915.      biBPP := FBits shr 3;
  916.      biHeight := FHeight;
  917.      biWidth := FWidth;
  918.      biScanWidth := (FWidth*biBPP + 3) and not 3;
  919.      biLineDiff := biScanWidth * -DIB_ORIENT;
  920.      biSurface:= FPSurface;
  921.      biClipRect := FClipRect;
  922.      FCanUpdate := False;
  923.      {$IFDEF WIN32}
  924.      GDIFlush;
  925.      {$ENDIF}
  926. end;
  928. {-- TMMDIBCanvas --------------------------------------------------------}
  929. procedure TMMDIBCanvas.DIB_DoneDrawing;
  930. begin
  931.      biPenPos.X := 0;
  932.      biPenPos.Y := 0;
  933.      biHeight := 0;
  934.      biWidth := 0;
  935.      biScanWidth := 0;
  936.      biSurface:= nil;
  937.      FCanUpdate := True;
  938.      Changed;
  940.      LeaveCriticalSection(DataSection);
  941. end;
  943. const
  944.     MaxAnimColors = 246 - 10;
  946. {-- TMMDIBCanvas --------------------------------------------------------}
  947. procedure TMMDIBCanvas.FreeColors;
  948. begin
  949.    if FAnimColors <> nil then
  950.       FAnimColors.Free;
  951.    FAnimColors := nil;
  952. end;
  954. {-- TMMDIBCanvas --------------------------------------------------------}
  955. function  TMMDIBCanvas.GetAnimCount: Integer;
  956. begin
  957.    if FAnimColors <> nil then
  958.       Result := FAnimColors.Count
  959.    else
  960.       Result := 0;
  961. end;
  963. {-- TMMDIBCanvas --------------------------------------------------------}
  964. procedure TMMDIBCanvas.SetAnimCount(Value: Integer);
  965. begin
  966.    if (Value < 0) or (Value > MaxAnimColors) then
  967.       { TODO: Should be res id }
  968.       raise EMMDIBError.Create('Invalid count of animated colors');
  970.    if Value <> AnimatedColorCount then
  971.    begin
  972.       FAnimCount := Value;
  973.       RecreateDIB;
  974.    end;
  975. end;
  977. {-- TMMDIBCanvas --------------------------------------------------------}
  978. function  TMMDIBCanvas.GetAnimColor(Index: Integer): TColor ;
  979. begin
  980.    if not InRange(Index,0,AnimatedColorCount-1) then
  981.       { Should be res id }
  982.       raise EMMDIBError.Create('Invalidate animated color index');
  984.    Result := TColorRef(FAnimColors[Index]);
  985. end;
  987. {------------------------------------------------------------------------}
  988. function QuadToColor(Q: TRGBQuad): TColorRef;
  989. begin
  990.    with Q do Result := RGB(rgbRed,rgbGreen,rgbBlue);
  991. end;
  993. {------------------------------------------------------------------------}
  994. function ColorToQuad(C: TColorRef): TRGBQuad;
  995. begin
  996.    with Result do
  997.    begin
  998.       rgbRed  := GetRValue(C);
  999.       rgbGreen:= GetGValue(C);
  1000.       rgbBlue := GetBValue(C);
  1001.    end;
  1002. end;
  1004. {-- TMMDIBCanvas --------------------------------------------------------}
  1005. function TMMDIBCanvas.GetAnimColorValue(Index: Integer): TColor;
  1006. var
  1007.    Pal: array[0..255] of TRGBQuad;
  1009. begin
  1010.    if not InRange(Index,0,AnimatedColorCount-1) then
  1011.       { Should be res id }
  1012.       raise EMMDIBError.Create('Invalidate animated color index');
  1014.    {$IFDEF WIN32}
  1015.    if GetDIBColorTable(Handle,0,256,Pal) <> 256 then
  1016.    {$ELSE}
  1017.    if WinGGetDIBColorTable(Handle,0,256,@Pal) <> 256 then
  1018.    {$ENDIF}
  1019.       { TODO: Should be res id }
  1020.       raise EMMDIBError.Create('Get palette entries failed');
  1022.    Result := QuadToColor(Pal[FAnimFirst+Index]);
  1023. end;
  1025. {-- TMMDIBCanvas --------------------------------------------------------}
  1026. procedure TMMDIBCanvas.SetAnimColorValue(Index: Integer; Value: TColor);
  1027. var
  1028.    Pal1: array[0..255] of TRGBQuad;
  1029.    Pal2: array[0..255] of TPaletteEntry;
  1030. begin
  1031.    if not InRange(Index,0,AnimatedColorCount-1) then
  1032.       { Should be res id }
  1033.       raise EMMDIBError.Create('Invalidate animated color index');
  1035.    Value := ColorToRGB(Value);
  1037.    if FAnimLock > 0 then
  1038.    begin
  1039.       FAnimValues[Index] := Pointer(Value);
  1040.       Exit;
  1041.    end;
  1043.    {$IFDEF WIN32}
  1044.    if GetDIBColorTable(Handle,0,256,Pal1) <> 256 then
  1045.    {$ELSE}
  1046.    if WinGGetDIBColorTable(Handle,0,256,@Pal1) <> 256 then
  1047.    {$ENDIF}
  1048.       { TODO: Should be res id }
  1049.       raise EMMDIBError.Create('Get palette entries failed');
  1051.    if GetPaletteEntries(FHPalette,0,256,Pal2) <> 256 then
  1052.       { TODO: Should be res id }
  1053.       raise EMMDIBError.Create('Get palette entries failed');
  1055.    Pal1[FAnimFirst+Index] := ColorToQuad(Value);
  1056.    Pal2[FAnimFirst+Index] := ColorToPalEntry(Value);
  1058.    {$IFDEF WIN32}
  1059.    if SetDIBColorTable(Handle,0,256,Pal1) <> 256 then
  1060.    {$ELSE}
  1061.    if WinGSetDIBColorTable(Handle,0,256,@Pal1) <> 256 then
  1062.    {$ENDIF}
  1063.       { TODO: Should be res id }
  1064.       raise EMMDIBError.Create('Set palette entries failed');
  1066.    {$IFDEF WIN32}
  1067.    if not AnimatePalette(FHPalette,0,256,@Pal2[0]) then
  1068.       { TODO: Should be res id }
  1069.       raise EMMDIBError.Create('Animation of palette entries failed');
  1070.    {$ELSE}
  1071.    AnimatePalette(FHPalette,0,256,Pal2[0]);
  1072.    {$ENDIF}
  1073. end;
  1075. {-- TMMDIBCanvas --------------------------------------------------------}
  1076. function  TMMDIBCanvas.GetAnimColorIndex(Index: Integer): Integer;
  1077. begin
  1078.    Result := FAnimFirst + Index;
  1079. end;
  1081. {-- TMMDIBCanvas --------------------------------------------------------}
  1082. procedure TMMDIBCanvas.BeginAnimate;
  1083. var
  1084.    Pal : array[0..255] of TRGBQuad;
  1085.    i   : Integer;
  1086. begin
  1087.    Inc(FAnimLock);
  1088.    if (FAnimLock = 1) and (AnimatedColorCount > 0) then
  1089.    begin
  1090.       {$IFDEF WIN32}
  1091.       if GetDIBColorTable(Handle,FAnimFirst,AnimatedColorCount,Pal) <> UINT(AnimatedColorCount) then
  1092.       {$ELSE}
  1093.       if WinGGetDIBColorTable(Handle,FAnimFirst,AnimatedColorCount,@Pal) <> AnimatedColorCount then
  1094.       {$ENDIF}
  1095.          { TODO: Should be res id }
  1096.          raise EMMDIBError.Create('Get palette entries failed');
  1097.       FAnimValues := TList.Create;
  1098.       for i := 0 to AnimatedColorCount - 1 do
  1099.           FAnimValues.Add(Pointer(QuadToColor(Pal[i])));
  1100.    end;
  1101. end;
  1103. {-- TMMDIBCanvas --------------------------------------------------------}
  1104. procedure TMMDIBCanvas.EndAnimate;
  1105. var
  1106.    Pal1: array[0..255] of TRGBQuad;
  1107.    Pal2: array[0..255] of TPaletteEntry;
  1108.    i   : Integer;
  1109. begin
  1110.    Dec(FAnimLock);
  1111.    if (FAnimLock = 0) and (AnimatedColorCount > 0) then
  1112.    begin
  1113.       for i := 0 to AnimatedColorCount - 1 do
  1114.       begin
  1115.          Pal1[i] := ColorToQuad(TColorRef(FAnimValues[i]));
  1116.          Pal2[i] := ColorToPalEntry(TColorRef(FAnimValues[i]));
  1117.       end;
  1118.       try
  1119.          {$IFDEF WIN32}
  1120.          if SetDIBColorTable(Handle,FAnimFirst,AnimatedColorCount,Pal1) <> UINT(AnimatedColorCount) then
  1121.          {$ELSE}
  1122.          if WinGSetDIBColorTable(Handle,FAnimFirst,AnimatedColorCount,@Pal1) <> AnimatedColorCount then
  1123.          {$ENDIF}
  1124.             { TODO: Should be res id }
  1125.             raise EMMDIBError.Create('Set palette entries failed');
  1127.          {$IFDEF WIN32}
  1128.          if not AnimatePalette(FHPalette,FAnimFirst,AnimatedColorCount,@Pal2[0]) then
  1129.             { TODO: Should be res id }
  1130.             raise EMMDIBError.Create('Animation of palette entries failed');
  1131.          {$ELSE}
  1132.          AnimatePalette(FHPalette,FAnimFirst,AnimatedColorCount,Pal2[0]);
  1133.          {$ENDIF}
  1135.       finally
  1136.          FAnimValues.Free;
  1137.          FAnimValues := nil;
  1138.       end;
  1139.    end;
  1140. end;
  1142. {== TMMDIBGraphicControl ================================================}
  1143. constructor TMMDIBGraphicControl.Create(AOwner: TComponent);
  1144. begin
  1145.      inherited Create(AOwner);
  1147.      FDIBCanvas := TMMDIBCanvas.Create(Self);
  1148.      FUseBackDIB := False;
  1149.      PaletteRealize := False;
  1150.      PaletteMapped := False;
  1151.      FBackGround := TBitmap.Create;
  1152.      FBackGround.OnChange := BackGroundChanged;
  1153. end;
  1155. {-- TMMDIBGraphicControl ------------------------------------------------}
  1156. destructor TMMDIBGraphicControl.Destroy;
  1157. begin
  1158.    FBackGround.Free;
  1159.    FDIBCanvas.Free;
  1161.    inherited Destroy;
  1162. end;
  1164. {-- TMMDIBGraphicControl ------------------------------------------------}
  1165. procedure TMMDIBGraphicControl.SetBPP(aValue: integer);
  1166. begin
  1167.    FDIBCanvas.BitsPerPixel := aValue;
  1168.    Invalidate;
  1169. end;
  1171. {-- TMMDIBGraphicControl ------------------------------------------------}
  1172. function TMMDIBGraphicControl.GetBPP: integer;
  1173. begin
  1174.    Result := FDIBCanvas.BitsPerPixel;
  1175. end;
  1177. {-- TMMDIBGraphicControl ------------------------------------------------}
  1178. procedure TMMDIBGraphicControl.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
  1179. begin
  1180.    inherited SetBounds(aLeft,aTop,aWidth,aHeight);
  1181.    FDIBCanvas.SetBounds(aLeft, aTop, aWidth, aHeight);
  1182. end;
  1184. {-- TMMDIBGraphicControl ------------------------------------------------}
  1185. procedure TMMDIBGraphicControl.Loaded;
  1186. begin
  1187.    inherited Loaded;
  1189.    UseBackgroundDIB := FTempUseDIB;
  1190. end;
  1192. {-- TMMDIBGraphicControl ------------------------------------------------}
  1193. function TMMDIBGraphicControl.GetPalette: HPALETTE;
  1194. begin
  1195.    if PaletteRealize then
  1196.       Result := FDIBCanvas.Palette
  1197.    else
  1198.       Result := inherited GetPalette;
  1199. end;
  1201. {-- TMMDIBGraphicControl ------------------------------------------------}
  1202. procedure TMMDIBGraphicControl.SetRealize(aValue: Boolean);
  1203. begin
  1204.    if (aValue <> FDIBCanvas.PaletteRealize) then
  1205.    begin
  1206.       FDIBCanvas.PaletteRealize := aValue;
  1207.       Invalidate;
  1208.    end;
  1209. end;
  1211. {-- TMMDIBGraphicControl ------------------------------------------------}
  1212. function TMMDIBGraphicControl.GetRealize: Boolean;
  1213. begin
  1214.    Result := FDIBCanvas.PaletteRealize;
  1215. end;
  1217. {-- TMMDIBGraphicControl ------------------------------------------------}
  1218. procedure TMMDIBGraphicControl.SetMapped(aValue: Boolean);
  1219. begin
  1220.    if (aValue <> FDIBCanvas.PaletteMapped) then
  1221.    begin
  1222.       FDIBCanvas.PaletteMapped := aValue;
  1223.       Invalidate;
  1224.    end;
  1225. end;
  1227. {-- TMMDIBGraphicControl ------------------------------------------------}
  1228. function TMMDIBGraphicControl.GetMapped: Boolean;
  1229. begin
  1230.    Result := FDIBCanvas.PaletteMapped;
  1231. end;
  1233. {-- TMMDIBGraphicControl ------------------------------------------------}
  1234. procedure TMMDIBGraphicControl.SetBackGround(aBitmap: TBitmap);
  1235. begin
  1236.    FBackGround.Assign(aBitmap);
  1237. end;
  1239. {-- TMMDIBGraphicControl ------------------------------------------------}
  1240. procedure TMMDIBGraphicControl.BackGroundChanged(Sender: TObject);
  1241. begin
  1242.    if not (csLoading in ComponentState) then
  1243.    begin
  1244.       if (csDesigning in ComponentState) then
  1245.       begin
  1246.          if (FBackGround.Empty) then
  1247.          begin
  1248.             PaletteRealize := False;
  1249.             PaletteMapped := False;
  1250.             FUseBackDIB := False;
  1251.          end
  1252.          else
  1253.          begin
  1254.             PaletteRealize := True;
  1255.             FUseBackDIB := True;
  1256.          end;
  1257.       end;
  1259.       if FUseBackDIB then
  1260.          FDIBCanvas.BackGroundBitmap := FBackGround
  1261.       else
  1262.          FDIBCanvas.BackGroundBitmap := NIL;
  1264.      Invalidate;
  1265.    end;
  1266. end;
  1268. {-- TMMDIBGraphicControl ------------------------------------------------}
  1269. procedure TMMDIBGraphicControl.SetUseBackDIB(aValue: Boolean);
  1270. begin
  1271.    if csLoading in ComponentState then
  1272.    begin
  1273.       FTempUseDIB := aValue;
  1274.       Exit;
  1275.    end;
  1277.    if (aValue <> FUseBackDIB) then
  1278.    begin
  1279.       if aValue And (NOT FBackGround.Empty) then
  1280.          FUseBackDIB := True
  1281.       else
  1282.          FUseBackDIB := False;
  1284.       if (not (csLoading in ComponentState)) then
  1285.       begin
  1286.          PaletteRealize := FUseBackDIB;
  1287.          if FUseBackDIB then FDIBCanvas.BackGroundBitmap := FBackGround
  1288.          else FDIBCanvas.BackGroundBitmap := NIL;
  1289.       end;
  1291.       Invalidate;
  1292.    end;
  1293. end;
  1295. {-- TMMDIBGraphicControl ------------------------------------------------}
  1296. procedure TMMDIBGraphicControl.DrawBackGround;
  1297. begin
  1298.      with FDIBCanvas do
  1299.      begin                                         { copy background DIB }
  1300.           if (FPSurface <> NIL) AND (FPBackSurface <> NIL) then
  1301.              DIB_CopyDIBBits(FPBackSurface,0,0,FWidth,FHeight,0,0)
  1302.           else
  1303.           begin
  1304.                DIB_SetTColor(Color);
  1305.                DIB_Clear;                             { clear background }
  1306.           end;
  1307.      end;
  1308. end;
  1310. {-- TMMDIBGraphicControl ------------------------------------------------}
  1311. procedure TMMDIBGraphicControl.FastDraw(DrawProc: TMMDIBDrawProc; Clear: Boolean);
  1312. var
  1313.   DC: HDC;
  1314.   Control: TWinControl;
  1316. begin
  1317.    {$IFDEF BUILD_ACTIVEX}
  1318.    Control := Self;
  1319.    {$ELSE}
  1320.    Control := Parent;
  1321.    {$ENDIF}
  1323.    if Visible and (Control <> nil) and Control.HandleAllocated then
  1324.    begin
  1325.       DC := GetDC(Control.Handle);
  1326.       try
  1327.         {$IFDEF DELPHI3}
  1328.         Canvas.Lock;
  1329.         {$ENDIF}
  1331.         {$IFNDEF BUILD_ACTIVEX}
  1332.         if RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then
  1333.         begin
  1334.            MoveWindowOrg(DC, Left, Top);
  1335.            IntersectClipRect(DC, 0, 0, Width, Height);
  1336.         {$ELSE}
  1337.         if RectVisible(DC, Rect(0, 0, Width, Height)) then
  1338.         begin
  1339.         {$ENDIF}
  1340.            Canvas.Handle := DC;
  1341.            DrawProc(Clear);
  1342.         end;
  1344.       finally
  1345.         Canvas.Handle := 0;
  1346.         ReleaseDC(Control.Handle, DC);
  1347.         {$IFDEF DELPHI3}
  1348.         Canvas.Unlock;
  1349.         {$ENDIF}
  1350.       end;
  1351.   end;
  1352. end;
  1354. initialization
  1355.   InitializeCriticalSection(DataSection);
  1356. finalization
  1357.   DeleteCriticalSection(DataSection);
  1358. end.