22-12-2017, Saat: 15:57
(Son Düzenleme: 23-12-2017, Saat: 13:44, Düzenleyen: Fesih ARSLAN.)
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
İ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

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[I]);
{
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[i] 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[I]);
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[I]);
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[i]);
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[i]);
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[i])] + 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[i]));
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[i] <> pAyirac then
Parca := Parca + pStr[I]
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[i]),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[i] 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[i] + 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[i] = pSilinecekKarakter Then Continue;
WStr := WStr + pStr[i];
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[I] 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[I], Harfler_TXT);
if P <> 0 then
begin
if pCeviriTipi = TypeCHR then TempStr[I] := Chr(Harfler_CHR[P]);
if pCeviriTipi = TypeASC then TempStr[I] := 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[i] of
'Ğ' : ws[i] := 'G';
'ğ' : ws[i] := 'g';
'Ü' : ws[i] := 'U';
'ü' : ws[i] := 'u';
'Ş' : ws[i] := 'S';
'ş' : ws[i] := 's';
'İ' : ws[i] := 'I';
'ı' : ws[i] := 'i';
'Ö' : ws[i] := 'O';
'ö' : ws[i] := 'o';
'Ç' : ws[i] := 'C';
'ç' : ws[i] := '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[I]);
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[i]);
2,4,6,8,10,12 : ToplamCift := ToplamCift + StrToInt(FVeri[i]);
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[I] 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[I] <> _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 <= '9'));
Assert((ch2 >= '0') and (ch2 <= '9'));
{Ord('0') is $30, so we can just use the low nybble of the character
as value.}
Result := Chr((Ord(ch1) and $F) or ((Ord(ch2) and $F) shl 4))
end;
var
i: Integer;
begin
if Odd(Length(inStr)) then
Result := fn_NumStringToBCD('0' + instr)
else begin
SetLength(Result, Length(inStr) div 2);
for i := 1 to Length(Result) do
Result[i] := Pack(inStr[2 * i - 1], inStr[2 * i]);
end;
end;
function fn_BCDToNumString(const inStr: string): string;
procedure UnPack(ch: Char; var ch1, ch2: Char);
begin
ch1 := Chr((Ord(ch) and $F) + $30);
ch2 := Chr(((Ord(ch) shr 4) and $F) + $30);
Assert((ch1 >= '0') and (ch1 <= '9'));
Assert((ch2 >= '0') and (ch2 <= '9'));
end;
var
i: Integer;
begin
SetLength(Result, Length(inStr) * 2);
for i := 1 to Length(inStr) do
UnPack(inStr[i], Result[2 * i - 1], Result[2 * i]);
end;
procedure pr_StringToByteArray(const inStr: string; var InOutByte:Array of Byte);
var
i : Integer;
begin
for I := Low(inStr) to High(inStr) do
begin
InOutByte[I] := Ord(inStr[I]);
end;
end;
function fn_StrToFloat(pStr, DecSeperator : String):String;
var
Str, Sonuc, Tam, Ond : string ;
Swc : Boolean;
I : Integer;
begin
Sonuc := '0';
Tam := '';
Ond := '';
Swc := False;
I := 0;
Str := ReverseString(pStr);
While I < Length(Str) do
Begin
I := I + 1;
If Str[I] In ['0'..'9'] then
Begin
If Swc = False then
Ond := Ond + Copy(Str, I, 1)
Else
Tam := Tam + Copy(Str, I, 1)
End
Else
Begin
if Ond = '' then Continue;
Swc := True
End
End;
If Tam = '' then
Sonuc := ReverseString(Ond)
Else
Sonuc := ReverseString(Tam) + DecSeperator + ReverseString(Ond);
Result := Sonuc;
end;
function fn_ReSizeJpgToJpg(_Jpeg : TJpegImage; _iWidth, _iHeight:Integer):TJpegImage;
var
bmp: TBitmap;
scale: Double;
begin
try
if _Jpeg.Height > _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[I],'');
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[i]));
except;
end
else Result := V;
end;
end.
Bu dünyada kendine sakladığın bilgi ahirette işine yaramaz.

