[Back to STRINGS SWAG index] [Back to Main SWAG index] [Original]

    {
      Strings2 : routine di gestione stringhe tipo 'C' (PChar),
                 gestione messaggi,
                 help,
                 common dialog,
                 profiling,
                 file .INI

      Versione 2.0A
    }
    unit Strings2;

    {$V-}
    {$IFDEF Final}
    {$D-,I-,L-,R-,S-}
    {$ELSE}
    {$D+,I+,L+,R+,S+}
    {$ENDIF}

    interface

    uses
      WinDos,
      Strings,
      OWindows;

    {--------------------------------------------------------- Scansione stringhe }

    function StrRTrimm(Str : PChar) : PChar;
      {- Elimina gli spazi alla fine della stringa Str.}

    function StrLTrimm(Str : PChar) : PChar;
      {- Elimina gli spazi all'inizio della stringa Str.}

    function StrToken(var Str : PChar; Delim : char) : PChar;
      {- Restituisce la parte di Str fino al primo carattere Delim. Modifica Str
         in modo che punti al primo carattere dopo Delim. Elimina gli spazi.}

    function StrPasNil(P : PChar) : string;

    {------------------------------------------------- Conversione numero/stringa }

    function StrToInt(Str : PChar) : longint;
      {- Restituisce il valore intero rappresentato dalla stringa decimale Str.}

    function StrToIntDef(Str : PChar; DefV : longint) : longint;
      {- Restituisce il valore intero rappresentato dalla stringa decimale Str.
         Se Str è nil o è vuota o non è corretta viene restituito DefV.}

    function StrToReal(Str : PChar) : real;
      {- Restituisce il valore reale rappresentato dalla stringa decimale Str.}

    function RealToStr(V : real; NDigits : integer; Dest : PChar) : PChar;
      {- In Dest la reappresentazione decimale di V con NDigits cifre dopo
         la virgola. Cifre '0' non significative vengono eliminate.}

    function IntToStr(V : longint; Dest : PChar) : PChar;
      {- In Dest la rappresentazione decimale di V. Restituisce Dest.}

    {--------------------------------------------------------- Gestione nomi file }

    function GetFileName(FilePath : PChar) : PChar;
      {- Restituisce il nome del file FilePath.}

    function GetExtension(FilePath : PChar) : PChar;
      {- Restituisce l'estensione (compreso il punto) del file FilePath.}

    function HasWildCards(FilePath : PChar) : boolean;
      {- True se FilePath contiene wildcard: '*' o '?'.}

    function HasPath(FilePath : PChar): boolean;
      {- True se FilePath contiene il nome di una directory e/o di un drive.}

    function PutExtension(FilePath,NewExt : PChar) : PChar;
      {- Sostituisce l'estensione di FilePath con NewExt. FilePath deve
         avere il posto per mettere l'estensione. Se NewExt=nil l'estensione
         di FilePath viene eliminata.}

    {--------------------------------------------------- Gestione file di profile }

    function GetPrivateProfileFlag(Sec,Key : PChar; Default : boolean; FileName : PChar) : boolean;

    function GetPrivateProfileLong(Sec,Key : PChar; Default : longint; FileName : PChar) : longint;

    function GetPrivateProfileReal(Sec,Key : PChar; Default : real; FileName : PChar) : real;

    function GetPrivateProfileText(Sec,Key : PChar;
                                   Default,Dest : PChar; DestSize : integer;
                                   FileName : PChar) : integer;

    procedure WritePrivateProfileFlag(Sec,Key : PChar; V : boolean; FileName : PChar);

    procedure WritePrivateProfileInt(Sec,Key : PChar; V : longint; FileName : PChar);

    procedure WritePrivateProfileReal(Sec,Key : PChar; V : real; NDigits : integer; FileName : PChar);

    procedure WritePrivateProfileText(Sec,Key : PChar; V : PChar; FileName : PChar);

    {-------------------------------------------------------------- Gestione help }

    procedure SetHelpFileName(FN : PChar);
      {- Setta il nome del file contenente l'help per il programma.}

    function ExecHelp(Command : word; Data : longint) : boolean;
      {- Richiama l'help con comando Command e parametro Data.}

    procedure CloseHelp;
      {- Chiude l'help associato al programma.}

    {------------------------------------------------------------------ Profiling }

    procedure StartProfile;
      {- Inizia il conteggio del tempo trascorso.}

    procedure EndProfile;
      {- Visualizza il tempo trascorso dall'ultima StartProfile.}

    {------------------------------------- Caricamento e visualizzazione messaggi }

    const
      MParent = 65535;     {Valore di TitleH per avere come titolo la caption
                            di AParent.}

    function MsgPtr(MsgH : word) : PChar;
      {- Restituisce il messaggio di codice MsgH. Il messaggio non può essere lungo più
         di 80 caratteri.}

    function MessageBoxH(AParent : PWindowsObject; MsgH,TitleH : word; BoxType : word) : integer;
      {- Visualizza un message box con caption di codice TitleH e messaggio di codice MsgH.
         BoxType è il tipo del message box da creare. Viene restituito il codice restituito dal
         message box.}

    procedure ErrorMsg(AParent : PWindowsObject; MsgH,TitleH : word);
      {- Visualizza il messaggio di codice MsgH in un message box con caption di codice
         TitleH.}

    procedure ParErrorMsg(AParent : PWindowsObject; MsgH,TitleH : word; ParS : PChar);
      {- Visualizza il messaggio di codice MsgH con parametro ParS ('%s' nella
         messaggio di errore) in un message box con caption di codice TitleH.}

    procedure ParParErrorMsg(AParent : PWindowsObject; MsgH,TitleH : word; ParS1,ParS2 : PChar);
      {- Visualizza il messaggio di codice MsgH con parametri ParS1 e ParS2 ('%s' nella
         messaggio di errore) in un message box con caption di codice TitleH.}

    procedure ErrorMsgStr(AParent : PWindowsObject; Msg : PChar; TitleH : word);
      {- Visualizza il messaggio Msg in un message box.}

    procedure Panic(N : integer);
      {- Errore fatale non previsto: visualizza 'This can't happen' e interrompe
         l'esecuzione del programma.}

    procedure Warning(N : integer);
      {- Errore non fatale non previsto: visualizza 'Warning' e prosegue.}

    {------------------------------------------- Richiamo common dialog }

    function GetOpenFName(AParent : PWindowsObject;
                          FName : PChar;
                          MCaption,MDesc : word;
                          MustExist : boolean) : boolean;

    function GetSaveFName(AParent : PWindowsObject;
                          FName : PChar;
                          MCaption,MDesc : word) : boolean;

    implementation {==============================================================}

    uses
      WinTypes,
      WinProcs,
      CommDlg,
      Arit;

    {--------------------------------------------------------- Scansione stringhe }

    function StrRTrimm(Str : PChar) : PChar;
    var
      EndS : PChar;
    begin
      if Str = nil then StrRTrimm := nil
      else begin
        EndS := StrEnd(Str)-1;
        while (EndS >= Str) and (EndS^ = ' ') do dec(EndS);
        inc(EndS);
        EndS^ := #0;
        StrRTrimm := Str;
      end;
    end; { StrRTrimm }

    function StrLTrimm(Str : PChar) : PChar;
    begin
      if Str = nil then StrLTrimm := nil
      else begin
        while (Str^ = ' ') do inc(Str);
        StrLTrimm := Str;
      end;
    end; { StrLTrimm }

    function StrToken(var Str : PChar; Delim : char) : PChar;
    var
      DelimS : PChar;
    begin
      if Str = nil then StrToken := nil
      else begin
        DelimS := StrScan(Str,Delim);
        if DelimS = nil then DelimS := StrEnd(Str)-1
        else DelimS^ := #0;
        StrToken := StrRTrimm(StrLTrimm(Str));
        Str := DelimS+1;
      end;
    end; { StrToken }

    function StrPasNil(P : PChar) : string;
    begin
      if (P <> nil) then StrPasNil := StrPas(P)
      else StrPasNil := '';
    end;  { StrPasNil }

    {------------------------------------------------- Conversione numero/stringa }

    function StrToInt(Str : PChar) : longint;
    begin
      StrToInt := StrToIntDef(Str,-32768)
    end; { StrToInt }

    function StrToIntDef(Str : PChar; DefV : longint) : longint;
    var
      V : longint;
      Code : integer;
    begin
      if Str = nil then StrToIntDef := DefV
      else begin
        val(Str,V,Code);
        if Code <> 0 then V := DefV;
        StrToIntDef := V;
      end;
    end; { StrToIntDef }

    function StrToReal(Str : PChar) : real;
    var
      V : real;
      Code : integer;
    begin
      val(Str,V,Code);
      if Code <> 0 then V := -32768;
      StrToReal := V;
    end; { StrToReal }

    function RealToStr(V : real; NDigits : integer; Dest : PChar) : PChar;
    var
      Buffer : array[0..20] of char;
      P : PChar;
    begin
      Str(V:1:NDigits,Buffer);
      P := Buffer+StrLen(Buffer);
      while PChar(P-1)^ = '0' do dec(P);
      if PChar(P-1)^ = '.' then dec(P);
      P^ := #0;
      StrCopy(Dest,Buffer);
      RealToStr := Dest;
    end; { RealToStr }

    function IntToStr(V : longint; Dest : PChar) : PChar;
    var
      Buffer : array[0..12] of char;
    begin
      Str(V,Buffer);
      StrCopy(Dest,Buffer);
      IntToStr := Dest;
    end; { IntToStr }

    {--------------------------------------------------------- Gestione nomi file }

    function GetFileName(FilePath : PChar) : PChar;
    var
      P: PChar;
    begin
      P := StrRScan(FilePath,'\');
      if P = nil then P := StrRScan(FilePath,':');
      if P = nil then GetFileName := FilePath else GetFileName := P + 1;
    end; { GetFileName }

    function GetExtension(FilePath : PChar) : PChar;
    var
      P: PChar;
    begin
      P := StrScan(GetFileName(FilePath),'.');
      if P = nil then GetExtension := StrEnd(FilePath)
      else GetExtension := P;
    end; { GetExtension }

    function HasWildCards(FilePath : PChar) : boolean;
    begin
      HasWildCards := (StrScan(FilePath,'*') <> nil) or
                      (StrScan(FilePath,'?') <> nil);
    end; { HasWildCards }

    function HasPath(FilePath : PChar): boolean;
    begin
      HasPath := (StrRScan(FilePath,'\') <> nil) or
                 (StrRScan(FilePath,':') <> nil);
    end;  { HasPath }

    function PutExtension(FilePath,NewExt : PChar) : PChar;
    var
      P : PChar;
    begin
      P := GetExtension(FilePath);
      if (NewExt = nil) or
         (StrLen(NewExt) = 0) or
         (StrLen(NewExt) = 1) and (NewExt[0] = '.') then P^ := #0
      else begin
        if NewExt[0] <> '.' then begin
          P^ := '.';
          inc(P);
        end;
        StrLCopy(P,NewExt,4);
      end;
      PutExtension := FilePath;
    end; { PutExtension }

    {--------------------------------------------------- Gestione file di profile }

    function GetPrivateProfileFlag(Sec,Key : PChar; Default : boolean; FileName : PChar) : boolean;
    var
      Buffer : array[0..6] of char;
    begin
      GetPrivateProfileString(Sec,Key,'',Buffer,SizeOf(Buffer),FileName);
      if StrLen(Buffer) = 0 then GetPrivateProfileFlag := Default
      else begin
        StrLower(Buffer);
        if (StrComp(Buffer,'0') = 0) or
           (StrComp(Buffer,'false') = 0) or
           (StrComp(Buffer,'off') = 0) then GetPrivateProfileFlag := false
        else if (StrComp(Buffer,'1') = 0) or
           (StrComp(Buffer,'true') = 0) or
           (StrComp(Buffer,'on') = 0) then GetPrivateProfileFlag := true
        else GetPrivateProfileFlag := Default;
      end;
    end; { GetPrivateProfileFlag }

    function GetPrivateProfileLong(Sec,Key : PChar; Default : longint; FileName : PChar) : longint;
    var
      Buffer : array[0..20] of char;
      Code : integer;
      V : longint;
    begin
      GetPrivateProfileString(Sec,Key,'',Buffer,SizeOf(Buffer),FileName);
      if StrLen(Buffer) = 0 then GetPrivateProfileLong := Default
      else begin
        Val(Buffer,V,Code);
        if Code <> 0 then GetPrivateProfileLong := Default
        else GetPrivateProfileLong := V;
      end;
    end; { GetPrivateProfileLong }

    function GetPrivateProfileReal(Sec,Key : PChar; Default : real; FileName : PChar) : real;
    var
      Buffer : array[0..20] of char;
      Code : integer;
      V : real;
    begin
      GetPrivateProfileString(Sec,Key,'',Buffer,SizeOf(Buffer),FileName);
      if StrLen(Buffer) = 0 then GetPrivateProfileReal := Default
      else begin
        Val(Buffer,V,Code);
        if Code <> 0 then GetPrivateProfileReal := Default
        else GetPrivateProfileReal := V;
      end;
    end; { GetPrivateProfileReal }

    function GetPrivateProfileText(Sec,Key : PChar;
                                   Default,Dest : PChar; DestSize : integer;
                                   FileName : PChar) : integer;
    var
      BufPtr,Source : PChar;
      BufSize : integer;
      NumBuf : array[0..3] of char;
    begin
      BufSize := DestSize*4;
      GetMem(BufPtr,BufSize);
      GetPrivateProfileString(Sec,Key,'',BufPtr,BufSize,FileName);
      if StrLen(BufPtr) = 0 then StrLCopy(Dest,Default,DestSize-1)
      else begin
        Source := BufPtr;
        while Source^ <> #0 do begin
          if Source^ <> '#' then begin
            Dest^ := Source^;
            inc(Source);
          end else begin
            inc(Source);
            Dest^ := chr(Min(255,StrToIntDef(StrLCopy(NumBuf,Source,3),ord(' '))));
            inc(Source,StrLen(NumBuf));
          end;
          inc(Dest);
        end;
        Dest^ := #0;
      end;
      GetPrivateProfileText := StrLen(Dest);
      FreeMem(BufPtr,BufSize);
    end; { GetPrivateProfileText }

    procedure WritePrivateProfileFlag(Sec,Key : PChar; V : boolean; FileName : PChar);
    const
      ZU : array[false..true] of PChar = ('0','1');
    begin
      WritePrivateProfileString(Sec,Key,ZU[V],FileName);
    end; { WritePrivateProfileFlag }

    procedure WritePrivateProfileInt(Sec,Key : PChar; V : longint; FileName : PChar);
    var
      Buffer : array[0..12] of char;
    begin
      WVSPrintF(Buffer,'%ld',V);
      WritePrivateProfileString(Sec,Key,Buffer,FileName);
    end; { WritePrivateProfileInt }

    procedure WritePrivateProfileReal(Sec,Key : PChar; V : real; NDigits : integer; FileName : PChar);
    var
      Buffer : array[0..20] of char;
    begin
      Str(V:1:NDigits,Buffer);
      WritePrivateProfileString(Sec,Key,Buffer,FileName);
    end; { WritePrivateProfileReal }

    procedure WritePrivateProfileText(Sec,Key : PChar; V : PChar; FileName : PChar);
    var
      BufPtr,Dest : PChar;
      BufSize,I : integer;
    begin
      if (V = nil) or (StrLen(V) = 0) then
        WritePrivateProfileString(Sec,Key,V,FileName)
      else begin
        BufSize := StrLen(V)*4+1;
        GetMem(BufPtr,BufSize);
        Dest := BufPtr;
        while V^ <> #0 do begin
          if not (V^ in [#1..#31,'#']) then begin
            Dest^ := V^;
            inc(Dest);
          end else begin
            I := ord(V^);
            WVSPrintF(Dest,'#%03d',I);
            Dest := StrEnd(Dest);
          end;
          inc(V);
        end;
        Dest^ := #0;
        WritePrivateProfileString(Sec,Key,BufPtr,FileName);
        FreeMem(BufPtr,BufSize);
      end;
    end; { WritePrivateProfileText }

    {-------------------------------------------------------------- Gestione help }

    var
      HelpFile : array[0..fsPathName] of char;

    procedure SetHelpFileName(FN : PChar);
    begin
      StrLCopy(HelpFile,FN,fsPathName);
    end; { SetHelpFileName }

    function ExecHelp(Command : word; Data : longint) : boolean;
    begin
      ExecHelp := not WinHelp(Application^.MainWindow^.HWindow,HelpFile,Command,Data);
    end; { ExecHelp }

    procedure CloseHelp;
    begin
      ExecHelp(Help_Quit,0);
    end; { CloseHelp }

    {------------------------------------------------------------------ Profiling }

    var
      Time : longint;

    procedure StartProfile;
    begin
      Time := GetCurrentTime;
    end; { StartProfile }

    procedure EndProfile;
    var
      Buffer : array[0..80] of char;
      Value : longint;
    begin
      Value := GetCurrentTime-Time;
      WVSPrintF(Buffer,'Tempo impiegato: %ldms',Value);
      MessageBox(GetFocus,Buffer,'',mb_Ok);
    end; { EndProfile }

    {------------------------------------- Caricamento e visualizzazione messaggi }

    const
      MaxTitleLen = 50;   {Lunghezza massima dei titoli dei message box.}
      MaxMsgLen   = 80;   {Lunghezza massima dei messaggi dei message box
                           e dei messaggi caricati con la MsgPtr.}

    var
      MsgBuffer : array[0..MaxMsgLen] of char;

    function MsgPtr(MsgH : word) : PChar;
    begin
      LoadString(hInstance,MsgH,MsgBuffer,SizeOf(MsgBuffer));
      MsgPtr := @MsgBuffer;
    end; { MsgPtr }

    function MessageBoxH(AParent : PWindowsObject; MsgH,TitleH : word; BoxType : word) : integer;
    var
      Msg   : array[0..MaxMsgLen] of char;
      Title : array[0..MaxTitleLen] of char;
    begin
      if (TitleH = MParent) and (AParent <> nil) then
        GetWindowText(AParent^.HWindow,Title,SizeOf(Title))
      else
        LoadString(hInstance,TitleH,Title,SizeOf(Title));
      LoadString(hInstance,MsgH,Msg,SizeOf(Msg));
      if AParent = nil then
        MessageBoxH := MessageBox(GetFocus,Msg,Title,BoxType)
      else
        MessageBoxH := MessageBox(AParent^.HWindow,Msg,Title,BoxType);
    end; { MessageBoxH }

    procedure ErrorMsg(AParent : PWindowsObject; MsgH,TitleH : word);
    begin
      MessageBoxH(AParent,MsgH,TitleH,mb_IconExclamation);
    end; { ErrorMsg }

    procedure ParErrorMsg(AParent : PWindowsObject; MsgH,TitleH : word; ParS : PChar);
    var
      Title : array[0..MaxTitleLen] of char;
      Msg,Buffer : array[0..MaxMsgLen] of char;
    begin
      if (TitleH = MParent) and (AParent <> nil) then
        GetWindowText(AParent^.HWindow,Title,SizeOf(Title))
      else
        LoadString(hInstance,TitleH,Title,SizeOf(Title));
      LoadString(hInstance,MsgH,Msg,SizeOf(Msg));
      if ParS = nil then ParS := '';
      WVSPrintf(Buffer,Msg,ParS);
      if AParent = nil then
        MessageBox(GetFocus,Buffer,Title,mb_IconExclamation)
      else
        MessageBox(AParent^.HWindow,Buffer,Title,mb_IconExclamation);
    end; { ParErrorMsg }

    procedure ParParErrorMsg(AParent : PWindowsObject; MsgH,TitleH : word; ParS1,ParS2 : PChar);
    var
      Title : array[0..MaxTitleLen] of char;
      Msg,Buffer : array[0..MaxMsgLen] of char;
      ParBuffer : array[1..2] of PChar;
    begin
      if (TitleH = MParent) and (AParent <> nil) then
        GetWindowText(AParent^.HWindow,Title,SizeOf(Title))
      else
        LoadString(hInstance,TitleH,Title,SizeOf(Title));
      LoadString(hInstance,MsgH,Msg,SizeOf(Msg));
      if Pars1 <> nil then ParBuffer[1] := ParS1
      else ParBuffer[1] := '';
      if Pars2 <> nil then ParBuffer[2] := ParS2
      else ParBuffer[2] := '';
      WVSPrintf(Buffer,Msg,ParBuffer);
      if AParent = nil then
        MessageBox(GetFocus,Buffer,Title,mb_IconExclamation)
      else
        MessageBox(AParent^.HWindow,Buffer,Title,mb_IconExclamation);
    end; { ParParErrorMsg }

    procedure ErrorMsgStr(AParent : PWindowsObject; Msg : PChar; TitleH : word);
    begin
      if AParent = nil then
        MessageBox(GetFocus,Msg,MsgPtr(TitleH),mb_IconExclamation)
      else
        MessageBox(AParent^.HWindow,Msg,MsgPtr(TitleH),mb_IconExclamation);
    end; { ErrorMsgStr }

    procedure Panic(N : integer);
    var
      MsgBuffer : array[0..32] of char;
    begin
      WVSPrintF(MsgBuffer,'This can''t happen (%d)',N);
      MessageBox(GetFocus,MsgBuffer,'Fatal error',mb_IconExclamation);
      halt(1);
    end; { Panic }

    procedure Warning(N : integer);
    var
      MsgBuffer : array[0..32] of char;
    begin
      WVSPrintF(MsgBuffer,'This shouldn''t happen (%d)',N);
      MessageBox(GetFocus,MsgBuffer,'Warning',mb_IconExclamation);
    end; { Warning }

    {----------------------------------------------------- Richiamo common dialog }

    function GetOpenFName(AParent : PWindowsObject;
                          FName : PChar;
                          MCaption,MDesc : word;
                          MustExist : boolean) : boolean;
    var
      OpenFileName : TOpenFileName;
      DefExt : array[0..fsExtension] of char;
      Filter : array[0..fsExtension+84] of char;
    begin
      FillChar(OpenFileName,SizeOf(TOpenFileName),#0);
      StrCopy(DefExt,GetExtension(FName)+1);
      FillChar(Filter,SizeOf(Filter),#0);
      StrCopy(Filter,MsgPtr(MDesc));
      StrCopy(Filter+StrLen(Filter)+1,'*.');
      StrCat(Filter+StrLen(Filter)+1,DefExt);
      with OpenFileName do begin
        hInstance     := HInstance;
        hwndOwner     := AParent^.HWindow;
        lpstrDefExt   := DefExt;
        lpstrFile     := FName;
        lpstrFilter   := Filter;
        if MCaption <> 0 then lpstrTitle:= MsgPtr(MCaption);
        if MustExist then Flags := ofn_FileMustExist;
        Flags         := Flags or ofn_HideReadOnly;
        lStructSize   := sizeof(TOpenFileName);
        nFilterIndex  := 1;       {Index into Filter String in lpstrFilter}
        nMaxFile      := fsPathName+1;
      end;
      GetOpenFName := GetOpenFileName(OpenFileName);
      AnsiLower(Fname);
    end; { GetOpenFName }

    function GetSaveFName(AParent : PWindowsObject;
                          FName : PChar;
                          MCaption,MDesc : word) : boolean;
    var
      OpenFileName : TOpenFileName;
      DefExt : array[0..fsExtension] of char;
      Filter : array[0..fsExtension+84] of char;
    begin
      FillChar(OpenFileName,SizeOf(TOpenFileName),#0);
      StrCopy(DefExt,GetExtension(FName)+1);
      FillChar(Filter,SizeOf(Filter),#0);
      StrCopy(Filter,MsgPtr(MDesc));
      StrCopy(Filter+StrLen(Filter)+1,'*.');
      StrCat(Filter+StrLen(Filter)+1,DefExt);
      with OpenFileName do begin
        hInstance     := HInstance;
        hwndOwner     := AParent^.HWindow;
        lpstrDefExt   := DefExt;
        lpstrFile     := FName;
        lpstrFilter   := Filter;
        if MCaption <> 0 then lpstrTitle:= MsgPtr(MCaption);
        Flags         := ofn_OverWritePrompt or ofn_HideReadOnly;
        lStructSize   := sizeof(TOpenFileName);
        nFilterIndex  := 1;       {Index into Filter String in lpstrFilter}
        nMaxFile      := fsPathName+1;
      end;
      GetSaveFName := GetSaveFileName(OpenFileName);
      AnsiLower(FName);
    end; { GetSaveFName }

    {----------------------------------------------------------------------- Main }

    end. { unit Strings2 }

[Back to STRINGS SWAG index] [Back to Main SWAG index] [Original]