pub_program.pas

以前写的一个利用P2P 技术的一个通讯的例子。里面用到了 DBISAM 、INDY 控件。

end;

function getnextyear(m_date: string; m_flag: integer = 0): string;
begin
   {with f_reca_dm.qy_wangy do
      begin
         close;
         sql.Clear;
         sql.Add('select aa=dateadd(dd,-1,dateadd(yy,1,:vdate))');
         parambyname('vdate').asdatetime := strtodate(m_date);
         open;
         result := datetostr(fieldbyname('aa').asdatetime);
         close;
      end;}
end;

function findfile(FFileName: string): boolean;
var
   FSearchRec: TSearchRec;
   FindResult: integer;
begin
   result := false;
   FindResult := FindFirst(FFileName, faAnyFile, FSearchRec);
   try
      result := FindResult = 0;
   finally
      FindClose(FSearchRec);
   end;
end;

procedure corr_birth(sender: TObject);
var
   s: string;
begin
   if not (sender is TFlatEdit) then
      exit;
   s := trim((sender as TFlatEdit).Text);
   if (copy(s, 1, 2) = '20') and (strtodate(s) > strtodate(gstr_pubdate)) then
      (sender as TFlatEdit).Text := '19' + copy(s, 3, length(s));
end;

function gtd_name(m_gtd: integer): string;
begin
   result := ''; // '0 - 意向';
   case m_gtd of
      1: result := '1 - 确认';
      2: result := '2 - 必来';
   end;
end;

function copy_wy(m_src: string): string;
var
   i: integer;
   s1, s2, s3: string;
begin
   s3 := '';
   for i := 1 to 1000 do
      begin
         s1 := strnextchar(pchar(m_src));
         s2 := copy(m_src, 1, length(m_src) - length(s1));
         s3 := s3 + s2;
         m_src := s1;
         if m_src = '' then
            break;
         if length(s3) > 248 then
            break;
      end;
   result := s3;
end;

function space_wy(m_src: string; m_len: integer): string;
var
   i, j: integer;
begin
   result := m_src;
   i := length(m_src);
   if i > m_len then
      result := copy(m_src, 1, m_len)
   else
      for j := i to m_len do
         result := result + ' ';
end;

function get_bn_name(mn_name: string; coolbar: TCoolbar): string;
var
   i: integer;
   s, s1: string;
begin
   result := '';
   with coolbar do
      for i := 0 to ControlCount - 1 do
         if controls[i] is TSpeedButton then
            begin
               s := uppercase(TSpeedButton(controls[i]).Name);
               s1 := getEventName(controls[i], coolbar, 'onclick');
               s1 := uppercase(TSpeedButton(controls[i]).Hint);
               if pos(mn_name, s1) > 0 then
                  begin
                     result := s;
                     break;
                  end;
            end;
end;

function encrypt_str(Src: string; Key: string; Encrypt: Boolean; m_brand: boolean = true): string;
var
   idx: integer;
   KeyLen: Integer;
   KeyPos: Integer;
   offset: Integer;
   dest: string;
   SrcPos: Integer;
   SrcAsc: Integer;
   TmpSrcAsc: Integer;
   Range: Integer;
begin
   try
      KeyLen := Length(Key);
      if KeyLen = 0 then key := 'wangy lsy dmp';
      KeyPos := 0;
      SrcPos := 0;
      SrcAsc := 0;
      Range := 256;
      if Encrypt then
         begin
            Randomize;
            offset := 18;
            if m_brand then
               offset := Random(Range);
            dest := format('%1.2x', [offset]);
            for SrcPos := 1 to Length(Src) do
               begin
                  SrcAsc := (Ord(Src[SrcPos]) + offset) mod 255;
                  if KeyPos < KeyLen then
                     KeyPos := KeyPos + 1
                  else
                     KeyPos := 1;
                  SrcAsc := SrcAsc xor Ord(Key[KeyPos]);
                  dest := dest + format('%1.2x', [SrcAsc]);
                  offset := SrcAsc;
               end;
         end
      else
         begin
            offset := StrToInt('$' + copy(src, 1, 2));
            SrcPos := 3;
            repeat
               SrcAsc := StrToInt('$' + copy(src, SrcPos, 2));
               if KeyPos < KeyLen then
                  KeyPos := KeyPos + 1
               else
                  KeyPos := 1;
               TmpSrcAsc := SrcAsc xor Ord(Key[KeyPos]);
               if TmpSrcAsc <= offset then
                  TmpSrcAsc := 255 + TmpSrcAsc - offset
               else
                  TmpSrcAsc := TmpSrcAsc - offset;
               dest := dest + chr(TmpSrcAsc);
               offset := srcAsc;
               SrcPos := SrcPos + 2;
            until SrcPos >= Length(Src);
         end;
      Result := Dest;
   except
      showmessage(src);
   end;
end;

function getEventName(v, o: TComponent; Event: string): string;
var
   BinStream: TMemoryStream;
   StrStream: TStringStream;
   s, VName, nowName: string;

   procedure ObjectBinaryToText(Input, Output: TStream);
   var
      NestingLevel: Integer;
      SaveSeparator: Char;
      Reader: TReader;
      Writer: TWriter;
      ObjectName, PropName: string;

      procedure WriteStr(const S: string);
      begin
         if SameText(ObjectName, vname) and SameText(PropName, event) then
            result := S;
      end;

      procedure ConvertValue; forward;

      procedure ConvertHeader;
      var
         ClassName: string;
         Flags: TFilerFlags;
         Position: Integer;
      begin
         Reader.ReadPrefix(Flags, Position);
         ClassName := Reader.ReadStr;
         ObjectName := Reader.ReadStr;
      end;

      procedure ConvertBinary;
      const
         BytesPerLine = 32;
      var
         MultiLine: Boolean;
         I: Integer;
         Count: Longint;
         Buffer: array[0..BytesPerLine - 1] of Char;
         Text: array[0..BytesPerLine * 2 - 1] of Char;
      begin
         Reader.ReadValue;

         Inc(NestingLevel);
         Reader.Read(Count, SizeOf(Count));
         MultiLine := Count >= BytesPerLine;
         while Count > 0 do
            begin

               if Count >= 32 then
                  I := 32
               else
                  I := Count;
               Reader.Read(Buffer, I);
               BinToHex(Buffer, Text, I);

               Dec(Count, I);
            end;
         Dec(NestingLevel);

      end;

      procedure ConvertProperty; forward;

      procedure ConvertValue;
      const
         LineLength = 64;
      var
         I, J, K, L: Integer;
         S: string;
         W: WideString;
         LineBreak: Boolean;
      begin
         case Reader.NextValue of
            vaList:
               begin
                  Reader.ReadValue;
                  Inc(NestingLevel);
                  while not Reader.EndOfList do
                     ConvertValue;
                  Reader.ReadListEnd;
                  Dec(NestingLevel);
               end;
            vaInt8, vaInt16, vaInt32:
               Reader.ReadInteger;
            vaExtended:
               Reader.ReadFloat;
            vaSingle:
               FloatToStr(Reader.ReadSingle);
            vaCurrency:
               FloatToStr(Reader.ReadCurrency * 10000);
            vaDate:
               FloatToStr(Reader.ReadDate);
            vaWString, vaUTF8String:
               begin
                  W := Reader.ReadWideString;
               end;
            vaString, vaLString:
               begin
                  S := Reader.ReadString;
               end;
            vaIdent, vaFalse, vaTrue, vaNil, vaNull:
               WriteStr(Reader.ReadIdent);
            vaBinary:
               ConvertBinary;
            vaSet:
               begin
                  Reader.ReadValue;
                  while True do
                     begin
                        S := Reader.ReadStr;
                        if S = '' then Break;
                     end;
               end;
            vaCollection:
               begin
                  Reader.ReadValue;
                  Inc(NestingLevel);
                  while not Reader.EndOfList do
                     begin
                        if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
                           ConvertValue;
                        Reader.CheckValue(vaList);
                        Inc(NestingLevel);
                        while not Reader.EndOfList do
                           ConvertProperty;
                        Reader.ReadListEnd;
                        Dec(NestingLevel);
                        //  WriteIndent;
                     end;
                  Reader.ReadListEnd;
                  Dec(NestingLevel);
               end;
            vaInt64:
               IntToStr(Reader.ReadInt64);
            else
               abort;
         end;
      end;

      procedure ConvertProperty;
      begin

         PropName := Reader.ReadStr; // save for error reporting
         ConvertValue;
      end;

      procedure ConvertObject;
      begin
         ConvertHeader;

         Inc(NestingLevel);
         while not Reader.EndOfList do
            ConvertProperty;
         Reader.ReadListEnd;
         while not Reader.EndOfList do
            ConvertObject;
         Reader.ReadListEnd;