jvvclutils.pas

East make Tray Icon in delphi

@@1:    POP     DS
{$ENDIF}
end;

{$IFNDEF COMPILER5_UP}
procedure FreeAndNil(var Obj);
var
  P: TObject;
begin
  P := TObject(Obj);
  TObject(Obj) := nil;
  P.Free;
end;
{$ENDIF}

{ Manipulate huge pointers routines by Ray Lischner, The Waite Group, Inc. }

{$IFDEF WIN32}

procedure HugeInc(var HugePtr: Pointer; Amount: Longint);
begin
  HugePtr := PChar(HugePtr) + Amount;
end;

procedure HugeDec(var HugePtr: Pointer; Amount: Longint);
begin
  HugePtr := PChar(HugePtr) - Amount;
end;

function HugeOffset(HugePtr: Pointer; Amount: Longint): Pointer;
begin
  Result := PChar(HugePtr) + Amount;
end;

procedure HMemCpy(DstPtr, SrcPtr: Pointer; Amount: Longint);
begin
  Move(SrcPtr^, DstPtr^, Amount);
end;

procedure HugeMove(Base: Pointer; Dst, Src, Size: Longint);
var
  SrcPtr, DstPtr: PChar;
begin
  SrcPtr := PChar(Base) + Src * SizeOf(Pointer);
  DstPtr := PChar(Base) + Dst * SizeOf(Pointer);
  Move(SrcPtr^, DstPtr^, Size * SizeOf(Pointer));
end;

{$ELSE}

procedure __AHSHIFT; far; external 'KERNEL' index 113;

{ Increment a huge pointer }

procedure HugeInc(var HugePtr: Pointer; Amount: Longint); assembler;
asm
        MOV     AX,Amount.Word[0]
        MOV     DX,Amount.Word[2]
        LES     BX,HugePtr
        ADD     AX,ES:[BX]
        ADC     DX,0
        MOV     CX,Offset __AHSHIFT
        SHL     DX,CL
        ADD     ES:[BX+2],DX
        MOV     ES:[BX],AX
end;

{ Decrement a huge pointer }

procedure HugeDec(var HugePtr: Pointer; Amount: Longint); assembler;
asm
        LES     BX,HugePtr
        MOV     AX,ES:[BX]
        SUB     AX,Amount.Word[0]
        MOV     DX,Amount.Word[2]
        ADC     DX,0
        MOV     CX,OFFSET __AHSHIFT
        SHL     DX,CL
        SUB     ES:[BX+2],DX
        MOV     ES:[BX],AX
end;

{ ADD an offset to a huge pointer and return the result }

function HugeOffset(HugePtr: Pointer; Amount: Longint): Pointer; assembler;
asm
        MOV     AX,Amount.Word[0]
        MOV     DX,Amount.Word[2]
        ADD     AX,HugePtr.Word[0]
        ADC     DX,0
        MOV     CX,OFFSET __AHSHIFT
        SHL     DX,CL
        ADD     DX,HugePtr.Word[2]
end;

{ 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;

// (rom) Ouch. so old DelForExp failed to format the indents

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 }

{ 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}
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. }
{$IFNDEF COMPILER3_UP}
const
  RT_ANICURSOR = MakeIntResource(21);
{$ENDIF}
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
    OSCheck(GetTempPath(MAX_PATH, Path) <> 0);
    OSCheck(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;

// (rom) changed to var
var
  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;