mmdibcv.pas

一套及时通讯的原码

begin
     EnterCriticalSection(DataSection);

     Changing;
     CheckDIB;
     biPenPos.X := 0;
     biPenPos.Y := 0;
     biBits := FBits;
     biBPP := FBits shr 3;
     biHeight := FHeight;
     biWidth := FWidth;
     biScanWidth := (FWidth*biBPP + 3) and not 3;
     biLineDiff := biScanWidth * -DIB_ORIENT;
     biSurface:= FPSurface;
     biClipRect := FClipRect;
     FCanUpdate := False;
     {$IFDEF WIN32}
     GDIFlush;
     {$ENDIF}
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DIB_DoneDrawing;
begin
     biPenPos.X := 0;
     biPenPos.Y := 0;
     biHeight := 0;
     biWidth := 0;
     biScanWidth := 0;
     biSurface:= nil;
     FCanUpdate := True;
     Changed;

     LeaveCriticalSection(DataSection);
end;

const
    MaxAnimColors = 246 - 10;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.FreeColors;
begin
   if FAnimColors <> nil then
      FAnimColors.Free;
   FAnimColors := nil;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
function  TMMDIBCanvas.GetAnimCount: Integer;
begin
   if FAnimColors <> nil then
      Result := FAnimColors.Count
   else
      Result := 0;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetAnimCount(Value: Integer);
begin
   if (Value < 0) or (Value > MaxAnimColors) then
      { TODO: Should be res id }
      raise EMMDIBError.Create('Invalid count of animated colors');

   if Value <> AnimatedColorCount then
   begin
      FAnimCount := Value;
      RecreateDIB;
   end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
function  TMMDIBCanvas.GetAnimColor(Index: Integer): TColor ;
begin
   if not InRange(Index,0,AnimatedColorCount-1) then
      { Should be res id }
      raise EMMDIBError.Create('Invalidate animated color index');

   Result := TColorRef(FAnimColors[Index]);
end;

{------------------------------------------------------------------------}
function QuadToColor(Q: TRGBQuad): TColorRef;
begin
   with Q do Result := RGB(rgbRed,rgbGreen,rgbBlue);
end;

{------------------------------------------------------------------------}
function ColorToQuad(C: TColorRef): TRGBQuad;
begin
   with Result do
   begin
      rgbRed  := GetRValue(C);
      rgbGreen:= GetGValue(C);
      rgbBlue := GetBValue(C);
   end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
function TMMDIBCanvas.GetAnimColorValue(Index: Integer): TColor;
var
   Pal: array[0..255] of TRGBQuad;

begin
   if not InRange(Index,0,AnimatedColorCount-1) then
      { Should be res id }
      raise EMMDIBError.Create('Invalidate animated color index');

   {$IFDEF WIN32}
   if GetDIBColorTable(Handle,0,256,Pal) <> 256 then
   {$ELSE}
   if WinGGetDIBColorTable(Handle,0,256,@Pal) <> 256 then
   {$ENDIF}
      { TODO: Should be res id }
      raise EMMDIBError.Create('Get palette entries failed');

   Result := QuadToColor(Pal[FAnimFirst+Index]);
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetAnimColorValue(Index: Integer; Value: TColor);
var
   Pal1: array[0..255] of TRGBQuad;
   Pal2: array[0..255] of TPaletteEntry;
begin
   if not InRange(Index,0,AnimatedColorCount-1) then
      { Should be res id }
      raise EMMDIBError.Create('Invalidate animated color index');

   Value := ColorToRGB(Value);

   if FAnimLock > 0 then
   begin
      FAnimValues[Index] := Pointer(Value);
      Exit;
   end;

   {$IFDEF WIN32}
   if GetDIBColorTable(Handle,0,256,Pal1) <> 256 then
   {$ELSE}
   if WinGGetDIBColorTable(Handle,0,256,@Pal1) <> 256 then
   {$ENDIF}
      { TODO: Should be res id }
      raise EMMDIBError.Create('Get palette entries failed');

   if GetPaletteEntries(FHPalette,0,256,Pal2) <> 256 then
      { TODO: Should be res id }
      raise EMMDIBError.Create('Get palette entries failed');

   Pal1[FAnimFirst+Index] := ColorToQuad(Value);
   Pal2[FAnimFirst+Index] := ColorToPalEntry(Value);

   {$IFDEF WIN32}
   if SetDIBColorTable(Handle,0,256,Pal1) <> 256 then
   {$ELSE}
   if WinGSetDIBColorTable(Handle,0,256,@Pal1) <> 256 then
   {$ENDIF}
      { TODO: Should be res id }
      raise EMMDIBError.Create('Set palette entries failed');

   {$IFDEF WIN32}
   if not AnimatePalette(FHPalette,0,256,@Pal2[0]) then
      { TODO: Should be res id }
      raise EMMDIBError.Create('Animation of palette entries failed');
   {$ELSE}
   AnimatePalette(FHPalette,0,256,Pal2[0]);
   {$ENDIF}
end;

{-- TMMDIBCanvas --------------------------------------------------------}
function  TMMDIBCanvas.GetAnimColorIndex(Index: Integer): Integer;
begin
   Result := FAnimFirst + Index;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.BeginAnimate;
var
   Pal : array[0..255] of TRGBQuad;
   i   : Integer;
begin
   Inc(FAnimLock);
   if (FAnimLock = 1) and (AnimatedColorCount > 0) then
   begin
      {$IFDEF WIN32}
      if GetDIBColorTable(Handle,FAnimFirst,AnimatedColorCount,Pal) <> UINT(AnimatedColorCount) then
      {$ELSE}
      if WinGGetDIBColorTable(Handle,FAnimFirst,AnimatedColorCount,@Pal) <> AnimatedColorCount then
      {$ENDIF}
         { TODO: Should be res id }
         raise EMMDIBError.Create('Get palette entries failed');
      FAnimValues := TList.Create;
      for i := 0 to AnimatedColorCount - 1 do
          FAnimValues.Add(Pointer(QuadToColor(Pal[i])));
   end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.EndAnimate;
var
   Pal1: array[0..255] of TRGBQuad;
   Pal2: array[0..255] of TPaletteEntry;
   i   : Integer;
begin
   Dec(FAnimLock);
   if (FAnimLock = 0) and (AnimatedColorCount > 0) then
   begin
      for i := 0 to AnimatedColorCount - 1 do
      begin
         Pal1[i] := ColorToQuad(TColorRef(FAnimValues[i]));
         Pal2[i] := ColorToPalEntry(TColorRef(FAnimValues[i]));
      end;
      try
         {$IFDEF WIN32}
         if SetDIBColorTable(Handle,FAnimFirst,AnimatedColorCount,Pal1) <> UINT(AnimatedColorCount) then
         {$ELSE}
         if WinGSetDIBColorTable(Handle,FAnimFirst,AnimatedColorCount,@Pal1) <> AnimatedColorCount then
         {$ENDIF}
            { TODO: Should be res id }
            raise EMMDIBError.Create('Set palette entries failed');

         {$IFDEF WIN32}
         if not AnimatePalette(FHPalette,FAnimFirst,AnimatedColorCount,@Pal2[0]) then
            { TODO: Should be res id }
            raise EMMDIBError.Create('Animation of palette entries failed');
         {$ELSE}
         AnimatePalette(FHPalette,FAnimFirst,AnimatedColorCount,Pal2[0]);
         {$ENDIF}

      finally
         FAnimValues.Free;
         FAnimValues := nil;
      end;
   end;
end;

{== TMMDIBGraphicControl ================================================}
constructor TMMDIBGraphicControl.Create(AOwner: TComponent);
begin
     inherited Create(AOwner);

     FDIBCanvas := TMMDIBCanvas.Create(Self);
     FUseBackDIB := False;
     PaletteRealize := False;
     PaletteMapped := False;
     FBackGround := TBitmap.Create;
     FBackGround.OnChange := BackGroundChanged;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
destructor TMMDIBGraphicControl.Destroy;
begin
   FBackGround.Free;
   FDIBCanvas.Free;

   inherited Destroy;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.SetBPP(aValue: integer);
begin
   FDIBCanvas.BitsPerPixel := aValue;
   Invalidate;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
function TMMDIBGraphicControl.GetBPP: integer;
begin
   Result := FDIBCanvas.BitsPerPixel;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
begin
   inherited SetBounds(aLeft,aTop,aWidth,aHeight);
   FDIBCanvas.SetBounds(aLeft, aTop, aWidth, aHeight);
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.Loaded;
begin
   inherited Loaded;

   UseBackgroundDIB := FTempUseDIB;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
function TMMDIBGraphicControl.GetPalette: HPALETTE;
begin
   if PaletteRealize then
      Result := FDIBCanvas.Palette
   else
      Result := inherited GetPalette;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.SetRealize(aValue: Boolean);
begin
   if (aValue <> FDIBCanvas.PaletteRealize) then
   begin
      FDIBCanvas.PaletteRealize := aValue;
      Invalidate;
   end;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
function TMMDIBGraphicControl.GetRealize: Boolean;
begin
   Result := FDIBCanvas.PaletteRealize;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.SetMapped(aValue: Boolean);
begin
   if (aValue <> FDIBCanvas.PaletteMapped) then
   begin
      FDIBCanvas.PaletteMapped := aValue;
      Invalidate;
   end;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
function TMMDIBGraphicControl.GetMapped: Boolean;
begin
   Result := FDIBCanvas.PaletteMapped;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.SetBackGround(aBitmap: TBitmap);
begin
   FBackGround.Assign(aBitmap);
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.BackGroundChanged(Sender: TObject);
begin
   if not (csLoading in ComponentState) then
   begin
      if (csDesigning in ComponentState) then
      begin
         if (FBackGround.Empty) then
         begin
            PaletteRealize := False;
            PaletteMapped := False;
            FUseBackDIB := False;
         end
         else
         begin
            PaletteRealize := True;
            FUseBackDIB := True;
         end;
      end;

      if FUseBackDIB then
         FDIBCanvas.BackGroundBitmap := FBackGround
      else
         FDIBCanvas.BackGroundBitmap := NIL;

     Invalidate;
   end;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.SetUseBackDIB(aValue: Boolean);
begin
   if csLoading in ComponentState then
   begin
      FTempUseDIB := aValue;
      Exit;
   end;

   if (aValue <> FUseBackDIB) then
   begin
      if aValue And (NOT FBackGround.Empty) then
         FUseBackDIB := True
      else
         FUseBackDIB := False;

      if (not (csLoading in ComponentState)) then
      begin
         PaletteRealize := FUseBackDIB;
         if FUseBackDIB then FDIBCanvas.BackGroundBitmap := FBackGround
         else FDIBCanvas.BackGroundBitmap := NIL;
      end;

      Invalidate;
   end;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.DrawBackGround;
begin
     with FDIBCanvas do
     begin                                         { copy background DIB }
          if (FPSurface <> NIL) AND (FPBackSurface <> NIL) then
             DIB_CopyDIBBits(FPBackSurface,0,0,FWidth,FHeight,0,0)
          else
          begin
               DIB_SetTColor(Color);
               DIB_Clear;                             { clear background }
          end;
     end;
end;

{-- TMMDIBGraphicControl ------------------------------------------------}
procedure TMMDIBGraphicControl.FastDraw(DrawProc: TMMDIBDrawProc; Clear: Boolean);
var
  DC: HDC;
  Control: TWinControl;

begin
   {$IFDEF BUILD_ACTIVEX}
   Control := Self;
   {$ELSE}
   Control := Parent;
   {$ENDIF}

   if Visible and (Control <> nil) and Control.HandleAllocated then
   begin
      DC := GetDC(Control.Handle);
      try
        {$IFDEF DELPHI3}
        Canvas.Lock;
        {$ENDIF}

        {$IFNDEF BUILD_ACTIVEX}
        if RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then
        begin
           MoveWindowOrg(DC, Left, Top);
           IntersectClipRect(DC, 0, 0, Width, Height);
        {$ELSE}
        if RectVisible(DC, Rect(0, 0, Width, Height)) then
        begin
        {$ENDIF}
           Canvas.Handle := DC;
           DrawProc(Clear);
        end;

      finally
        Canvas.Handle := 0;
        ReleaseDC(Control.Handle, DC);
        {$IFDEF DELPHI3}
        Canvas.Unlock;
        {$ENDIF}
      end;
  end;
end;

initialization
  InitializeCriticalSection(DataSection);
finalization
  DeleteCriticalSection(DataSection);
end.