Bazı Çeviri Fonksiyonları Unit dosyası

A

Acoupotan

Forum Üyesi
22 Eyl 2022
166
0
0
Egypt
Selamlar

İhtiyaç duyduğumda ufak tefek dönüştürme fonksiyonları yazmıştım.
Bunları bir araya getirdiğim Uniti paylaşayım dedim.
Bazı fonksiyonlar Delphi 3'den beri gelen fonksiyonlar olduğundan yeni versiyonlarda daha basit çözümleride olabilir
Eh artık bununda kusuruna bakmazsınız sanırım
smile.png

Unit UnitDonusumler;

interface

uses
*Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
*StdCtrls, StrUtils, DateUtils, Jpeg, variants,
*IdHashMessageDigest, //Md5 Sifreleme için
*Math;

const
*Harfler_TXT : String = 'ıİüÜşŞöÖğÐçÇ';
*Harfler_CHR : array[1..12] of Integer = (253, 221, 252, 220, 254, 222, 246, 214, 240, 208, 231, 199);
*Harfler_ASC : array[1..12] of Integer = (141, 152, 129, 154, 159, 158, 148, 153, 167, 166, 135, 128);

*BinTable: array [0..15] of string =
* // 0 * * * 1 * * * 2 * * * 3 * * * 4 * * * 5 * * * 6 * * * 7 * * * 8 * * * 9 * * * A * * * B * * * C * * * D * * * E * * * F
* *('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111', '1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');

type
*TRGB=Record
* *R : Byte;
* *G : Byte;
* *B : Byte;
end;

type
*CeviriTipleri = (TypeCHR, TypeASC, TypePrinter);

* *function fn_HexDegerKontrol(pHexDeger:String):Boolean;

* *function fn_ChuckSumLRC(pStr : string) :byte;
* *function fn_HexToInt64(pHexDeger:String):Int64;
* *function fn_CharConvert(pCeviriTipi:CeviriTipleri; pDeger:String):String;
* *function fn_HexToBin(pHex: string): string;
* *function fn_KarakterSil(pStr, pSilinecekKarakter:String):String;
* *function fn_AscToHex(pStr, pBaglac:AnsiString):AnsiString;
* *function fn_HexToAsc(pStr:String):String;
* *function fn_TurkceleriDegistir(pStr:String):String;
* *function fn_TBytesToString(pBytes:TBytes): String;
* *function fn_BytesArrayToString(bytearray: array of byte; len : Integer ): String;
* *function fn_BarCodeEAN13_CheckDigit_Hesapla(FVeri: String):String;
* *function fn_StringParcala(pStr, pAyirac : String) : TStrings;
* *function fn_StringTersCevir(pStr: String) : String;
* *function fn_StrTamamla(pDolacakData:String; pDolduracakData:Char; pAdet:SmallInt):String;
* *function FarkZaman(BasZaman, BitZaman:TDateTime; var FSaat, FDakika, FTplDakika: Double):String;

* *function fn_StringToMemoryStream(pString: String): TMemoryStream;
* *function fn_MemoryStreamToString(pMemoryStream: TMemoryStream): String;
* *function fn_CepTelKotrol(_sCepTel : string) : string;

* *function fn_CheckLRC(const s: AnsiString): byte;
* *function fn_BCC_Bul(FVeri: String):String;
* *function fn_BCC_FarmaDRC_SerialNo(FVeri: String):String;
* *function fn_Fatek_LRC_Hesapla(pData:String):String;
* *function fn_Fatek_CRC16_ModeBus(pData:String):String;
* *function fn_CRC_ParaTanima(pData:String):String;
* *function fn_MD5_Olutur(pData:String):String;

* *function fn_StrToFloat(pStr, DecSeperator : String):String;
* *function fn_NumStringToBCD(const inStr: string): string;
* *function fn_BCDToNumString(const inStr: string): string;
* *procedure pr_StringToByteArray(const inStr: string; var InOutByte:Array of Byte);

* *function fn_ReSizeJpgToJpg(_Jpeg : TJpegImage; _iWidth, _iHeight:Integer):TJpegImage;

* *function fn_Renk_ColorToHex( Color : TColor ) : string;
* *function fn_Renk_HexToColor( sColor : string ) : TColor;
* *function fn_Renk_ColorToRGB( Color : TColor ) : TRGB;
* *function fn_Renk_RGBToColor(_RGB : TRGB ) : TColor;
* *function fn_Renk_IntToColor( iValue : Integer ) : TColor;
* *function fn_Renk_IntToHex( iValue : Integer ) : String;

* *function fn_VariantToString(_AVar: OleVariant): string;
* *function fn_StrToHex(sValue:WideString):WideString;

var
*ConvetTipi : CeviriTipleri;


implementation

function fn_MemoryStreamToString(pMemoryStream: TMemoryStream): String;
var
*xString : String;
begin
*xString := '';
*SetString(xString, PChar(pMemoryStream.Memory), pMemoryStream.Size div SizeOf(Char));
*Result := xString;
end;

function fn_StringToMemoryStream(pString: String): TMemoryStream;
var
*xMemoryStream: TMemoryStream;
begin
*xMemoryStream := TMemoryStream.Create;
*xMemoryStream.WriteBuffer(Pointer(pString)^, (Length(pString) * 2));
*xMemoryStream.Position := 0;
*Result := xMemoryStream;
end;


function fn_MD5_Olutur(pData:String):String;
var
*IdMD5: TIdHashMessageDigest5;
begin
* *try
* * * Result := '';
* * * IdMD5 := TIdHashMessageDigest5.Create;
* * * Result := IdMD5.HashStringAsHex(pData);
* *except
* *end;
* *IdMD5.Free;
end;

function fn_CRC_ParaTanima(pData:String):String;
var
*CRCToplam, TmpMod, I: Integer;
*TmpStr : String;
begin
*TmpStr := pData;

*CRCToplam := 0;
*for I := 1 to Length(TmpStr) do
* *CRCToplam := CRCToplam + Ord(TmpStr);

{
*if CRCToplam > 256 then
*begin
* *TmpMod := CRCToplam Mod 512;
* *if TmpMod = 0 then
* * *Result := '00'
* *else
* * *Result := IntToHex((512 - (CRCToplam Mod 512)), 2);
*end
*else
*begin
}
* *TmpMod := CRCToplam Mod 256;
* *if TmpMod = 0 then
* * *Result := '00'
* *else
* * *Result := IntToHex((256 - (CRCToplam Mod 256)), 2);
// *end;
end;

function FarkZaman(BasZaman, BitZaman:TDateTime; var FSaat, FDakika, FTplDakika: Double):String;
Var
*Fark: Double;
begin
*Result:='';
*if BasZaman > BitZaman Then
* *Result:='Hatalı Parametre.';
*Fark:=((BitZaman - BasZaman) * 24);
*FSaat:=Trunc(Fark);
*FDakika:=(Frac(Fark) * 60);
// *FDakika:=Round((Frac(Fark) * 60));
*if FDakika = 60 Then
*begin
* *FSaat:=FSaat + 1;
* *FDakika:=0;
*end;
* *FTplDakika :=Floor(((FSaat * 60) + FDakika))
end;

function fn_HexDegerKontrol(pHexDeger:String):Boolean;
var
*i : Smallint;
begin
*Result := True;
*for i := 1 to Length(pHexDeger) do
* *if Not(pHexDeger in ['0'..'9', 'A'..'F', 'a'..'f']) *then
* * *Result := False;
end;

function fn_Fatek_CRC16_ModeBus(pData:String):String;
var
*CRC: word;
*N, I: integer;
*B:byte;
begin
*CRC := $FFFF;
*for I := 1 to Length (pData) do
*begin
* *B := Ord(pData);
* *CRC := CRC xor B;
* *for N := 1 to 8 do
* *begin
* * *if (CRC and 1)0 then
* * * *CRC := (CRC shr 1) xor $A001
* * *else
* * * *CRC := CRC shr 1;
* *end;
*end;
Result := Chr(CRC and $ff) + Chr(CRC shr 8);
end;

function fn_Fatek_LRC_Hesapla(pData:String):String;
var
*T, I : Integer;
*H : String;
begin
*T := 0;
*for I := 1 to Length(pData) do
* *T := T + Ord(pData);
*H := IntToHex(T, 8);
*Result := H[7] + H[8];
end;

function fn_BCC_Bul(FVeri: String):String;
var i,x:Integer;
begin
*x:= ord(FVeri[1]) xor ord(FVeri[2]);
*for i := 3 to Length(FVeri) do
*begin
* *x:= x xor Ord(FVeri);
*end;
*Result := IntToHex(x, 2);
end;

function fn_BCC_FarmaDRC_SerialNo(FVeri: String):String;
var i,x:Integer;
begin
*x:= ord(FVeri[1]) xor 77;
*for i := 2 to Length(FVeri) do
*begin
* *x:= x xor Ord(FVeri);
*end;
*Result := IntToHex(x, 2);
end;

function fn_HexToBin(pHex: string): string;
var
*i: integer;
begin
*Result := '';
*for i := Length(pHex) downto 1 do
* *Result := BinTable[StrToInt('$' + pHex)] + Result;
end;

function fn_CheckLRC(const s: AnsiString): byte;
var i: integer;
begin
*result := 0;
*for i := 1 to length(s) do
* *inc(result,ord(s));
*result := (result xor $FF)+1; // or result := (not result)+1;
end;

function fn_ChuckSumLRC(pStr : string) :byte;
var i : Integer;
*Len : integer;
*lrc : byte;
begin
*Len := length(pStr);
*lrc := 0;
*if len > 0 then
*begin
* *lrc := ord(len);
* *for i := 2 to Len do
* * *lrc := lrc xor (Ord(pStr[i-1]));
* *end;
*Result := lrc;
end;

function fn_StrTamamla(pDolacakData:String; pDolduracakData:Char; pAdet:SmallInt):String;
begin
*while Length(pDolacakData) < pAdet do
* *pDolacakData := pDolacakData + pDolduracakData;

*Result := Copy(pDolacakData, 1, pAdet);
end;

function fn_StringTersCevir(pStr : String): String;
var
*i : Integer;
Begin
*Result := '';
*For i := Length(pStr) DownTo 1 Do
*Begin
* *Result := Result + Copy(pStr, i, 1) ;
*End;
end;

function fn_StringParcala(pStr, pAyirac : String) : TStrings;
var
*Sonuc : TStringList;
*I : integer;
*Parca : string;
begin
*Sonuc := TStringList.Create();
*Parca := '';

*for i := 1 to Length(pStr) do
*begin
* *if pStr pAyirac then
* * *Parca := Parca + pStr
* *else
* *begin
* * *Sonuc.Add(Parca);
* * *Parca := '';
* *end;
*end;

*if Length(pStr) > 0 then
* *if Sonuc.Count = 0 then
* * *parca := pStr;
*Sonuc.Add(Parca);
*Result := Sonuc;
end;

function fn_AscToHex(pStr, pBaglac:AnsiString):AnsiString;
var
* i:Integer;
* WStr:AnsiString;
begin
*WStr := '';
*for i := 1 to Length(pStr) do
* *WStr := WStr + pBaglac + IntTOHex(Ord(pStr),2);
*Result := WStr;
end;

function fn_HexToAsc(pStr:String):String;
var
* i: Integer;
* WStr, HexStr :String;
begin
*WStr := '';
*i := 1;
*while i < Length(pStr) do
*begin
* *if not(pStr in ['0'..'9', 'A'..'F']) then
* *begin
* * *Inc(i);
* * *Continue;
* *end;

* *if not(pStr[i+1] in ['0'..'9', 'A'..'F']) then
* *begin
* * *Inc(i);
* * *Continue;
* *end;

* *HexStr := pStr + pStr[i+1];
* *WStr := WStr + Chr(StrToInt64('$' + HexStr));
* *i:=i+2;
*end;
*Result := WStr;
end;

function fn_KarakterSil(pStr, pSilinecekKarakter:String):String;
var
* i:Integer;
* WStr:String;
begin
*for i := 1 to Length(pStr) do
*begin
* *if pStr = pSilinecekKarakter Then Continue;
* *WStr := WStr + pStr;
*end;
*Result := WStr;
end;

function fn_HexToInt64(pHexDeger:String):Int64;
var
*I:Integer;
*TempStr : String;
*wflag:Boolean;
begin
*try
* *wFlag := False;
* *for I := 1 to Length(pHexDeger) do
* *begin
* * *TempStr := pHexDeger;
* * *if TempStr IN ['0'..'9', 'A'..'F'] then Continue;
* * *wFlag := True;
* * *Break;
* *end;
* *if wFlag = False then
* * *Result := StrToInt64(('$' + pHexDeger))
* *else
* * *Result := 0;
*except
* *Result := 0;
*end;
end;

function fn_CharConvert(pCeviriTipi:CeviriTipleri; pDeger:String):String;
var
*I, P :Integer;
*TempStr:String;
begin
*TempStr := pDeger;
*if pCeviriTipi = TypePrinter then
*begin
* *TempStr := pDeger;
* *TempStr := AnsiReplaceStr(TempStr,'ı', CHR(141));
* *TempStr := AnsiReplaceStr(TempStr,'ç', CHR(135));
* *TempStr := AnsiReplaceStr(TempStr,'ğ', CHR(167));
* *TempStr := AnsiReplaceStr(TempStr,'ö', CHR(148));
* *TempStr := AnsiReplaceStr(TempStr,'ş', CHR(159));
* *TempStr := AnsiReplaceStr(TempStr,'ü', CHR(129));
* *TempStr := AnsiReplaceStr(TempStr,'İ', CHR(152));
* *TempStr := AnsiReplaceStr(TempStr,'Ç', CHR(128));
* *TempStr := AnsiReplaceStr(TempStr,'Ð', CHR(166));
* *TempStr := AnsiReplaceStr(TempStr,'Ö', CHR(153));
* *TempStr := AnsiReplaceStr(TempStr,'Ş', CHR(158));
* *TempStr := AnsiReplaceStr(TempStr,'Ü', CHR(154));
*end
*else
*begin
* *for I := 1 to Length(TempStr) do
* *begin
* * *P := Pos(TempStr, Harfler_TXT);
* * *if P 0 then
* * *begin
* * * *if pCeviriTipi = TypeCHR then TempStr := Chr(Harfler_CHR[P]);
* * * *if pCeviriTipi = TypeASC then TempStr := Chr(Harfler_ASC[P]);
* * *end;
* *end;
*end;
*Result := TempStr;
end;

function fn_TurkceleriDegistir(pStr:String):String;
var
*ws:String;
*i:integer;
begin
*ws:=pStr;
*for i := 1 to Length(ws) do
*begin
* *case ws of
* * *'Ð' : ws := 'G';
* * *'ğ' : ws := 'g';
* * *'Ü' : ws := 'U';
* * *'ü' : ws := 'u';
* * *'Ş' : ws := 'S';
* * *'ş' : ws := 's';
* * *'İ' : ws := 'I';
* * *'ı' : ws := 'i';
* * *'Ö' : ws := 'O';
* * *'ö' : ws := 'o';
* * *'Ç' : ws := 'C';
* * *'ç' : ws := 'c';
* * end;
*end;
*Result := ws;
end;

function fn_BytesArrayToString(bytearray: array of byte; len : Integer ): String;
var
*a: Integer;
begin
*result := '';
*for a := 0 to len-1 do begin
* *result := result + char( bytearray[a] );
*end;
end;

function fn_TBytesToString(pBytes:TBytes): String;
var
*I, xSize: Integer;
*xStr:String;
begin
*xStr := '';
*xSize := Length(pBytes);
*for I := 1 to xSize do begin
* *xStr := xStr + Char(pBytes);
*end;
*Result := xStr;
end;

function fn_BarCodeEAN13_CheckDigit_Hesapla(FVeri: String):String;
var i:Integer;
ModKalan, ToplamTek, ToplamCift:Integer;
begin
*ToplamTek *:= 0;
*ToplamCift := 0;
*for I := 1 to 12 do
*begin
* *case I of
* * 1,3,5,7,9,11 *: ToplamTek *:= ToplamTek *+ StrToInt(FVeri);
* * 2,4,6,8,10,12 : ToplamCift := ToplamCift + StrToInt(FVeri);
* *end;
*end;
*ModKalan := ((ToplamCift * 3) + ToplamTek) Mod 10;
*if ModKalan = 0 then
* *Result := IntToStr(ModKalan)
*else
* *Result := IntToStr(10 - ModKalan);
end;

function fn_CepTelKotrol(_sCepTel : string) : string;
var
*I : Integer;
*Sonuc, bKontrol : Boolean;
begin
* *if _sCepTel[1] = '0' then
* *begin
* * * Delete(_sCepTel,1,1);
* * * if (_sCepTel[1] = '5') and (Length(_sCepTel)=10) then
* * * * Sonuc := True
* * * else
* * * * Sonuc := False;
* *end else
* *begin
* * * if (_sCepTel[1] = '5') and (Length(_sCepTel)=10) then
* * * * Sonuc := True
* * * else
* * * * Sonuc := False;
* *end;

* *if Sonuc = True Then
* * *for I := 1 to Length(_sCepTel) do
* * * *if Not(_sCepTel in ['0'..'9']) then
* * * * *Sonuc := False;

* *if Sonuc = True Then
* *begin
* * * *bKontrol := True;
* * * *for I := 1 to Length(_sCepTel) do
* * * * * *if I < Length(_sCepTel) then
* * * * * * * *if _sCepTel _sCepTel[I+1] then
* * * * * * * * * *bKontrol := False;

* * * *if bKontrol = True then
* * * * * Sonuc := False;
* *end;

* *if Sonuc = True then
* * *Result := _sCeptel
* *else
* * *Result := '';
end;

function fn_NumStringToBCD(const inStr: string): string;
*function Pack(ch1, ch2: Char): Char;
*begin
* *Assert((ch1 >= '0') and (ch1 = '0') and (ch2 = '0') and (ch1 = '0') and (ch2 _Jpeg.Width then
* * * *scale := 100 / _Jpeg.Height
* * *else
* * * *scale := 100 / _Jpeg.Width;
* * *bmp := TBitmap.Create;
* * *try
* * * *{Create thumbnail bitmap, keep pictures aspect ratio}
* * * *bmp.Width := 100; //orj Round(jpg.Width * scale);
* * * *bmp.Height:= 100; //orj Round(jpg.Height * scale);
* * * *bmp.Canvas.StretchDraw(bmp.Canvas.Cliprect, _Jpeg);
* * *finally
* * * *_Jpeg.Assign(bmp);
* * * *bmp.free;
* * *end;
* *finally
* * * *Result := _Jpeg;
* *end;
end;

function fn_Renk_ColorToHex( Color : TColor ) : string;
begin
* *Result := IntToHex( GetRValue( Color ), 2 ) + *//Red
* * * * * * *IntToHex( GetGValue( Color ), 2 ) + *//Green
* * * * * * *IntToHex( GetBValue( Color ), 2 ); * //Blue
end;

function fn_Renk_HexToColor( sColor : string ) : TColor;
begin
* *Result := RGB(StrToInt( '$'+Copy( sColor, 1, 2 ) ), * //Red
* * * * * * * * *StrToInt( '$'+Copy( sColor, 3, 2 ) ), * //Green
* * * * * * * * *StrToInt( '$'+Copy( sColor, 5, 2 ) )); *//Blue
end;

function fn_Renk_IntToHex( iValue : Integer ) : String;
var
*sHex : String;
begin
* *sHex := IntToHex(iValue, 6);
* *sHex := Copy(sHex, 5, 2) + Copy(sHex, 3, 2) + Copy(sHex, 1, 2);
* *Result := sHex;
end;

function fn_Renk_IntToColor( iValue : Integer ) : TColor;
var
*sHex : String;
begin
* *sHex := IntToHex(iValue, 6);
* *Result := RGB(StrToInt( '$'+Copy( sHex, 5, 2 ) ), * //Red
* * * * * * * * *StrToInt( '$'+Copy( sHex, 3, 2 ) ), * //Green
* * * * * * * * *StrToInt( '$'+Copy( sHex, 1, 2 ) )); *//Blue
end;

function fn_Renk_ColorToRGB( Color : TColor ) : TRGB;
begin
* *Result.R := GetRValue( Color ); *//Red
* *Result.G := GetGValue( Color ); *//Green
* *Result.B := GetBValue( Color ); *//Blue
end;

function fn_Renk_RGBToColor(_RGB : TRGB ) : TColor;
begin
* *Result := RGB(_RGB.R, _RGB.G, _RGB.B); // Red, Green, Blue
end;

function fn_StrToHex(sValue:WideString):WideString;
var
*I : Integer;
*_ws : WideString;
begin
* *_ws := '0x';
* *for I := 1 to Length(sValue) do
* * * _ws := _ws + fn_AscToHex(sValue,'');
* *Result := _ws + IntToHex(10, 2) + IntToHex(13, 2);
end;

function fn_VariantToString(_AVar: OleVariant): string;
var
* i: integer;
* V: olevariant;
begin
* Result := '';
* if VarType(_AVar) = (varVariant or varByRef) then
* * *V := Variant(TVarData(_AVar).VPointer^)
* else V := _AVar;

* if VarType(V) = (varByte or varArray) then
* * * try
* * * * for i:=VarArrayLowBound(V,1) to VarArrayHighBound(V,1) do
* * * * * Result := Result + Chr(Byte(V));
* * * except;
* * * end
* * else Result := V;
end;

end.
 
Cevap yazmak için giriş yap yada kayıt ol.

Genel Forum

Türkçe Forum Siteleri

İnternette bilgi paylaşımı ve tartışma ortamı arayanlar için forum siteleri uzun yıllardır popüler bir tercih olmuştur. Her yaştan ve ilgi alanından kullanıcıya hitap eden genel forum siteleri, teknoloji, oyun, kültür ve daha pek çok konuda geniş içerik sunmaktadır. Bu platformlar, katılımcıların hem öğrenme hem de eğlenceli vakit geçirme ihtiyaçlarını karşılamaktadır.

Genel Forum Sitesi

İnternette Türkçe forumlar üzerinden içerik paylaşmak, dil bariyerini ortadan kaldırarak yerel kültüre uygun bir deneyim sunar. Türkçe forum siteleri, kullanıcıların bilgiye kolayca ulaşabileceği, aynı zamanda sosyal ve eğlenceli paylaşımlar yapabileceği platformlar oluşturur. Türkiye'deki internet kullanıcıları için bu forumlar, ilgi çekici konularda derinlemesine sohbetler sunar.

Genel Forum Siteleri

Günlük hayatın stresinden uzaklaşmak isteyenler için eğlenceli forumlar, keyifli bir alternatif sunar. Farklı hobilere ve ilgi alanlarına yönelik içeriklerle dolu olan bu forum paylaşım siteleri, kullanıcılarına samimi bir ortamda vakit geçirme fırsatı sunarken, aynı zamanda yeni insanlarla tanışma imkanı da sağlar. Eğlenceli paylaşımlar ve interaktif etkinliklerle dolu olan bu platformlar, hem öğrenmeyi hem de keyifli vakit geçirmeyi bir arada sunar.

İnternette yeni bir topluluk arayan ya da bilgi alışverişi yapmak isteyenler için genel forum siteleri harika bir başlangıç noktasıdır. Geniş bir kullanıcı kitlesine hitap eden Türkçe forumlar, herkesin ilgisini çekecek konularla doludur. Siz de bu platformlara katılarak, kendi ilgi alanlarınıza uygun başlıklarda sohbetlere katılabilir ve katkıda bulunabilirsiniz. 

Not : Lütfen Çekim Paylaşım Forumları için sitemizi kullanmayın.

Üst