sf_utils.pas

smartflash ,delphi vcl组件 ,可以实现透明flash窗体

  Canvas.Pen.Color := Color;
  Canvas.Polygon(Points);
end;

procedure FillHalftonePolygon(Canvas: TCanvas; Points: array of TPoint; Color, HalfColor: TColor);
var
  i, j: integer;
  HalfBrush: TBrush;
  HalfBitmap: TBitmap;
begin
  { Fill Polygon }
  HalfBrush := TBrush.Create;
  HalfBitmap := TBitmap.Create;
  HalfBitmap.Width := 8;
  HalfBitmap.Height := 8;

  { Create halftone bitmap }
  HalfBitmap.Canvas.Brush.Style := bsSolid;
  HalfBitmap.Canvas.Brush.Color := Color;
  HalfBitmap.Canvas.FillRect(Rect(0, 0, 8, 8));

  for i := 0 to HalfBitmap.Width - 1 do
    for j := 0 to HalfBitmap.Height - 1 do
    begin
      if Odd(i) and Odd(j) then
        HalfBitmap.Canvas.Pixels[i, j] := HalfColor;
      if not Odd(i) and not Odd(j) then
        HalfBitmap.Canvas.Pixels[i, j] := HalfColor;
    end;

  HalfBrush.Bitmap := HalfBitmap;

  Canvas.Brush := HalfBrush;
  Canvas.Pen.Style := psClear;
  Canvas.Polygon(Points);

  HalfBitmap.Free;
  HalfBrush.Free;
end;

procedure DrawIcon(Canvas: TCanvas; ARect: TRect; AIcon: TIcon);
var
  R: TRect;
begin
  if AIcon = nil then Exit;

  R := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON));
  RectCenter(R, ARect);

  DrawIconEx(Canvas.Handle, R.Left, R.Top, AIcon.Handle, 0, 0, 0, 0, DI_NORMAL);
end;

procedure DrawIcon(Canvas: TCanvas; ARect: TRect; AIcon: Cardinal); overload;
var
  R: TRect;
begin
  if AIcon = 0 then Exit;

  R := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON));
  RectCenter(R, ARect);

  DrawIconEx(Canvas.Handle, R.Left, R.Top, AIcon, 0, 0, 0, 0, DI_NORMAL);
end;

procedure DrawIcon(DC: HDC; ARect: TRect; AIcon: TIcon);
var
  R: TRect;
begin
  if AIcon = nil then Exit;

  R := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON));
  RectCenter(R, ARect);

  DrawIconEx(DC, R.Left, R.Top, AIcon.Handle, 0, 0, 0, 0, DI_NORMAL);
end;

procedure DrawIcon(DC: HDC; ARect: TRect; AIcon: Cardinal);
var
  R: TRect;
begin
  if AIcon = 0 then Exit;

  R := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON));
  RectCenter(R, ARect);

  DrawIconEx(DC, R.Left, R.Top, AIcon, 0, 0, 0, 0, DI_NORMAL);
end;

procedure DrawGlyphShadow(Canvas: TCanvas; X, Y: integer; Glyph: TsfBitmap; Color: TColor);
var
  Shadow: TsfBitmap;
  i: integer;
  P: PsfColor;
begin
  Shadow := TsfBitmap.Create;
  try
    Shadow.Assign(Glyph);
    Shadow.AlphaBlend := true;
    Shadow.CheckingTransparent;

    for i := 0 to Shadow.Width * Shadow.Height - 1 do
    begin
      P := @Shadow.Bits[i];
      if P^ shr 24 > 0 then
        P^ := sfColor(Color, 100);
    end;

    Shadow.Draw(Canvas.Handle, X, Y);
  finally
    Shadow.Free;
  end;
end;

{ Stream routines ============================================================}

function ReadString(S: TStream): string;
var
  L: Integer;
begin
  L := 0;
  S.Read(L, SizeOf(L));
  SetLength(Result, L);
  S.Read(Pointer(Result)^, L);
end;

procedure WriteString(S: TStream; Value: string);
var
  L: Integer;
begin
  L := Length(Value);
  S.Write(L, SizeOf(L));
  S.Write(Pointer(Value)^, L);
end;

{ Region routines =============================================================}

var
  Rts: array [0..5000] of TRect;

function CreateRegionDataFromBitmap(Bitmap: TsfBitmap; var RgnData: PRgnData;
  Left, Top: integer): HRgn;
var
  j, i, i1: integer;
  TrColor: TsfColor;
  C: PsfColor;
  Count: integer;
begin
  Result := 0;

  TrColor := sfTransparent;

  if Bitmap.Empty then Exit;
  if Bitmap.Width * Bitmap.Height = 0 then Exit;

  Count := 0;
  for j := 0 to Bitmap.Height-1 do
  begin
    i := -1;
    while i < Bitmap.Width do
    begin
      repeat
        Inc(i);
        C := Bitmap.PixelPtr[i, j];
        if i >= Bitmap.Width then Break;
      until not ((C^ and not AlphaMask) = TrColor);

      if i >= Bitmap.Width then Break;

      i1 := i;
      repeat
        Inc(i1);
        If (i1 >= Bitmap.Width) Then Break;
        C := Bitmap.PixelPtr[i1, j];
      until ((C^ and not AlphaMask) = TrColor);

      if i <> i1 then
      begin
        Rts[Count] := Rect(Left + i, Top + j, Left + i1, Top + j + 1);
        Inc(Count);
      end;
      i := i1;
    end;
  end;
  { Make Region data }
  Result := Count * SizeOf(TRect);
  GetMem(Rgndata, SizeOf(TRgnDataHeader) + Result);
  RgnData^.rdh.dwSize := SizeOf(TRgnDataHeader);
  RgnData^.rdh.iType := RDH_RECTANGLES;
  RgnData^.rdh.nCount := Count;
  RgnData^.rdh.nRgnSize := 0;
  RgnData^.rdh.rcBound := Rect(0, 0, Bitmap.Width, Bitmap.Height);
  { Update New Region }
  Move(Rts, RgnData^.Buffer, Result);
  Result := SizeOf(TRgnDataHeader) + Count * SizeOf(TRect);
end;

function CreateRegionFromBitmap(Bitmap: TsfBitmap; Left, Top: integer): HRgn;
var
  RgnData: PRgnData;
  Size: integer;
begin
  RgnData := nil;
  Size := CreateRegionDataFromBitmap(Bitmap, RgnData, Left, Top);
  Result := ExtCreateRegion(nil, Size, RgnData^);
  if RgnData <> nil then FreeMem(RgnData, Size);
end;

{ System Routines }

function GetKeyBoardDelayInterval: integer;
var
  A: DWORD;
begin
  SystemParametersInfo(SPI_GETKEYBOARDDELAY, 0, @A, 0);
  Result := (A + 1) * 200;
end;

function GetKeyBoardSpeedInterval: integer;
var
  A: DWORD;
begin
  SystemParametersInfo(SPI_GETKEYBOARDSPEED, 0, @A, 0);
  Result := Round(1000 / ((A + 1) * 2.3));
end;

{ System Routines }

var
  MMX_ACTIVE: Boolean;

function CPUID_Available: Boolean;
asm
        MOV       EDX,False
        PUSHFD
        POP       EAX
        MOV       ECX,EAX
        XOR       EAX,$00200000
        PUSH      EAX
        POPFD
        PUSHFD
        POP       EAX
        XOR       ECX,EAX
        JZ        @1
        MOV       EDX,True
@1:     PUSH      EAX
        POPFD
        MOV       EAX,EDX
end;

function CPU_Signature: Integer;
asm
        PUSH    EBX
        MOV     EAX,1
        DW      $A20F   // CPUID
        POP     EBX
end;

function CPU_Features: Integer;
asm
        PUSH    EBX
        MOV     EAX,1
        DW      $A20F   // CPUID
        POP     EBX
        MOV     EAX,EDX
end;

function HasMMX: Boolean;
begin
  Result := False;
  if not CPUID_Available then Exit;              // no CPUID available
  if CPU_Signature shr 8 and $0F < 5 then Exit;  // not a Pentium class
  if CPU_Features and $800000 = 0 then Exit;     // no MMX
  Result := True;
end;
 
procedure EMMS;
begin
  if MMX_ACTIVE then
  asm
    db $0F,$77               /// EMMS
  end;
end;

{ Unicode Routines ============================================================}

function StringToWideString(CodePage: Cardinal; const s: String): WideString;
var l: Integer;
begin
  if Length(s)=0 then
  begin
    Result := '';
    exit;
  end;
  l := MultiByteToWideChar(CodePage,MB_PRECOMPOSED or MB_USEGLYPHCHARS,
    PChar(s), Length(s), nil, 0);
  if (l = 0) and (CodePage <> CP_ACP) then
  begin
    CodePage := CP_ACP;
    l := MultiByteToWideChar(CodePage, MB_PRECOMPOSED or MB_USEGLYPHCHARS,
      PChar(s), Length(s), nil, 0);
  end;
  if l<>0 then
  begin
    SetLength(Result, l);
    MultiByteToWideChar(CodePage, MB_PRECOMPOSED or MB_USEGLYPHCHARS,
      PChar(s), Length(s), Pointer(Result), l);
  end
  else
  begin
    SetLength(Result, Length(s));
    for l := 1 to Length(Result) do
      Result[l] := '?';
  end;
end;

{ Screen ======================================================================}

function GetPixelFormat: TPixelFormat;
var
  B: TBitmap;
  Bitmap: HBITMAP;
  DIB: TDIBSection;
begin
  Result := pfCustom;

  B := TBitmap.Create;
  try
    B.Width := 4;
    B.Height := 4;
    B.HandleType := bmDIB;

    Bitmap := GetCurrentObject(B.Canvas.Handle, OBJ_BITMAP);
    if Bitmap <> 0 then
    begin
      if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
      begin
        case DIB.dsBmih.biBitCount of
          1: Result := pf1bit;
          4: Result := pf4bit;
          8: Result := pf8bit;
          15: Result := pf15bit;
          16: Result := pf16bit;
          24: Result := pf24bit;
          32: Result := pf32bit;
        else
          Result := pfCustom;
        end;
      end;
    end;
  finally
    B.Free;
  end;

  CPixelFormat := Result;
end;


{ Region routines =============================================================}

function CreateRegionDataFromBitmap_Flash(Bitmap: TsfBitmap; var RgnData: PRgnData;
  Left, Top: integer): HRgn;
var
  j, i, i1: integer;
  TrColor: TsfColor;
  C: PsfColor;
  Count: integer;
begin
  Result := 0;

  TrColor := sfTransparent;

  if Bitmap.Empty then Exit;
  if Bitmap.Width * Bitmap.Height = 0 then Exit;

  Count := 0;
  for j := 0 to Bitmap.Height-1 do
  begin
    i := -1;
    while i < Bitmap.Width do
    begin
      repeat
        Inc(i);
        C := Bitmap.PixelPtr[i, j];
        if i >= Bitmap.Width then Break;
      until not ((C^ shr 24 = 0));

      if i >= Bitmap.Width then Break;

      i1 := i;
      repeat
        Inc(i1);
        If (i1 >= Bitmap.Width) Then Break;
        C := Bitmap.PixelPtr[i1, j];
      until ((C^ shr 24 = 0));

      if i <> i1 then
      begin
        Rts[Count] := Rect(Left + i, Top + j, Left + i1, Top + j + 1);
        Inc(Count);
      end;
      i := i1;
    end;
  end;
  { Make Region data }
  Result := Count * SizeOf(TRect);
  GetMem(Rgndata, SizeOf(TRgnDataHeader) + Result);
  RgnData^.rdh.dwSize := SizeOf(TRgnDataHeader);
  RgnData^.rdh.iType := RDH_RECTANGLES;
  RgnData^.rdh.nCount := Count;
  RgnData^.rdh.nRgnSize := 0;
  RgnData^.rdh.rcBound := Rect(0, 0, Bitmap.Width, Bitmap.Height);
  { Update New Region }
  Move(Rts, RgnData^.Buffer, Result);
  Result := SizeOf(TRgnDataHeader) + Count * SizeOf(TRect);
end;

function CreateRegionFromBitmap_Flash(Bitmap: TsfBitmap; Left, Top: integer): HRgn;
var
  RgnData: PRgnData;
  Size: integer;
begin
  RgnData := nil;
  Size := CreateRegionDataFromBitmap_Flash(Bitmap, RgnData, Left, Top);
  Result := ExtCreateRegion(nil, Size, RgnData^);
  if RgnData <> nil then FreeMem(RgnData, Size);
end;


initialization

  GetPixelFormat;
  MMX_ACTIVE := HasMMX;

finalization

end.