mmutils.pas

一套及时通讯的原码

function GetFileSize(Name: TFileName): Longint;
var
   SearchRec: TSearchRec;

begin
   try
      if FindFirst(ExpandFileName(Name), faAnyFile, SearchRec) = 0 then
         Result := SearchRec.Size
      else
         Result := -1;
   finally
      FindClose(SearchRec);
   end;
end;

{$IFDEF WIN32}
{ This function is used if the OS doesn't support GetDiskFreeSpaceEx }
{=========================================================================}
function BackfillGetDiskFreeSpaceEx(Directory: PChar; var FreeAvailable,
                                    TotalSpace: Int64;
                                    TotalFree: PInt64): Bool; stdcall;
var
  SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: DWORD;
  Temp: Int64;
  Dir : PChar;
begin
  if Directory <> nil then
     Dir := PChar(ExtractFileDrive(Directory)+'\')
  else
     Dir := nil;

  Result := GetDiskFreeSpace(Dir, SectorsPerCluster, BytesPerSector,
                             FreeClusters, TotalClusters);
  Temp := SectorsPerCluster;
  Temp := Temp * BytesPerSector;
  FreeAvailable := Temp * FreeClusters;
  TotalSpace    := Temp * TotalClusters;
end;
{$ENDIF}

{=========================================================================}
function GetDiskStats(const Directory: string; var nFree, nSize: Int64): Boolean;
{$IFDEF WIN32}
begin
   Result := _GetDiskFreeSpaceEx(PChar(ExtractFileDir(Directory)),nFree, nSize, nil);
   if not Result then
   begin { avoid errors from unchecked divisions }
      nFree := 0;
      nSize := 1;
   end;
{$ELSE}
var
   iDrive: Byte;
begin
   iDrive := Byte(UpCase(Directory[0]))-64;
   nSize := DiskSize(iDrive);
   nFree := DiskFree(iDrive);
   Result := True;
{$ENDIF}
end;

{=========================================================================}
function GetDiskFree(const Directory: string; nBytes: Longint): Boolean;
var
   nFree,nSize,n: Int64;
begin
   Result := False;
   if GetDiskStats(Directory,nFree,nSize) then
   begin
      n := nBytes;
      Result := nFree >= n;
   end;
end;

const
     RC_Active     = clWhite; { the resource color for active sements    }
     RC_Inactive   = clSilver;{ the resource color for inactive segments }
     RC_Background = clBlack; { the resource color for the background    }

{=========================================================================}
{ Change the black/white SrcBitmap to a colored DestBitmap                }
{=========================================================================}
procedure ChangeColors(Bitmap: TBitmap; DrawInactive: Boolean;
                       ForeColor, InactiveColor, BackColor: TColor);
Var
   aRect: TRect;
   MaskF, MaskB, MaskI: TBitmap;

   function CreateMask(Bmp: TBitmap; Color: TColor): TBitmap;
   begin
      Result := TBitmap.Create;
      with Result do
      begin
         Monochrome  := True;
         Width       := Bmp.Width;
         Height      := Bmp.Height;
         SetBkColor(Bmp.Canvas.Handle,ColorToRGB(Color));
         Canvas.Draw(0,0,Bmp);
      end;
   end;

   procedure PutMask(Bmp: TBitmap; aMask: TBitmap; Color: TColor; Mode: TCopyMode);
   begin
      with Bmp do
      begin
         Canvas.CopyMode := Mode;
         SetTextColor(Canvas.Handle,0);
         SetBkColor(Canvas.Handle,ColorToRGB(Color));
         Canvas.StretchDraw(Bounds(0,0,Width,Height),aMask);
      end;
   end;

begin
    aRect := Rect(0,0,Bitmap.Width,Bitmap.Height);
    MaskF := CreateMask(Bitmap,RC_ACTIVE);
    try
        MaskB := CreateMask(Bitmap,RC_Background);
        try
            MaskI := CreateMask(Bitmap,RC_INACTIVE);
            try
                PutMask(Bitmap,MaskF,ForeColor,cmSrcCopy);
                PutMask(Bitmap,MaskB,BackColor,cmSrcInvert);
                if DrawInactive then
                    PutMask(Bitmap,MaskI,InactiveColor,cmSrcInvert)
                else
                    PutMask(Bitmap,MaskI,BackColor,cmSrcInvert);
            finally
                MaskI.Free;
            end;
        finally
            MaskB.Free;
        end;
    finally
        MaskF.Free;
    end;
end;

{=========================================================================}
procedure GetBitmapSize(Bitmap: HBitmap; var W, H: integer);
var
{$IFDEF WIN32}
   bm: Windows.TBitmap;
{$ELSE}
   bm: WinTypes.TBitmap;
{$ENDIF}
begin
   GetObject(Bitmap, SizeOf(bm), @bm);
   W := bm.bmWidth;
   H := bm.bmHeight;
end;

{=========================================================================}
function GetTransparentColorEx(Bitmap: HBitmap; Point: TPoint): TColorRef;
var
   MemDC: HDC;
   OldBitmap: HBITMAP;
   W,H: integer;
begin
   MemDC := CreateCompatibleDC(0);
   OldBitmap := SelectObject(MemDC, Bitmap);
   GetBitmapSize(Bitmap,W,H);
   Point.X := MinMax(Point.X,0,W-1);
   Point.Y := MinMax(Point.Y,0,H-1);
   Result := GetPixel(MemDC,Point.X,Point.Y);
   SelectObject(MemDC, OldBitmap);
   DeleteDC(MemDC);
end;

{=========================================================================}
function GetTransparentColor(Bitmap: HBitmap): TColorRef;
begin
   Result := GetTransparentColorEx(Bitmap,Point(0,MaxInt-1));
end;

{=========================================================================}
procedure DrawTransparentBitmapEx(DC: HDC; Bitmap: HBitmap; X, Y: integer;
                                  Src: TRect; Transparent: TColorRef);
type
    _TPoint = record
        X: integer;
        Y: integer;
    end;
var
   cColor          : TColorRef;
   bmAndBack,
   bmAndObject,
   bmAndMem,
   bmSave,
   bmBackOld,
   bmObjectOld,
   bmMemOld,
   bmSaveOld       : HBitmap;
   hdcMem,
   hdcBack,
   hdcObject,
   hdcTemp,
   hdcSave         : HDC;
   bmWidth,bmHeight: integer;

begin
   {$IFDEF WIN32}
   EnterCriticalSection(TransSection);
   try
   {$ENDIF}
      hdcTemp := CreateCompatibleDC(DC);
      SelectObject(hdcTemp, Bitmap); { select the bitmap }

      bmWidth  := Src.Right-Src.Left;
      bmHeight := Src.Bottom-Src.Top;

      { create some DCs to hold temporary data }
      hdcBack   := CreateCompatibleDC(DC);
      hdcObject := CreateCompatibleDC(DC);
      hdcMem    := CreateCompatibleDC(DC);
      hdcSave   := CreateCompatibleDC(DC);

      { create a bitmap for each DC }

      { monochrome DC }
      bmAndBack   := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
      bmAndObject := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);

      bmAndMem    := CreateCompatibleBitmap(DC, bmWidth, bmHeight);
      bmSave      := CreateCompatibleBitmap(DC, bmWidth, bmHeight);

      { each DC must select a bitmap object to store pixel data }
      bmBackOld   := SelectObject(hdcBack, bmAndBack);
      bmObjectOld := SelectObject(hdcObject, bmAndObject);
      bmMemOld    := SelectObject(hdcMem, bmAndMem);
      bmSaveOld   := SelectObject(hdcSave, bmSave);

      { set proper mapping mode }
      SetMapMode(hdcTemp, GetMapMode(DC));

      { save the bitmap sent here, because it will be overwritten }
      BitBlt(hdcSave, 0, 0, bmWidth, bmHeight, hdcTemp, Src.Left, Src.Top, SRCCOPY);

      { set the background color of the source DC to the color.
        contained in the parts of the bitmap that should be transparent }
      cColor := SetBkColor(hdcTemp, ColorToRGB(Transparent));

      { create the object mask for the bitmap by performing a BitBlt()
        from the source bitmap to a monochrome bitmap }
      BitBlt(hdcObject, 0, 0, bmWidth, bmHeight, hdcTemp, Src.Left, Src.Top, SRCCOPY);

      { set the background color of the source DC back to the original color }
      SetBkColor(hdcTemp, cColor);

      { create the inverse of the object mask }
      BitBlt(hdcBack, 0, 0, bmWidth, bmHeight, hdcObject, 0, 0, NOTSRCCOPY);

      { copy the background of the main DC to the destination }
      BitBlt(hdcMem, 0, 0, bmWidth, bmHeight, DC, X, Y, SRCCOPY);

      { mask out the places where the bitmap will be placed }
      BitBlt(hdcMem, 0, 0, bmWidth, bmHeight, hdcObject, 0, 0, SRCAND);

      { mask out the transparent colored pixels on the bitmap }
      BitBlt(hdcTemp, Src.Left, Src.Top, bmWidth, bmHeight, hdcBack, 0, 0, SRCAND);

      { XOR the bitmap with the background on the destination DC }
      BitBlt (hdcMem, 0, 0, bmWidth, bmHeight, hdcTemp, Src.Left, Src.Top, SRCPAINT);

      { copy the destination to the screen }
      BitBlt(DC, X, Y, bmWidth, bmHeight, hdcMem, 0, 0, SRCCOPY);

      { place the original bitmap back into the bitmap sent here }
      BitBlt(hdcTemp, Src.Left, Src.Top, bmWidth, bmHeight, hdcSave, 0, 0, SRCCOPY);

      { delete the memory bitmaps }
      DeleteObject(SelectObject(hdcBack, bmBackOld));
      DeleteObject(SelectObject(hdcObject, bmObjectOld));
      DeleteObject(SelectObject(hdcMem, bmMemOld));
      DeleteObject(SelectObject(hdcSave, bmSaveOld));

      { delete the memory DCs }
      DeleteDC(hdcMem);
      DeleteDC(hdcBack);
      DeleteDC(hdcObject);
      DeleteDC(hdcSave);
      DeleteDC(hdcTemp);
   {$IFDEF WIN32}
   finally
      LeaveCriticalSection(TransSection);
   end;
   {$ENDIF}
end;

{=========================================================================}
procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBitmap; X, Y: integer;
                                Transparent: TColorRef);
var
   Src: TRect;

begin
   Src.TopLeft := Point(0,0);
   { convert bitmap dimensions from device to logical points }
   GetBitmapSize(Bitmap, Src.Right, Src.Bottom);
   DrawTransparentBitmapEx(DC, Bitmap, X, Y,
                           Src, Transparent);
end;

{=========================================================================}
procedure TileBlt(DC: HDC; Bitmap: HBitmap; const aRect: TRect; ROP: Longint);
{ This procedure tiles the given Bitmap aBitmap on DC. }
{ aRect specifies the dimensions                       }
var
   aWidth, aHeight,W,H: integer;
   TempDC: HDC;
   oldBitmap: HBitmap;
   i,j : integer;

begin
   {$IFDEF WIN32}
   EnterCriticalSection(TransSection);
   try
   {$ENDIF}
      OldBitmap := 0;
      TempDC := CreateCompatibleDC(DC);
      try
         OldBitmap := SelectObject(TempDC, Bitmap); { select the bitmap }

         GetBitmapSize(Bitmap,aWidth,aHeight);

         i := 0;
         H := aRect.Bottom-aRect.Top;
         while H > 0 do
         begin
            j := 0;
            W := aRect.Right-aRect.Left;
            while W > 0 do
            begin
               BitBlt(DC, aRect.Left+j*aWidth, aRect.Top+i*aHeight,
                      Min(aWidth,W), Min(aHeight,H),
                      TempDC,0,0,ROP);
               dec(W,aWidth);
               inc(j);
            end;
            dec(H,aHeight);
            inc(i);
         end;

      finally
         SelectObject(TempDC, OldBitmap);
         DeleteDC(TempDC);
      end;
   {$IFDEF WIN32}
   finally
      LeaveCriticalSection(TransSection);
   end;
   {$ENDIF}
end;

{=========================================================================}
procedure FillGradient(DC: HDC; BeginColor, EndColor: TColor;
                       nColors: integer; const aRect: TRect);
var
   BeginRGBValue : array[0..2] of Byte;
   RGBDifference : array[0..2] of integer;
   ColorBand     : TRect;
   i             : Integer;
   Red,Green,Blue: Byte;
   Brush,OldBrush: HBrush;

begin
   { Extract the begin RGB values, set the Red, Green and Blue colors }
   BeginRGBValue[0] := GetRValue(ColorToRGB(BeginColor));
   BeginRGBValue[1] := GetGValue(ColorToRGB(BeginColor));
   BeginRGBValue[2] := GetBValue(ColorToRGB(BeginColor));

   { Calculate the difference between begin and end RGB values }
   RGBDifference[0] := GetRValue(ColorToRGB(EndColor))-BeginRGBValue[0];
   RGBDifference[1] := GetGValue(ColorToRGB(EndColor))-BeginRGBValue[1];
   RGBDifference[2] := GetBValue(ColorToRGB(EndColor))-BeginRGBValue[2];

   { Calculate the color band's top and bottom coordinates, for Left To Right fills }
   ColorBand.Top := aRect.Top;
   ColorBand.Bottom := aRect.Bottom;

   { Perform the fill }
   for i := 0 to nColors-1 do
   begin
      { Calculate the color band's left and right coordinates }
      ColorBand.Left  := aRect.Left+ MulDiv(i, aRect.Right-aRect.Left, nColors);
      ColorBand.Right := aRect.Left+ MulDiv(i+1, aRect.Right-aRect.Left, nColors);
      { Calculate the color band's color }
      if (nColors > 1) then
      begin
         Red   := BeginRGBValue[0] + MulDiv(i, RGBDifference[0],nColors-1);
         Green := BeginRGBValue[1] + MulDiv(i, RGBDifference[1],nColors-1);
         Blue  := BeginRGBValue[2] + MulDiv(i, RGBDifference[2],nColors-1);
      end
      else
      begin
         { Set to the Begin Color if set to only one color }
         Red   := BeginRGBValue[0];
         Green := BeginRGBValue[1];
         Blue  := BeginRGBValue[2];
      end;

      { Create a brush with the appropriate color for this band }
      Brush := CreateSolidBrush(RGB(Red,Green,Blue));
      { Select that brush into the temporary DC. }
      OldBrush := SelectObject(DC, Brush);
      try
         { Fill the rectangle using the selected brush -- PatBlt is faster than FillRect }
         PatBlt(DC, ColorBand.Left, ColorBand.Top, ColorBand.Right-ColorBand.Left, ColorBand.Bottom-ColorBand.Top, PATCOPY);
      finally
         { Clean up the brush }
         SelectObject(DC, OldBrush);
         DeleteObject(Brush);
      end;
   end;
end;

{=========================================================================}
procedure FillSolid(DC: HDC; Color: TColor; const aRect: TRect);