delphi 摩斯密码 加密解密 支持中文

最近突然来了性致，玩起了摩斯码加密解密，由于国际标准摩斯密码中并不存在中文字符，所以需要先进行转码。

发现有一些是先把中文进行Unicode编码，再转摩斯码；有的是先转Ascii，但我比较推荐用2进制转码再加密，原因如下：

摩尔斯电码也被称作摩斯密码，是一种时通时断的信号代码，通过不同的排列顺序来表达不同的英文字母、数字和标点符号。它发明于1837年，
是一种早期的数字化通信形式。不同于现代化的数字通讯，摩尔斯电码只使用零和一两种状态的二进制代码（感觉二进制比较符合），它的代码包括五种：短促的点信号“・”，
保持一定时间的长信号“—”，表示点和划之间的停顿、每个词之间中等的停顿，以及句子之间长的停顿。

 

点击下载>>>

值的一提的是：因为国际标准摩斯密码中并不存在中文字符，所以本站的中文摩斯密码加密解密工具使用了中文Unicode编码进行转换得到摩斯码。如果您使用了本工具对中文字符进行了摩斯码加密，建议同样使用本工具对其进行解密，因为大部分网站的摩斯密码转换工具不支持中文编码！并且还有部分生成的是伪摩斯密码！

 

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Memo1: TMemo;
    Button1: TButton;
    Edit2: TEdit;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
function ifincludehz(strtxt: string): boolean;    //判断是否含有汉字
var
  i: integer;
begin
//先判断要截取的字符串最后一个字节的类型
//如果为汉字的第一个字节则减(加)一位
  result := false;

  for i := 0 to length(strtxt) do
  begin
    if ByteType(strtxt, i) = mbLeadByte then
    begin
      result := true;
      break;
    end;
  end;
end;


function UnicodeToChinese(sStr: string): string;
var
  i: Integer;
  index: Integer;
  temp, top, last: string;
begin
  index := 1;
  while index >= 0 do
  begin
    index := Pos('\u', sStr) - 1;
    if index < 0 then         //非 unicode编码不转换 ,自动过滤
    begin
      last := sStr;
      Result := Result + last;
      Exit;
    end;
    top := Copy(sStr, 1, index); // 取出 编码字符前的 非 unic 编码的字符，如数字
    temp := Copy(sStr, index + 1, 6); // 取出编码，包括 \u,如\u4e3f
    Delete(temp, 1, 2);
    Delete(sStr, 1, index + 6);
    Result := Result + top + WideChar(StrToInt('$' + temp));
  end;
end;

function ChineseToUniCode(sStr: string): string;     //汉字的 UniCode 编码范围是: $4E00..$9FA5    
var
  w:Word;
  hz:WideString;
  i:Integer;
  s:string;
begin
  hz:=sStr;
  for i:=1 to Length(hz) do begin
    w := Ord(hz[i]);
    s:=IntToHex(w, 4);
    Result := Result +'\u'+ LowerCase(s);
  end;
end;

function BinToHexEachOther(ValueA : string; Action : Boolean) : string;
  //把二进制串转换成十六进制串或相反
  var
    ValueArray1 : Array [0..15] of string[4];
    ValueArray2 : Array [0..15] of char;
    i : shortint;
begin
    //数组初始化
    ValueArray1[0] := '0000';  ValueArray1[1] := '0001';  ValueArray1[2] := '0010';
    ValueArray1[3] := '0011';  ValueArray1[4] := '0100';  ValueArray1[5] := '0101';
    ValueArray1[6] := '0110';  ValueArray1[7] := '0111';  ValueArray1[8] := '1000';
    ValueArray1[9] := '1001';  ValueArray1[10] := '1010';  ValueArray1[11] := '1011';
    ValueArray1[12] := '1100';  ValueArray1[13] := '1101';  ValueArray1[14] := '1110';
    ValueArray1[15] := '1111';
    for i := 0 to 15 do
      if i >= 10 then ValueArray2[i] := chr(65 + (i - 10))
      else ValueArray2[i] := inttostr(i)[1];

    Result := '';
    if Action then
    begin //二进制串转换成十六进制串
      if (Length(ValueA) MOD 4 <> 0) then
        ValueA := stringofchar('0',Length(ValueA) MOD 4) + ValueA;
      while (Length(ValueA) >= 4) do
      begin
        for i := 0 to 15 do
          if Copy(ValueA,1,4) = ValueArray1[i] then
            Result := Result + ValueArray2[i];
        ValueA := Copy(ValueA,5,Length(ValueA) - 4);
      end;
    end
    else begin //十六进制串转换成二进制串
      while (Length(ValueA) >= 1) do
      begin
        for i := 0 to 15 do
          if Copy(ValueA,1,1) = ValueArray2[i] then
            Result := Result + ValueArray1[i];
        ValueA := Copy(ValueA,2,Length(ValueA) - 1);
      end;
    end;
end;

function HexCharToInt(HexToken : char):Integer;
begin
Result:=0;
if (HexToken>#47) and (HexToken<#58) then       { chars 0....9 }
   Result:=Ord(HexToken)-48
else if (HexToken>#64) and (HexToken<#71) then  { chars A....F }
   Result:=Ord(HexToken)-65 + 10;
end;

Function ConvertStrToBin(Value : string):string;//把字符串转化为二进制数
var tempHex : string[2];
    i : integer;
begin
  Result := '';
  if trim(Value) = '' then Exit;
  tempHex := '';
  for i := 1 to Length(Value) do
  begin
    tempHex := IntToHex(Ord(Value[i]),2);//每个字符转成两位十六进制数
    Result := Result + BinToHexEachOther(tempHex,False);//十六进制转成二进制
  end;
end;

Function ConvertBinToStr(Value : string):string; //把二进制数据转化为字符串
Var tempHex : string;
    i, tempInt : integer;
begin
  Result := '';
  if trim(Value) = '' then Exit;
  tempHex := BinToHexEachOther(Value,true);//二进制转成十六进制
  i := 0;
  Repeat
    begin
      i := i + 1;
      tempInt := HexCharToInt(tempHex[i]);
      i := i + 1;
      tempInt := tempInt * 16 + HexCharToInt(tempHex[i]);
       //以上将两位十六进制数转变为一个十进制数
      Result := Result + chr(TempInt); //转成ASCII码
    end;
  Until i >= length(tempHex)
end;

function MorseEncode(str: string): string;
const
  oldarr: array[0..55] of string = ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
                                    '1','2','3','4','5','6','7','8','9','0',
                                     '.',':',',',';','?','=', '''','/','!','-','_','"','(',')','$','&','@','+',' ','\');
  newarr: array[0..55] of string = ('.-','-...','-.-.','-..','.','..-.','--.','....','..','.---','-.-','.-..','--','-.','---','.--.','--.-','.-.','...','-','..-','...-','.--','-..-','-.--','--..',
                                    '.----','..---','...--','....-','.....','-....','--...','---..','----.','-----',
                                    '.-.-.-','---...','--..--','-.-.-.','..--..','-...-','.----.','-..-.','-.-.--','-....-','..--.-','.-..-.','-.--.','-.--.-','...-..-','.-...','.--.-.','.-.-.',' ','-.---..');
var
  strin: string;
  size: Integer;
  value: string;
  i,j: Integer;
begin
  strin := UpperCase(str);
  value := '';
  for i := 1 to Length(str) do
  begin
    size := -1;
    for j := 0 to High(oldarr) do
    begin
      if strin[i] = oldarr[j] then
      begin
        size := j;
        Break;
      end;
    end;
    if size >= 0 then
      value := value + newarr[size] + ' '
    else
      value := value + strin[i];
  end;
  Result := Trim(value);
end;

function MorseDecode(Code: string): string;
const
  oldarr: array[0..55] of string = ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
                                    '1','2','3','4','5','6','7','8','9','0',
                                     '.',':',',',';','?','=', '''','/','!','-','_','"','(',')','$','&','@','+',' ','\');
  newarr: array[0..55] of string = ('.-','-...','-.-.','-..','.','..-.','--.','....','..','.---','-.-','.-..','--','-.','---','.--.','--.-','.-.','...','-','..-','...-','.--','-..-','-.--','--..',
                                    '.----','..---','...--','....-','.....','-....','--...','---..','----.','-----',
                                    '.-.-.-','---...','--..--','-.-.-.','..--..','-...-','.----.','-..-.','-.-.--','-....-','..--.-','.-..-.','-.--.','-.--.-','...-..-','.-...','.--.-.','.-.-.',' ','-.---..');
var
  strarr: TStringList;
  size: Integer;
  value: string;
  i,j: Integer;
begin
  strarr := TStringList.Create;
  strarr.Delimiter := ' ';
  strarr.DelimitedText := Code;
  value := '';
  for i := 0 to strarr.Count-1 do
  begin
    size := -1;
    for j := 0 to High(newarr) do
    begin
      if strarr[i] = newarr[j] then
      begin
        size := j;
        Break;
      end;
    end;
    if size >= 0 then
      value := value + oldarr[size]
    else
      value := value + strarr[i];
  end;
  strarr.Free;
  Result := LowerCase(value);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if ifincludehz(Edit1.Text) then    
      Memo1.Text:=MorseEncode(ConvertStrToBin(edit1.Text))
     else
     Memo1.Text:=MorseEncode(edit1.Text);  
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
     if ifincludehz(Edit1.Text) then
      Edit2.Text:=ConvertBinToStr(MorseDecode(Memo1.Text))
        else
      Edit2.Text:=MorseDecode(Memo1.Text);
end;

end.