fccommon.pas

一套及时通讯的原码

  NewKeyState: TKeyboardState;
begin
   GetKeyboardState(KeyState);
   NewKeyState:= KeyState;
   NewKeyState [VKShift] := $81;
   NewKeyState [VKChar] := $81;
   SetKeyboardState(NewKeyState);
   PostMessage(Handle, WM_KEYDOWN, VKChar, 1);
   PostMessage(Handle, WM_KEYUP, VKChar, 1);
   SetKeyboardState(KeyState);
end;

function fcRectWidth(Rect: TRect): Integer;
begin
  result := Rect.Right - Rect.Left;
end;

function fcRectHeight(Rect: TRect): Integer;
begin
  result := Rect.Bottom - Rect.Top;
end;

function fcSubstring(s: string; Start, Stop: integer): string;
begin
  if Stop = 0 then result := Copy(s, Start, length(s) - Start + 1)
  else result := Copy(s, Start, Stop - Start);
end;

function fcIndexOf(Substr, s: string; Index: integer): integer;
begin
  result := pos(Substr, fcSubstring(s, Index, 0));
  if result <> 0 then result := result + Index - 1;
end;

function fcLastIndexOf(Substr, s: string; Index: integer): integer;
begin
  if Index = 0 then Index := Length(s);
  for result := Index - Length(Substr) downto 1 do
    if Copy(s, result, Length(Substr)) = Substr then break;
end;

// Returns the position of Index'th (zero-based) occurance of Substring

function fcNthIndexOf(Substr, s: string; Index: integer): integer;
var Counter: integer;
begin
  Counter := -1;
  result := 0;
  while Counter < Index do
  begin
    inc(Counter);
    result := fcIndexOf(Substr, s, result + 1);
  end;
end;

// Index is zero based.  eg.

function fcCountTokens(s, Delimiter: string): integer;
var i: integer;
begin
  result := 0;
  if length(s) > 0 then result := 1;
  for i := 1 to Length(s) do
    if Copy(s, i, Length(Delimiter)) = Delimiter then inc(result);
end;

// fcGetToken('RichEdit's are great!', ' ', 1) will return 'are'

function fcGetToken(s, Delimiter: string; Index: integer): string;
var Temp: integer;
begin
  if (Index >= fcCountTokens(s, Delimiter)) then result := ''
  else begin
    Temp := fcNthIndexOf(Delimiter, s, Index - 1);
    if Temp <> 0 then inc(Temp, Length(Delimiter))
    else Temp := 1;
    result := fcSubstring(s, Temp, fcNthIndexOf(Delimiter, s, Index));
  end;
end;

// Set's a given token to the given value and returns the updated string.

function fcSetToken(s, Delimiter, Token: string; Index: integer): string;
var Temp: integer;
begin
  Temp := fcNthIndexOf(Delimiter, s, Index - 1);
  if Temp <> 0 then inc(Temp, Length(Delimiter));
  if Temp = 0 then
  begin
    Temp := Length(s) + Length(Delimiter) + 1;
    s := s + Delimiter;
  end;
  if fcNthIndexOf(Delimiter, s, Index) <> 0 then
    result :=
      fcSubstring(s, 1, Temp) +
      Token +
      fcSubstring(s, fcNthIndexOf(Delimiter, s, Index), 0)
  else
    result :=
      fcSubstring(s, 1, Temp) +
      Token;
end;

function fcFindToken(s, Delimiter, Token: string): Integer;
var i: Integer;
begin
  result := -1;
  for i := 0 to fcCountTokens(s, Delimiter) - 1 do
    if fcGetToken(s, Delimiter, i) = Token then
    begin
      result := i;
      Break;
    end;
end;

function fcGetPropInfo(Component: TPersistent; PropName: string): PPropInfo;
begin
  result := GetPropInfo(Component.ClassInfo, PropName);
  if result = nil then raise EInvalidOperation.Create(Format('Property %s does not exist.', [Propname]));
end;

function fcGenerateName(Component: TComponent; const Base: string): string;
var i, j: Integer;
    Accept: Boolean;
begin
  i := 1;
  while True do
  begin
    result := Base + InttoStr(i);
    Accept := True;
    for j := 0 to Component.ComponentCount - 1 do
      if Component.Components[j].Name = result then
      begin
        Accept := False;
        Break;
      end;
    if Accept then Break;
    inc(i);
  end;
end;

function fcGetCursorPos: TPoint;
begin
  GetCursorPos(result);
end;

function fcThisThat(const Clause: Boolean; TrueVal, FalseVal: Integer): Integer;
begin
  if Clause then result := TrueVal else Result := FalseVal;
end;

function fcSize(cx, cy: Integer): TSize;
begin
  result.cx := cx;
  result.cy := cy;
end;

function fcSizeEqual(Size1, Size2: TSize): Boolean;
begin
  result := (Size1.cx = Size2.cx) and (Size1.cy = Size2.cy);
end;

function fcStripAmpersands(Value: string): string;
begin
  result := fcReplace(Value, '&&', #0);
  result := fcReplace(result, '&', '');
  result := fcReplace(result, #0, '&');
end;

function fcReplace(s, Find, Replace: string): string;
var i: integer;
begin
  i := 1;
  result := '';
  while i <> 0 do
  begin
    result := result + fcSubstring(s, i, fcIndexOf(Find, s, i));
    if fcIndexOf(Find, s, i) = 0 then Break;
    result := result + Replace;
    i := fcIndexOf(Find, s, i);
    if i <> 0 then inc(i, Length(Find));
  end;
end;

function fcLineHeight(Canvas: TCanvas; Flags: Integer; MaxWidth: Integer; Line: string): Integer;
var r: TRect;
begin
  r := Rect(0, 0, MaxWidth, 0);
  DrawTextEx(Canvas.Handle, PChar(Line), Length(Line), r, Flags or DT_CALCRECT, nil);
  result := fcRectHeight(r);
end;

function fcMultiLineTextSize(Canvas: TCanvas; Text: string; LineSpacing: Integer;
  MaxWidth: Integer; DrawFlags: Integer): TSize;
var i: Integer;
    s: string;
    TokenCount: Integer;
    r: TRect;
begin
  TokenCount := fcCountTokens(Text, #13#10);
  result := fcSize(0, 0);

  for i := 0 to TokenCount - 1 do
  begin
    s := fcGetToken(Text, #13#10, i);
    if MaxWidth = 0 then
    begin
      inc(result.cy, Canvas.TextHeight(s));
      if Canvas.TextWidth(s) > result.cx then result.cx := Canvas.TextWidth(s);
    end else begin
      r := Rect(0, 0, MaxWidth, 0);
      DrawTextEx(Canvas.Handle, PChar(s), Length(s), r, DrawFlags or DT_CALCRECT, nil);
      inc(result.cy, fcRectHeight(r));
      if fcRectWidth(r) > result.cx then result.cx := fcRectWidth(r);
    end;
    if i < TokenCount - 1 then inc(result.cy, LineSpacing);
  end;
end;

procedure fcAdjustFlag(Condition: Boolean; var Flag: UINT; FlagVal: UINT);
begin
  if Condition then Flag := Flag or FlagVal
  else Flag := Flag and not FlagVal;
end;

function fcSign(Value: Extended): Integer;
begin
  if Value > 0 then result := 1 else if Value < 0 then result := -1 else result := 0;
end;

procedure fcOffsetBitmap(Bitmap: TfcBitmap; Transparent: TColor; Offset: TPoint);
var TempBitmap: TBitmap;
begin
  TempBitmap := TBitmap.Create;
  TempBitmap.Assign(Bitmap);
  TempBitmap.Width := TempBitmap.Width + Abs(Offset.x) * 2;
  TempBitmap.Height := TempBitmap.Height + Abs(Offset.y) * 2;
  TempBitmap.Canvas.Brush.Color := Transparent;
  TempBitmap.Canvas.FillRect(Rect(0, 0, TempBitmap.Width, TempBitmap.Height));
  TempBitmap.Canvas.Draw(Offset.x, Offset.y, Bitmap);
  Bitmap.Assign(TempBitmap);
  TempBitmap.Free;
end;

procedure fcDottedLine(Canvas: TCanvas; p1, p2: TPoint);
var i: integer;
    x, y: integer;
    tot: integer;
begin
{var ABrush: HBRUSH;
begin
  ABrush := fcGetDitherBrush;
  SelectObject(Canvas.Handle, ABrush);
  SetTextColor(Canvas.Handle, clBlack);
  SetBkColor(Canvas.Handle, clWhite);
  SetBkMode(Canvas.Handle, TRANSPARENT);
  PatBlt(Canvas.Handle, 0, 0, 1, 20, $A000C9);
  DeleteObject(ABrush);}

  Canvas.Refresh;
  x := p1.x;
  y := p1.y;
  tot := fcMax(Abs(p2.y - p1.y), Abs(p2.x - p1.x));
  for i := 0 to tot do if i mod 2 = 0 then
  begin
    Canvas.Polyline([Point(x,y), Point(x+1,y+1)]);
    inc(x, (p2.x - p1.x) div fcMax(1, (tot div 2)));
    inc(y, (p2.y - p1.y) div fcMax(1, (tot div 2)));
  end;
end;

procedure fcTransparentDraw(Canvas: TCanvas; ARect: TRect; Bitmap: TfcBitmap; TransparentColor: TColor);
var MaskBm: TfcBitmap;
    Mask: TBitmap;
    TmpBitmap: TBitmap;
begin
  if TransparentColor = -1 then TransparentColor := fcGetStdColor(Bitmap.Pixels[0, 0]);
  MaskBm := TfcBitmap.Create;
  MaskBm.Assign(Bitmap);
  MaskBm.Mask(fcGetColor(TransparentColor));

  Mask := TBitmap.Create;
  Mask.Assign(MaskBm);
  Mask.Monochrome := True;

  MaskBm.Free;

  TmpBitmap := TBitmap.Create;
  TmpBitmap.Assign(Bitmap);
  fcDrawMask(Canvas, ARect, TmpBitmap, Mask, True);
  TmpBitmap.Free;

  Mask.Free;
end;

function fcModifyColor(Color: TColor; Amount: Integer; Percent: Boolean): TColor;
var Colors: TRGBQuad;
  function HighestOthers(Value: PByte): Byte;
  begin
    with Colors do
    begin
      result := 0;
      if Value = @rgbBlue then result := fcMax(rgbRed, rgbGreen)
      else if Value = @rgbRed then result := fcMax(rgbBlue, rgbGreen)
      else if Value = @rgbGreen then result := fcMax(rgbRed, rgbBlue);
    end;
  end;
  function Check(Value: Integer): Byte;
  begin
    result := Value;
    if Value < 0 then result := 0;
    if Value > 255 then result := 255;
  end;
  procedure DoChange(Value: PByte);
  begin
    if (Value^ = 0) and (HighestOthers(Value) = 255) and (Amount > 0) then
    begin
      if Percent then Value^ := Check(255 * Amount div 100)
      else Value^ := Check(Amount);
    end else begin
      if Percent then
      begin
        if Amount > 0 then Value^ := Check(Value^ + (255 - Value^) * Amount div 100)
        else Value^ := Check(Value^ + Value^ * Amount div 100);
      end else Value^ := Check(Value^ + Amount);
    end;
  end;
begin
  with Colors do
  begin
    fcColorToByteValues(Color, rgbReserved, rgbBlue, rgbGreen, rgbRed);
    DoChange(@rgbRed);
    DoChange(@rgbBlue);
    DoChange(@rgbGreen);
    result := RGB(rgbRed, rgbGreen, rgbBlue);
  end;
end;

procedure fcImageListDraw(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas;
  X, Y: Integer; Style: Cardinal; Enabled: Boolean);
const
  ROP_DSPDxax = $00E20746;
var
  R: TRect;
  DestDC, SrcDC: HDC;
  function GetRGBColor(Value: TColor): DWORD;
  begin
    Result := ColorToRGB(Value);
    case Result of
      clNone: Result := CLR_NONE;
      clDefault: Result := CLR_DEFAULT;
    end;
  end;
var AMonoBitmap: TBitmap;
begin
  with ImageList do
  begin
    if HandleAllocated then
    begin
      if Enabled then
         ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0,
            GetRGBColor(TImageList(ImageList).BkColor), GetRGBColor(TImageList(ImageList).BlendColor), Style)
      else
      begin
        AMonoBitmap := TBitmap.Create;
        with AMonoBitmap do
        begin
          Monochrome := True;
          Width := TImageList(ImageList).Width;
          Height := TImageList(ImageList).Height;
        end;

        { Store masked version of image temporarily in FBitmap }
        ImageList_DrawEx(Handle, Index, AMonoBitmap.Canvas.Handle, 0,0,0,0, 0,0,
          ILD_MASK);
        R := Rect(X, Y, X+TImageList(ImageList).Width, Y+TImageList(ImageList).Height);
        SrcDC := AMonoBitmap.Canvas.Handle;
        { Convert Black to clBtnHighlight }
        Canvas.Brush.Color := clBtnHighlight;
        DestDC := Canvas.Handle;
        Windows.SetTextColor(DestDC, clWhite);
        Windows.SetBkColor(DestDC, clBlack);
        BitBlt(DestDC, X+1, Y+1, TImageList(ImageList).Width, TImageList(ImageList).Height, SrcDC, 0, 0, ROP_DSPDxax);
        { Convert Black to clBtnShadow }
        Canvas.Brush.Color := clBtnShadow;
        DestDC := Canvas.Handle;
        Windows.SetTextColor(DestDC, clWhite);
        Windows.SetBkColor(DestDC, clBlack);
        BitBlt(DestDC, X, Y, TImageList(ImageList).Width, TImageList(ImageList).Height, SrcDC, 0, 0, ROP_DSPDxax);
        AMonoBitmap.Free;
      end;
    end;
  end;
end;

procedure fcImageListDrawFixBug(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas;
  X, Y: Integer; Style: Cardinal; Enabled: Boolean);
const
  ROP_DSPDxax = $00E20746;
var
  R: TRect;
  DestDC, SrcDC: HDC;
  function GetRGBColor(Value: TColor): DWORD;
  begin