Joachim Mohr Mathematik Musik Delphi
//Die Prozeduren wandeln ein Binärstring in einen Textstring und umgekehrt um.
//Kopiere den Text und füge ihn in Deinen Delphi-Editor ein.
//Speichere ihn dann als "umwandlungsprozeduren.pas" ab.
unit umwandlungsprozeduren;
interface
function FileToStr(const pfad: string): string;
procedure StrToFile(const s, pfad: string);
function BinaerStrToTextStr80(const s:string): string;
function TextStr80ToBinaerStr(const s: string): string;
implementation
uses forms,classes, SysUtils, dialogs;
const Trennzeichenkette = 'Binaer zu Text (c) Joachim Mohr b0i1n2t3x4t5&6%7/8';
function copyab(const s: string; const i: integer): string;
begin result := copy(s, i, length(s) - i + 1) end;
function BinaerStrToTextStr(const b:string): string;
const Hub = 40; //Oberhalb #39 (Hochkomma)
var k:integer;
strtext, str01:string;
function NullEinsStrgZuTextstr(const s01:string): string;
//Jeweils 7 Bytes - zum Beispiel - "0011000" wird in ein "lesbares" Byte uebergeführt
var k,j: integer;
a: string;
function NullEinsZuChar(const s:string): char; //zum Beispiel s='0011000';
var j,n: byte;
begin //geht auch kuerzer mit "shr" und "and" ("Maschinennaher Code").
n := 0;
for j := 1 to 7 do
if (j <=length(s)) and (s[j] = '1') then
Case j of 7: n := n + 1;
6: n := n + 2;
5: n := n + 4;
4: n := n + 8;
3: n := n + 16;
2: n := n + 32;
1: n := n + 64;
End; //n maximal 127
if n < Hub then n := n + 128; //So wird ein "unlesbares" Char "lesbar"
result := char(n)
end;
begin
setlength(a,7);
setlength(result,length(s01) div 7+1);
k := 0;
while k <= length(s01) do Begin
for j := 1 to 7 do
if (k + j <=length(s01)) and (s01[k+j] = '1')
then a[j] := '1' else a[j] := '0';
inc(k,7);
result[k div 7] := NullEinsZuChar(a);
End;
end;
begin
setlength(strtext,length(b)); // strtext := stringtest + kostet zu viel Zeit
setlength(str01,length(b)); // Deswegen wird gleich zu Anfang Speicherplatz reserviert
for k := 1 to length(b) do
if ord(b[k]) >= Hub then Begin
strtext[k] := b[k];
str01[k] := '0';
End else Begin
strtext[k] := char(ord(b[k]) + Hub); //Nicht "lesbares" Char wird "lesbar".
str01[k] := '1'; //Das muss man sich merken "0" oder "1"
End;
str01 := NullEinsStrgZuTextstr(str01);
result := Trennzeichenkette + strtext + Trennzeichenkette + str01;
end;
function TextStringToText80str(const s: string): string; //Text80 bestehr aus Zeilen mit 80 Zeichen
var k, n: integer;
begin
setlength(result,1025*length(s) div 1000 + 100); //Je 80 Zeichen + 2 Zeichen = 2,5% mehr
n := 0;
for k := 1 to length(s) do Begin
inc(n);
result[n] := s[k];
if k mod 80 = 0 then BEgin
result[n+1] := #13;
result[n+2] := #10;
inc(n,2);
ENd;
End;
result := copy(result,1,n);
end;
{function TextStringToText80str(const s: string): string; //Text80 bestehr aus Zeilen mit 80 Zeichen
var s0: string;
begin
s0 := s;
result := '';
while s0 <> '' do Begin
if result = '' then result := copy(s0,1,80) else
result := result + #13#10 + copy(s0,1,80);
s0 := copyab(s0,81);
End;
if result = TextStringToText80str0(s) then showmessage('korrekt')
else showmessage('nk');
end;}
function BinaerStrToTextStr80(const s:string): string;
begin
result := TextStringToText80str(BinaerStrToTextStr(s));
end;
{Die Umkehrfunktion: Zwei Delphistrings werden in einen Binaerstring umgewandelt}
function TextStrToBinaerstr0(const t,s01:string): string;
const Hub = 40; //Oberhalb Hochkomma
var k:integer;
s01echtausNullEins: string;
function TextStrZuNullEinsStr(const t:string): string;
var k: integer;
function CharZuNullEins(const c:char): string; //geht auch "maschinennaeher"
var k,n: integer;
begin
setlength(result,7);
n := ord(c);
if n >=128 then n := n - 128; //Das war urspruenglich ein "unlesbares" Char.
for k := 1 to 7 do
Case k of 7: if n and 1 = 1 then result[k] := '1' else result[k] := '0';
6: if n and 2 = 2 then result[k] := '1' else result[k] := '0';
5: if n and 4 = 4 then result[k] := '1' else result[k] := '0';
4: if n and 8 = 8 then result[k] := '1' else result[k] := '0';
3: if n and 16 = 16 then result[k] := '1' else result[k] := '0';
2: if n and 32 = 32 then result[k] := '1' else result[k] := '0';
1: if n and 64 = 64 then result[k] := '1' else result[k] := '0';
End;
end;
begin
result := '';
for k := 1 to length(t) do result := result + CharZuNullEins(t[k]);
end;
begin
s01echtausNullEins := TextStrZuNullEinsstr(s01);
setlength(result,length(t));
for k := 1 to length(t) do Begin
if s01echtausNullEins[k] = '0' then result[k] := t[k] else
result[k] := char(ord(t[k]) - Hub);
End;
end;
function TextStrToBinaerStr(const textstring:string): string;
//textstring ist Trennzeichenkette + t + Trennzeichenkette + s01;
var t,s01: string;
n : integer;
begin
t := copyab(textstring,length(Trennzeichenkette) + 1);
n := pos(Trennzeichenkette,t);
if n = 0 then Begin
showmessage('Fehler: Keine "' + Trennzeichenkette + '"-Datei');
exit;
End;
s01 := copyab(t,n + length(Trennzeichenkette));
t := copy(t,1,n-1);
result := TextStrToBinaerstr0(t,s01);
end;
function Text80strTextString(const s: string): string;
var k, laenge_s, n, n80, n_s: integer;
begin
laenge_s := length(s);
setlength(result,laenge_s); //Weniger. Genau je 80 Zeichen 2 Zeichen weg
n := 0; //Die Stelle in s
n80 := 0; //Jeweils 80 Zeichen werden gelesen, dann wird #13#10 ueberssprungen
n_s := 0; //Die Stelle in result
for k := 1 to length(s) do Begin
inc(n);
inc(n80);
if n <= laenge_s then Begin
inc(n_s);
result[n_s] := s[n];
End;
if n80 = 80 then Begin
inc(n,2);
n80 := 0;
End;
End;
result := copy(result,1,n_s);
end;
{function Text80strTextString(const s: string): string;
var s0: string;
begin
s0 := s;
result := '';
while s0 <> '' do Begin
result := result + copy(s0,1,80); //dahinter #13#10
s0 := copyab(s0,83);
End;
showmessage(inttostr(length(result)) + #13 + inttostr(length(text80strTextString0(s))));
if result = Text80strTextString0(s) then showmessage('korrekt') else
showmessage('nk');
end;}
function TextStr80ToBinaerStr(const s: string): string;
begin
result := TextStrToBinaerStr(Text80strTextString(s));
end;
// Die Lese- und Schreibprozeduren fuer Strings
function FileToStr(const pfad: string): string; //String als Puffer fuer die Bytes
var
F: TStream;
begin
F := TFileStream.Create(pfad, fmOpenRead or fmShareDenyWrite); //uses SysUtils
try
SetLength(result, F.Size);
F.ReadBuffer(PChar(result)^, F.Size);
finally
F.Free;
end;
end;
procedure StrToFile(const s, pfad: string);
var
F: TStream;
begin
F := TFileStream.Create(pfad,fmCreate); //uses SysUtils
try
F.write(PChar(s)^,length(s));
finally
F.Free;
end;
end;
end.