tb97ctls.pas

企业智能(ERP)管理系统

        DeleteDC (DC);

        for I := 0 to High(TransColors) do
          if TransColors[I] = -1 then
            TransColors[I] := Pixels[W * (H-1)] and $FFFFFF;
              { ^ 'and' operation is necessary because the high byte is undefined }

        MonoPixel := MonoPixels;
        for Y := SourceOffset.Y to SourceOffset.Y+SourceSize.Y-1 do begin
          StartMonoPixel := MonoPixel;
          CurBit := 7;
          Pixel := @Pixels[(Y * W) + SourceOffset.X];
          for X := 0 to SourceSize.X-1 do begin
            for I := 0 to High(TransColors) do
              if Pixel^ and $FFFFFF = Cardinal(TransColors[I]) then begin
                { ^ 'and' operation is necessary because the high byte is undefined }
                MonoPixel^ := MonoPixel^ or (1 shl CurBit);
                Break;
              end;
            Dec (CurBit);
            if CurBit < 0 then begin
              Inc (Integer(MonoPixel));
              CurBit := 7;
            end;
            Inc (Integer(Pixel), SizeOf(Longint));  { proceed to the next pixel }
          end;
          Integer(MonoPixel) := Integer(StartMonoPixel) + MonoScanLineSize;
        end;
      finally
        FreeMem (Pixels);
      end;

      { Write new bits into a new HBITMAP, and assign this handle to MaskBitmap }
      MaskBmp := CreateBitmap(SourceSize.X, SourceSize.Y, 1, 1, nil);
      with Info.Header do begin
        biWidth := SourceSize.X;
        biHeight := -SourceSize.Y;  { negative number makes it a top-down DIB }
        biPlanes := 1;
        biBitCount := 1;
      end;
      DC := CreateCompatibleDC(0);
      SetDIBits (DC, MaskBmp, 0, SourceSize.Y, MonoPixels, PBitmapInfo(@Info)^,
        DIB_RGB_COLORS);
      DeleteDC (DC);
    finally
      FreeMem (MonoPixels);
    end;

    MaskBitmap.Handle := MaskBmp;
  end;
  procedure GenerateMaskBitmap (const MaskBitmap, SourceBitmap: TBitmap;
    const SourceOffset, SourceSize: TPoint; const TransColors: array of TColor);
  { Returns handle of a monochrome bitmap, with pixels in SourceBitmap of color
    TransColor set to white in the resulting bitmap. All other colors of
    SourceBitmap are set to black in the resulting bitmap. This uses the
    regular ROP_DSPDxax BitBlt method. }
  var
    CanvasHandle: HDC;
    SaveBkColor: TColorRef;
    DC: HDC;
    MaskBmp, SaveBmp: HBITMAP;
    I: Integer;
  const
    ROP: array[Boolean] of DWORD = (SRCPAINT, SRCCOPY);
  begin
    CanvasHandle := SourceBitmap.Canvas.Handle;

    MaskBmp := CreateBitmap(SourceSize.X, SourceSize.Y, 1, 1, nil);
    DC := CreateCompatibleDC(0);
    SaveBmp := SelectObject(DC, MaskBmp);
    SaveBkColor := GetBkColor(CanvasHandle);
    for I := 0 to High(TransColors) do begin
      SetBkColor (CanvasHandle, ColorToRGB(TransColors[I]));
      BitBlt (DC, 0, 0, SourceSize.X, SourceSize.Y, CanvasHandle,
        SourceOffset.X, SourceOffset.Y, ROP[I = 0]);
    end;
    SetBkColor (CanvasHandle, SaveBkColor);
    SelectObject (DC, SaveBmp);
    DeleteDC (DC);

    MaskBitmap.Handle := MaskBmp;
  end;
  procedure ReplaceBitmapColorsFromMask (const MaskBitmap, DestBitmap: TBitmap;
    const DestOffset, DestSize: TPoint; const ReplaceColor: TColor);
  var
    DestDC: HDC;
    SaveBrush: HBRUSH;
    SaveTextColor, SaveBkColor: TColorRef;
  begin
    DestDC := DestBitmap.Canvas.Handle;

    SaveBrush := SelectObject(DestDC, CreateSolidBrush(ColorToRGB(ReplaceColor)));
    SaveTextColor := SetTextColor(DestDC, clBlack);
    SaveBkColor := SetBkColor(DestDC, clWhite);
    BitBlt (DestDC, DestOffset.X, DestOffset.Y, DestSize.X, DestSize.Y,
      MaskBitmap.Canvas.Handle, 0, 0, ROP_DSPDxax);
    SetBkColor (DestDC, SaveBkColor);
    SetTextColor (DestDC, SaveTextColor);
    DeleteObject (SelectObject(DestDC, SaveBrush));
  end;
  function CopyBitmapToDDB (const SourceBitmap: TBitmap): TBitmap;
  { Makes a device-dependent duplicate of SourceBitmap. The color palette,
    if any, is preserved. }
  var
    SB: HBITMAP;
    SavePalette: HPALETTE;
    DC: HDC;
    BitmapInfo: packed record
      Header: TBitmapInfoHeader;
      Colors: array[0..255] of TColorRef;
    end;
    Bits: Pointer;
  begin
    Result := TBitmap.Create;
    try
      Result.Palette := CopyPalette(SourceBitmap.Palette);
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;
      SB := SourceBitmap.Handle;
      if SB = 0 then Exit;  { it would have a null handle if its width or height was zero }
      SavePalette := 0;
      DC := CreateCompatibleDC(0);
      try
        if Result.Palette <> 0 then begin
          SavePalette := SelectPalette(DC, Result.Palette, False);
          RealizePalette (DC);
        end;
        BitmapInfo.Header.biSize := SizeOf(TBitmapInfoHeader);
        BitmapInfo.Header.biBitCount := 0;  { instructs GetDIBits not to fill in the color table }
        { First retrieve the BitmapInfo header only }
        if GetDIBits(DC, SB, 0, 0, nil, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS) <> 0 then begin
          GetMem (Bits, BitmapInfo.Header.biSizeImage);
          try
            { Then read the actual bits }
            if GetDIBits(DC, SB, 0, SourceBitmap.Height, Bits, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS) <> 0 then
              { And copy them to the resulting bitmap }
              SetDIBits (DC, Result.Handle, 0, SourceBitmap.Height, Bits, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS);
          finally
            FreeMem (Bits);
          end;
        end;
      finally
        if SavePalette <> 0 then SelectPalette (DC, SavePalette, False);
        DeleteDC (DC);
      end;
    except
      Result.Free;
      raise;
    end;
  end;
const
  ROPs: array[Boolean] of DWORD = (ROP_PSDPxax, ROP_DSPDxax);
var
  OriginalBmp, OriginalMaskBmp, TmpImage, DDB, MonoBmp, MaskBmp, UseMaskBmp: TBitmap;
  I: TButtonState97;
  B: Boolean;
  AddPixels, IWidth, IHeight, IWidthA, IHeightA: Integer;
  IRect, IRectA, SourceRect, R: TRect;
  DC: HDC;
  UsesMask: Boolean;
{$IFDEF TB97D3}
  IsHighColorDIB: Boolean;
{$ELSE}
const
  IsHighColorDIB = False;
{$ENDIF}
begin
  if (State <> bsDisabled) and (Ord(State) >= NumGlyphs) then
    State := bsUp;
  Result.B := True;
  Result.I := FIndexs[True, State];
  if Result.I = -1 then begin
    Result.B := False;
    Result.I := FIndexs[False, State];
  end;
  if Result.I <> -1 then Exit;
  if FImageList = nil then begin
    if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
    UsesMask := (FOriginalMask.Width <> 0) and (FOriginalMask.Height <> 0);
  end
  else begin
    if (FImageIndex < 0) or (FImageIndex >= FImageList.Count) then Exit;
    UsesMask := False;
  end;
  B := State <> bsDisabled;
  { + AddPixels is to make sure the highlight color on generated disabled glyphs
    doesn't get cut off }
  if FImageList = nil then begin
    IWidthA := FOriginal.Width div FNumGlyphs;
    IHeightA := FOriginal.Height;
  end
  else begin
    IWidthA := TCustomImageListAccess(FImageList).Width;
    IHeightA := TCustomImageListAccess(FImageList).Height;
  end;
  IRectA := Rect(0, 0, IWidthA, IHeightA);
  AddPixels := Ord(State = bsDisabled);
  IWidth := IWidthA + AddPixels;
  IHeight := IHeightA + AddPixels;
  IRect := Rect(0, 0, IWidth, IHeight);
  if FGlyphList[B] = nil then begin
    if GlyphCache = nil then
      GlyphCache := TGlyphCache.Create;
    FGlyphList[B] := GlyphCache.GetList(IWidth, IHeight);
  end;
  {$IFDEF TB97D3}
  IsHighColorDIB := (FImageList = nil) and (FOriginal.PixelFormat > pf4bit);
  {$ENDIF}
  OriginalBmp := nil;
  OriginalMaskBmp := nil;
  TmpImage := nil;
  MaskBmp := nil;
  try
    OriginalBmp := TBitmap.Create;
    OriginalBmp.Assign (FOriginal);
    OriginalMaskBmp := TBitmap.Create;
    OriginalMaskBmp.Assign (FOriginalMask);
    TmpImage := TBitmap.Create;
    TmpImage.Width := IWidth;
    TmpImage.Height := IHeight;
    TmpImage.Canvas.Brush.Color := clBtnFace;
    if FImageList = nil then
      TmpImage.Palette := CopyPalette(OriginalBmp.Palette);
    I := State;
    if Ord(I) >= NumGlyphs then I := bsUp;
    SourceRect := Bounds(Ord(I) * IWidthA, 0, IWidthA, IHeightA);
    if FImageList <> nil then begin
      MaskBmp := TBitmap.Create;
      MaskBmp.Monochrome := True;
      MaskBmp.Width := IWidthA;
      MaskBmp.Height := IHeightA;
      ImageList_Draw (FImageList.Handle, FImageIndex, MaskBmp.Canvas.Handle,
        0, 0, ILD_MASK);
    end;

    if State <> bsDisabled then begin
      if FImageList = nil then begin
        TmpImage.Canvas.CopyRect (IRectA, OriginalBmp.Canvas, SourceRect);
        if not UsesMask then begin
          {$IFDEF TB97D3}
          { Use clDefault instead of FTransparentColor whereever possible to
            ensure compatibility with all video drivers when using high-color
            (> 4 bpp) DIB glyphs }
          FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, clDefault);
          {$ELSE}
          FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, FTransparentColor);
          {$ENDIF}
        end
        else begin
          MonoBmp := TBitmap.Create;
          try
            MonoBmp.Monochrome := True;
            MonoBmp.Width := IWidth;
            MonoBmp.Height := IHeight;
            MonoBmp.Canvas.CopyRect (IRectA, OriginalMaskBmp.Canvas, SourceRect);
            FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MonoBmp);
          finally
            MonoBmp.Free;
          end;
        end;
      end
      else begin
        ImageList_Draw (FImageList.Handle, FImageIndex, TmpImage.Canvas.Handle,
          0, 0, ILD_NORMAL);
        FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MaskBmp);
      end;
    end
    else begin
      MonoBmp := nil;
      DDB := nil;
      try
        MonoBmp := TBitmap.Create;
        { Uses the CopyBitmapToDDB to work around a Delphi 3 flaw. If you copy
          a DIB to a second bitmap via Assign, change the HandleType of the
          second bitmap to bmDDB, then try to read the Handle property, Delphi
          converts it back to a DIB. }
        if FImageList = nil then
          DDB := CopyBitmapToDDB(OriginalBmp)
        else begin
          DDB := TBitmap.Create;
          DDB.Width := IWidthA;
          DDB.Height := IHeightA;
          ImageList_Draw (FImageList.Handle, FImageIndex, DDB.Canvas.Handle,
            0, 0, ILD_NORMAL);
        end;
        if NumGlyphs > 1 then
          with TmpImage.Canvas do begin
            CopyRect (IRectA, DDB.Canvas, SourceRect);

            { Convert white to clBtnHighlight }
            if not IsHighColorDIB then
              GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft,
                IRectA.BottomRight, [GetNearestColor(OriginalBmp.Canvas.Handle, clWhite)])
            else
              GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp, SourceRect.TopLeft,
                IRectA.BottomRight, [clWhite]);
            ReplaceBitmapColorsFromMask (MonoBmp, TmpImage, IRectA.TopLeft,
              IRectA.BottomRight, clBtnHighlight);

            { Convert gray to clBtnShadow }
            if not IsHighColorDIB then
              GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft,
                IRectA.BottomRight, [GetNearestColor(OriginalBmp.Canvas.Handle, clGray)])
            else
              GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp, SourceRect.TopLeft,
                IRectA.BottomRight, [clGray]);
            ReplaceBitmapColorsFromMask (MonoBmp, TmpImage, IRectA.TopLeft,
              IRectA.BottomRight, clBtnShadow);

            if not UsesMask then begin
              { Generate the transparent mask in MonoBmp. The reason why
                it doesn't just use a mask color is because the mask needs
                to be of the glyph -before- the clBtnHighlight/Shadow were
                translated }
              if not IsHighColorDIB then
                GenerateMaskBitmap (MonoBmp, DDB,
                  SourceRect.TopLeft, IRectA.BottomRight, FTransparentColor)
              else
                GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp,
                  SourceRect.TopLeft, IRectA.BottomRight, [-1]);
            end
            else
              MonoBmp.Canvas.CopyRect (IRectA, OriginalMaskBmp.Canvas, SourceRect);
            with MonoBmp do begin
              Width := Width + AddPixels;
              Height := Height + AddPixels;
              { Set the additional bottom and right row on disabled glyph
                masks to white so that it always shines through, since the
                bottom and right row on TmpImage was left uninitialized }
              Canvas.Pen.Color := clWhite;
              Canvas.PolyLine ([Point(0, Height-1), Point(Width-1, Height-1),
                Point(Width-1, -1)]);
            end;

            FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MonoBmp);
          end
        else begin
          { Create a disabled version }
          if FOldDisabledStyle then begin
            { "Old" TSpeedButton style }
            if FImageList = nil then begin
              if not UsesMask then begin
                if IsHighColorDIB then
                  GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp,
                    SourceRect.TopLeft, IRectA.BottomRight, [clBlack])
                else begin
                  with MonoBmp do begin
                    Assign (DDB);  { must be a DDB for this to work right }
                    Canvas.Brush.Color := clBlack;
                    Monochrome := True;
                  end;
                end;
              end
              else begin
                MonoBmp.Assign (DDB);  { must be a DDB for this to work right }
                with TBitmap.Create do
                  try
                    Monochrome := True;
                    Width := OriginalMaskBmp.Width;
                    Height := OriginalMaskBmp.Height;
                    R := Rect(0, 0, Width, Height);
                    Canvas.CopyRect (R, OriginalMaskBmp.Canvas, R);
                    DC := Canvas.Handle;
                    with MonoBmp.Canvas do begin
                      BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
                        SourceRect.Left, SourceRect.Top, ROP_DSna);
                      BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
                        SourceRect.Left, SourceRect.Top, SRCPAINT);
                    end;
                  finally
                    Free;
                  end;
                MonoBmp.Canvas.Brush.Color := clBlack;
                MonoBmp.Monochrome := True;
              end
            end
            else begin
              with MonoBmp do begin
                Width := IWidthA;
                Height := IHeightA;
                Canvas.Brush.Color := clWhite;
                Canvas.FillRect (IRectA);
                ImageList_Draw (FImageList.Handle, FImageIndex, Canvas.Handle,
                  0, 0, ILD_TRANSPARENT);
                Canvas.Brush.Color := clBlack;