Voila quelques fonctions qui pouront rendre service à certains.
Il y a 3 sortes de foctions :
- fabriqués maison
- modifiés maison
- copiés sur d'autres sources
Mises à jours prevues pour bientôt.
Bonne prog.
Source / Exemple :
unit perso;
interface
uses
Windows,Messages,Dialogs,SysUtils,Math,Classes, Consts, ShellAPI, Forms ;
type
EInvalidDest = class(EStreamError);
EFCantMove = class(EStreamError);
//-------------------------------------------------------------------------------------
// ------- DECLARATION DES PROCEDURES ET FONCTIONS ------------------------------------
//-------------------------------------------------------------------------------------
// Fonctions divers
procedure TEMPO(temps:longint);
function Crypter(str_pass_original : string ) : string;
// Fonctions mathématiques
function Arrondir( nombre : extended ; nbDecim : extended) : extended;
// Liaison série RS232
procedure InitPort;
procedure OpenPort;
procedure ClosePort;
function Envoi_RS232( str_envoi : string) : boolean;
// Fonctions système
procedure SimuClick(bouton : integer ; x : DWord ; y : DWord);
// Opérations sur fichiers et dossiers
procedure CopieFichier(Const sourcefilename, targetfilename : string);
procedure MakeDir(s:string);
procedure MoveFile(const FileName, DestName: string);
function GetFileSize(const FileName: string): LongInt;
function FileDateTime(const FileName: string): TDateTime;
function HasAttr(const FileName: string; Attr: Word): Boolean;
function ExecuteFile(const FileName, Params, DefaultDir: string;
ShowCmd: Integer): THandle;
// Traitement sur chaînes de caractères
function NumToString(str : string ; nb_0 : integer) : string;
function EnleverCaracteres( str_chaine : string; position : integer; nb_car : integer) : string;
function EnleverChaine( str_chaine_source : string ; str_chaine_a_effacer : string ) : string;
function NombreRepetitionsChaine(str_chaine_source : string; chaine_a_compter : string ) : integer;
function PresenceCaracteres(str_chaine_source : string ; chaine_carac : string) : boolean;
function EnleverExtension(str : string) : string;
// Déclaration de constantes
const
// Carcteres Speciaux
NUMEROS = '0123456789';
LETTRES_MIN = 'abcdefghijklmnopqrstuvwxyz';
LETTRES_MAJ = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
INTERDITS_FICHIERS = ',;:!./*$?#{}][''';
// Fonction enlever caracteres
DEBUT = 0;
FIN = 1;
// Event Click Souris
DROIT = 1;
GAUCHE = 2;
MILIEU = 3;
NULL = 0;
SInvalidDest = 'Le fichier de destination %s n''existe pas';
SFCantMove = 'Impossible de déplacer %s';
// Déclaration de variables globales
var
test : integer;
DCB:TDCB;
RS232_ouverte,test_RS232:Boolean;
Hdl,Hdl2:THandle;
implementation
//*******************************************************************************
//*******************************************************************************
//****** ****************************
//****** FONCTIONS SUR LES FICHIERS ET REPERTOIRES ****************************
//****** ****************************
//*******************************************************************************
//*******************************************************************************
{ MoveFile procedure }
{
Moves the file passed in FileName to the directory specified in DestDir.
Tries to just rename the file. If that fails, try to copy the file and
delete the original.
Raises an exception if the source file is read-only, and therefore cannot
be deleted/moved.
}
procedure MoveFile(const FileName, DestName: string);
var
Destination: string;
begin
Destination := ExpandFileName(DestName); { expand the destination path }
if not RenameFile(FileName, Destination) then { try just renaming }
begin
if HasAttr(FileName, faReadOnly) then { if it's read-only... }
raise EFCantMove.Create(Format(SFCantMove, [FileName])); { we wouldn't be able to delete it }
CopieFichier(FileName, Destination); { copy it over to destination...}
// DeleteFile(FileName); { ...and delete the original }
end;
end;
{ GetFileSize function }
{
Returns the size of the named file without opening the file. If the file
doesn't exist, returns -1.
}
function GetFileSize(const FileName: string): LongInt;
var
SearchRec: TSearchRec;
begin
if FindFirst(ExpandFileName(FileName), faAnyFile, SearchRec) = 0 then
Result := SearchRec.Size
else Result := -1;
end;
function FileDateTime(const FileName: string): System.TDateTime;
begin
Result := FileDateToDateTime(FileAge(FileName));
end;
function HasAttr(const FileName: string; Attr: Word): Boolean;
begin
Result := (FileGetAttr(FileName) and Attr) = Attr;
end;
function ExecuteFile(const FileName, Params, DefaultDir: string;
ShowCmd: Integer): THandle;
var
zFileName, zParams, zDir: array[0..79] of Char;
begin
Result := ShellExecute(Application.MainForm.Handle, nil,
StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
StrPCopy(zDir, DefaultDir), ShowCmd);
end;
{fabrique un sous-répertoire donné avec gestion d'erreurs}
procedure MakeDir(s:string);
var Rech: TSearchRec;
begin
{$I-}
if FindFirst(s+'\*.*', faDirectory, Rech)<>0 then begin {s'il n'existe pas déjà}
MkDir(s);
if IOResult <> 0 then
MessageDlg('Impossible de créer le répertoire '+s, mtError, [mbOk], 0);
end;
FindClose(Rech);
{$I+}
end;
procedure CopieFichier(Const sourcefilename, targetfilename : string);
var
S,T : TFileStream;
begin
S := TFileStream.Create(sourcefilename, fmOpenRead);
try
T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
try
T.CopyFrom(S, S.Size);
finally
T.Free;
end;
finally
S.Free;
end;
end;
//*******************************************************************************
//*******************************************************************************
//****** ******************************
//****** FONCTIONS SUR LES CHAINES DE CARACTERES ******************************
//****** ******************************
//*******************************************************************************
//*******************************************************************************
{ Detecte si les caracteres envoyés en 2e parametre se trouvent dans la chaine
correspondand au 1er parametre.
Renvoi TRUE si les caracteres sont present dans la chaîne sinon FALSE}
function EnleverExtension(str : string) : string;
var
taille, i : integer;
str_temp : string;
begin
str_temp := str;
taille := length(str);
// On parcours la chaine de droite à gauche
for i := taille-1 downto 0 do
begin
// Si on voit un point
if Copy(str, i, 1) = '.' then
begin
str_temp := Copy(str, 0, i-1);
break;
end ;
end;
Result := str_temp;
end;
//-------------------------------------------------------------------------------
function PresenceCaracteres(str_chaine_source : string ; chaine_carac : string) : boolean;
var
i : integer;
str : string;
bool_resultat : boolean;
begin
bool_resultat := false;
for i := 1 to length(chaine_carac) do
begin
if Pos(chaine_carac[i], str_chaine_source) > 0 then
begin
bool_resultat := true;
break;
end;
end;
Result := bool_resultat;
end;
{ Renvoi le nombre de repetitions d'une sous-chaine dans une chaine
Si la sous-chaine n'est pas presente dans la chaine, la function renvoie 0 }
function NombreRepetitionsChaine(str_chaine_source : string; chaine_a_compter : string ) : integer;
var
i : integer ;
chaine : string;
nb_iterations : integer;
begin
// On fait une copie
chaine := str_chaine_source;
// On ititialise le nb_iterations
nb_iterations := 0;
for i := 0 to length(str_chaine_source) do
begin
if EnleverChaine(chaine, chaine_a_compter) = 'NULL' then break
else
begin
nb_iterations := nb_iterations + 1;
chaine := EnleverChaine(chaine, chaine_a_compter);
end;
end;
Result := nb_iterations;
end;
{ Efface une sous-chaine dans une chaine
Renvoi la chaine apres traitement si déroulement correct
Si la chaine recherchée n'est pas trouvée elle renvoi 'NULL' }
function EnleverChaine( str_chaine_source : string ; str_chaine_a_effacer : string ) : string ;
var
ipos : integer;
str_resultat : string;
begin
// On cherche la position de la sous-chaine dans la chaine
ipos := Pos( str_chaine_a_effacer, str_chaine_source);
if ipos = 0 then str_resultat := 'NULL'
else
begin
// On efface la sous-chaine
Delete(str_chaine_source, ipos, length(str_chaine_a_effacer));
str_resultat := str_chaine_source;
end;
Result := str_resultat;
end;
{ Cette fonction enleve un certain nombre de carcteres à la fin ou au debut d'1 chaine
Elle retourne la nouvelle chaine si tout se déroule correctement
Sinon elle envoi 'NULL' }
function EnleverCaracteres( str_chaine : string; position : integer; nb_car : integer) : string;
var
str_resultat : string;
i : integer;
begin
// Si le nombre de caracteres à effacer est superieur a la longueur de la chaine
if nb_car >= length(str_chaine) then str_resultat := 'NULL'
else
if position = DEBUT then
begin
str_resultat := Copy(str_chaine, nb_car + 1, length(str_chaine) - nb_car + 1);
end
else if position = FIN then
begin
str_resultat := Copy(str_chaine, 0, length(str_chaine) - nb_car);
end
else str_resultat := 'NULL';
Result := str_resultat;
end;
{ Formate une chaîne de caractères
On formate la chaine 'str' en 'nb_0' caractères
Si la longueur de 'str' < 'nb_o' alors on ajute des '0' devant 'str'
sinon on retourne 'NULL'
}
function NumToString(str : string ; nb_0 : integer) : string;
var
len_str,i : integer;
begin
len_str := length(str);
if len_str <= nb_0 then // si la chaîne est superieure au nombre de cacarteres du format voulu
begin
for i := 1 to (nb_0 - len_str) do str := '0' + str;
end
else if len_str > nb_0 then str := 'NULL';
NumToString := str;
end;
//*******************************************************************************
//*******************************************************************************
//************** ************************************
//************** FONCTIONS MATHEMATIQUES ************************************
//************** ************************************
//*******************************************************************************
//*******************************************************************************
function Arrondir( nombre : extended ; nbDecim : extended) : extended;
var
p10 : extended;
begin
if nbDecim = 2 then result := round(nombre * 100) / 100
else
begin
p10 := Power(10, nbDecim);
result := round(nombre * p10) / p10;
end;
end;
//*******************************************************************************
//*******************************************************************************
//******************* **************************************
//******************* FONCTIONS RS232 **************************************
//******************* **************************************
//*******************************************************************************
//*******************************************************************************
// Initialisation de la ligne RS232
procedure InitPort;
begin
DCB.BaudRate:=CBR_9600;
DCB.StopBits:=ONESTOPBIT;
DCB.ByteSize:=8;
DCB.Parity:=NOPARITY;
DCB.DCBLength:=sizeof(DCB);
end;
// Ouverture de la ligne RS232
procedure OpenPort;
var
ComTimeOut:TCommTimeOuts;
begin
if RS232_ouverte=false then begin
initport;
Hdl:=CreateFile('COM1',GENERIC_READ or GENERIC_WRITE,0,NIL,OPEN_EXISTING,0,Hdl2);
SetCommState(Hdl,DCB); {Association du Handdle au DCB}
EscapeCommFunction(Hdl,SETDTR); {Signal DTR à +12V}
EscapeCommFunction(Hdl,CLRRTS); {Signal RTS à -12V}
ComTimeOut.ReadTotalTimeoutConstant:=10;
ComTimeOut.ReadTotalTimeoutmultiplier:=1;
SetCommTimeouts(hdl,ComTimeOut);
RS232_ouverte:=True;
end;
end;
// Fermeture de la ligne RS232
procedure ClosePort;
begin
CloseHandle(Hdl);
RS232_ouverte:=False;
end;
// Envoie une chaîne de caractères sur la liaison série
function Envoi_RS232( str_envoi : string) : boolean;
var
c:array[1..30] of char;
len_valeur : integer;
begin
// Initilisation de la ligne RS232
ClosePort;
InitPort;
OpenPort;
// On détermine la taille de la chaîne à envoyer
len_valeur := length( str_envoi );
// on convertie la chaine en tableau
StrPCopy(@c, str_envoi);
// on écrit sur la ressource Hdl : RS232
//Envoi_RS232 := WriteFile(Hdl,c,len_valeur,len_valeur,NIL);
end;
//*******************************************************************************
//*******************************************************************************
//************************** *******************************
//************************** FONCTIONS SYSTEME *******************************
//************************** *******************************
//*******************************************************************************
//*******************************************************************************
{ Simule un click de souris à un endroit donné en parametres.
bouton represente le bouton a cliquer : CLICK_DROIT , CLICK_GAUCHE , CLICK_MILIEU.
x , y : representent les coordonnées du click. Si x = y = NULL = 0 alors le click
s'effectue a l'endroit ou se trouve le curseur}
procedure SimuClick(bouton : integer ; x : DWord ; y : DWord);
var
x_temp, y_temp : DWord;
begin
Case bouton of
MILIEU : begin
mouse_event(MOUSEEVENTF_MIDDLEDOWN,x,y,0,0);
mouse_event(MOUSEEVENTF_MIDDLEUP,x,y,0,0);
end;
DROIT : begin
mouse_event(MOUSEEVENTF_RIGHTDOWN,x,y,0,0);
mouse_event(MOUSEEVENTF_RIGHTUP,x,y,0,0);
end;
GAUCHE : begin
mouse_event(MOUSEEVENTF_LEFTDOWN,x,y,0,0);
mouse_event(MOUSEEVENTF_LEFTUP,x,y,0,0);
end;
end;
end;
//*******************************************************************************
//*******************************************************************************
//************************** ********************************
//************************** FONCTIONS DIVERS ********************************
//************************** ********************************
//*******************************************************************************
//*******************************************************************************
// Renvoie une chaîne de caractères cryptée en modifiant la chine passée en paramettre
// A titre indicatif 'a' = 8.91
function Crypter(str_pass_original : string ) : string;
var
i ,iVal: integer;
str : string;
begin
str := '';
for i := 1 to length(str_pass_original) do str := str + floattostr(Arrondir((Ord(str_pass_original[i]) + 1) / 11 , 2));
result := str;
end;
// Tempo en millisecondes
procedure TEMPO(temps:longint);
var
heur,minute,seconde,msec:Word;
DepartEnSec,heureEnSec:longint;
begin
DecodeTime(Time,heur,minute,seconde,msec);
DepartEnSec:=heur*3600000+minute*60000+seconde*1000+msec;
DecodeTime(Time,heur,minute,seconde,msec);
heureEnSec:=heur*3600000+minute*60000+seconde*1000+msec;
while heureEnSec - DepartEnSec < temps do begin
DecodeTime(Time,heur,minute,seconde,msec);
heureEnSec:=heur*3600000+minute*60000+seconde*1000+msec;
end;
end;
end.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.