expertcad/SRC/Protection/U_ProtectionCommon.pas

unit U_ProtectionCommon;
interface
uses
  Windows, Forms, Graphics, Registry, Classes, SysUtils, Messages,{ bz2,} Dialogs,
  ComCtrls, ShlObj, ShellAPI, Controls, IcsPlus, Printers,
  AbBzip2, AbZBrows, AbUnZper, AbArcTyp, AbMeter, AbBrowse, AbBase;
type
  // Ïåðèîä ëèöåíçèè
  TPeriod = (pWeek, pMonth, pQuarter);

  TFieldInfo = class
  public
    id: integer;
    isblob: byte;
    name: string[31];
  end;

  TLang = (lRus, lUkr);

const

//  DateTrial = '30.03.06';

  //DateEXE = '09.12.22';
  //DateEXEPE = 'December, 09, 2022';
  //BuildEXE = '381';
  {
  DateEXE = '27.03.24';
  DateEXEPE = 'March, 27, 2024';

  BuildEXE = '384';
  }
  DateEXE = '10.01.25';
  DateEXEPE = 'January, 10, 2025';

  BuildEXE = '385';

  DownLoadPath = 'c:\temp\';

  {$if Defined(ES_GRAPH_SC)}
    {$if Defined(ES_GRAPH_SC_EXE)}
      RegPath = '\SOFTWARE\Ýêñïåðò-Ñîôò\Ñòðîèòåëüíûé êàëüêóëÿòîð ÃÌ 2.2.0';
    {$else}
      RegPath = '\SOFTWARE\Ýêñïåðò-Ñîôò\Ñòðîèòåëüíûé êàëüêóëÿòîð Ã_Ì 2.2.0';
    {$ifend}
  {$else}
    {$IF Defined(SCS_SPA)}
      RegPath = '\SOFTWARE\TelcoCAD 2.2.0';
    {$ELSE}
      {$IF Defined(TELECOM)}
        RegPath = '\SOFTWARE\Ýêñïåðò-Ñîôò\Ýêñïåðò-Òåëåêîì 2.2.0';
      {$ELSE}
        {$IF Defined(SCS_PE) or Defined(SCS_PANDUIT)}
          {$IF Defined(SCS_PANDUIT)}
            RegPath = '\SOFTWARE\Expert-Soft\Panduit Network CAD 2.2.0';
          {$ELSE}
            RegPath = '\SOFTWARE\Expert-Soft\CableProject CAD 2.2.0';
          {$IFEND}
        {$ELSE}
          RegPath = '\SOFTWARE\Ýêñïåðò-Ñîôò\Ýêñïåðò-ÑÊÑ 2.2.0';
        {$IFEND}
      {$IFEND}
    {$IFEND}
  {$ifend}

  {$IF Defined(SCS_SPA)}
    Url = 'http://www.telcocad.net/';
    eMail = 'office@telcocad.net';
    ServPort = 165;
  {$ELSE}
    Url = 'http://www.expertsoft.com.ua/scs/';
    eMail = 'office@expertsoft.com.ua';
    ServPort = 105;
  {$IFEND}

  {$IF Defined(SCS_PE) or Defined(SCS_PANDUIT)}
    {$IF Defined(SCS_PANDUIT)}
      CapAdd = 'Panduit Network CAD';
    {$ELSE}
      CapAdd = 'CableProject CAD';
    {$IFEND}
  {$ELSEIF Defined(SCS_SPA)}
    CapAdd = 'TELCOCAD';
  {$ELSE}
    {$if Defined(ES_GRAPH_SC)}
      CapAdd = 'Ãðàôè÷åñêèé ìîäóëü';
    {$else}
      CapAdd = 'ExpertCAD';
    {$ifend}
  {$IFEND}

  FirstRunKey = 'FirstRun0205';

  HelpName = 'help\help.htm';
  HelpFileName = 'help\help.htm';
  UpdateDir = '\Update';

  RegCode = '4512423443';

  RegRootKey = HKEY_CURRENT_USER;

  RegKey = 'Registration';
  PathKey = 'Path';
  PasswdKey = 'Passwd';

  LicServerKey = 'LicenseServer';

  ContentStateKey = 'ContentState';
  ShowRegistrationKey = 'Registration';
  {$if Defined(ES_GRAPH_SC)}
    OurTempDir = '\SC_Graph';
  {$else}
    {$IF Defined(SCS_SPA)}
      OurTempDir = '\TelcoCAD';
    {$ELSE}
      OurTempDir = '\ExpertCAD';
    {$IFEND}
  {$ifend}


///////////////////////////////////////////////////////////////
var
  cd: TCopyDataStruct;
  GNowOpen: boolean;

  OpenFileAtStart: string;

  ISFirstRun: Boolean;
  GLicenceServer: string;
  GWasDisconnect: boolean;
  GConnectClose: boolean;
  ConnectExcept: Boolean;
  ConnectPres: Boolean;
  ConnectRecvBasePath: Boolean;
  ConnectRecvProgCode: boolean;
  ConnectRecvUserCode: boolean;
  GLicProgCode: string;
  GLicUserCode: string;
  RecvBasePath: string;
  GCurrTickCount: Cardinal;
  GPrevTickCount: Cardinal;
  GHintCount: integer;

  DateID: string;

  GTerminateOnExit: Boolean;
  IDESerialG: string;
  GSHI: TShellExecuteInfo;

  ProgramRegisterPro: boolean;
  ProgramRegisterTrial: boolean;

  USER_ID: integer;
  FirstRun: boolean;

  Lang: TLang; // Òåêóùèé ÿçûê 1 - rus, 2 - ukr
  TempDir: string;
  ExeDir: string;

  function GetEXEDir: String;

  function GetTempDir: string;

  procedure CheckFirstRun;
  procedure GetDateTrial;

  function GetWinDir: string;

  function CheckPakedStream(InStream: TStream; SetPos: Boolean = True): Boolean;

  function CheckPakedFile(const aFileName: string): Boolean;

  //procedure PakStream(InStream: TStream; OutStream: TStream; aCompLevel: TCompressionLevel = clMiddle);
  procedure PakStream(InStream: TStream; OutStream: TStream);

  //procedure PakFile(aFileName: string; aCompLevel: TCompressionLevel = clMiddle);
  procedure PakFile(aFileName: string);

  procedure UnPakStream(InStream: TStream; OutStream: TStream; SetPos: Boolean = True);

  procedure UnPakFile(aFileName: string);

  procedure FieldsInfoToStream(FieldsInfo: TStringList; Stream: TStream);

  procedure FieldsInfoFromStream(FieldsInfo: TStringList; Stream: TStream);

  function CRCCheck(FileName: string): boolean;

  function CRCPakFile(Src: String; Dest: String): Boolean;

  function CRCUnPakFile(Src: String; Dest: String): Boolean;

  function CorrectPath(Path: string): string;

  procedure EraseFile(FileName: string);

  procedure SetupPrinter(aH, aW, aOrient: integer);

  procedure SaveAutoShowPanel(AutoShow: boolean = False);

  function isAutoShowPanel: boolean;

  procedure SaveBoolToRegistry(AParamName: String; AValue: Boolean);
  procedure SaveIntToRegistry(AParamName: String; AValue: Integer);
  procedure SaveStrToRegistry(AParamName, AValue: String);
  function GetBoolFromRegistry(AParamName: String; ADefValue: Boolean = true): Boolean;
  function GetIntFromRegistry(AParamName: String; ADefValue: Integer = 0): Integer;
  function GetStrFromRegistry(AParamName: String; ADefValue: String = ''): string;


implementation

function GetEXEDir: String;
begin
  Result := ExeDir;
end;

procedure SetupPrinter2;
var
  Device : array[0..cchDeviceName-1] of Char;
  Driver : array[0..(MAX_PATH-1)] of Char;
  Port : array[0..32] of Char;
  hDMode : THandle;
  pDMode : PDevMode;
  sDev : array[0..32] of Char;
begin
  Printer.GetPrinter(Device,Driver,Port,hDMode);
  if hDMode <> 0 then
  begin
    pDMode :=GlobalLock(hDMode);
    if pDMode <> nil then
    begin
      pdMode^.dmOrientation := 0;
      // landscape
      pdMode^.dmPaperSize := DMPAPER_A3;
//      pdMode^.dmPaperLength
      // (ñì. win32.hlp DEVMODE)
      GlobalUnlock(hDMode);
    end;
  end;
end;


procedure SetupPrinter(aH, aW, aOrient: integer);
var
  Device: array[0..255] of char;
  Driver: array[0..255] of char;
  Port: array[0..255] of char;
  hDMode: THandle;
  PDMode: PDEVMODE;
begin
  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.GetPrinter(Device, Driver, Port, hDMode);
  if hDMode <> 0 then begin
    pDMode := GlobalLock(hDMode);
    if pDMode <> nil then begin

     {Set to legal}
//      pDMode^.dmFields := pDMode^.dmFields or dm_PaperSize;
//      pDMode^.dmPaperSize := DMPAPER_LEGAL;

     {Set to custom size}
      if aOrient = 1 then
        aOrient := 2
      else
        aOrient := 1;
      pdMode^.dmOrientation := aOrient;
      pDMode^.dmFields := pDMode^.dmFields or
        DM_PAPERSIZE or
        DM_PAPERWIDTH or
        DM_PAPERLENGTH;
      pDMode^.dmPaperSize := DMPAPER_USER;
//      if aOrient = 2 then
//      begin
//        pDMode^.dmPaperWidth := (aH + 1) * 10 {SomeValueInTenthsOfAMillimeter};
//        pDMode^.dmPaperLength := (aW + 1) * 10 {SomeValueInTenthsOfAMillimeter};
//      end
//      else
//      begin
//        pDMode^.dmPaperWidth := aW * 10 {SomeValueInTenthsOfAMillimeter};
//        pDMode^.dmPaperLength := aH * 10 {SomeValueInTenthsOfAMillimeter};
//      end;
     {Set the bin to use}
//      pDMode^.dmFields := pDMode^.dmFields or DMBIN_MANUAL;
//      pDMode^.dmDefaultSource := DMBIN_MANUAL;

      GlobalUnlock(hDMode);
    end;
  end;
  Printer.PrinterIndex := Printer.PrinterIndex;
end;

procedure FieldsInfoToStream(FieldsInfo: TStringList; Stream: TStream);
var
  i: integer;
  buffint: integer;
  // Tolik 21/06/2019 --
  //buffstr: string;
  buffstr: AnsiString;
  //
  buffbyte: byte;

begin
  if FieldsInfo.Count = 0 then
    exit;

  for i := 0 to FieldsInfo.Count - 1 do
  begin
    buffint := i;
    Stream.Write(buffint, sizeof(buffint));
    buffbyte := TFieldInfo(FieldsInfo.Objects[i]).isblob;
    Stream.Write(buffbyte, sizeof(buffbyte));
    buffstr := FieldsInfo.Strings[i];
    Stream.Write(buffstr[1], 31);
  end;
end;

procedure FieldsInfoFromStream(FieldsInfo: TStringList; Stream: TStream);
var
  i: integer;
  buffint: integer;
  // Tolik 21/06/2019 --
  //buffstr: string;
  buffstr: AnsiString;
  //
  buffbyte: byte;
  obj: TFieldInfo;

begin
  if (Stream.Size = Stream.Position) or (Stream.Size = 0) then
    exit;

  SetLength(buffstr, 32);
  while Stream.Size > Stream.Position do
  begin
    Stream.Read(buffint, sizeof(buffint));
    Stream.Read(buffbyte, sizeof(buffbyte));
    Stream.Read(buffstr[1], 31);
    obj := TFieldInfo.Create;
    with obj do
    begin
      id := buffint;
      isblob := buffbyte;
      name := buffstr;
    end;
    FieldsInfo.AddObject(buffstr, TObject(obj));
  end;
end;

function isAutoShowPanel: boolean;
var
  Reg: TRegistry;
  resreg: integer;
begin
  {$IF Defined(SCS_PE)}
    result := false;
    exit;
  {$IFEND}
  result := true;
  Reg := TRegistry.Create;
  try
    Reg.RootKey := RegRootKey;
    if Reg.OpenKey(RegPath, false) then
    begin
      try
        resreg := Reg.ReadInteger('ShowPanel');
      except
        resreg := 1;
      end;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
  if resreg = 1 then
    result := True
  else
    result := False;
end;

procedure SaveAutoShowPanel(AutoShow: boolean = False);
var
  Reg: TRegistry;
  resreg: integer;
begin
  if AutoShow then
    resreg := 1
  else
    resreg := 0;  
  Reg := TRegistry.Create;
  try
    Reg.RootKey := RegRootKey;
    if Reg.OpenKey(RegPath, true) then
    begin
      try
        Reg.WriteInteger('ShowPanel', resreg);
      except
      end;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

procedure SaveBoolToRegistry(AParamName: String; AValue: Boolean);
var
  resreg: integer;
begin
  if AValue then
    resreg := 1
  else
    resreg := 0;
  SaveIntToRegistry(AParamName, resreg);
end;

procedure SaveIntToRegistry(AParamName: String; AValue: Integer);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := RegRootKey;
    if Reg.OpenKey(RegPath, true) then
    begin
      try
        Reg.WriteInteger(AParamName, AValue);
      except
      end;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

procedure SaveStrToRegistry(AParamName, AValue: String);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := RegRootKey;
    if Reg.OpenKey(RegPath, true) then
    begin
      try
        Reg.WriteString(AParamName, AValue);
      except
      end;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

function GetBoolFromRegistry(AParamName: String; ADefValue: Boolean = true): Boolean;
var
  Reg: TRegistry;
  DefValue: Integer;
  resreg: integer;
begin
  result := ADefValue;

  DefValue := 1;
  if ADefValue then
    DefValue := 1
  else
    DefValue := 0;

  resreg := GetIntFromRegistry(AParamName, DefValue);

  if resreg = 1 then
    result := True
  else
    result := False;
end;

function GetIntFromRegistry(AParamName: String; ADefValue: Integer = 0): Integer;
var
  Reg: TRegistry;
begin
  result := ADefValue;
  Reg := TRegistry.Create;
  try
    Reg.RootKey := RegRootKey;
    if Reg.OpenKey(RegPath, false) then
    begin
      try
        Result := Reg.ReadInteger(AParamName);
      except
        Result := ADefValue;
      end;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

function GetStrFromRegistry(AParamName: String; ADefValue: String = ''): string;
var
  Reg: TRegistry;
begin
  result := ADefValue;
  Reg := TRegistry.Create;
  try
    Reg.RootKey := RegRootKey;
    if Reg.OpenKey(RegPath, false) then
    begin
      try
        if Reg.ValueExists(AParamName) then
          Result := Reg.ReadString(AParamName);
      except
        Result := ADefValue;
      end;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

procedure GetDateTrial;
var
  DateTr: TDate;
  DateCurr: TDate;
  Reg: TRegistry;
begin
  {$if Defined(ADMIN_RU) or Defined(FINAL_CD_RU) or Defined(FINAL_PRO_RU)}
    DateTrial := DateTrialR;
    DateTr := Now;
    DateCurr := Now;
    Reg := TRegistry.Create;
    try
      Reg.RootKey := RegRootKey;
      if Reg.OpenKey(RegPath, false) then
      begin
        try
          DateTr := Reg.ReadInteger('DiskUse');
        except
          DateTr := Now;
        end;
      end;
    finally
      Reg.CloseKey;
      Reg.Free;
    end;

    if DateTr - strtodate(DateTrial) > 300 then
      DateTrial := datetostr(strtodate(DateTrialR) + 300)
    else
      DateTrial := Datetostr(DateTr);
    DateTr := strtodate(DateTrial);

    Reg := TRegistry.Create;
    try
      Reg.RootKey := RegRootKey;
      if Reg.OpenKey(RegPath, false) then
      begin
        try
          Reg.WriteInteger('DiskUse', round(DateTr));
        except
          DateTr := Now;
        end;
      end;
    finally
      Reg.CloseKey;
      Reg.Free;
    end;
  {$ifend}
end;

procedure CheckFirstRun;
var
  Reg: TRegistry;
  KodInt: integer;
  FirstRunF: boolean;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := RegRootKey;
    if Reg.OpenKey(RegPath, false) then
    begin
      try
        FirstRunF := Reg.ReadBool(FirstRunKey);
        KodInt := 1;
      except
        KodInt := 0;
      end;
      if KodInt = 0 then
      begin
        try
          Reg.DeleteValue('MemUse');
        except
        end;
      end;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

procedure RegisterFileType(ext, FileNameFull: string);
var
  reg: TRegistry;
  FileName: string;
begin
  reg:=TRegistry.Create;
  try
    try
      FileName := copy(FileNameFull, 1, pos('%', FileNameFull) - 3);
    except
      FileName := FileNameFull;
    end;
    try
      with reg do
      begin
        RootKey:=HKEY_CLASSES_ROOT;
        OpenKey('.' + ext, True);
        WriteString('', ext + 'file');
        CloseKey;
        CreateKey(ext + 'file');
        OpenKey(ext + 'file\DefaultIcon', True);
        WriteString('', FileName + ',0');
        CloseKey;
        OpenKey(ext + 'file\shell\open\command', True);
        WriteString('',FileNameFull);
      end;
    except
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

function getHexColor(dColor: integer): String;
var
  temp: string;
begin
  temp := IntToHex(dColor, 6);
  result := copy(temp, 5, $ffff) + copy(temp, 3, 2) + copy(temp, 1, 2);
end;

function getDecColor(hColor: string): integer;
var
  temp: string;
begin
  temp := copy(hColor, 5, $ffff) + copy(hColor, 3, 2) + copy(hColor, 1, 2);
  result := StrToInt('$' + temp);
end;

// ôóíêöèÿ âîçâðàùàåò ïóòü íà ïàïêó Windows
// Tolik 21/06/2019 --
function GetWinDir: string;
var
  s: PChar;
  a: string;
begin
  GetMem(s, 256*2);
  GetWindowsDirectory(s, 255);
  a := s;
  freemem(s);
  result := a;
end;
{
function GetWinDir: string;
var
  s: PChar;
  a: string;
begin
  Max_Path
  GetMem(s, 255);
  GetWindowsDirectory(s, 255);
  a := s;
  result := a;
end;
}
//

function GetTempDir: string;
var
  buff: pchar;
  s: string;
begin
  if length(TempDir) > 0 then
  begin
    if DirectoryExists(TempDir) then
      Result := TempDir
    else
    begin
      TempDir := '';
      Result := GetTempDir;
    end;
  end
  else
  begin
    // Tolik 24/06/* 2019 --
    s := GetEnvironmentVariable('tmp');

    if ((s = '') or (not DirectoryExists(s))) then
      s := GetEnvironmentVariable('temp');

    if ((s = '') or (not DirectoryExists(s))) then
      s := exedir;

    (*
    // Tolik 21/06/2019 --
    getmem(buff, 256*2);
    //
    s := '';
    if (GetEnvironmentVariable('tmp',buff, 254) >0)
      and (DirectoryExists(buff)) then
    begin
      s := buff;
    end
    else
    if (GetEnvironmentVariable('temp',buff, 254) >0)
      and (DirectoryExists(buff)) then
    begin
      s := buff;
    end
    else
      s := exedir;
    freemem(buff);
    *)
    try
      if not DirectoryExists(s + OurTempDir) then
        MkDir(s + OurTempDir);
      TempDir := s + OurTempDir;
      result := TempDir;
    except
      ShowMessage('Îøèáêà âðåìåííîé äèðåêòîðèè!');
      {$if Defined(ES_GRAPH_SC)}
        Application.Terminate;
      {$else}
        ExitProcess(1);
      {$ifend}
    end;
  end;
end;

function GetTmpFileName: string;
var
  s: string;
  tempdir: string;
begin
  SetLength(s, MAX_PATH);
  tempdir := GetTempDir;
  GetTempFileName(PChar(tempdir), 'EL', 0, PChar(s));
  Result := Trim(StrPas(PChar(s)));
end;

function PathRemoveSeparator(const Path: string): string;
var
  L: Integer;

const
  PathSeparator    = '\';

begin
  L := Length(Path);
  //Tolik 21/06/2019 --
  //if (L <> 0) and (AnsiLastChar(Path) = PathSeparator) then
  if (L <> 0) and ((Path[L]) = PathSeparator) then
  //
    Result := Copy(Path, 1, L - 1)
  else
    Result := Path;
end;

function BuildFileList(const Path: string; const Attr: Integer; const List: TStrings): Boolean;
var
  SearchRec: TSearchRec;
  R: Integer;
begin
  Assert(List <> nil);
  R := FindFirst(Path, Attr, SearchRec);
  Result := R = 0;
  try
    if Result then
    begin
      while R = 0 do
      begin
        if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
          List.Add(SearchRec.Name);
        R := FindNext(SearchRec);
      end;
      Result := R = ERROR_NO_MORE_FILES;
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;

//procedure PakFile(aFileName: string; aCompLevel: TCompressionLevel = clMiddle);
procedure PakFile(aFileName: string);
var
  UStream: TMemoryStream;
  PStream: TMemoryStream;
begin
  try
    UStream := TMemoryStream.Create;
    PStream := TMemoryStream.Create;
    UStream.LoadFromFile(aFileName);
    UStream.Position := 0;
    //PakStream(UStream, PStream, aCompLevel);
    PakStream(UStream, PStream);
    PStream.Position := 0;
    DeleteFile(aFileName);
    PStream.SaveToFile(aFileName);
  finally
    UStream.Free;
    PStream.Free;
  end;
end;

procedure UnPakFile(aFileName: string);
var
  UStream: TMemoryStream;
  PStream: TMemoryStream;
begin
  try
    UStream := TMemoryStream.Create;
    PStream := TMemoryStream.Create;
    PStream.LoadFromFile(aFileName);
    PStream.Position := 0;
    UnPakStream(PStream, UStream);
    UStream.Position := 0;
    DeleteFile(aFileName);
    UStream.SaveToFile(aFileName);
  except
    on E: Exception do ShowMessage('UnPakFile - ' + E.Message);
  end;
  UStream.Free;
  PStream.Free;
end;

function CheckPakedStream(InStream: TStream; SetPos: Boolean = True): Boolean;
var
  SavedPos: Integer;
  Count: Integer;
begin
  Result := false;

  SavedPos := InStream.Position;
  try
    if SetPos then
      InStream.Position := 0;
    InStream.Read(Count, 4);
    if (Count = -2) then
      Result := true;
  finally
    InStream.Position := SavedPos;
  end;
end;

function CheckPakedFile(const aFileName: string): Boolean;
var
  FileStream: TFileStream;
begin
  Result := false;
  FileStream := TFileStream.Create(aFileName, fmOpenRead);
  try
    Result := CheckPakedStream(FileStream);
  finally
    FreeAndNil(FileStream);
  end;
end;

//procedure PakStream(InStream: TStream; OutStream: TStream; aCompLevel: TCompressionLevel = clMiddle);
{procedure PakStream(InStream: TStream; OutStream: TStream);
var
  TempStream: TStream;
  ZStream: TCompressStream;
  i: integer;
begin
  TempStream := TMemoryStream.Create;

  InStream.Position := 0;
  ZStream := TCompressStream.Create(aCompLevel, TempStream, InStream.Size, nil);
  ZStream.CopyFrom(InStream, InStream.Size);
  ZStream.Free;
  if InStream.Size <= TempStream.Size then
  begin
    TempStream.Free;
    InStream.Position := 0;
    OutStream.CopyFrom(InStream, InStream.Size);
  end
  else
  begin
    i := -2;
    OutStream.Write(i, 4);
    TempStream.Position := 0;
    OutStream.CopyFrom(TempStream, TempStream.Size);
    TempStream.Free;
  end;
  OutStream.Position := 0;
end;
}

procedure PakStream(InStream: TStream; OutStream: TStream);
var
  TempStream: TStream;
  //ZStream: TCompressStream;
  zStream: TBZCompressionStream;
  i: integer;
begin
  TempStream := TMemoryStream.Create;

  InStream.Position := 0;

  //ZStream := TCompressStream.Create(aCompLevel, TempStream, InStream.Size, nil);
  zStream := TBZCompressionStream.Create(bs1, TempStream);
  ZStream.CopyFrom(InStream, InStream.Size);
  ZStream.Free;
  if InStream.Size <= TempStream.Size then
  begin
    TempStream.Free;
    InStream.Position := 0;
    OutStream.CopyFrom(InStream, InStream.Size);
  end
  else
  begin
    i := -2;
    OutStream.Write(i, 4);
    TempStream.Position := 0;
    OutStream.CopyFrom(TempStream, TempStream.Size);
    TempStream.Free;
  end;
  OutStream.Position := 0;
end;

procedure UnPakStream(InStream: TStream; OutStream: TStream; SetPos: Boolean = True);
var
  //ZStream: TDecompressStream;
  ZStream: TBZDecompressionStream;
  BufferSize, Count: integer;
  Buffer: PByte;
begin
  if SetPos then
    InStream.Position := 0;
  InStream.Read(Count, 4);
  if (Count = -2) then
  begin
    if InStream.Size > 140000 then
    begin
      BufferSize := 1165536;
      if InStream.Size > 600000 then
        BufferSize := 20000000;
      if InStream.Size > 1500000 then
        BufferSize := 45000000;
    end
    else
      BufferSize := 65536;
    Buffer := AllocMem(BufferSize);


    //ZStream := TDeCompressStream.Create(muNormal, InStream, InStream.Size, nil);
    ZStream := TBZDecompressionStream.Create(InStream);

    repeat
      Count := ZStream.Read(Buffer^, BufferSize);
      Application.ProcessMessages;
      if Count <> 0 then
      begin
        OutStream.Write(Buffer^, Count);
      end
      else
        break;
    until False;
    ZStream.Free;
    FreeMem(Buffer);
  end
  else
  begin
    InStream.Position := 0;
    OutStream.CopyFrom(InStream, InStream.Size);
  end;
  OutStream.Position := 0;
end;

// ôóíêöèÿ âîçâðàùàåò èñòèíó, åñëè â ñòðèíãå åñòü öèôðû
function isNumeric(temp: String): boolean;
begin
    if temp[1] in ['1', '2', '3', '4', '5', '6', '7', '8', '9', '0',
     'I', 'V', 'X', '-', 'À', 'Á', 'Â', 'Ã', 'Ä'] then
      Result := True
    else Result := False;
end;

function CRCCheck(FileName: string): boolean;
var
  NewCRC, OldCRC: LongWord;
  InStream, TempStream: TStream;
  // Tolik 21/06/2019
  //s: string;
  s: AnsiString;
  //
begin
  Result := False;
  try
    InStream := TFileStream.Create(FileName, fmOpenRead);
    InStream.Position := 0;
    SetLength(s, 3);
    InStream.Read(s[1],3);
    s := Trim(s);
    if s  = 'CRC' then
    begin
      InStream.Read(OldCRC,SizeOf(OldCRC));
      TempStream := TMemoryStream.Create;
      TempStream.CopyFrom(InStream, InStream.Size - InStream.Position);
      TempStream.Position := 0;
      Crc32Initialization;
      NewCrc:=Crc32Stream(TempStream,0);
      Result := NewCrc = OldCRC;
    end;
    InStream.Free;
    TempStream.Free;
  except

  end;
end;

function CRCPakFile(Src: String; Dest: String): Boolean;
var
  InStream, OutStream, TempStream: TStream;
  Crc: LongWord;
begin
  Result := False;
  if FileExists(Src) then
  begin
    try
      TempStream := TFileStream.Create(Src, fmOpenRead);
      TempStream.Position := 0;

      InStream := TMemoryStream.Create;

      PakStream(TempStream, InStream);
      TempStream.Free;


      InStream.Position := 0;

      OutStream := TFileStream.Create(Dest, fmCreate{ and fmOpenWrite});

      Crc32Initialization;
      Crc:=Crc32Stream(InStream,0);

      OutStream.Write('CRC', 3);
      OutStream.Write(Crc, SizeOf(Crc));
      InStream.Position := 0;
      OutStream.CopyFrom(InStream, InStream.Size);
      InStream.Free;
      OutStream.Free;
      Result := True;
    except

    end;
  end;
end;

function CRCUnPakFile(Src: String; Dest: String): Boolean;
var
  InStream, OutStream, TempStream: TStream;
  Crc: LongWord;
begin
  Result := False;
  if FileExists(Src){and CRCCheck(Src)} then
  begin
    try
      TempStream := TFileStream.Create(Src, fmOpenRead);
      TempStream.Position := 3 + SizeOf(CRC);
      InStream := TMemoryStream.Create;
      InStream.CopyFrom(TempStream, TempStream.Size - TempStream.Position);
      InStream.Position := 0;

      TempStream.Free;
      TempStream := TMemoryStream.Create;

      UnPakStream(InStream, TempStream);
      InStream.Free;

      TempStream.Position := 0;

      OutStream := TFileStream.Create(Dest, fmCreate{ and fmOpenWrite});

      OutStream.CopyFrom(TempStream, TempStream.Size);
      TempStream.Free;
      OutStream.Free;
      Result := True;
    except

    end;
  end;
end;

function CorrectPath(Path: string): string;
begin
  if Length(Path) = 0 then
    Result := '';

  if PAth[Length(Path)] = '\' then
    Result := Path
  else
    Result := Path + '\';
end;

procedure EraseFile(FileName: string);
begin
  if FileExists(FileName) then
  begin
    FileSetAttr(FileName, 0);
    DeleteFile(FileName);
  end;
end;

function ConvertToDos(doc_in: Ansistring): Ansistring;
var
  doc_out: PAnsiChar;
  temps: Ansistring;
begin
  {$if Not Defined(DOCwIMAGES)}
    GetMem(doc_out, length(doc_in) + 1);
    CharToOemA(PAnsiChar(doc_in), doc_out);
    Result := copy(doc_out, 1, length(doc_out));
    FreeMem(doc_out);
  {$else}
    {$if Defined(FINAL_PRO_RU) or Defined(FINAL_CD_RU) or Defined(ADMIN_RU) or Defined(DEMO_RU)}
      GetMem(doc_out, length(doc_in) + 1);
      CharToOemA(PAnsiChar(doc_in), doc_out);
      Result := copy(doc_out, 1, length(doc_out));
      FreeMem(doc_out);
    {$else}
      result := doc_in;
    {$ifend}
  {$ifend}
end;

end.