mmbmplst.pas

一套及时通讯的原码

            Size := Stream.Position - (OldPos + SizeOf(Size));
            Pos := Stream.Position;
            Stream.Position := OldPos;
            Stream.Write(Size, SizeOf(Size));
            Stream.Position := Pos;
         end;
      end;
   finally
      EndUpdate;
   end;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.ReadData(Stream: TStream);
begin
   LoadFromStream(Stream);
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.WriteData(Stream: TStream);
begin
   SaveToStream(Stream);
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.LoadFromFile(const FName: TFileName);
var
  Stream: TStream;
begin
   Stream := TFileStream.Create(FName, fmOpenRead);
   try
      LoadFromStream(Stream);
   finally
      Stream.Free;
   end;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.ReplaceFromFile(const FName: TFileName);
var
  Stream: TStream;
begin
   Stream := TFileStream.Create(FName, fmOpenRead);
   try
      ReplaceFromStream(Stream);
   finally
      Stream.Free;
   end;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.SaveToFile(const FName: TFileName);
var
  Stream: TStream;
begin
   Stream := TFileStream.Create(FName, fmCreate);
   try
      SaveToStream(Stream);
   finally
      Stream.Free;
   end;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.AddListFromFile(const FName: TFileName);
var
   BML: TMMBitmapList;
begin
   BML := TMMBitmapList.Create(nil);
   try
      BML.LoadFromFile(FName);
      AddList(BML);
   finally
      BML.Free;
   end;
end;

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

   ControlStyle      := ControlStyle - [csOpaque];

   FBitmapIndex      := -1;
   FBitmapBackIndex  := -1;
   FBitmaps          := nil;
   FObserver         := TMMObserver.Create;
   FObserver.OnNotify:= BitmapsNotify;

   FTag2             := 0;
   FTransColor       := clDefault;

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);

   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
destructor TMMCustomBitmapListControl.Destroy;
begin
   BitmapList := nil;

   FObserver.Free;

   inherited Destroy;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.Notification(AComponent: TComponent; Operation: TOperation);
begin
   inherited Notification(AComponent, Operation);

   if (Operation = opRemove) then
   begin
      if (aComponent = BitmapList) then BitmapList := nil;
   end;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.BitmapChanged;
begin
   if (csDesigning in ComponentState) then
       Refresh
   else if (Parent <> nil) and (Parent.HandleAllocated) then
       Paint;
   Refresh;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.BitmapsNotify(Sender, Data: TObject);
begin
   BitmapChanged;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.SetBitmaps(aValue: TMMBitmapList);
begin
  { bug fix for AX Controls }
  if integer(aValue) = integer(Self) then exit;

  if (FBitmaps <> nil) then FBitmaps.RemoveObserver(FObserver);
  FBitmaps := aValue;
  if (FBitmaps <> nil) then
  begin
     FBitmaps.AddObserver(FObserver);
     {$IFNDEF BUILD_ACTIVEX}
     if aValue <> nil then aValue.FreeNotification(Self);
     {$ENDIF}
  end;
  BitmapChanged;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.SetBitmapIndex(aValue: integer);
begin
   if (FBitmapIndex <> aValue) then
   begin
      FBitmapIndex := Max(aValue,-1);
      BitmapChanged;
   end;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListcontrol.SetBitmapBackIndex(aValue: integer);
begin
   if (FBitmapBackIndex <> aValue) then
   begin
      FBitmapBackIndex := Max(aValue,-1);
      Invalidate;
   end;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.BitmapValid: Boolean;
begin
   Result := (FBitmaps <> nil) and (FBitmapIndex >= 0) and (FBitmapIndex <  FBitmaps.Count);
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.GetBitmap: TBitmap;
begin
   if BitmapValid then
      Result := FBitmaps[BitmapIndex]
   else
      Result := nil;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.FindTransparentColor: TColor;
begin
   Result := clDefault;

   if BitmapValid then
      Result := MMUtils.GetTransparentColor(Bitmap.Handle);
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.GetTransparentColor: TColor;
begin
   if (FTransColor = clDefault) then
      Result := FindTransparentColor
   else
      Result := ColorToRGB(FTransColor);
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.SetTransparentColor(aValue: TColor);
begin
   if (aValue <> FTransColor) then
   begin
      if (aValue = clDefault) then
          FTransMode := tmAuto
      else
          FTransMode := tmFixed;

      FTransColor := aValue;

      Perform(CM_TRANSCOLORCHANGED, 0, 0);
  end;
  {$IFDEF WIN32}
  {$IFDEF TRIAL}
  {$DEFINE _HACK2}
  {$I MMHACK.INC}
  {$ENDIF}
  {$ENDIF}
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.SetTransparentMode(aValue: TTransparentMode);
begin
   if (aValue <> FTransMode) then
   begin
      if (aValue = tmAuto) then
          SetTransparentColor(clDefault)
      else
          SetTransparentColor(GetTransparentColor);
   end;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.TransparentColorStored: Boolean;
begin
   Result := FTransMode = tmFixed;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.CMTransColorChanged(var message: TMessage);
begin
   Invalidate;
end;

{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.GetPalette: HPALETTE;
begin
   if BitmapValid then
      Result := Bitmap.Palette
   else
      Result := 0;
end;

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

   FNumGlyphs   := 1;
   FAutoSize    := False;
   FGlyphOrient := goHorizontal;
   FGlyphIndex  := 0;
   FHorizMargin := 0;
   FVertMargin  := 0;
   Width        := 80;
   Height       := 80;

   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;


{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.BitmapChanged;
begin
   DoAutoSize;
end;

{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.DoAutoSize;
var
   W,H: integer;
begin
   if (csLoading in ComponentState) or
      (csReading in ComponentState) or
      (csDestroying in ComponentState) then exit;

   if BitmapValid and FAutosize then
   begin
      if (FGlyphOrient = goHorizontal) then
      begin
         W := Bitmap.Width div FNumGlyphs;
         if (W > 0) and (Bitmap.Height > 0) then
             SetBounds(Left, Top, W, Bitmap.Height);
      end
      else
      begin
         H := Bitmap.Height div FNumGlyphs;
         if (H > 0) and (Bitmap.Width > 0) then
             SetBounds(Left, Top, Bitmap.Width, H);
      end;
   end;
   Invalidate;
end;

{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.SetNumGlyphs(aValue: integer);
begin
   if (FNumGlyphs <> aValue) then
   begin
      FNumGlyphs := Max(aValue,1);
      DoAutosize;
   end;
end;

{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.SetGlyphOrient(aValue: TMMGlyphOrientation);
begin
   if (FGlyphOrient <> aValue) then
   begin
      FGlyphOrient := aValue;
      DoAutoSize;
   end;
end;

{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.SetAutoSize(aValue: Boolean);
begin
   if (aValue <> FAutoSize) then
   begin
      FAutoSize := aValue;
      DoAutoSize;
   end;
end;

{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.SetGlyphIndex(aValue: integer);
begin
   if (aValue <> FGlyphIndex) then
   begin
      FGlyphIndex := aValue;
      if (csDesigning in ComponentState) then
         Refresh
      else
         FastDraw;
   end;
end;

{-- TMMBitmapListImage --------------------------------------------------------}
function TMMBitmapListImage.GetSrcRect(index: integer): TRect;
begin
   index := Min(index,FNumGlyphs-1);
   if (FGlyphOrient = goHorizontal) then
   begin
      Result.Left := index * (Bitmap.Width div FNumGlyphs);
      Result.Top := 0;
      Result.Right := (index+1) * (Bitmap.Width div FNumGlyphs);
      Result.Bottom := Bitmap.Height;
   end
   else
   begin
      Result.Left := 0;
      Result.Top := index * (Bitmap.Height div FNumGlyphs);
      Result.Right := Bitmap.Width;
      Result.Bottom := Min((index+1) * (Bitmap.Height div FNumGlyphs),Bitmap.Height);
   end;
end;

{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.FastDraw;
var
  DC: HDC;
  Control: TWinControl;

begin
   Control := Parent;

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

        if RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then
        begin
           MoveWindowOrg(DC, Left, Top);
           IntersectClipRect(DC, 0, 0, Width, Height);
           Canvas.Handle := DC;
           PaintBitmap;
        end;

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

{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.PaintBitmap;
begin
   if (Visible or (csDesigning in ComponentState)) and BitmapValid then
   begin
      {$IFDEF DELPHI3}
      Bitmap.Canvas.Lock;
      {$ENDIF}
      try
         if not (csDesigning in ComponentState) and assigned(FOnPaint) then
            FOnPaint(Self,Canvas,Rect(0,0,Width,Height),GetSrcRect(FGlyphIndex))
         else
            Canvas.CopyRect(Rect(0,0,Width,Height),
                            Bitmap.Canvas,
                            GetSrcRect(FGlyphIndex));

      finally
         {$IFDEF DELPHI3}
         Bitmap.Canvas.UnLock;
         {$ENDIF}
      end;
   end
   else if csDesigning in ComponentState then
   begin
      Canvas.Brush.Style := bsClear;
      Canvas.Pen.Color   := clBlack;
      Canvas.Pen.Style   := psDot;
      Canvas.Rectangle(0,0,Width,Height);
   end;
end;

{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.Paint;
begin
   PaintBitmap;
end;

end.