DELPHI盒子
!实时搜索: 盒子论坛 | 注册用户 | 修改信息 | 退出
检举帖 | 全文检索 | 关闭广告 | 捐赠
技术论坛
 用户名
 密  码
自动登陆(30天有效)
忘了密码
≡技术区≡ ①
DELPHI技术
lazarus/fpc/Free Pascal
移动应用开发
Web应用开发
数据库专区
报表专区
网络通讯
开源项目
论坛精华贴
≡发布区≡ ②
发布代码
发布控件
文档资料
经典工具
≡事务区≡ ③
网站意见
盒子之家
招聘应聘
信息交换
论坛信息
最新加入： laidabin
今日帖子： 6
在线用户： 34
导航： 论坛 -> DELPHI技术 斑竹:liumazi,sephil  
作者：
男 magiewang (magiewang) ▲▲▲△△ -
普通会员
2017/4/24 19:44:42
标题：
求大神帮忙看看这段代码还有的旧吗？ 浏览:1403
加入我的收藏
楼主： 以前摘自传奇的一段加密函数，在好多程序里用到，现在转10.2了，这个函数不能用了，强制转ANSISTRING也不行，但以前好多工作档案都是用这个编码内容然后存储的，急！急！急！

unit EDCode;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,ComCtrls,
    Dialogs, StdCtrls, IniFiles, StrUtils, DateUtils, shlObj, ShellAPI;

  procedure Encode6BitBuf(src, dest: PChar; srclen, destlen: Integer);
  procedure Decode6BitBuf(source: String; buf: PChar; buflen: integer);
  function EncodeStringMir(Str:String):String;  
  function DecodeStringMir(str: String):String;

implementation

procedure Encode6BitBuf(src, dest: PChar; srclen, destlen: Integer);
var
   i, restcount, destpos: integer;
   made, ch, rest: byte;
begin
  try
     restcount := 0;
     rest      := 0;
     destpos   := 0;
     for i:=0 to srclen - 1 do
     begin
        if destpos >= destlen then break;
        ch := byte (src[i]);
        made := byte ((rest or (ch shr (2+restcount))) and $3F);
        rest := byte (((ch shl (8 - (2+restcount))) shr 2) and $3F);
        Inc (restcount, 2);

        if restcount < 6 then begin
          dest[destpos] := char(made + $3C);
          Inc (destpos);
        end else begin
          if destpos < destlen-1 then begin
          dest[destpos]   := char(made + $3C);
          dest[destpos+1] := char(rest + $3C);
          Inc (destpos, 2);
          end else begin
          dest[destpos]   := char(made + $3C);
          Inc (destpos);
          end;
          restcount := 0;
          rest := 0;
        end;
     end;
     if restcount > 0 then begin
      dest[destpos] := char (rest + $3C);
        Inc (destpos);
     end;
     dest[destpos] := #0;
  except end;
end;

procedure Decode6BitBuf(source: String; buf: PChar; buflen: integer);
const
  Masks: array[2..6] of byte = ($FC, $F8, $F0, $E0, $C0);
var
  i, len, bitpos, madebit, bufpos: Integer;
  ch, tmp, _byte: Byte;
begin
  try
     Len := Length(source);
     bitpos  := 2;
     madebit := 0;
     bufpos  := 0;
     tmp    := 0;
     for i:=1 to len do begin
      if Integer(source[i]) - $3C >= 0 then
        ch := Byte(source[i]) - $3C
        else begin
          bufpos := 0;
          break;
        end;

        if bufpos >= buflen then break;

        if (madebit+6) >= 8 then begin
          _byte := Byte(tmp or ((ch and $3F) shr (6-bitpos)));
          buf[bufpos] := Char(_byte);
          Inc (bufpos);
          madebit := 0;
          if bitpos < 6 then Inc (bitpos, 2)
          else begin
          bitpos := 2;
          continue;
          end;
        end;
        tmp := Byte (Byte(ch shl bitpos) and Masks[bitpos]);   // #### ##--
        Inc (madebit, 8-bitpos);
     end;
     buf [bufpos] := #0;
  except end;
end;

function EncodeStringMir(Str:String):String;
Var
  EncBuf : PChar;
begin
  try
    GetMem(EncBuf, 51200);
    Encode6BitBuf(PChar(str), EncBuf, Length(str), 51200);
    Result := StrPas(EncBuf);
  finally
    FreeMem(EncBuf);
  end;
end;   

function DecodeStringMir(str:String):String;
Var
  EncBuf: PChar;
begin
  try
    GetMem(EncBuf, 51200);
    Decode6BitBuf(str, EncBuf, 51200);
    Result := StrPas(EncBuf);
  finally
    FreeMem(EncBuf);
  end;
end;

end.
----------------------------------------------
-
作者：
男 magiewang (magiewang) ▲▲▲△△ -
普通会员
2017/4/24 19:46:27
1楼： 代码一直运行于D7，改10.2后默认String是WideString，强制转换成ansistring后，一样无法得到正确结果，求教！！！！万分感谢
----------------------------------------------
-
作者：
男 bahamut8348 (leonna) ★☆☆☆☆ -
普通会员
2017/4/24 20:11:05
2楼： unit EDCode;

interface

procedure Encode6BitBuf(src, dest: PAnsiChar; srclen, destlen: Integer);
procedure Decode6BitBuf(source: AnsiString; buf: PAnsiChar; buflen: integer);
function EncodeStringMir(Str: AnsiString): AnsiString;
function DecodeStringMir(str: AnsiString): AnsiString;

implementation

procedure Encode6BitBuf(src, dest: PAnsiChar; srclen, destlen: Integer);
var
  i, restcount, destpos: integer;
  made, ch, rest: byte;
begin
  try
    restcount := 0;
    rest := 0;
    destpos := 0;
    for i := 0 to srclen - 1 do
    begin
      if destpos >= destlen then
        break;

      ch := Byte(src[i]);
      made := Byte((rest or (ch shr (2 + restcount))) and $3F);
      rest := Byte(((ch shl (8 - (2 + restcount))) shr 2) and $3F);
      Inc(restcount, 2);
      if restcount < 6 then
      begin
        dest[destpos] := AnsiChar(made + $3C);
        Inc(destpos);
      end
      else
      begin
        if destpos < destlen - 1 then
        begin
          dest[destpos] := AnsiChar(made + $3C);
          dest[destpos + 1] := AnsiChar(rest + $3C);
          Inc(destpos, 2);
        end
        else
        begin
          dest[destpos] := AnsiChar(made + $3C);
          Inc(destpos);
        end;
        restcount := 0;
        rest := 0;
      end;
    end;
    if restcount > 0 then
    begin
      dest[destpos] := AnsiChar(rest + $3C);
      Inc(destpos);
    end;
    dest[destpos] := #0;
  except
  end;
end;

procedure Decode6BitBuf(source: AnsiString; buf: PAnsiChar; buflen: integer);
const
  Masks: array [2 .. 6] of byte = ($FC, $F8, $F0, $E0, $C0);
var
  i, len, bitpos, madebit, bufpos: Integer;
  ch, tmp, _byte: Byte;
begin
  try
    Len := Length(source);
    bitpos := 2;
    madebit := 0;
    bufpos := 0;
    tmp := 0;
    for i := 1 to len do
    begin
      if Integer(source[i]) - $3C < 0 then
      begin
        bufpos := 0;
        break;
      end;

      if bufpos >= buflen then
        break;

      ch := Byte(source[i]) - $3C;

      if (madebit + 6) >= 8 then
      begin
        _byte := Byte(tmp or ((ch and $3F) shr (6 - bitpos)));
        buf[bufpos] := AnsiChar(_byte);
        Inc(bufpos);
        madebit := 0;
        if bitpos < 6 then
          Inc(bitpos, 2)
        else
        begin
          bitpos := 2;
          continue;
        end;
      end;
      tmp := Byte(Byte(ch shl bitpos) and Masks[bitpos]); // #### ##--
      Inc(madebit, 8 - bitpos);
    end;
    buf[bufpos] := #0;
  except
  end;
end;

function EncodeStringMir(Str: AnsiString): AnsiString;
var
  EncBuf: PAnsiChar;
begin
  GetMem(EncBuf, 51200);
  try
    Encode6BitBuf(PAnsiChar(str), EncBuf, Length(str), 51200);
    Result := EncBuf;
  finally
    FreeMem(EncBuf);
  end;
end;

function DecodeStringMir(str: AnsiString): AnsiString;
var
  EncBuf: PAnsiChar;
begin
  GetMem(EncBuf, 51200);
  try
    Decode6BitBuf(str, EncBuf, 51200);
    Result := EncBuf;
  finally
    FreeMem(EncBuf);
  end;
end;

end.
----------------------------------------------
--
作者：
男 bahamut8348 (leonna) ★☆☆☆☆ -
普通会员
2017/4/24 20:11:31
3楼： 自己的代码居然自己都救不了。。。
----------------------------------------------
--
作者：
男 jackalan (nVicen) ★☆☆☆☆ -
盒子活跃会员
2017/4/24 20:11:57
2楼： 你确定都转ansistring？xe开始pchar默认是pwidechar，要转换pchar也要转pansichar
----------------------------------------------
简单做人，认真做事。
作者：
男 wang_80919 (Flying Wang) ★☆☆☆☆ -
普通会员
2017/4/25 8:57:32
4楼： 楼上不信就算了，楼主信了就行。
----------------------------------------------
(C)(P)Flying Wang
作者：
男 wang_80919 (Flying Wang) ★☆☆☆☆ -
普通会员
2017/4/25 8:58:12
5楼： 对于 6BitBuf 这种名字来说。
TBytes 更适合。
----------------------------------------------
(C)(P)Flying Wang
作者：
男 magiewang (magiewang) ▲▲▲△△ -
普通会员
2017/4/25 9:32:07
6楼： 3Q，bahamut8348
----------------------------------------------
-
作者：
男 wang_80919 (Flying Wang) ★☆☆☆☆ -
普通会员
2017/4/25 9:52:42
7楼： 楼主在搞传奇？
----------------------------------------------
(C)(P)Flying Wang
作者：
男 wang_80919 (Flying Wang) ★☆☆☆☆ -
普通会员
2017/4/25 9:56:33
8楼： 跨平台 字符串 讨论(以及 字符串编码 讨论)
http://www.2pascal.com/forum.php?mod=viewthread&tid=1654&fromuid=4
(出处: 2Pascal-新时代的Pascal)

根据上面的帖子，做的新代码。

unit SixBitCode;

interface

uses
  System.Classes,
  System.SysUtils;

procedure Encode6BitBuf(src, dest: TStream);
procedure Decode6BitBuf(src, dest: TStream);
function EncodeStringMir(str: string; AEncoding: TEncoding = nil): string;
function DecodeStringMir(str: string; AEncoding: TEncoding = nil): string;

implementation

Uses
  System.StrUtils;

procedure Encode6BitBuf(src, dest: TStream);
var
  restcount: integer;
  _Byte,
  made, ch, rest: Byte;
begin
  if src = nil then exit;
  if dest = nil then exit;
  restcount := 0;
  rest := 0;
  while src.Position < src.Size do
  begin
    src.Read(ch, 1);
    made := Byte((rest or (ch shr (2 + restcount))) and $3F);
    rest := Byte(((ch shl (8 - (2 + restcount))) shr 2) and $3F);
    Inc(restcount, 2);
    _Byte := made + $3C;
    if restcount < 6 then
    begin
      dest.Write(_Byte, 1);
    end
    else
    begin
      if True then //长度无限
      begin
        dest.Write(_Byte, 1);
        _Byte := rest + $3C;
        dest.Write(_Byte, 1);
      end
      else
      begin
        dest.Write(_Byte, 1);
      end;
      restcount := 0;
      rest := 0;
    end;
  end;
  if restcount > 0 then
  begin
    _Byte := rest + $3C;
    dest.Write(_Byte, 1);
  end;
end;

procedure Decode6BitBuf(src, dest: TStream);
const
  Masks: array [2 .. 6] of byte = ($FC, $F8, $F0, $E0, $C0);
var
  i, bitpos, madebit: Integer;
  ch, tmp, _byte: Byte;
begin
  if src = nil then exit;
  if dest = nil then exit;
  bitpos := 2;
  madebit := 0;
  tmp := 0;
  while src.Position < src.Size do
  begin
    src.Read(ch, 1);
    ch := ch - $3C;
    if ch < 0 then break;
    if (madebit + 6) >= 8 then
    begin
      _byte := Byte(tmp or ((ch and $3F) shr (6 - bitpos)));
      dest.Write(_byte, 1);
      madebit := 0;
      if bitpos < 6 then
        Inc(bitpos, 2)
      else
      begin
        bitpos := 2;
        continue;
      end;
    end;
    tmp := Byte(Byte(ch shl bitpos) and Masks[bitpos]); // #### ##--
    Inc(madebit, 8 - bitpos);
  end;
end;

function EncodeStringMir(str: string; AEncoding: TEncoding = nil): string;
var
  src, dest: TStringStream;
begin
  if AEncoding = nil then
    AEncoding := TEncoding.UTF8;
  src := TStringStream.Create(str, AEncoding, False);
  dest := TStringStream.Create('', TEncoding.ASCII, False);
  try
    Encode6BitBuf(src, dest);
    Result := dest.DataString;
  finally
    FreeAndNil(src);
    FreeAndNil(dest);
  end;
end;

function DecodeStringMir(str: string; AEncoding: TEncoding = nil): string;
var
  src, dest: TStringStream;
begin
  if AEncoding = nil then
    AEncoding := TEncoding.UTF8;
  src := TStringStream.Create(str, TEncoding.ASCII, False);
  dest := TStringStream.Create('', AEncoding, False);
  try
    Decode6BitBuf(src, dest);
    Result := dest.DataString;
  finally
    FreeAndNil(src);
    FreeAndNil(dest);
  end;
end;

end.


虽然 效率不高，但是复用性好，支持各种编码。

你不用关心 str 的编码，只要第二个参数给出编码就行。
  ShowMessage(EncodeStringMir('你好', TEncoding.ANSI)); //兼容 D7 的结果。
  ShowMessage(DecodeStringMir(EncodeStringMir('你好', TEncoding.ANSI), TEncoding.ANSI));
----------------------------------------------
(C)(P)Flying Wang
作者：
男 sail2000 (小帆工作室) ★☆☆☆☆ -
盒子活跃会员
2017/4/26 7:37:34
9楼： 字符串好调试啊。自己下多几个断点看内存读写的是什么就知道如何解决了。
----------------------------------------------
delphi 是兴趣，和工作无关，即使它倒闭。又不靠它 delphi 吃饭，怕甚？
信息
登陆以后才能回复
Copyright © 2CCC.Com 盒子论坛 v3.0.1 版权所有 页面执行74.21875毫秒 RSS