Soyez le premier à donner votre avis sur cette source.
Snippet vu 7 596 fois - Téléchargée 194 fois
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.
Radioham
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.