rm_tb97ctls.pas

中小企业管理系统------ ERP系统原代码

begin
  Invalidate;
  if (FImageList <> nil) or (Value < Low(TNumGlyphs97)) or
     (Value > High(TNumGlyphs97)) then
    FNumGlyphs := 1
  else
    FNumGlyphs := Value;
  GlyphChanged (nil);
end;

function TButtonGlyph.CreateButtonGlyph (State: TButtonState97): TBoolInt;
const
  ROP_DSPDxax = $00E20746;
  ROP_PSDPxax = $00B8074A;
  ROP_DSna = $00220326;  { D & ~S }

  procedure GenerateMaskBitmapFromDIB (const MaskBitmap, SourceBitmap: TBitmap;
    const SourceOffset, SourceSize: TPoint; TransColors: array of TColor);
  { This a special procedure meant for generating monochrome masks from
    >4 bpp color DIB sections. Because each video driver seems to sport its own
    interpretation of how to handle DIB sections, a workaround procedure like
    this was necessary. }
  type
    TColorArray = array[0..536870910] of TColorRef;
  var
    Info: packed record
      Header: TBitmapInfoHeader;
      Colors: array[0..1] of TColorRef;
    end;
    W, H: Integer;
    I, Y, X: Integer;
    Pixels: ^TColorArray;
    Pixel: ^TColorRef;
    MonoPixels: Pointer;
    MonoPixel, StartMonoPixel: ^Byte;
    MonoScanLineSize, CurBit: Integer;
    DC: HDC;
    MaskBmp: HBITMAP;
  begin
    W := SourceBitmap.Width;
    H := SourceBitmap.Height;
    MonoScanLineSize := SourceSize.X div 8;
    if SourceSize.X mod 8 <> 0 then
      Inc (MonoScanLineSize);
    if MonoScanLineSize mod 4 <> 0 then  { Compensate for scan line boundary }
      MonoScanLineSize := (MonoScanLineSize and not 3) + 4;
    MonoPixels := AllocMem(MonoScanLineSize * SourceSize.Y);  { AllocMem is used because it initializes to zero }
    try
      GetMem (Pixels, W * H * 4);
      try
        FillChar (Info, SizeOf(Info), 0);
        with Info do begin
          with Header do begin
            biSize := SizeOf(TBitmapInfoHeader);
            biWidth := W;
            biHeight := -H;  { negative number makes it a top-down DIB }
            biPlanes := 1;
            biBitCount := 32;
            {biCompression := BI_RGB;}  { implied due to the FillChar zeroing }
          end;
          {Colors[0] := clBlack;}  { implied due to the FillChar zeroing }
          Colors[1] := clWhite;
        end;
        DC := CreateCompatibleDC(0);
        GetDIBits (DC, SourceBitmap.Handle, 0, H, Pixels, PBitmapInfo(@Info)^,
          DIB_RGB_COLORS);
        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)