AbetoDesign_FactuGES2/Source/Base/Utiles/uSistemaFunc.pas

{
===============================================================================
  Copyright (©) 2002. Rodax Software.
===============================================================================
  Los contenidos de este fichero son propiedad de Rodax Software titular del
  copyright. Este fichero sólo podrá ser copiado, distribuido y utilizado,
  en su totalidad o en parte, con el permiso escrito de Rodax Software, o de
  acuerdo con los términos y condiciones establecidas en el acuerdo/contrato
  bajo el que se suministra.
  -----------------------------------------------------------------------------
  Web:  www.rodax-software.com
===============================================================================
  Fecha primera versión: 01-11-2002
  Versión actual: 1.0.0
  Fecha versión actual: 01-11-2002
===============================================================================
  Modificaciones:

    Fecha         Comentarios
    ---------------------------------------------------------------------------
===============================================================================
}
unit uSistemaFunc;

interface

uses
  SysUtils, Classes, Graphics;

{ Funciones del sistema }
function Ejecutar (const LineaComando: String; Oculto, Esperar: Boolean) : Boolean;
procedure EscribirEnFichero (NombreFichero, Texto : string);
function DarRutaTemporal : String;
function DarDirectorioTemporal : String;
function DarFicheroTemporal : String;
function DarFicheroJPGTemporal : String;
function DarFicheroBMPTemporal : String;
function DarFicheroTIFFTemporal : String;
function DarFicheroHTMLTemporal : String;
function DarFicheroExcelTemporal : String;
function DarFicheroPDFTemporal : String; overload;
function DarFicheroPDFTemporal(const AFileName : String) : String; overload;
function DarVersionFichero (Executable : String) : String;
function DarFechaFichero (Executable : String) : String;
procedure CopiarFichero(const Origen, Destino: string);
procedure Deltree(DirToKill : String; KillChoosenDir : Boolean);
function GetSpecialFolderPath(folder : integer) : string;
function PreguntarRuta(const ATitulo: String; const AComentario: String; var ARuta: String): Boolean;
function PreguntarFicheroWordExportar (var Fichero : String) : Boolean;
function PreguntarFicheroExcelExportar (var Fichero : String) : Boolean;
function PreguntarFicheroPDFExportar (var Fichero : String) : Boolean;
function EscapeIllegalChars(AFileName: string): string;
function FindFile(const filespec: TFileName; attributes: integer = faReadOnly Or faHidden Or faSysFile Or faArchive): TStringList;
function ExecAndWait(sCommandLine: string): Boolean;

//Directorios informes: EMPRESA, TIENDA, IDIOMA
function DarRutaFichero(const ARutaIni: String; const AFichero: String; const ADirectorio1: String = ''; const ADirectorio2: String = ''; const ADirectorio3: String = ''): Variant;

{ Fuentes }
procedure SetDefaultFonts(const AFont: TFont);
procedure SetDesktopIconFonts(const AFont: TFont);


implementation

uses
  Windows, Variants, Dialogs, JclFileUtils,
  Messages, Controls, Forms,
  StdCtrls, SHFolder, cxShellBrowserDialog,
  cxLookAndFeels, uStringsUtils;


function ExecAndWait(sCommandLine: string): Boolean;
var
  dwExitCode: DWORD;
  tpiProcess: TProcessInformation;
  tsiStartup: TStartupInfo;
begin
  Result := False;
  FillChar(tsiStartup, SizeOf(TStartupInfo), 0);
  tsiStartup.cb := SizeOf(TStartupInfo);
  if CreateProcess(nil, PChar(sCommandLine), nil, nil, False, 0,
    nil, nil, tsiStartup, tpiProcess) then
  begin
    if WAIT_OBJECT_0 = WaitForSingleObject(tpiProcess.hProcess, INFINITE) then
    begin
      if GetExitCodeProcess(tpiProcess.hProcess, dwExitCode) then
      begin
        if dwExitCode = 0 then
          Result := True
        else
          SetLastError(dwExitCode + $2000);
      end;
    end;
    dwExitCode := GetLastError;
    CloseHandle(tpiProcess.hProcess);
    CloseHandle(tpiProcess.hThread);
    SetLastError(dwExitCode);
  end;
end;


function GetSpecialFolderPath(folder : integer) : string;
const
  SHGFP_TYPE_CURRENT = 0;
var
  path: array [0..MAX_PATH] of char;
begin
  if SUCCEEDED(SHGetFolderPath(0, folder, 0, SHGFP_TYPE_CURRENT, @path[0])) then
    Result := path
  else
    Result := '';
end;

procedure EscribirEnFichero (NombreFichero, Texto : string);
var
  FicheroAux : TextFile;
begin
  SysUtils.DeleteFile(NombreFichero);
  AssignFile(FicheroAux, NombreFichero);
  Rewrite(FicheroAux);
  WriteLn(FicheroAux, Texto);
  CloseFile(FicheroAux);
end;


function Ejecutar (const LineaComando: String; Oculto, Esperar: Boolean): Boolean;
var
   StartupInfo : TStartupInfo;
   ProcessInfo : TProcessInformation;
begin
  {setup the startup information for the application }
  FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  with StartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
    if Oculto then
      wShowWindow:= SW_HIDE
    else
      wShowWindow:= SW_SHOWNORMAL;
  end;

  Result := CreateProcess(nil,PChar(LineaComando), nil, nil, False,
                          NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
  if Esperar then
    if Result then
    begin
      WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    end;
end;

function DarRutaTemporal: String;
var
  nBufferLength : DWORD; // size, in characters, of the buffer
  lpBuffer      : PChar; // address of buffer for temp. path
begin
  nBufferLength := MAX_PATH + 1; // initialize
  GetMem( lpBuffer, nBufferLength );
  try
    if GetTempPath( nBufferLength, lpBuffer ) <> 0 then
      Result := StrPas( lpBuffer )
    else
      Result := '';
  finally
    FreeMem( lpBuffer );
  end;
end;

function DarFicheroTemporal : String;
var
  Buf: array [0..MAX_PATH] of Char;
  RutaTmp : string;
begin
  RutaTmp := DarRutaTemporal;
  if GetTempFileName(PChar(RutaTmp), 'tmp', 0, Buf) <> 0 then
    SetString(Result, Buf, StrLen(Buf))
  else
    Result := '';
end;

function DarFicheroTIFFTemporal : String;
var
  Cadena : String;
begin
  Cadena := DarFicheroTemporal;
  Result := Copy(Cadena, 0, (Length(Cadena)-3)) + 'tif';
end;

function DarFicheroPDFTemporal : String;
var
  Cadena : String;
begin
  Cadena := DarFicheroTemporal;
  Result := Copy(Cadena, 0, (Length(Cadena)-3)) + 'pdf';
end;

function DarFicheroPDFTemporal(const AFileName : String) : String;
var
  Cadena : String;
  RutaTmp : string;
begin
  if not EsCadenaVacia(AFileName) then
  begin
    RutaTmp := DarRutaTemporal;
    Cadena := ExtractFileName(AFileName);
    Cadena := StringReplace(Cadena, ExtractFileExt(Cadena), '', []);
    Result := RutaTmp + Cadena + '.pdf';
  end
  else
    Result := DarFicheroPDFTemporal;
end;

function DarFicheroBMPTemporal : String;
var
  Cadena : String;
begin
  Cadena := DarFicheroTemporal;
  Result := Copy(Cadena, 0, (Length(Cadena)-3)) + 'bmp';
end;

function DarFicheroExcelTemporal : String;
var
  Cadena : String;
begin
  Cadena := DarFicheroTemporal;
  Result := Copy(Cadena, 0, (Length(Cadena)-3)) + 'xls';
end;

function DarFicheroHTMLTemporal : String;
var
  Cadena : String;
begin
  Cadena := DarFicheroTemporal;
  Result := Copy(Cadena, 0, (Length(Cadena)-3)) + 'html';
end;

function DarFicheroJPGTemporal : String;
var
  Cadena : String;
begin
  Cadena := DarFicheroTemporal;
  Result := Copy(Cadena, 0, (Length(Cadena)-3)) + 'jpg';
end;

function PreguntarFicheroWordExportar (var Fichero : String) : Boolean;
var
  DialogoSalvar : TSaveDialog;
begin
  DialogoSalvar := TSaveDialog.Create(NIL);
  try
    with DialogoSalvar do
    begin
      DefaultExt := 'doc';
      Filter := 'Documento de Word (*.doc)|*.doc';
      FilterIndex := 0;
      Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing];
    end;
    Result := DialogoSalvar.Execute;
    if Result then
      Fichero := DialogoSalvar.FileName;
  finally
    DialogoSalvar.Free;
  end;
end;

function PreguntarFicheroExcelExportar (var Fichero : String) : Boolean;
var
  DialogoSalvar : TSaveDialog;
begin
  DialogoSalvar := TSaveDialog.Create(NIL);
  try
    with DialogoSalvar do
    begin
      DefaultExt := 'xls';
      Filter := 'Documento de Excel (*.xls)|*.xls';
      FilterIndex := 0;
      Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing];
    end;
    Result := DialogoSalvar.Execute;
    if Result then
      Fichero := DialogoSalvar.FileName;
  finally
    DialogoSalvar.Free;
  end;
end;

function PreguntarFicheroPDFExportar (var Fichero : String) : Boolean;
var
  DialogoSalvar : TSaveDialog;
begin
  DialogoSalvar := TSaveDialog.Create(NIL);
  try
    with DialogoSalvar do
    begin
      DefaultExt := 'pdf';
      Filter := 'Documento pdf (*.pdf)|*.pdf';
      FileName := Fichero;
      FilterIndex := 0;
      Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing];
    end;
    Result := DialogoSalvar.Execute;
    if Result then
      Fichero := DialogoSalvar.FileName;
  finally
    DialogoSalvar.Free;
  end;
end;

function DarVersionFichero (Executable : String) : String;
var
  Obj : TJclFileVersionInfo;
begin
  Obj := TJclFileVersionInfo.Create(Application.ExeName);
  try
    Result := Obj.FileVersion;
  finally
    FreeAndNil(Obj);
  end;
end;

function DarFechaFichero (Executable : String) : String;
var
   FileTime, LocalFileTime : TFileTime;
   SystemTime : TSystemTime;
   hFile  : Integer;
begin
   hFile := FileOpen(Executable, fmShareDenyNone);
   try
      if hFile <> -1 then
      begin
        Windows.GetFileTime( hFile, nil, nil, @FileTime ); // ftLasWriteTime
         // Change the file time to local time
         FileTimeToLocalFileTime( FileTime, LocalFileTime );
         if FileTimeToSystemTime(LocalFileTime, SystemTime) then
          Result := DateTimeToStr(SystemTimeToDateTime(SystemTime));
      end; // if hFile <> 0
   finally
      FileClose( hFile );
   end; // try
end;


procedure CopiarFichero(const Origen, Destino: string);
begin
  CopyFile(PChar(Origen), PChar(Destino), FALSE);
end;

procedure DoDelTree(TheDir : String);
 Var
  Search : TSearchRec;
  rec    : word;
Begin
  If TheDir[Length(TheDir)] <> '\' Then TheDir := TheDir + '\';
   rec := SysUtils.FindFirst(TheDir + '*.*', faAnyFile, Search);
  While rec = 0 Do
   Begin
    If Search.Name[1] <> '.' Then
     Begin
// Is this a directory?
      If (Search.Attr And faDirectory) = faDirectory Then
       Begin
// If so, lets call DelTree again using this new
// directory as the TheDir parameter.
        DoDelTree(TheDir + Search.Name);
// Not that all of the files are gone from this directoy,
// we can remove the directory.
        RmDir(TheDir + Search.Name);
       End
       Else
       Begin
// We found a file.
// Now lets reset its attributes so we don't have any problems
// deleting them.
        SysUtils.FileSetAttr(TheDir + Search.Name, 0);
        SysUtils.DeleteFile(TheDir + Search.Name);
        Application.ProcessMessages;
       End;
     End;
    rec := SysUtils.FindNext(Search);
   End;
  SysUtils.FindClose(Search);
End;

procedure Deltree(DirToKill : String; KillChoosenDir : Boolean);
begin
{$I-}
 DoDelTree(DirToKill);
// If we want to delete the choosen directory.
 If KillChoosenDir Then
 RmDir(DirToKill);
 //modified
  if IOResult <> 0 then
  ShowMessage('Could not delete ' + DirToKill);
//{$I}
end;


function PreguntarRuta(const ATitulo: String; const AComentario: String; var ARuta: String): Boolean;
var
  cxShellBrowserDialog1: TcxShellBrowserDialog;
begin
  cxShellBrowserDialog1 := TcxShellBrowserDialog.Create(NIL);
  try
    with cxShellBrowserDialog1 do
    begin
      Name := 'cxShellBrowserDialog1';
      FolderLabelCaption := AComentario;
      LookAndFeel.NativeStyle := True;
      LookAndFeel.Kind := lfStandard;
      Title := ATitulo;

      Result := cxShellBrowserDialog1.Execute;
      ARuta := cxShellBrowserDialog1.Path;
    end;
  finally
    FreeANDNIL(cxShellBrowserDialog1);
  end;
end;


function EscapeIllegalChars(AFileName: string): string;
var
  x: integer;
const
  IllegalCharSet: set of char =
    ['|','<','>','\','^','+','=','?','/','[',']','"',';',',','*'];
begin
  for x := 1 to Length(AFileName) do
    if AFileName[x] in IllegalCharSet then
      AFileName[x] := '_';
  Result := AFileName;
end;

function FindFile(const filespec: TFileName; attributes: integer): TStringList;
var
  spec: string;
  list: TStringList;

procedure RFindFile(const folder: TFileName);
var
  SearchRec: TSearchRec;
begin
  // Locate all matching files in the current
  // folder and add their names to the list
  if FindFirst(folder + spec, attributes, SearchRec) = 0 then begin
    try
      repeat
        if (SearchRec.Attr and faDirectory = 0) or
           (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
          list.Add(folder + SearchRec.Name);
      until FindNext(SearchRec) <> 0;
    except
      SysUtils.FindClose(SearchRec);
      raise;
    end;
    SysUtils.FindClose(SearchRec);
  end;
  // Now search the subfolders
  if FindFirst(folder + '*', attributes
      Or faDirectory, SearchRec) = 0 then
  begin
    try
      repeat
        if ((SearchRec.Attr and faDirectory) <> 0) and
           (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
          RFindFile(folder + SearchRec.Name + '\');
      until FindNext(SearchRec) <> 0;
    except
      SysUtils.FindClose(SearchRec);
      raise;
    end;
    SysUtils.FindClose(SearchRec);
  end;
end; // procedure RFindFile inside of FindFile

begin // function FindFile
  list := TStringList.Create;
  try
    spec := ExtractFileName(filespec);
    RFindFile(ExtractFilePath(filespec));
    Result := list;
  except
    list.Free;
    raise;
  end;
end;

function DarDirectorioTemporal : String;
var
  Cadena: String;
begin
  Cadena := ExtractFileName(DarFicheroTemporal);
  Cadena := StringReplace(Cadena, ExtractFileExt(Cadena), '', []);
  Result := DarRutaTemporal + Cadena + '\';
end;

function DarRutaFichero(const ARutaIni: String; const AFichero: String; const ADirectorio1: String = ''; const ADirectorio2: String = ''; const ADirectorio3: String = ''): Variant;
var
  ARutaCompleta: String;
begin
  Result := Null;

  ARutaCompleta := ARutaIni + '\' + ADirectorio1 + '\' + ADirectorio2 + '\' + ADirectorio3 + '\' + AFichero;
  if FileExists(ARutaCompleta) then
     Result := ARutaCompleta
  else
  begin
    ARutaCompleta := ARutaIni + '\' + ADirectorio1 + '\' + ADirectorio3 + '\' + AFichero;
    if FileExists(ARutaCompleta) then
       Result := ARutaCompleta
    else
    begin
      ARutaCompleta := ARutaIni + '\' + ADirectorio1 + '\' + ADirectorio2 + '\' + AFichero;
      if FileExists(ARutaCompleta) then
         Result := ARutaCompleta
      else
      begin
        ARutaCompleta := ARutaIni + '\' + ADirectorio1 + '\' + AFichero;
        if FileExists(ARutaCompleta) then
           Result := ARutaCompleta
        else
        begin
          ARutaCompleta := ARutaIni + '\' + AFichero;
          if FileExists(ARutaCompleta) then
             Result := ARutaCompleta
        end;
      end;
    end;
  end;
end;



procedure SetDefaultFonts(const AFont: TFont);
begin
  AFont.Handle := GetStockObject(DEFAULT_GUI_FONT);
end;

procedure SetDesktopIconFonts(const AFont: TFont);
var
  LogFont: TLogFont;
begin
  if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont),
    @LogFont, 0) then
    AFont.Handle := CreateFontIndirect(LogFont)
  else
    SetDefaultFonts(AFont);
end;



end.