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';
}
const
   frm_web_other = 0;
   frm_web_chat = 1;
type
   MsgHookProc = function(nCode: Integer; wParam: WPARAM; lParam: LPARAM): Lresult; stdcall;
var
   Peedy: IagentCtlCharacter; // Ex
   Request1, Request2: IagentCtlRequest;
   g_bsel: boolean;
   g_diff, gint_rptflag, m_lang, Gint_module, gint_top, gint_left, gint_width, gint_height: integer;
   g_mshow: integer;
   Gstr_SerIP, Gstr_MyIP, Gstr_MyAcc: string;
   gint_chatfrm, Gint_SerPORT, Gint_MyPort, gint_dec: integer;

   Gstr_compu, tran_str, gstr_pubdate: string;
   sys_day, date_msg, pre_msg, late_msg, null_zero_msg, null_msg, right_msg, nodata_msg, re_input, fema_msg, male_msg, inst_excel, del_msg, asksave_msg: string;
   succ_msg, err_msg: string;
   col_width: array[0..60] of integer;

   //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;
procedure display_v_sg(sg_jl: TAdvStringGrid; m_sql: string; m_col, m_field, m_diff: integer);
function RepeatStr(i: Integer; m_bask: boolean = false): string;

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 OnlyCharIn(Input: string): string;
function GetStr(s: string; ret: string = '0'; onlychar: boolean = false): string;
function analy_str(m_fir: string; m_src: string = ''; m_end: string = '*'): 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 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; dat: string = ''): Boolean;
function inc_date(m_adate: string; m_up: integer): string;
function inc_time(m_atime: string; m_up: integer): string;

function InputBox_wy(s_cap: string = '输入框'; s_hint: string = '输入值'; s_def: string = ''; def_ret: string = ''; input_type: integer = 0): string;
procedure init_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 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
   p2p_public, U_WEB_DM, qstrings,
   qrprntr, QRPDFFilter, QRExport, QRPDFFilt, qrwebfilt, imcode, calfunc, U_WEB_INPUT, U_WEB_LOCATE; //, //
//   U_RECA_DM;

function RepeatStr(i: Integer; m_bask: boolean = false): string;
begin
   if m_bask then
      result := '与表格中第 ' + inttostr(i) + ' 行重复,是否继续?'
   else
      result := '与表格中第 ' + inttostr(i) + ' 行重复!';
end;

procedure init_string;
begin
   male_msg := iif(m_lang = 1, '男', 'MAN');
   fema_msg := iif(m_lang = 1, '女', 'LADY');
   right_msg := iif(m_lang = 1, '您权限级别不够!', 'YOU HAVE NOT ENOUGH RIGHT !');
   nodata_msg := iif(m_lang = 1, '系统无相应资料!', 'NO CORRESPONDING INFO!');
   re_input := iif(m_lang = 1, ', 请确认后重输!', ', PLEASE REINPUT!');
   null_zero_msg := iif(m_lang = 1, ' 不能为零、为空!', ' CAN''T BE NULL OR ZERO ');
   null_msg := iif(m_lang = 1, ' 不能为空!', ' CAN''T BE NULL ');
   inst_excel := iif(m_lang = 1, '请安装Ms Excel !', 'PLEASE SETUP EXCEL APPLICATION !');
   asksave_msg := iif(m_lang = 1, '数据尚未保存, 确认退出?', 'DATA DOES NOT BE SAVED,MAKE SURE TO QUIT ?');
   del_msg := iif(m_lang = 1, '确认删除(Y/N)?', 'BE SURE TO DELETE (Y/N)');
   date_msg := iif(m_lang = 1, '截止日期不能早於起始日期!', 'END DATE MUST <= BEGIN DATE');
   pre_msg := iif(m_lang = 1, ' 不能小於 ', ' CAN''T < ');
   late_msg := iif(m_lang = 1, ' 不能大於 ', ' CAN''T > ');
   sys_day := iif(m_lang = 1, ' 系统日期!', 'SYSTEM DATE!');
   succ_msg := iif(m_lang = 1, '数据已保存!', 'DATA SAVE SUCCESSFULLY!');
   err_msg := iif(m_lang = 1, '数据未存入数据库, 请查原因!', 'SAVE FAILED !');

   {select_msg := iif(m_lang = 1, '不能不选!', ' CAN''T UNSELECT ');
   no_exist_msg := iif(m_lang = 1, ' 不存在', ' DOES NOT EXISTS ');

   exit_msg := iif(m_lang = 1, '确认退出?', 'MAKE SURE TO QUIT ?');
   succ1_msg := iif(m_lang = 1, ' 已保存!', ' SAVED!');
   prn_msg := iif(m_lang = 1, '程序异常, 请稍候再试!', 'APPLICATION ERROR,PLEASE TRY AGAIN SOME MOMENT LATER!');

   with f_reca_dm.qy_wangy do
      begin
         close;
         sql.Clear;
         sql.Add('select htlname,htlnamee from config_gd');
         open;
         case m_lang of
            1: gstr_htlname := fieldbyname('htlname').asstring;
            2: gstr_htlname := fieldbyname('htlnamee').asstring;
         end;
         close;
      end;

   m_hintrm := iif(m_lang = 1, '号房已被', '] ROOM HAVE BEEN ['); //""
   disc_msg := iif(m_lang = 1, '折扣无效, 请确认后重输!', 'INVALID DISCOUNT, PLEASE REINPUT!');
   curr_day := iif(m_lang = 1, '今天!', 'TODAY!');
   adate_msg := iif(m_lang = 1, '起始日期', 'BEG DATE');
   ddate_msg := iif(m_lang = 1, '截止日期', 'ENG DATE');
   pass_err := iif(m_lang = 1, '身份证号输入不正确!', 'INCORRECT PASSID');
   permit_msg := iif(m_lang = 1, '1 - 允许', '1 - ALLOW');
   forbid_msg := iif(m_lang = 1, '0 - 禁止', '0 - FORBID');
   msg_fit := iif(m_lang = 1, 'F - 散客', 'F - FIT');
   msg_group := iif(m_lang = 1, 'G - 团队', 'G - GROUP');
   msg_meeting := iif(m_lang = 1, 'M - 会议', 'M - MEETING');
   yes_msg := iif(m_lang = 1, '是', 'YES');
   no_msg := iif(m_lang = 1, '否', 'NO');

   case m_lang of
      1: msg_rmddate := '住客离店时间 不能晚於 该客房离店时间, 否则,须将'#13#10#13#10'客房离店时间 修改为 该住客离店时间' + msg_continue;
      2: msg_rmddate := 'GST DEPA TIME CAN''T LATER THAN DEPA TIME,OR ELSE, MUST MODIFY ROOM DEPA TIME TO GST DEPA TIME, CONTINUE?';
   end;
   msg_scan := iif(m_lang = 1, ' 已存有签名样式, 如保存将覆盖原签名, 是否先调阅, 再决定(否则直接覆盖)? ', ' ''S SIGNATURE HAD BEEN SAVED,SELECT NO TO OVERWRITE IT OR SELECT YES TO VIEW IT FIRST,YES OR NO ?');
   msg_issue_key := iif(m_lang = 1, '是否发卡?', 'ISSUE KEYCARDS?');
   msg_zero := iif(m_lang = 1, '您录入的金额为零,是否继续?', 'THE AMOUNT IS ZERO,CONTINUE?');
   sel_msg := iif(m_lang = 1, '请先选中表格中某一条记录!', 'PLEASE SELECT A RECORD FROM GRID AT FIRST !');
   msg_bill := iif(m_lang = 1, '当日费用不可输入负数, 负数只用於冲减往日费用!', 'YOU CAN''T INPUT NEGATIVE,NEGATIVE IS USED TO REBATE!');
   msg_fsave := iif(m_lang = 1, '该客房为保留房', 'THE ROOM HAS BEEN RESERVED');
   msg_nochkin := iif(m_lang = 1, '该客房尚未办理入住', 'THE ROOM HAS NOT CHECKED IN');
   //msg_noexist := iif(m_lang = 1, '该客房不存在', 'THE ROOM DOES NOT EXIST');
   msg_the_room := iif(m_lang = 1, '该客房', 'THE ROOM');
   msg_this_room_is := iif(m_lang = 1, '该客房为', 'THE ROOM IS '); // //" "
   max_pax_msg := iif(m_lang = 1, '酒店最大允许数! ', 'THE MAX AMOUNT !');
   msg_person_max := iif(m_lang = 1, '酒店最大允许数!', 'MAX PERSON!');
   msg_person := iif(m_lang = 1, '住客人数', 'GST RM PAX'); //""
   msg_savedrm := iif(m_lang = 1, '保留房', 'SAVED ROOM'); // //""
   msg_paying := iif(m_lang = 1, '该客房正在进行结帐', 'THE ROOM IS PAYING '); //""
   msg_length_rm := iif(m_lang = 1, '房号长度应为 ', 'ROOM LENGTH SHOULD BE '); // ""
   msg_bit := iif(m_lang = 1, ' 位 ', ' BIT '); //""
   msg_gst_in := iif(m_lang = 1, '该房尚无客人入住!', 'THE ROOM IS NOT OCCUPIED!'); //""
   msg_continue := iif(m_lang = 1, ',是否继续?', ', CONTINUE?'); //""
   msg_rm_person := iif(m_lang = 1, '客房人均住客数', 'GST RM AVERAGE PAX'); //""
   msg_right_click := iif(m_lang = 1, '    **右击看同行房**', '   **RIGHT CLICK TO VIEW THE ROOMS WENT ALONG** '); //"GST RM PAX"
   msg_select_corp := iif(m_lang = 1, '请先选定协议类型,再选择协议公司!', 'SELECT CONTRACT TYPE FIRST BEFORE SELECT CORP!'); //""
   msg_blkrm_used := iif(m_lang = 1, '该类客房已经排满, 请确认!', 'THE KIND OF GST ROOM HAVE BLKED FULL!'); //""
   msg_blkrm_over := iif(m_lang = 1, '该客人订房数已用完, 请确认!', 'NEW ARR RMS OF THE GUEST USED UP!'); //""
   msg_chkinrm_used := iif(m_lang = 1, '该客人新入住客房数已用完, 请确认!', 'BLK RMS OF THE GUEST USED UP!'); //""
   msg_pwd_length := iif(m_lang = 1, '身份证号长度应为 15 / 18 位!', 'PASSID LENGTH IS 15 / 18 BIT !'); //
   msg_setup_savedrm := iif(m_lang = 1, '置为保留房!', 'SET AS SAVED ROOM'); //

   prnask_msg := iif(m_lang = 1, '是否先预览?', 'WOULD YOU PREVIEW THE REPORT?');
   iarate_msg := iif(m_lang = 1, '输入加收的房租和服务费', 'ENTER EXTRA RM RATE AND SVR CHG');
   ext_hdrate := iif(m_lang = 1, '加收半天房租?', 'EXTRA HALF DAY RATE');
   ext_fdrate := iif(m_lang = 1, '加收一天房租?', 'EXTRA ONE DAY RATE?');
   day_rate := iif(m_lang = 1, '输入当日入住退房房租和服务费', 'ENTER DAY LATE RM RATE AND SVR CHG');
   drate_ask := iif(m_lang = 1, '当天入住退房, 收房费 ?', 'THE ROOM IS DAY LATE,PAY RATE?');
   bbrq_input := iif(m_lang = 1, '请输入报表日期:', 'PLEASE INPUT REPORT DATE:');
   input_box := iif(m_lang = 1, '输入框', 'INPUT BOX');
   nogrp_in := iif(m_lang = 1, '无在住团队和会议!', 'NO OCCUPIED GROUP AND MEETING!');
   noroom_msg := iif(m_lang = 1, '无此房号或房态不合要求,请检查!', 'NO THIS ROOM OR RST NOT SIZE UP! ');
   room_iscash := iif(m_lang = 1, '此房正在结帐!若是程序非正常关闭,导致正在结帐的情况,可通过签单抵押来取消', 'THE ROOM IS PAYING !');
   endcash_ask := iif(m_lang = 1, '退出结帐 ?', 'QUIT PAY ?');
   meet_room := iif(m_lang = 1, '成员房间 [', 'MEMBER ROOM [');
   endcash_msg := iif(m_lang = 1, ']签单状态为<正在结帐>, 结帐中止!', '] CTL STATUS IS <PAYING>, PAY STOP!');
   nosucess := iif(m_lang = 1, '失败!', 'UNSUCCESS !');
   need_tsfw := iif(m_lang = 1, '要求特服', 'SP.SVR REQ');
   spec_msg := iif(m_lang = 1, '重要信息', 'IMPT INFO');
   zk_msg := iif(m_lang = 1, '住客留言', 'GST MSG');
   fk_msg := iif(m_lang = 1, '访客留言', 'VISIT MSG');
   pt_unset := iif(m_lang = 1, '付款方式未设置!', 'PAY TYPE UNSET!');
   cost_unset := iif(m_lang = 1, '费用项目未设置!', 'NOT SET COST ITEM');
   input_card := iif(m_lang = 1, '请确认刷卡後使用积分消费!', '');
   setup_exl := iif(m_lang = 1, '请安装Ms Excel !', 'PLEASE SETUP EXCEL APPLICATION !');
   nobill_msg := iif(m_lang = 1, '没有帐单!', ' NO BILL !');
   days := iif(m_lang = 1, '/天', '/DAY');
   gen_flag := iif(m_lang = 1, ' 班', 'SHFT');
   input_money := iif(m_lang = 1, '必须录入金额!', ' MUST INPUT AMOUNT !');
   plz_input := iif(m_lang = 1, '请输入', 'PLEASE INPUT ');
   date_msg1 := iif(m_lang = 1, '日期', 'DATE ');
   time_msg := iif(m_lang = 1, '时间', 'TIME ');
   prn_date := iif(m_lang = 1, '日期:', 'DATE: ');
   prn_opno := iif(m_lang = 1, '制表:', 'OPNO: ');
   this_gen := iif(m_lang = 1, '当班', 'THE SHFT');
   the_opno := iif(m_lang = 1, ' 工号:', 'OPNO: ');
   str_fee1 := iif(m_lang = 1, '保 险 费', 'INSUR');
   str_fee2 := iif(m_lang = 1, '政 府 税', 'TAX');
   str_fee3 := iif(m_lang = 1, '保险费', 'INSUR');
   str_fee4 := iif(m_lang = 1, '政府税', 'TAX');
   sure_update := iif(m_lang = 1, '确认数据修改?', 'BE SURE TO MODIFY DATA ?');
   prn_time := iif(m_lang = 1, '           打印时间:', '         PRINT TIME:'); }
end;

procedure display_v_sg(sg_jl: TAdvStringGrid; m_sql: string; m_col, m_field, m_diff: integer);
var
   i, j, k, m_colcount, arow, m_flag: integer;
   s, s1: string;
begin
   arow := 0;
   s1 := '';