pub_program.pas

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

      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;
         Dec(NestingLevel);
      end;

   begin
      NestingLevel := 0;
      Reader := TReader.Create(Input, 4096);
      SaveSeparator := DecimalSeparator;
      DecimalSeparator := '.';
      try
         Writer := TWriter.Create(Output, 4096);
         try
            Reader.ReadSignature;
            ConvertObject;
         finally
            Writer.Free;
         end;
      finally
         DecimalSeparator := SaveSeparator;
         Reader.Free;
      end;
   end;

begin
   result := '';
   if (v = nil) or (O = nil) then
      exit;
   VName := v.Name;

   BinStream := TMemoryStream.Create;
   try
      StrStream := TStringStream.Create(s);
      try
         BinStream.WriteComponent(o);
         BinStream.Seek(0, soFromBeginning);
         ObjectBinaryToText(BinStream, StrStream);
         StrStream.Seek(0, soFromBeginning);
         // Result := StrStream.DataString;
      finally
         freeandnil(StrStream);

      end;
   finally
      freeandnil(BinStream)
   end;
end;

function cryptstr(const s: string; stype: dword): string;
var
   i: integer;
   fkey: integer;
begin
   result := '';
   case stype of
      0: // setpass;
         begin
            randomize;
            fkey := random($FF);
            for i := 1 to length(s) do
               result := result + chr(ord(s[i]) xor i xor fkey);
            result := result + char(fkey);
         end;
      1: // getpass
         begin
            fkey := ord(s[length(s)]);
            for i := 1 to length(s) - 1 do
               result := result + chr(ord(s[i]) xor i xor fkey);
         end;
   end;
end;

procedure bold_sg(sg_jl: TAdvStringGrid);
begin
   with sg_jl do
      begin
         DefaultRowHeight := 22;
         rowheights[0] := 20;
         font.Style := [fsbold];
         font.Color := clnavy;
         selectioncolor := clinfobk;
         selectiontextcolor := clmaroon;
      end;
end;

function trim_wy(m_src: string; m_flag: smallint = 0): string;
var
   i, j: integer;
begin
   result := m_src;
   case m_flag of
      0: result := trim(m_src);
      1: //left
         begin
            j := 0;
            for i := 1 to length(m_src) do
               if ord(m_src[i]) > 31 then
                  begin
                     j := i;
                     break;
                  end;
            if j > 0 then
               result := copy(m_src, j, length(m_src));
         end;
      2: //right
         begin
            j := 0;
            for i := length(m_src) to 1 do
               if ord(m_src[i]) > 31 then
                  begin
                     j := i;
                     break;
                  end;
            if j > 0 then
               result := copy(m_src, 1, j);
         end;
   end;
end;

procedure refresh_pubdate;
begin
   {with f_reca_dm.qy_wangy do
      begin
         close;
         sql.Clear;
         sql.Add('select date from config');
         open;
         Gstr_Pubdate := datetostr(fieldbyname('date').asdatetime);
         close;
      end;}
end;

function comp_year(adate, ddate: string): boolean;
var
   year1, year2, month1, month2, day1, day2: word;
begin
   DecodeDate(strtodate(adate), Year1, Month1, Day1);
   DecodeDate(strtodate(ddate), Year2, Month2, Day2);
   result := year1 = year2;
end;

function beauty_str(m_src: string): string;
var
   i: integer;
   s: string;
   m_beng: boolean;
begin
   m_src := trim(m_src);
   s := '';
   result := m_src;
   for i := 1 to length(m_src) do //先去除多馀空格;
      if (m_src[i] <> ' ') or ((m_src[i] = ' ') and (m_src[i + 1] <> ' ')) then
         s := s + m_src[i];

   m_bEng := false;
   for i := 1 to length(s) do
      case s[i] of
         chr(8), chr(32)..chr(57), chr(65)..chr(90), chr(97)..chr(122):
            m_bEng := true;
         else
            begin
               m_bEng := false;
               exit;
            end;
      end;

   m_src := lowercase(s);
   s := '';
   for i := 1 to length(m_src) do //先去除多馀空格;
      if (i = 1) or ((m_src[i - 1] = ' ') and (m_src[i] <> ' ')) then
         s := s + chr(ord(m_src[i]) - 32)
      else
         s := s + m_src[i];
   result := s;
end;

function getlunar_day(m_date: TDatetime): string;
var
   i, j, k: word; //  k,
   span: integer;
   s: string;
begin
   {span := CalcDateDiff(m_date, strtodate('1901-01-01'));
   l_CalcLunarDate(i, j, k, span);
   s := FormatMonth(j) + FormatLunarDay(k); // FormatLunarYear(i) +
   result := 'date:' + s + '*';
   s := GetLunarHolDay(m_date);
   result := result + 'holiday:' + s + '*';
   s := GetConstellationName(m_date);
   result := result + 'west:' + s + '*';}
end;

procedure query_db(m_strsql: string; m_shint: string = '');
begin
   {with f_reca_dm.qy_wangy do
      begin
         close;
         sql.Clear;
         sql.Add(m_strsql);
         open;
         if RecordCount = 0 then
            begin
               MessageDlg(getstr(m_shint, nodata_msg), mtinformation, [mbok], 0);
               close;
               abort;
            end;
         close;
      end;}
end;

procedure common_deal(QuickRep1: TQuickRep; rpt_name: string = '');
var
   s: string;
   XLSFilt: TQRXLSFilter;
   RTFFilt: TQRRTFExportFilter;
   HTMFilt: TQRGHTMLDocumentFilter;
   PDFFilt: TQRPDFExportFilter;
   PDF_qrp: TQRPDFDocumentFilter;
   TXTFilt: TQRAsciiExportFilter; {}
   FSearchRec: TSearchRec;
begin
   {PDFFilt := TQRPDFDocumentFilter.Create('PDFExport uncomp.pdf');
   pdffilt.AddFontMap('WebDings:ZapfDingBats');
   pdffilt.TextOnTop := true;
   pdffilt.LeftMargin := 25;
   pdffilt.topMargin := -10;
   pdffilt.CompressionOn := false;
   pdffilt.Concatenating := true;
   pdffilt.SetTempPath('c:\temp');
   F_RPT_ZZKRMD.QuickRep1.ExportToFilter(PDFFilt);
   F_RPT_ZZKRMD.close;
   pdffilt.EndConcat;
   pdffilt.Free;
   }
   if gint_rptflag > 1 then
      begin
         s := '.\' + datetostr(strtodate(gstr_pubdate), 6) + '\'; // + datetostr(strtodate(gstr_pubdate), 6);
         //s := 'C:\Inetpub\wwwroot\web-hotel\Manage\Report\' + datetostr(strtodate(gstr_pubdate), 6); // + '\';
         //s := datetostr(strtodate(gstr_pubdate), 6);
         if FindFirst(s, faAnyFile, FSearchRec) <> 0 then
            createdirectory(pchar(s), nil);
         FindClose(FSearchRec);
         s := s + '\';
      end;
   //showmessage(QuickRep1.Parent.ClassName);
   try
      case gint_rptflag of
         0: QuickRep1.preview;
         1: QuickRep1.print;
         2: //html      {
            begin
               HTMFilt := TQRGHTMLDocumentFilter.Create(s + rpt_name + '.htm');
               //HTMFilt.Concat := true;
               //HTMFilt.ConcatCount := 2;
               //HTMFilt.PictureDir := 'webpics';
               HTMFilt.MultiPage := false;
               HTMFilt.PageLinks := true;