pub_program.pas

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

unit Pub_program;

interface
uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   grids, ExtCtrls, StdCtrls, Mask, DBCtrls, Menus, ComCtrls, DB, DBTables, printers, math,
   OleCtrls, AgentObjects_TLB, Buttons, AdvGrid, dbadvgrd, TFlatComboBoxUnit,
   TFlatEditUnit, QuickRpt, Qrctrls, TFlatMemoUnit, TFlatButtonUnit; // _adel

{
procedure SetWndHandle(Value: HWND); stdcall; external 'testpass.dll';
procedure SetHookHandle(hHandle: HHOOK); stdcall; external 'testpass.dll';
function GetHookHandle: HHOOK; stdcall; external 'testpass.dll';
function GetHDll: HINST; stdcall; external 'testpass.dll';
}

type
   MsgHookProc = function(nCode: Integer; wParam: WPARAM; lParam: LPARAM): Lresult; stdcall;
var
   Peedy: IagentCtlCharacter; // Ex
   Request1, Request2: IagentCtlRequest;
   g_diff, gint_rptflag, m_lang, Gint_module, gint_top, gint_left, gint_width, gint_height: integer;
   Gstr_compu, tran_str, gstr_pubdate: string;
   g_bsel: boolean;
   null_msg, re_input, fema_msg, male_msg: string;

   //stringGrid 公共控制函数
function Check_sg(sg_jl: Tstringgrid; arow: integer = 1; specrow: boolean = false): boolean;
function count_wy(sg_jl: tstringgrid; bzl: integer; s_bz: string; inhotel: smallint = 0; m_bpart: boolean = false): integer;
function search_no(sg_jl: tstringGrid; bzl: integer; s_bz: string): integer;
function noedit_sg(sg_jl: Tstringgrid; bzl: integer = 0): boolean;
function lastcol_sg(sg_jl: Tstringgrid): integer;
function check_name(s, m_name: string): boolean;
function trim_wy(m_src: string; m_flag: smallint = 0): string;
function clear_name(m_src: string): string;
function cryptstr(const s: string; stype: dword): string;
function encrypt_str(Src: string; Key: string; Encrypt: Boolean; m_brand: boolean = true): string;
procedure fresh_menu(m_menu: TMainMenu; coolbar: TCoolBar);
function getEventName(v, o: TComponent; Event: string): string;
function get_bn_name(mn_name: string; coolbar: TCoolbar): string;
function findfile(FFileName: string): boolean;

function sg_locate_wy(sg_jl: TAdvStringGrid; bzl: integer = 0): integer;
function Clear_sg(sg_jl: Tadvstringgrid; yes: bool = true; enable: bool = true; acol: integer = 10): integer;
function verifydate_sg(sg_jl: TAdvStringGrid; acol, arow: integer; dat: string = ''): Boolean;
function compare_date(adate, ddate: string): string;
procedure bold_sg(sg_jl: TAdvStringGrid);
function copy_wy(m_src: string): string;
function gtd_name(m_gtd: integer): string;
function input_date: string;

function search_list_wy(m_list: TStringList; m_src: string): string;
procedure chg_prnsize(sender: TQuickRep);
procedure clear_sg_wy(sg: TAdvStringGrid); //此函数仅用於清空 STRING GRID 中的数据, 不能用於数据修改
procedure del_sg_wy(sg_jl: tstringgrid; var updrow: integer; bzl: integer = 0; mcl: integer = 0);
procedure after_save_wy(sg_jl: tadvstringgrid); overload;
procedure after_save_wy(sg_jl: tstringgrid; setflag: boolean = true; bzl: integer = 0; mcl: integer = 0); overload;
procedure jshjs_wy(sg_jl: TStringGrid; var secondr: integer; index: integer);
procedure str_grid_wy(sg: tstringgrid; var arow: integer); //此函数仅用於清空 STRING GRID 中的数据, 能用於数据修改
procedure title_sg_wy(sg: tadvstringgrid; title: string; m_bSpace: boolean = true); //此函数仅用於为 STRING GRID 第一行命名标题
procedure title_dbsg_wy(sg: tDBAdvStringgrid; title: string);
procedure bztomc_wy(sg_jl: tstringgrid; bzl: integer; mcl: integer);
procedure replace_mask(Sender: TObject; m_mask: string = '#,##0.0');

function comp_year(adate, ddate: string): boolean;
function space_wy(m_src: string; m_len: integer): string;
function SpeedInput(btime, etime: Cardinal): boolean; //n-毫秒

procedure corr_birth(sender: TObject);
procedure refresh_pubdate;
procedure query_db(m_strsql: string; m_shint: string = '');
procedure ClearAll(Sender: TObject; m_bsg: bool = true);
procedure Flat_repaint(Sender: TObject; m_bsg: bool = true);
procedure MakeRounded(Control: TWinControl);
procedure common_deal(QuickRep1: TQuickRep; rpt_name: string = '');
function chk_eng(m_src: string): boolean;
function IsEMail(EMail: string): Boolean;

function CRCCheck(data: string): string;
function IsNum_wy(Input: string): boolean;
function UpperCase_WY(Input: string): string;
function getlunar_day(m_date: TDatetime): string;
function getindex(combo: TFlatComBoBox; s: string): Integer;
function boxsStr(boxs: tcombobox; s: string): Integer; overload;
function boxsStr(boxs: tflatcombobox; s: string): Integer; overload;
function dateadd(month: integer; yymmdd, startdate: string): string;
function Check_pn(pn_room: TPanel): boolean;
function GetSex(s: string): string; overload;
function GetSex(i: integer): string; overload;
function GetStr(s: string; ret: string = '0'; onlychar: boolean = false): string;
function GetPartStr(s: string; flag: string = '-'; ret: string = '0'; front: boolean = true; onlychar: boolean = false): string;
function iif(flag: boolean; A_ret: string; B_ret: string): string; overload;
function iif(flag: boolean; A_ret: integer; B_ret: integer): integer; overload;
function iif(flag: boolean; A_ret: tdatetime; B_ret: tdatetime): tdatetime; overload;
function iif(flag: boolean; A_ret: boolean; B_ret: boolean): boolean; overload;
function OnlyCharIn(Input: string): string;
function Only_Space(Input: string; var m_bEng: boolean; var m_sIdx: string; var m_sEng: string): string;
function beauty_str(m_src: string): string;
function gethellotext(hello: string; var sex: string): string;
function getremarktext(remark: string; m_flag: integer = 0): string;
function nextvip(m_vip: string; updown: integer): string;
function comp_zero(m_zero: string): Boolean;
function bow_str(m_str: string): string;

function XxToDx(const hjnum: real): string;
function WeekofYear(Date: TDate): integer;
function UnicodeToAnsi(Unicode: string): string;
function AnsiToUnicode(Ansi: string): string;
//procedure Jpg2Bmp(const source, dest: string);
//procedure Bmp2Jpg(const source, dest: string; const scale: byte);

//去除多馀空格,字符串间仅保留一个空格 //验证该字符串是否为纯英文字符串  //如该字符串为纯英文字符串,返回 IDX
function IsHz(Source: string): Bool;
function getmaxdate(m_adate: string): TDatetime; //此函数可用於输入时间
function Only_Tim(Key: char): char; //此函数可用於输入时间
function Only_dat(Key: char): char; //此函数可用於输入日期
function Only_Num(Key: char): char; //此函数仅用於输入各类流水号
function Only_CHR(Key: char): char; //此函数仅用於输入各类流水号
function Only_Mon(Key: char): char; //此函数可用於输入浮点数
function Only_Ansi(Key: char): char; //此函数可用於输入浮点数
function ReplaceChr(s, m_src, m_des: string): string;
function ReplaceStr(s: string; Src: string; Des: string): string;
function VerifyDate(Sender: TObject; dat: string = ''): Boolean;
function VerifyTime(Sender: TObject): Boolean;
function InputBox_wy(s_cap: string = '输入框'; s_hint: string = '输入值'; s_def: string = ''; def_ret: string = ''; input_type: integer = 0): string;

function analy_com_wy(Sender: TObject; m_bpass: boolean = false): boolean;
procedure ClearPn_wy(Sender: Tpanel; m_bAll: bool; m_bsg: bool = false);
procedure enablepn_wy(Sender: Tpanel; m_bFlag: bool; m_ball: boolean = false);
procedure visiblepn_wy(Sender: Tpanel; m_bFlag: bool);
procedure colorpn_wy(Sender: Tpanel; m_color: integer; m_ball: boolean = false);
procedure colorpn_font_wy(Sender: Tpanel; m_color: integer);

function padl(source: string; len: integer; ps: string): string;
function analy_str(flag: string; m_str: string = ''; m_flag: string = '*'): string;
function datetostr(adate: Tdatetime; hhmm: integer = 0): string;
function max_day_wy(yea: string; mon: string): string;
function rst_name(rst: integer): string;
function trans_money_wy(s: real): string;
function getlist_wy(cls: string; strlist: TStringList; front: bool = true): string;
function trans_lst_wy(cls: integer; strlist: TStringList; front: bool = true): string; overload;
function trans_lst_wy(cls: string; strlist: TStringList; front: bool = true): integer; overload;
function getnextyear(m_date: string; m_flag: integer = 0): string;

function GetWindowsVer: string;
function cstr(mon: currency; i, j: integer): string;
function verifydate_lsy(Sender: TObject; const Str: string; dat: string = ''): Boolean;
function WinDir(optWin: integer): string;
function pstomc(ps: integer): string; //付款状态对应名称
function ctltomc(ctl: integer): string; //签单状态对应名称
function vipname(vflag: integer): string; //VIP卡对应类别
function OnlyNum(Key: char): char;

procedure TextClearAll(Sender: TForm);
procedure Switch_off_menu(Sender: TObject);
procedure SetHook;
procedure unhook;
function Space(n: integer): string;
function read_card_ck_std(sInitStr: string): string;

implementation
uses
   qrprntr, QRPDFFilter, QRExport, QRPDFFilt, qrwebfilt, U_WEB_INPUT, U_WEB_LOCATE, imcode, calfunc; //, //
//   U_RECA_DM;

function SpeedInput(btime, etime: Cardinal): boolean; //n-毫秒
begin
   result := false;
   if etime - btime <= 1000 then
      begin
         result := true;
      end;
end;

procedure replace_mask(Sender: TObject; m_mask: string = '#,##0.0');
var
   i: Integer;
   qrtext: TQRDBText;
   qrexpr: TQRExpr;
begin
   for i := 0 to (Sender as TForm).ComponentCount - 1 do
      begin
         if ((Sender as TForm).Components[i] is TQRDBText) then
            begin
               qrtext := TQRDBText((Sender as TForm).Components[I]);
               if qrtext.mask = '#,##0.0' then
                  qrtext.mask := '#,##0.00'
               else
                  if qrtext.mask = '#,###.#' then
                  qrtext.mask := '#,###.##';
            end
         else
            if ((Sender as TForm).Components[i] is TQRExpr) then
            begin
               qrexpr := TQRExpr((Sender as TForm).Components[I]);
               if qrexpr.mask = '#,##0.0' then
                  qrexpr.mask := '#,##0.00'
               else
                  if qrexpr.mask = '#,###.#' then
                  qrexpr.mask := '#,###.##';
            end;
      end;
end;

function IsEMail(EMail: string): Boolean;
var
   s: string;
   ETpos: Integer;
begin
   ETpos := pos('@', EMail);
   if ETpos > 1 then
      begin
         s := copy(EMail, ETpos + 1, Length(EMail));
         if (pos('.', s) > 1) and (pos('.', s) < length(s)) then
            Result := true
         else
            Result := false;
      end
   else
      Result := false;
end;

procedure chg_prnsize(sender: TQuickRep);
begin
   //if (gint_psize = 1) and (sender.page.Orientation = poPortrait) then
   with sender.Page do
      begin
         PaperSize := A4;
         LeftMargin := 2;
         TopMargin := 20;
      end;
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