RTFormwork/项目代码/RTBasicsV1/F05染色检验/delphitwain/DelphiTwainUtils.pas

{GENERAL METHODS USED BY TWAIN DELPHI}
{december 2001®, made by Gustavo Daud}

{This unit contains general methods used by Delphi}
{Twain component. Some of the methods bellow aren't}
{directly related to Twain, but are pieces needed}
{to implement the component.}

unit DelphiTwainUtils;

{$INCLUDE DELPHITWAIN.INC}

interface

uses
  Twain;

type
  {Kinds of directories to be obtained with GetCustomDirectory}
  TDirectoryKind = (dkWindows, dkSystem, dkCurrent, dkApplication, dkTemp);

  {Class to store a list of pointers}
  TPointerList = class
  private
    {Stores pointer to the allocated data}
    Data: Pointer;
    {Contains number of additional items allocated every time}
    {it needs more data to store}
    fAdditionalBlock: Integer;
    {Contains the number of items in the list}
    fCount: Integer;
    {Contains number of allocated items}
    fAllocated: Integer;
    {Allocate/deallocate memory to have enough memory}
    {to hold the new number of items}
    procedure SetAllocated(const Value: Integer);
    {Sets the AdditionalBlock property}
    procedure SetAdditionalBlock(const Value: Integer);
    {Set the number of items in the list}
    procedure SetCount(const Value: Integer);
    function GetItem(Index: Integer): Pointer;
    procedure PutItem(Index: Integer; const Value: Pointer);
  public
    {Add a new item}
    procedure Add(Value: Pointer);
    {Clear all the items in the list}
    procedure Clear;
    {Object being created or destroyed}
    constructor Create;
    destructor Destroy; override;
    {Returns/sets an item value}
    property Item[Index: Integer]: Pointer read GetItem write PutItem; default;
    {Returns the number of items}
    property Count: Integer read fCount write SetCount;
    {Number of allocated items}
    property Allocated: Integer read fAllocated write SetAllocated;
    {Additional items to alloc when it needs more memory}
    property AdditionalBlock: Integer read fAdditionalBlock write
      SetAdditionalBlock;
  end;

{Returns custom Microsoft Windows® directories}
function GetCustomDirectory(const DirectoryKind: TDirectoryKind): String;
{Returns the last error string from Microsoft Windows®}
function GetLastErrorText(): String;
{Returns if the directory exists}
function DirectoryExists(const Directory: String): Boolean;
{Returns if the file exists}
function FileExists(const FilePath: String): Boolean;
{Extracts the file directory part}
function ExtractDirectory(const FilePath: String): String;
{Convert from integer to string}
{$IFDEF DONTUSEVCL}function IntToStr(Value: Integer): String;{$ENDIF}
{$IFDEF DONTUSEVCL}function StrToIntDef(Value: String;
  Default: Integer): Integer;{$ENDIF}
{$IFDEF DONTUSEVCL}function CompareMem(P1, P2: pChar;
  Size: Integer): Boolean;{$ENDIF}
{Convert from twain Fix32 to extended}
function Fix32ToFloat(Value: TW_FIX32): Extended;
{Convert from extended to Fix32}
function FloatToFix32 (floater: extended): TW_FIX32;

implementation

{Units used bellow}
uses
  Windows;

{$IFDEF DONTUSEVCL}
  function CompareMem(P1, P2: pChar; Size: Integer): Boolean;
  var
    i: Integer;
  begin
    {Default result}
    Result := TRUE;
    {Search each byte}
    FOR i := 1 TO Size DO
    begin
      {Compare booth bytes}
      if P1^ <> P2^ then
      begin
        Result := FALSE;
        Exit;
      end; {if P1^ <> P2^}
      {Move to next byte}
      Inc(P1); Inc(P2);
    end {FOR i}
  end {function};
{$ENDIF}

{$IFDEF DONTUSEVCL}
  function IntToStr(Value: Integer): String;
  begin
    Str(Value, Result);
  end;
{$ENDIF}

{$IFDEF DONTUSEVCL}
  function StrToIntDef(Value: String; Default: Integer): Integer;
  var Code: Integer;
  begin
    {Try converting from string to integer}
    Val(Value, Result, Code);
    {If any error ocurred, returns default value}
    if Code <> 0 then Result := Default;
  end;
{$ENDIF}


{Convert from extended to Fix32}
function FloatToFix32 (floater: extended): TW_FIX32;
var
  fracpart : extended;
begin
  //Obtain numerical part by truncating the float number
  Result.Whole := trunc(floater);
  //Obtain fracional part by subtracting float number by
  //numerical part. Also we make sure the number is not
  //negative by multipling by -1 if it is negative
  fracpart := floater - result.Whole;
  if fracpart < 0 then fracpart := fracpart * -1;
  //Multiply by 10 until there is no fracional part any longer
  while FracPart - trunc(FracPart) <> 0 do fracpart := fracpart * 10;
  //Return fracional part
  Result.Frac := trunc(fracpart);
end;

{Convert from twain Fix32 to extended}
function Fix32ToFloat(Value: TW_FIX32): Extended;
begin
  Result := Value.Whole + (Value.Frac / 65536.0);
end;

{Returns the last position for any of the characters in the parameter}
function LastPosition(const Text, characters: String): Integer;
var
  x, y: Integer;  {For loop variables}
begin
  Result := Length(Text);  {Initial result}

  {Search each character in the text}
  FOR x := 1 TO Length(Text) DO
  begin
    {Test for each character}
    FOR y := 1 TO Length(characters) DO
      if Text[x] = characters[y] then
        Result := x;
  end {for x}
end;

{Extracts the file directory}
function ExtractDirectory(const FilePath: String): String;
begin
  {Searches for the last \ or : characters}
  {ex: c:\windows\system32\yfile.ext or c:autoexec.bat}
  Result := Copy(FilePath, 1, LastPosition(FilePath, '\:'));
end;

{Returns if the file exists}
function FileExists(const FilePath: String): Boolean;
var
  FindData  : TWin32FindData;
  FindHandle: THandle;
begin
  {Searches for the file}
  FindHandle := FindFirstFile(PChar(FilePath), FindData);
  Result := (FindHandle <> INVALID_HANDLE_VALUE);
  {In case it found, closes the FindFirstFile handle}
  if Result then FindClose(FindHandle);
end;

{Returns if the directory exists}
function DirectoryExists(const Directory: String): Boolean;
var
  Attr: DWORD;
begin
  {Calls GetFileAttributes to verify}
  Attr := GetFileAttributes(PChar(Directory));
  Result := (Attr <> $FFFFFFFF) and (Attr and FILE_ATTRIBUTE_DIRECTORY <> 0);
end;

{Makes an language identifier using the two ids}
function MAKELANGID(p, s: WORD): DWORD;
begin
  Result := (s shl 10) or p;
end;

{Returns the last error string from Microsoft Windows®}}
function GetLastErrorText(): String;
var
  Buffer: Array[Byte] of Char;
  Len   : DWORD;
begin
  {Calls format message to translate from the error code ID to}
  {a text understandable error}
  Len := Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
    FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, GetLastError(),
    MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), Buffer, sizeof(Buffer), nil);
  {Remove this chars from the ending of the result}
  while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
  {Fills result}
  SetString(Result, Buffer, Len);
end;

{Includes a trailing backslash in the end of the directory; if necessary}
procedure IncludeTrailingBackslash(var Directory: String);
begin
  {If there isn't already a backslash, add one}
  if Directory[Length(Directory)] <> '\' then
    Directory := Directory + '\'
end;

{Returns custom Microsoft Windows® directories}
function GetCustomDirectory(const DirectoryKind: TDirectoryKind): String;
const
  {Default maximum size for directories}
  DEF_DIRLEN = MAX_PATH;

  {Calls appropriate method and returns necessary size}
  function CallDirectoryMethod(Buffer: Pointer; Size: UINT): UINT;
  begin
    {Test the directory needed by the parameter}
    case DirectoryKind of
      {Windows directory}
      dkWindows: Result := Windows.GetWindowsDirectory(Buffer, Size);
      {System directory}
      dkSystem : Result := Windows.GetSystemDirectory(Buffer, Size);
      {Current directory}
      dkCurrent: Result := Windows.GetCurrentDirectory(Size, Buffer);
      {Application directory}
      dkApplication: Result := Windows.GetModuleFileName(0, Buffer, Size);
      {Temp directory}
      dkTemp   : Result := Windows.GetTempPath(Size, Buffer);
      {Unknown directory}
      else Result := 0;
    end {case}
  end;

var
  DirectoryLen: UINT;
begin
  {Set length of the resulting buffer to MAX_PATH to try to hold}
  {windows directory}
  SetLength(Result, DEF_DIRLEN + 1);
  {Tries to obtain the windows directory and stores the size}
  DirectoryLen := CallDirectoryMethod(@Result[1], DEF_DIRLEN);

  {In case it was not enough to hold windows directory, enlarge}
  if DirectoryLen > DEF_DIRLEN then
  begin
    {Try again, now with the right size}
    SetLength(Result, DirectoryLen + 1);
    CallDirectoryMethod(@Result[1], DirectoryLen);
  end
  else {Otherwise, adjust the result to excluded unused data}
    SetLength(Result, DirectoryLen);

  {In case the user searched for the application directory}
  {extracts just the directory part}
  if DirectoryKind = dkApplication then
    Result := ExtractDirectory(Result);
  {Add a trailing backslash to end of the directory name}
  IncludeTrailingBackslash(Result);
end;

{ TPointerList object implementation }

{Add a new item}
procedure TPointerList.Add(Value: Pointer);
begin
  {Increase number of items and update new item}
  Count := Count + 1;
  Item[Count - 1] := Value;
end;

{Clear all the items in the list}
procedure TPointerList.Clear;
begin
  {Set number of items to 0 and initialize again allocated items}
  Count := 0;
  Allocated := AdditionalBlock;
end;

{TPointerList being created}
constructor TPointerList.Create;
begin
  {Let ancestor receive the call}
  inherited Create;

  {Allocate a number of items}
  fAdditionalBlock := 10;
  fAllocated := fAdditionalBlock;
  GetMem(Data, (fAllocated * sizeof(Pointer)));
end;

{TPointerList being destroyed}
destructor TPointerList.Destroy;
begin
  {Deallocate data}
  FreeMem(Data, (fAllocated * sizeof(Pointer)));

  {Let ancestor receive and finish}
  inherited Destroy;
end;

{Returns an item from the list}
function TPointerList.GetItem(Index: Integer): Pointer;
begin
  {Check item bounds and return item}
  if Index in [0..Count - 1] then
    Longint(Result) := pLongint(Longint(Data) + (Index * sizeof(Pointer)))^
  else Result := nil; {Otherwise returns nil}
end;

{Sets an item from the list}
procedure TPointerList.PutItem(Index: Integer; const Value: Pointer);
begin
  {Check item bounds and sets item}
  if Index in [0..Count - 1] then
    pLongint(Longint(Data) + (Index * sizeof(Pointer)))^ := Longint(Value);
end;

{Sets the AdditionalBlock property}
procedure TPointerList.SetAdditionalBlock(const Value: Integer);
begin
  {Value must be a positive number greater than 0}
  if (Value > 0) then
    fAdditionalBlock := Value;
end;

{Allocate/deallocate memory to have enough memory to hold}
{the new number of items}
procedure TPointerList.SetAllocated(const Value: Integer);
begin
  {Must be always greater than 0 the number of allocated items}
  {And it also should not be smaller than count}
  if (Value > 0) and (Value <= Count) then
  begin
    {Just realloc memory and update property variable}
    ReallocMem(Data, (Value * sizeof(Pointer)));
    fAllocated := Value;
  end {if (Value <> 0)}
end;

{Set the number of items in the list}
procedure TPointerList.SetCount(const Value: Integer);
begin
  {Value must be 0 or greater}
  if (Value >= 0) then
  begin
    {If there is no more memory to hold data, allocate some more}
    while (Value > fAllocated) do
      Allocated := Allocated + fAdditionalBlock;
    {Update property}
    fCount := Value;
  end {if (Value >= 0)}
end;

end.