mmdibcv.pas

一套及时通讯的原码

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.SetMapped(Value: Boolean);
begin
     if (Value <> FMapped) then
     begin
        FMapped := Value;
     end;
end;

{------------------------------------------------------------------------}
{ It is possible, because number palette entries <= 256 }
function FindUniqueColor(Pal: PLogPalette): TColorRef;
var
    N : Integer;
    C : TColorRef;

    function Unique: Boolean;
    var
       i: Integer;
    begin
       Result := False;
       for i := 0 to N - 1 do
       with Pal^.palPalEntry[i] do
       if RGB(peRed,peGreen,peBlue) = C then
          Exit;
       Result := True;
    end;
begin
   N := Pal^.palNumEntries;
   C := 0;
   while not Unique do Inc(C);
   Result := C;
end;

{------------------------------------------------------------------------}
function ColorToPalEntry(C: TColorRef): TPaletteEntry;
begin
   with Result do
   begin
      peRed   := GetRValue(C);
      peGreen := GetGValue(C);
      peBlue  := GetBValue(C);
      peFlags := PC_RESERVED;
   end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.CreateDIB;
Var
   LogPal: PLogPalette;
   {$IFDEF WIN32}
   BackBitImageSize: DWord;
   BackBitInfoSize: DWord;
   {$ELSE}
   BackBitImageSize: Longint;
   BackBitInfoSize: Longint;
   {$ENDIF}
   BackBitInfo: PBitmapInfo;
   BackBitImage: Pointer;
   i,j,H,W,aWidth,aHeight: integer;
   C: TColorRef;

begin
     if (FHDIBDC = 0) then exit;
     LogPal := nil;
     BackBitInfo := nil;
     BackBitImage := nil;

     {$IFNDEF WIN32}
     FBits := 8;
     {$ENDIF}

     { create the bitmap header }
     FPBitmapInfo := PBitmapInfo(DIB_Create(FBits,DIB_ORIENT,FWidth,FHeight,False));
     with FPBitMapInfo^.bmiHeader do
     begin
          {$IFDEF USEWING}
          if WinGRecommendDIBFormat(FPBitMapInfo) then
          begin        { make sure it's 8bpp and remember the orientation }
               biBitCount := FBits;
               biCompression := BI_RGB;
          end;
          {$ENDIF}
          biWidth := Max(FWidth,1);
          biHeight := Max(FHeight,1) * DIB_ORIENT;
     end;

     LogPal := CreateSystemColorPalette;
     try
        with LogPal^ do
        begin
           if (FBackBitmap <> nil) and (not FBackBitmap.Empty) then
           begin
              GetDIBSizes(FBackBitmap.Handle, BackBitInfoSize, BackBitImageSize);
              BackBitInfo:= GlobalAllocMem(BackBitInfoSize);
              BackBitImage:= GlobalAllocMem(BackBitImageSize);
              GetDIB(FBackBitmap.Handle, FBackBitmap.Palette, BackBitInfo^, BackBitImage^);
              i := 10;
              GetPaletteEntries(FBackBitmap.Palette, i, 235, palPalEntry[i]);
           end
           else if (FPLogPalette <> nil) then
           begin
              for i := 10 to 246 do
              with FPLogPalette^.palPalEntry[i] do
              begin
                 palPalEntry[i].peRed := peRed;
                 palPalEntry[i].peGreen := peGreen;
                 palPalEntry[i].peBlue := peBlue;
                 palPalEntry[i].peFlags := PC_NOCOLLAPSE;
              end;
           end;

           FreeColors;
           if FAnimCount <> 0 then
           begin
              FAnimColors := TList.Create;
              { For now let's alloc upper colors for animation }
              for i := 246 - FAnimCount + 1 to 246 do
              begin
                 C := FindUniqueColor(LogPal);
                 palPalEntry[i] := ColorToPalEntry(C);
                 FAnimColors.Add(Pointer(LongInt(C)));
              end;
              FAnimFirst := 246 - FAnimCount + 1;
           end
           else FAnimFirst := 256;

           { copy from the palette to the DIB bitmap color table }
           for i := 0 to 255 do
           with FPBitmapInfo^.bmiColors[i], palPalEntry[i] do
           begin
              rgbRed := peRed;
              rgbGreen := peGreen;
              rgbBlue := peBlue;
              { Set the PC_NOCOLLAPSE flag for each of our colors so }
              { that GDI won't merge them together.  Be careful not  }
              { to set PC_NOCOLLAPSE for the sys color entries or    }
              { we'll get multpile copies of these colors in the     }
              { palette when we realize it.                          }
              if (i > 9) and (i < 246) and not (i >= FAnimFirst) then
                 rgbReserved := PC_NOCOLLAPSE
              else
                 rgbReserved := 0;
           end;

           { create the palette }
           FHPalette := CreatePalette(LogPal^);
        end;

        if (FBackBitmap <> NIL) and (not FBackBitmap.Empty) then
        begin
           {$IFDEF USEWING}
           FHBackGround := WinGCreateBitmap(FHDIBDC, FPBitMapInfo, @FPBackSurface);
           {$ELSE}
           FHBackGround := CreateDIBSection(FHDIBDC, FPBitMapInfo^, DIB_RGB_Colors,
                                            FPBackSurface, {$IFDEF DELPHI3}0{$ELSE}Nil{$ENDIF}, 0);
           {$ENDIF}
           FHOrigBitmap := SelectObject(FHDIBDC, FHBackGround);

           aWidth  := BackBitInfo^.bmiHeader.biWidth;
           aHeight := BackBitInfo^.bmiHeader.biHeight;
           SetStretchBltMode(FHDIBDC, STRETCH_DELETESCANS);

           if FStretchBgnd then
           begin
              StretchDIBits(FHDIBDC,
                            0, 0,
                            FWidth,
                            FHeight,
                            0, 0,
                            aWidth,
                            aHeight,
                            BackBitImage,
                            BackBitInfo^,
                            DIB_RGB_Colors,
                            SRCCOPY);
           end
           else
           begin
              i := 0;
              H := FHeight;
              while H > 0 do
              begin
                 j := 0;
                 W := FWidth;
                 while W > 0 do
                 begin
                    StretchDIBits(FHDIBDC,
                                  j*aWidth, i*aHeight,
                                  aWidth,aHeight,
                                  0, 0,
                                  aWidth,
                                  aHeight,
                                  BackBitImage,
                                  BackBitInfo^,
                                  DIB_RGB_Colors,
                                  SRCCOPY);
                    dec(W,aWidth);
                    inc(j);
                 end;
                 dec(H,aHeight);
                 inc(i);
              end;
           end;

           FHBackGround := SelectObject(FHDIBDC, FHOrigBitmap);
        end;

     finally
        GlobalFreeMem(Pointer(BackBitInfo));
        GlobalFreeMem(Pointer(BackBitImage));
        GlobalFreeMem(Pointer(LogPal));
     end;

     {$IFDEF USEWING}
     FHBitmap := WinGCreateBitmap(FHDIBDC, FPBitMapInfo, @FPSurface);
     {$ELSE}
     FHBitmap := CreateDIBSection(FHDIBDC, FPBitMapInfo^, DIB_RGB_Colors,
                                  FPSurface, {$IFDEF DELPHI3}0{$ELSE}nil{$ENDIF}, 0);
     {$ENDIF}
     FHOrigBitmap := SelectObject(FHDIBDC, FHBitmap);
     PatBlt(FHDIBDC, 0, 0, FWidth, FHeight, BLACKNESS);

     Handle := FHDIBDC;
     FNeedUpdate := False;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DestroyDIB;
begin
     if (FHBackGround <> 0) then
     begin
          DeleteObject(FHBackGround);
          FHBackGround := 0;
          FPBackSurface := NIL;
     end;
     if (FHBitmap <> 0) then
     begin
          SelectObject(FHDIBDC, FHOrigBitmap);
          DeleteObject(FHBitmap);
          FHBitmap := 0;
          FPSurface := NIL;
     end;
     if (FHPalette <> 0) then
     begin
          DeleteObject(FHPalette);
          FHPalette := 0;
     end;
     if (FPBitmapInfo <> nil) then
        GlobalFreeMem(Pointer(FPBitmapInfo));
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.RecreateDIB;
begin
     if not FCanUpdate then
        raise EMMDIBError.Create(FOwner.ClassName +': Attempt to create new DIB while initialized for drawing');

     DestroyDIB;
     CreateDIB;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DIB_BitBlt(DestDC: THandle; Dest: TRect; X, Y: integer);
Var
   oldPalette: HPalette;

begin
     if (Handle <> 0) and (DestDC <> 0) then
     with Dest do
     begin
          if FRealize then
          begin
               oldPalette := SelectPalette(DestDC, FHPalette, not FMapped);
               RealizePalette(DestDC);
               {$IFDEF USEWING}
               WinGBitBlt(DestDC, Left, Top, Right, Bottom, FHDIBDC, X, Y);
               {$ELSE}
               BitBlt(DestDC, Left, Top, Right, Bottom, FHDIBDC, X, Y, SRCCOPY);
               {$ENDIF}
               SelectPalette(DestDC, OldPalette, not FMapped);
               RealizePalette(DestDC);
          end
          else
          begin
              {$IFDEF USEWING}
              WinGBitBlt(DestDC, Left, Top, Right, Bottom, FHDIBDC, X, Y);
              {$ELSE}
              BitBlt(DestDC, Left, Top, Right, Bottom, FHDIBDC, X, Y, SRCCOPY);
              {$ENDIF}
          end;
          {$IFDEF WIN32}
          GDIFlush;
          {$ENDIF}
     end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DIB_StretchBlt(DestDC: THandle; Dest: TRect; Src: TRect);
Var
   oldPalette: HPalette;

begin
     if (Handle <> 0) and (DestDC <> 0) then
     with Dest do
     begin
          if FRealize then
          begin
               oldPalette := SelectPalette(DestDC, FHPalette, not FMapped);
               RealizePalette(DestDC);
               {$IFDEF USEWING}
               WinGStretchBlt(DestDC, Left, Top, Right, Bottom,
                              FHDIBDC, Src.Left, Src.Top, Src.Right, Src.Bottom);
               {$ELSE}
               StretchBlt(DestDC, Left, Top, Right, Bottom,
                          FHDIBDC, Src.Left, Src.Top, Src.Right, Src.Bottom, SRCCOPY);
               {$ENDIF}
               SelectPalette(DestDC, OldPalette, not FMapped);
               RealizePalette(DestDC);
          end
          else
          begin
              {$IFDEF USEWING}
              WinGStretchBlt(DestDC, Left, Top, Right, Bottom,
                             FHDIBDC, Src.Left, Src.Top, Src.Right, Src.Bottom);
              {$ELSE}
              StretchBlt(DestDC, Left, Top, Right, Bottom,
                         FHDIBDC, Src.Left, Src.Top, Src.Right, Src.Bottom, SRCCOPY);
              {$ENDIF}
          end;
          {$IFDEF WIN32}
          GDIFlush;
          {$ENDIF}
     end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
function TMMDIBCanvas.DIB_GetPixelAddress(aSurface: Pointer; X, Y: integer): Pointer;
var
   biScanWidth,BPP: integer;

begin
   { make sure it's in range and if not return nil }
   if (X >= FWidth) or (Y >= FHeight) then
      raise EMMDIBError.Create('Attempt to get out of range pixel address');

   BPP := FBits shr 3;

   { Calculate the scan line storage width }
   biScanWidth := (FWidth*BPP + 3) and not 3;

   if (DIB_ORIENT = DIB_TOPDOWN) then
      Result := PChar(aSurface) + (Y * biScanWidth) + (X*BPP)
   else
      Result := PChar(aSurface) + ((FHeight-1-Y) * biScanWidth) + (X*BPP);
end;

{-- TMMDIBCanvas --------------------------------------------------------}
function TMMDIBCanvas.DIB_ColorToIndex(Color: TColor): Longint;
begin
     Result := ColorToRGB(Color);
     if FBits <= 8 then
        Result := GetNearestPaletteIndex(FHPalette, Result);
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DIB_SetClipRect(R: TRect);
begin
     FClipRect.Left  := Max(R.Left,0);
     FClipRect.Top   := Max(R.Top,0);
     FClipRect.Right := Min(R.Right,FWidth);
     FClipRect.Bottom:= Min(R.Bottom,FHeight);
     biClipRect := FClipRect;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
function TMMDIBCanvas.DIB_GetClipRect: TRect;
begin
    Result := FClipRect;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DIB_SetTColor(Color: TColor);
var
   Temp: Longint;

begin
     Temp := ColorToRGB(Color);
     if FBits = 24 then
     begin
        biColor := Temp;
     end
     else
     begin
        Temp := GetNearestPaletteIndex(FHPalette, Temp);
        asm
           mov  al, Temp.Byte[0]
           mov  ah, al
           mov  biColor.Word[0], ax
           mov  biColor.Word[2], ax
        end;
     end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DIB_SetColorRef(ColorRef: Longint);
var
   Temp: integer;

begin
     if FBits = 24 then
     begin
        biColor := ColorRef;
     end
     else
     begin
        Temp := GetNearestPaletteIndex(FHPalette, ColorRef);
        asm
           mov  al, Temp.Byte[0]
           mov  ah, al
           mov  biColor.Word[0], ax
           mov  biColor.Word[2], ax
        end;
     end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DIB_SetColor(Index: Longint);
begin
   if FBits = 24 then
   begin
      biColor := Index;
   end
   else
   begin
      asm
         {$IFDEF WIN32}
         mov  dh, dl
         mov  biColor.Word[0], dx
         mov  biColor.Word[2], dx
         {$ELSE}
         mov  al, byte ptr [Index]
         mov  ah, al
         mov  biColor.Word[0], ax
         mov  biColor.Word[2], ax
         {$ENDIF}
      end;
   end;
end;

{-- TMMDIBCanvas --------------------------------------------------------}
procedure TMMDIBCanvas.DIB_InitDrawing;