现在的分越来越少了，虽然问题不是很难，但也不至于这么少分吧

///////////////////////
procedure SetWindowRGN(hWnd: HWND; bmp: TBitmap; TransparentColor: TColor = clBlack;
  RedTol: Byte = 1; GreenTol: Byte = 1; BlueTol: Byte = 1);
const
  AllocUnit = 100;
type
  PRectArray = ^TRectArray;
  TRectArray = array[0..(MaxInt div SizeOf(TRect)) - 1] of TRect;
var
  pr: PRectArray;
  h: HRGN;
  RgnData: PRgnData;
  lr, lg, lb, hr, hg, hb: Byte;
  x, y, x0: Integer;
  b: PByteArray;
  ScanLinePtr: Pointer;
  ScanLineInc: Integer;
  maxRects: Cardinal;
  RGN: HRGN;
begin
  RGN := 0;
  { Keep on hand lowest and highest values for the "transparent" pixels }
  lr := GetRValue(TransparentColor);
  lg := GetGValue(TransparentColor);
  lb := GetBValue(TransparentColor);
  hr := Min($FF, lr + RedTol);
  hg := Min($FF, lg + GreenTol);
  hb := Min($FF, lb + BlueTol);

  bmp.PixelFormat := pf32bit;

  maxRects := AllocUnit;
  GetMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects));
  try
    with RgnData^.rdh do
    begin
      dwSize := SizeOf(RGNDATAHEADER);
      iType := RDH_RECTANGLES;
      nCount := 0;
      nRgnSize := 0;
      SetRect(rcBound, MAXLONG, MAXLONG, 0, 0);
    end;

    ScanLinePtr := bmp.ScanLine[0];
    ScanLineInc := Integer(bmp.ScanLine[1]) - Integer(ScanLinePtr);
    for y := 0 to bmp.Height - 1 do
    begin
      x := 0;
      while x < bmp.Width do
      begin
        x0 := x;
        while x < bmp.Width do
        begin
          b := @PByteArray(ScanLinePtr)[x * SizeOf(TRGBQuad)];
          // BGR-RGB: Windows 32bpp BMPs are made of BGRa quads (not RGBa)
          if (b[2] >= lr) and (b[2] <= hr) and
            (b[1] >= lg) and (b[1] <= hg) and
            (b[0] >= lb) and (b[0] <= hb) then
            Break; // pixel is transparent
          Inc(x);
        end;
        { test to see if we have a non-transparent area in the image }
        if x > x0 then
        begin
          { increase RgnData by AllocUnit rects if we exceeds maxRects }
          if RgnData^.rdh.nCount >= maxRects then
          begin
            Inc(maxRects, AllocUnit);
            ReallocMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));
          end;
          { Add the rect (x0, y)-(x, y+1) as a new visible area in the region }
          pr := @RgnData^.Buffer; // Buffer is an array of rects
          with RgnData^.rdh do
          begin
            SetRect(pr[nCount], x0, y, x, y + 1);
            { adjust the bound rectangle of the region if we are "out-of-bounds" }
            if x0 < rcBound.Left then
              rcBound.Left := x0;
            if y < rcBound.Top then
              rcBound.Top := y;
            if x > rcBound.Right then
              rcBound.Right := x;
            if y + 1 > rcBound.Bottom then
              rcBound.Bottom := y + 1;
            Inc(nCount);
          end;
        end; // if x > x0

        if RgnData^.rdh.nCount = 2000 then
        begin
          h := ExtCreateRegion(nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects), RgnData^);
          if RGN > 0 then
          begin // Expand the current region
            CombineRgn(RGN, RGN, h, RGN_OR);
            DeleteObject(h);
          end
          else // First region, assign it to Result
            RGN := h;
          RgnData^.rdh.nCount := 0;
          SetRect(RgnData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
        end;
        Inc(x);
      end; // scan every sample byte of the image
      Inc(Integer(ScanLinePtr), ScanLineInc);
    end;
    { need to call ExCreateRegion one more time because we could have left    }
    { a RgnData with less than 2000 rects, so it wasn't yet created/combined  }
    h := ExtCreateRegion(nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects), RgnData^);
    if RGN > 0 then
    begin
      CombineRgn(RGN, RGN, h, RGN_OR);
      DeleteObject(h);
    end
    else
      RGN := h;

    Windows.SetWindowRgn(hWnd, RGN, True);
    DeleteObject(RGN);

  finally
    FreeMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  Self.BorderStyle :=bsNone;
  SetWindowRGN(Self.Handle,Image1.Picture.Bitmap,Image1.Canvas.Pixels[0,0]);
end;