pub_program.pas

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

function compare_date(adate, ddate: string): string;
var
   i: integer;
begin
   i := round(strtodate(ddate) - strtodate(adate));
   if i = 0 then
      result := '0'
   else
      if i < 0 then
      result := '1'
   else
      if i > 0 then
      result := '2';
end;

function clear_name(m_src: string): string;
type
   TNumChar = set of char;
var
   numchar: TNumChar;
   i: integer;
begin
   numchar := ['/', '[', ']', '*', ':', '?', '%', ')', '(', '&', '!', '@', '$']; //#8为 BackSpace
   result := '';
   for i := 1 to length(m_src) do
      if (m_src[i] in numchar) then
         result := result + '-'
      else
         result := result + m_src[i];
end;

function check_name(s, m_name: string): boolean;
var
   db_name: string;
begin
   {   with f_reca_dm.qy_wangy do
         begin
            close;
            sql.Clear;
            sql.Add('select name from guest where krbm=:vkrbm');
            parambyname('vkrbm').asstring := s;
            prepare;
            open;
            db_name := getstr(fieldbyname('name').asstring, '-@$#');
            close;
         end;
      result := db_name = m_name; }
end;

function IsNum_wy(Input: string): boolean;
var
   i: integer;
begin
   result := false;
   for i := 1 to length(Input) do
      case ord(Input[i]) of
         48..57: result := true;
         else
            begin
               result := false;
               break;
            end;
      end;
end;

function bow_str(m_str: string): string;
var
   i: integer;
begin
   result := m_str;
   if length(m_str) > 40 then
      begin
         i := pos(' ', copy(m_str, 38, 100));
         if i = 0 then
            begin
               for i := 38 to length(m_str) - 1 do
                  if m_str[i] < chr(128) then
                     break;
               if (i + 10) < length(m_str) then
                  result := copy(m_str, 1, i) + #13#10 + '              ' + copy(m_str, i + 1, 100);
            end
         else
            result := copy(m_str, 1, 38 + i - 1) + #13#10 + '              ' + copy(m_str, 38 + i, 100);
      end;
end;

function nextvip(m_vip: string; updown: integer): string;
var
   i: integer;
begin
   {i := vip_list.IndexOf(m_vip);
   if i = -1 then
      i := 0;
   if UpDown = 1 then
      i := (i + 1) mod vip_list.Count
   else
      i := (i - 1 + vip_list.Count) mod vip_list.Count;
   result := vip_list.Strings[i];}
end;

function comp_zero(m_zero: string): Boolean;
begin
   m_zero := getstr(m_zero, '0', true);
   result := false;
   if (m_zero = '0') or (m_zero = '0.0') or (m_zero = '0.00') then
      result := true;
end;

function getmaxdate(m_adate: string): TDatetime; //此函数可用於输入时间
var
   year, month, day: word;
   adate: tDateTime;
begin
   {adate := strtodate(m_adate);
   with f_reca_dm.qy_wangy do
      begin
         close;
         sql.clear;
         sql.Add('select aa=dateadd(mm,1,:vadate)');
         parambyname('vadate').asdatetime := adate;
         open;
         adate := fieldbyname('aa').asdatetime;
         close;
      end;
   decodedate(adate, year, month, day);
   result := strtodate(inttostr(year) + '-' + inttostr(month) + '-01') - 1;}
end;

function WeekofYear(Date: TDate): integer;
var
   FirstDay, FirstWeekEnd, NowWeekEnd: TDate;
   Year, Month, Day: word;
begin
   DecodeDate(Date, Year, Month, Day);
   FirstDay := EncodeDate(Year, 1, 1);
   FirstWeekEnd := FirstDay + 7 - DayofWeek(FirstDay);
   NowWeekEnd := Date + 7 - DayofWeek(Date);
   Result := Round(NowWeekEnd - FirstWeekEnd) div 7 + 1;
end;

function padl(source: string; len: integer; ps: string): string;
begin
   result := trim(source);
   while length(result) < len do
      result := ps + result;
end;

function AnsiToUnicode(Ansi: string): string;
var
   s: string;
   i: integer;
   j, k: string[2];
   a: array[1..1000] of char;
begin
   s := '';
   StringToWideChar(Ansi, @(a[1]), 500);
   i := 1;
   while ((a[i] <> #0) or (a[i + 1] <> #0)) do
      begin
         j := IntToHex(Integer(a[i]), 2);
         k := IntToHex(Integer(a[i + 1]), 2);
         s := s + k + j;
         i := i + 2;
      end;
   Result := s;
end;

function UnicodeToAnsi(Unicode: string): string;
var
   s: string;
   i: integer;
   j, k: string[2];

   function ReadHex(AString: string): integer;
   begin
      Result := StrToInt('$' + AString)
   end;

begin
   i := 1;
   s := '';
   while i < Length(Unicode) + 1 do
      begin
         j := Copy(Unicode, i + 2, 2);
         k := Copy(Unicode, i, 2);
         i := i + 4;
         s := s + Char(ReadHex(j)) + Char(ReadHex(k));
      end;
   if s <> '' then
      s := WideCharToString(PWideChar(s + #0#0#0#0))
   else
      s := '';
   Result := s;
end;

function dateadd(month: integer; yymmdd, startdate: string): string;
begin
   {with f_reca_dm.qy_wangy do
      begin
         close;
         sql.Clear;
         if yymmdd = 'dd' then
            sql.Add('select aa=dateadd(dd,:vadd,:vdate)')
         else
            if yymmdd = 'mm' then
            sql.Add('select aa=dateadd(mm,:vadd,:vdate)')
         else
            if yymmdd = 'yy' then
            sql.Add('select aa=dateadd(yy,:vadd,:vdate)');
         parambyname('vadd').asinteger := month;
         parambyname('vdate').asdatetime := strtodate(startdate);
         open;
         result := datetostr(fieldbyname('aa').asdatetime);
         close;
      end;}
end;

function lastcol_sg(sg_jl: Tstringgrid): integer;
var
   i, j: integer;
begin
   j := 0;
   with sg_jl do
      for i := 0 to colcount - 1 do
         if (ColWidths[i] > 0) and (not (trim(cells[i, 0]) = '数据状态')) then
            inc(j);
   result := j;
end;

function GetSex(s: string): string; overload;
begin
   {s := trim(s);
   if s = male_msg then
      result := '0'
   else
      if s = fema_msg then
      result := '1'
   else
      result := '2';}
end;

function GetSex(i: integer): string; overload;
begin
   {case i of
      0: result := male_msg;
      1: result := fema_msg;
      else
         result := '';
   end; }
end;

procedure Flat_repaint(Sender: TObject; m_bsg: bool = true);
var
   i: Integer;
begin
   for i := 0 to (Sender as TForm).ComponentCount - 1 do
      begin
         if ((Sender as TForm).Components[i] is TFlatEdit) then
            begin
               sendmessage(TFlatEdit((Sender as TForm).Components[I]).Handle, wm_ncpaint, 0, 0); //  CM_MOUSEENTER
            end
         else
            if ((Sender as TForm).Components[i] is TFlatComBoBox) then
            begin
               sendmessage(TFlatComBoBox((Sender as TForm).Components[I]).Handle, wm_ncpaint, 0, 0); //  CM_MOUSEENTER
            end;
      end;
end;

procedure ClearAll(Sender: TObject; m_bsg: bool = true);
var
   i, j: Integer;
   panel: tpanel;
   edit: tedit;
   com: tcombobox;
   com_f: tflatcombobox;
begin
   for i := 0 to (Sender as TForm).ComponentCount - 1 do
      begin
         if ((Sender as TForm).Components[i] is TEdit) then
            begin
               edit := TEdit((Sender as TForm).Components[I]);
               edit.text := '';
               if (not (edit.enabled)) and m_bsg then
                  edit.Color := $00E9ECED //  $00ED EDEE
               else
                  edit.Color := clwhite;
            end
         else
            if ((Sender as TForm).Components[i] is TCheckBox) then
            TCheckBox((Sender as TForm).Components[I]).Checked := False
         else
            if ((Sender as TForm).Components[i] is TFlatEdit) then
            begin
               TFlatEdit((Sender as TForm).Components[I]).text := '';
               if TFlatEdit((Sender as TForm).Components[I]).Height < 20 then
                  TFlatEdit((Sender as TForm).Components[I]).Height := 20;
               if (not (TFlatEdit((Sender as TForm).Components[I]).enabled)) and m_bsg then
                  TFlatEdit((Sender as TForm).Components[I]).ColorFlat := $00ECF0F2 //  $00ED EDEE
               else
                  TFlatEdit((Sender as TForm).Components[I]).ColorFlat := clwhite;
            end
         else
            if ((Sender as TForm).Components[i] is TMemo) then
            begin
               TMemo((Sender as TForm).Components[I]).Clear;
               if (not (TMemo(Sender as TForm).enabled)) then
                  TMemo(Sender as TForm).Color := $00E9ECED
               else
                  TMemo(Sender as TForm).Color := clwhite;
            end
         else
            if ((Sender as TForm).Components[i] is TFlatComBoBox) then
            begin
               com_f := TFlatComboBox((Sender as TForm).Components[I]);
               com_f.itemindex := -1;
               com_f.text := '';
               if (not (com_f.enabled)) and m_bsg then
                  com_f.Color := $00ECF0F2 //00E8 EAEB
               else
                  com_f.Color := clwhite;
            end
         else
            if ((S