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