vclutils.pas

rxlib2.75控件包

{ When setting the Count, one might add many new items, which
  must be set to zero at one time, to initialize all items to nil.
  You could use FillChar, which fills by bytes, but, as DoMove
  is to Move, ZeroBytes is to FillChar, except that it always
  fill with zero valued words }
procedure FillWords(DstPtr: Pointer; Size: Word; Fill: Word); assembler;
asm
        MOV     AX,Fill
        LES     DI,DstPtr
        MOV     CX,Size.Word[0]
        CLD
        REP     STOSW
end;

{ Fill Length bytes of memory with Fill, starting at Ptr.
  This is just like the procedure in the Win32 API. The memory
  can be larger than 64K and can cross segment boundaries }
procedure FillMemory(Ptr: Pointer; Length: Longint; Fill: Byte);
var
  NBytes: Cardinal;
  NWords: Cardinal;
  FillWord: Word;
begin
  WordRec(FillWord).Hi := Fill;
  WordRec(FillWord).Lo := Fill;
  while Length > 1 do begin
    { Determine the number of bytes remaining in the segment }
    if Ofs(Ptr^) = 0 then NBytes := $FFFE
    else NBytes := $10000 - Ofs(Ptr^);
    if NBytes > Length then NBytes := Length;
    { Filling by words is faster than filling by bytes }
    NWords := NBytes div 2;
    FillWords(Ptr, NWords, FillWord);
    NBytes := NWords * 2;
    Dec(Length, NBytes);
    Ptr := HugeOffset(Ptr, NBytes);
  end;
  { If the fill size is odd, then fill the remaining byte }
  if Length > 0 then PByte(Ptr)^ := Fill;
end;

procedure ZeroMemory(Ptr: Pointer; Length: Longint);
begin
  FillMemory(Ptr, Length, 0);
end;

procedure cld; inline ($FC);
procedure std; inline ($FD);

function ComputeDownMoveSize(SrcOffset, DstOffset: Word): Word;
begin
  if SrcOffset > DstOffset then Result := Word($10000 - SrcOffset) div 2
  else Result := Word($10000 - DstOffset) div 2;
  if Result = 0 then Result := $7FFF;
end;

function ComputeUpMoveSize(SrcOffset, DstOffset: Word): Word;
begin
  if SrcOffset = $FFFF then Result := DstOffset div 2
  else if DstOffset = $FFFF then Result := SrcOffset div 2
  else if SrcOffset > DstOffset then Result := DstOffset div 2 + 1
  else Result := SrcOffset div 2 + 1;
end;

procedure MoveWords(SrcPtr, DstPtr: Pointer; Size: Word); assembler;
asm
        PUSH    DS
        LDS     SI,SrcPtr
        LES     DI,DstPtr
        MOV     CX,Size.Word[0]
        REP     MOVSW
        POP     DS
end;

procedure HugeMove(Base: Pointer; Dst, Src, Size: Longint);
var
  SrcPtr, DstPtr: Pointer;
  MoveSize: Word;
begin
  SrcPtr := HugeOffset(Base, Src * SizeOf(Pointer));
  DstPtr := HugeOffset(Base, Dst * SizeOf(Pointer));
  { Convert longword size to words }
  Size := Size * (SizeOf(Longint) div SizeOf(Word));
  if Src < Dst then begin
    { Start from the far end and work toward the front }
    std;
    HugeInc(SrcPtr, (Size - 1) * SizeOf(Word));
    HugeInc(DstPtr, (Size - 1) * SizeOf(Word));
    while Size > 0 do begin
      { Compute how many bytes to move in the current segment }
      MoveSize := ComputeUpMoveSize(Word(SrcPtr), Word(DstPtr));
      if MoveSize > Size then MoveSize := Word(Size);
      { Move the bytes }
      MoveWords(SrcPtr, DstPtr, MoveSize);
      { Update the number of bytes left to move }
      Dec(Size, MoveSize);
      { Update the pointers }
      HugeDec(SrcPtr, MoveSize * SizeOf(Word));
      HugeDec(DstPtr, MoveSize * SizeOf(Word));
    end;
    cld; { reset the direction flag }
  end
  else begin
    { Start from the beginning and work toward the end }
    cld;
    while Size > 0 do begin
      { Compute how many bytes to move in the current segment }
      MoveSize := ComputeDownMoveSize(Word(SrcPtr), Word(DstPtr));
      if MoveSize > Size then MoveSize := Word(Size);
      { Move the bytes }
      MoveWords(SrcPtr, DstPtr, MoveSize);
      { Update the number of bytes left to move }
      Dec(Size, MoveSize);
      { Advance the pointers }
      HugeInc(SrcPtr, MoveSize * SizeOf(Word));
      HugeInc(DstPtr, MoveSize * SizeOf(Word));
    end;
  end;
end;

{$ENDIF}

{ String routines }

{$W+}
function GetEnvVar(const VarName: string): string;
var
{$IFDEF WIN32}
  S: array[0..2048] of Char;
{$ELSE}
  S: array[0..255] of Char;
  L: Cardinal;
  P: PChar;
{$ENDIF}
begin
{$IFDEF WIN32}
  if GetEnvironmentVariable(PChar(VarName), S, SizeOf(S) - 1) > 0 then
    Result := StrPas(S)
  else Result := '';
{$ELSE}
  L := Length(VarName);
  P := GetDosEnvironment;
  StrPLCopy(S, VarName, 255);
  while P^ <> #0 do begin
    if (StrLIComp(P, {$IFDEF WIN32} PChar(VarName) {$ELSE} S {$ENDIF}, L) = 0) and
      (P[L] = '=') then
    begin
      Result := StrPas(P + L + 1);
      Exit;
    end;
    Inc(P, StrLen(P) + 1);
  end;
  Result := '';
{$ENDIF}
end;
{$W-}

{ function GetParamStr copied from SYSTEM.PAS unit of Delphi 2.0 }
function GetParamStr(P: PChar; var Param: string): PChar;
var
  Len: Integer;
  Buffer: array[Byte] of Char;
begin
  while True do
  begin
    while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
    if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
  end;
  Len := 0;
  while P[0] > ' ' do
    if P[0] = '"' then
    begin
      Inc(P);
      while (P[0] <> #0) and (P[0] <> '"') do
      begin
        Buffer[Len] := P[0];
        Inc(Len);
        Inc(P);
      end;
      if P[0] <> #0 then Inc(P);
    end else
    begin
      Buffer[Len] := P[0];
      Inc(Len);
      Inc(P);
    end;
  SetString(Param, Buffer, Len);
  Result := P;
end;

function ParamCountFromCommandLine(CmdLine: PChar): Integer;
var
  S: string;
  P: PChar;
begin
  P := CmdLine;
  Result := 0;
  while True do
  begin
    P := GetParamStr(P, S);
    if S = '' then Break;
    Inc(Result);
  end;
end;

function ParamStrFromCommandLine(CmdLine: PChar; Index: Integer): string;
var
  P: PChar;
begin
  P := CmdLine;
  while True do
  begin
    P := GetParamStr(P, Result);
    if (Index = 0) or (Result = '') then Break;
    Dec(Index);
  end;
end;

procedure SplitCommandLine(const CmdLine: string; var ExeName,
  Params: string);
var
  Buffer: PChar;
  Cnt, I: Integer;
  S: string;
begin
  ExeName := '';
  Params := '';
  Buffer := StrPAlloc(CmdLine);
  try
    Cnt := ParamCountFromCommandLine(Buffer);
    if Cnt > 0 then begin
      ExeName := ParamStrFromCommandLine(Buffer, 0);
      for I := 1 to Cnt - 1 do begin
        S := ParamStrFromCommandLine(Buffer, I);
        if Pos(' ', S) > 0 then S := '"' + S + '"';
        Params := Params + S;
        if I < Cnt - 1 then Params := Params + ' ';
      end;
    end;
  finally
    StrDispose(Buffer);
  end;
end;

function AnsiUpperFirstChar(const S: string): string;
var
  Temp: string[1];
begin
  Result := AnsiLowerCase(S);
  if S <> '' then begin
    Temp := Result[1];
    Temp := AnsiUpperCase(Temp);
    Result[1] := Temp[1];
  end;
end;

function StrPAlloc(const S: string): PChar;
begin
  Result := StrPCopy(StrAlloc(Length(S) + 1), S);
end;

function StringToPChar(var S: string): PChar;
begin
{$IFDEF WIN32}
  Result := PChar(S);
{$ELSE}
  if Length(S) = High(S) then Dec(S[0]);
  S[Length(S) + 1] := #0;
  Result := @(S[1]);
{$ENDIF}
end;

function DropT(const S: string): string;
begin
  if (UpCase(S[1]) = 'T') and (Length(S) > 1) then
    Result := Copy(S, 2, MaxInt)
  else Result := S;
end;

{ Cursor routines }

{$IFDEF WIN32}
{$IFNDEF RX_D3}
const
  RT_ANICURSOR = MakeIntResource(21);
{$ENDIF}
function LoadAniCursor(Instance: THandle; ResID: PChar): HCursor;
{ Unfortunately I don't know how we can load animated cursor from
  executable resource directly. So I write this routine using temporary
  file and LoadCursorFromFile function. }
var
  S: TFileStream;
  Path, FileName: array[0..MAX_PATH] of Char;
  Rsrc: HRSRC;
  Res: THandle;
  Data: Pointer;
begin
  Result := 0;
  Rsrc := FindResource(Instance, ResID, RT_ANICURSOR);
  if Rsrc <> 0 then begin
    Win32Check(GetTempPath(MAX_PATH, Path) <> 0);
    Win32Check(GetTempFileName(Path, 'ANI', 0, FileName) <> 0);
    try
      Res := LoadResource(Instance, Rsrc);
      try
        Data := LockResource(Res);
        if Data <> nil then
        try
          S := TFileStream.Create(StrPas(FileName), fmCreate);
          try
            S.WriteBuffer(Data^, SizeOfResource(Instance, Rsrc));
          finally
            S.Free;
          end;
          Result := LoadCursorFromFile(FileName);
        finally
          UnlockResource(Res);
        end;
      finally
        FreeResource(Res);
      end;
    finally
      Windows.DeleteFile(FileName);
    end;
  end;
end;
{$ENDIF}

function DefineCursor(Instance: THandle; ResID: PChar): TCursor;
var
  Handle: HCursor;
begin
  Handle := LoadCursor(Instance, ResID);
{$IFDEF WIN32}
  if Handle = 0 then
    Handle := LoadAniCursor(Instance, ResID);
{$ENDIF}
  if Handle = 0 then ResourceNotFound(ResID);
  for Result := 100 to High(TCursor) do { Look for an unassigned cursor index }
    if (Screen.Cursors[Result] = Screen.Cursors[crDefault]) then begin
      Screen.Cursors[Result] := Handle;
      Exit;
    end;
  DestroyCursor(Handle);
  raise EOutOfResources.Create(ResStr(SOutOfResources));
end;

const
  WaitCount: Integer = 0;
  SaveCursor: TCursor = crDefault;

procedure StartWait;
begin
  if WaitCount = 0 then begin
    SaveCursor := Screen.Cursor;
    Screen.Cursor := WaitCursor;
  end;
  Inc(WaitCount);
end;

procedure StopWait;
begin
  if WaitCount > 0 then begin
    Dec(WaitCount);
    if WaitCount = 0 then Screen.Cursor := SaveCursor;
  end;
end;

{ Grid drawing }

const
  DrawBitmap: TBitmap = nil;

procedure UsesBitmap;
begin
  if DrawBitmap = nil then DrawBitmap := TBitmap.Create;
end;

procedure ReleaseBitmap; far;
begin
  if DrawBitmap <> nil then DrawBitmap.Free;
  DrawBitmap := nil;
end;

procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;
  const Text: string; Alignment: TAlignment; WordWrap: Boolean
  {$IFDEF RX_D4}; ARightToLeft: Boolean = False {$ENDIF});
const
  AlignFlags: array [TAlignment] of Integer =
    (DT_LEFT or DT_EXPANDTABS or DT_NOPREFIX,
     DT_RIGHT or DT_EXPANDTABS or DT_NOPREFIX,
     DT_CENTER or DT_EXPANDTABS or DT_NOPREFIX);
  WrapFlags: array[Boolean] of Integer = (0, DT_WORDBREAK);
{$IFDEF RX_D4}
  RTL: array [Boolean] of Integer = (0, DT_RTLREADING);
{$ENDIF}
var
{$IFNDEF WIN32}
  S: array[0..255] of Char;
{$ENDIF}
  B, R: TRect;
  I, Left: Integer;
begin
  UsesBitmap;
  I := ColorToRGB(ACanvas.Brush.Color);
  if not WordWrap and (Integer(GetNearestColor(ACanvas.Handle, I)) = I) and
    (Pos(#13, Text) = 0) then
  begin { Use ExtTextOut for solid colors }
{$IFDEF RX_D4}
    { In BiDi, because we changed the window origin, the text that does not
      change alignment, actually gets its alignment changed. }
    if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then
      ChangeBiDiModeAlignment(Alignment);
{$ENDIF}
    case Alignment of
      taLeftJustify: Left := ARect.Left + DX;
      taRightJustify: Left := ARect.Right - ACanvas.TextWidth(Text) - 3;
      else { taCenter }
        Left := ARect.Left + (ARect.Right - ARect.Left) shr 1
          - (ACanvas.TextWidth(Text) shr 1);
    end;
{$IFDEF RX_D4}
    ACanvas.TextRect(ARect, Left, ARect.Top + DY, Text);
{$ELSE}
  {$IFDEF WIN32}
    ExtTextOut(ACanvas.Handle, Left, ARect.Top + DY, ETO_OPAQUE or
      ETO_CLIPPED, @ARect, PChar(Text), Length(Text), nil);
  {$ELSE}
    ExtTextOut(ACanvas.Handle, Left, ARect.Top + DY, ETO_OPAQUE or
      ETO_CLIPPED, @ARect, StrPCopy(S, Text), Length(Text), nil);
  {$ENDIF}
{$ENDIF}
  end
  else begin { Use FillRect and DrawText for dithered colors }
{$IFDEF RX_D3}
    DrawBitmap.Canvas.Lock;
    try
{$ENDIF}
      with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
      begin                     { brush origin tics in painting / scrolling.    }
        Width := Max(Width, Right - Left);
        Height := Max(Height, Bottom - Top);
        R := Rect(DX, DY, Right - Left - {$IFDEF WIN32} 1 {$ELSE} 2 {$ENDIF},
          Bottom - Top - 1);
        B := Rect(0, 0, Right - Left, Bottom - Top);
      end;
      with DrawBitmap.Canvas do begin
        Font := ACanvas.Font;
        Font.Color := ACanvas.Font.Color;
        Brush := ACanvas.Brush;
        Brush