很希望大家把自己做项目中的小技巧共享出来

时间：2021-06-02 02:48:46
很久没有在CSDN首页看到Delphi的技术分享贴了，大家努力啊~

193 个解决方案

#1

我来第一个：
在使用Delphi中，如果我们想存放一组对象时，用ObjectList最方便
如果将TObjectList的OwnsObjects属性设为True,那么Objectlist将自动管理数组成员的生命期~
例：
UserList:=TObjectList.Create(True)
此外还有Add,Remove等方法~

#2

不过要想从ObjectList取出对象时，需要向下转型

#3

不错~板凳~~

#4

不错~地板~~

#5

楼上大哥们，赏个技巧吧~
这样的贴子大家都不想沉下去~

#6

使用bcb6开发，开发包提供的是vc6开发的dll和lib文件，使用bcb6 bin目录下的工具：coff2omf   a.lib   b.lib   
将库文件a.lib转换格式生成库文件b.lib
coff2omf可以转换微软的COFF格式为Borland使用的OMF格式
在bcb6中导入即可直接调用了！

另外：tdump   -ee   mydll.dll   >1.txt  
研究一下别的程序或者dll里边调用了什么函数

#7

在Delphi数据库中，一些朋友的SQL语句写不出来，其实就是对相关子查询不熟悉，现在我总结一下~

自己总结的，不对请大家指正~：）
--相关子查询与普通子查询的区别在于：相关子查询引用了外部查询中的列！这种用外部查询来限制子查询的方法使
SQL查询变得更加强大和灵活。因为相关子查询能够引用外部查询，所以它们尤其适合编写复杂的where条件！
相关子查询不能自己单独运行，其执行顺序如下：
1.首先执行一次外部查询
2.对于外部查询中的每一行分别执行一次子查询，而且每次执行子查询时都会引用外部查询中当前行的值。
3.使用子查询的结果来确定外部查询的结果集。
如果外部查询返回100行，SQL 就将执行101次查询，一次执行外部查询，然后为外部查询返回的每一行执行一次子查询。但实际上，SQL的查询
优化器有可能会找到一种更好的方法来执行相关子查询，而不需要实际执行101次查询。

相关子查询典型用法：
declare @t table(rq varchar(10),hh int,ye dec(6,2))
insert into @t select '2006-01-02'    ,1111    ,2.01
union all select '2006-01-05'    ,1111    ,3.51
union all select '2006-01-10'    ,1111    ,2.55
union all select '2006-01-02'    ,2222    ,3.00
union all select '2006-01-04'    ,2222    ,2.00
union all select '2006-01-05'    ,3333    ,6.54
union all select '2006-01-06'    ,3333    ,5.23
union all select '2006-01-07'    ,3333    ,8.55

select * from @t a where not exists(select 1 from @t where hh=a.hh and rq>a.rq)

#8

D7以上版本的indy提供的IdStrings.pas里面有几个很有用处的字符处理函数

#9

不错

#10

不错,呵呵

#11

真是服了Delphi版了，这样的贴子也没人顶~

#12

我来顶了~~~呵呵,接点分

#13

呵呵，偶以前提过这样的问题，结果也是没有多少人参与

#14

up,go on study!

#15

友情关注。

#16

向前拱

#17

使用Delphi调用开源软件SQLITE函数：

sqlite引擎在Delphi中的应用从 www.sqlite.org 网站可下载到最新的 sqlite 代码

sqlite源文件：sqlite3.c和sqlite3.h。首先编译成OBJ,编译生成sqlite3.obj

   bcc32 -pc -RT- -O -w- -6 -I(bcc32)\include -c SQLite3.c

bcc32为BCB6中的工具，在Bin目录中。

DELPHI中引用 {$L 'OBJ\sqlite3.obj'} 即可调用其中的函数.

如果不想直接调用可使用第三方组件：ASQLite

关于Sqlite可自行在网上查询相关资料。

#18

up, 偶先想想再回。

#19

大家看一下ASP.NET版的技术共享贴(置顶贴),有好多人把技术拿出来，Delphi版怎么就不能呢？

#20

Delphi存在了这么多年，基本上能遇到的问题别人都问过了，
而且收集整理各种资料的事情，也早就有人在做，
大富翁离线资料、CSDN的FAQ、Delphi超级猛料、delphi未经证实葵花宝典
这些资料都已经很全了
还是别做重复劳动的好

#21

up

#22

上首页了,过来看看...

#23

我认为自己最能拿出手的东西，
可以做个基类使用，主要功能就是是子类的用户输入控件可以自动变色，
不必考虑种类繁多的第三方控件,
只要是有Color，OnEnter，OnExit，OnChange属性就行。
unit Ufrmbase;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons,typinfo;
type
  Tfrmbase = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure CmpEnter(Sender: TObject); //用户获得焦点
    procedure CmpExit(Sender: TObject); //用户失去焦点
  public
    { Public declarations }
  protected
    procedure pSetComponents;
  end;

var
  frmbase: Tfrmbase;
  //以后应该是可以设置的。风格管理，可以保存在注册表中
const
  ENTERC0LOR = $00CDBDB4;
  EXITCOLOR = $00DAF3DD;
implementation
{$R *.dfm}
procedure Tfrmbase.CmpEnter(Sender: TObject);
var
  sProp: PPropInfo;
begin
  sProp := GetPropInfo(Sender.ClassInfo, 'Color');
  if sProp <> nil then
    SetOrdProp(Sender, sProp, ENTERC0LOR);
end;

procedure Tfrmbase.CmpExit(Sender: TObject);
var
  sProp: PPropInfo;
begin
  sProp := GetPropInfo(Sender.ClassInfo, 'Color');
  if sProp <> nil then
    SetOrdProp(Sender, sProp, EXITCOLOR);
end;

procedure Tfrmbase.pSetComponents;
var
  i: Integer;
  sColor, sEnter, sExit, sChanged: PPropInfo;
  vEnter, vExit: TMethod;
  mEvent: TNotifyEvent;
begin
  for i := 0 to componentcount - 1 do
  begin
    sColor := GetPropInfo(Components[i].ClassInfo, 'Color');
    sEnter := GetPropInfo(Components[i].ClassInfo, 'OnEnter');
    sExit := GetPropInfo(Components[i].ClassInfo, 'OnExit');
    sChanged := GetPropInfo(Components[i].ClassInfo, 'OnChange');
    if (sChanged <> nil) and (sEnter <> nil) and
      (sExit <> nil) and (sColor <> nil) then
    begin
      SetOrdProp(Components[i], sColor, EXITCOLOR);
      mEvent := CmpEnter;
      vEnter.Code := @mEvent;
      vEnter.Data := Self;
      SetMethodProp(Components[i], sEnter, vEnter);
      mEvent := CmpExit;
      vExit.Code := @mEvent;
      vExit.Data := Self;
      SetMethodProp(Components[i], sExit, vExit);
    end;
  end;

end;

procedure Tfrmbase.FormCreate(Sender: TObject);
begin
  pSetComponents;
end;
end.

#24

{$Message Hint '比较好找'}

#25

不错，顶一下

#26

不错不错，大家继续~

#27

帮顶

#28

先顶上去，待会再共享点东西上来。

#29

顶先

#30

不错

#31

mark

#32

//--------------
如果要在窗体的画布上画图，消除重画时窗体的闪烁，可以在窗体创建时设置双内存机制。
self.doublebuffered:=true;

好处是：重画时（onPain()）窗体不会闪烁；
不足是：内存消耗较大；

//--------------
将数据加载到内存时，我们多使用动态数组，动态数组的使用是比较好用的。
1、生存期管理是由编译负责；
2、增加长度时，重新SetLength()不会影响原有的数据；
3、从数组中删除某个元素时，可以采用将数据项向前移的方法，移动完数据后，可以重新分配数组长度（缩短）；
4、使用记录类型数据的数组时，可以在记录类型中加入管理方法，实现对记录类型数据中，对象类型数据的管理；






#33

对于返回TStringList类型的函数常见的问题~ 

function TForm1.getlist:Tstringlist;
begin
  result:=TStringList.Create;
  result.Add('1');
  result.Add('2');
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  str:TStrings;
begin
 // str:=TStringList.Create;内存泄露
  str:=getlist;
  showmessage(str.Text);
  str.Free;
end;


//造成内存泄露的主要原因是程序员没有把对象与对象引用搞清楚~

#34

很难看到了，顶下

#35

不错，以上还有些好贴，不过，我有一个拼音首字母的用法，大家用过*时刻表吗？里面就有首字输入法
我有一个单元。
unit IMCode;

interface

function MakeSpellCode(stText: string; iMode, iCount: Integer): string;
{ iMode 二进制功能位说明
  X X X X X X X X X X X X X X X X
                            3 2 1
  1: 0 - 只取各个汉字声母的第一个字母; 1 - 全取
  2: 0 - 遇到不能翻译的字符不翻译; 1 - 翻译成 '?' (本选项目针对全角字符)
  3: 0 - 生成的串不包括非数字, 字母的其他字符; 1 - 包括
     (控制全角的要输出非数字, 字母字符的; 半角的非数字, 字母字符)
}

function GetSpellCode(szText: PChar; iMode, iCount: Integer): PChar; stdcall;

implementation

uses
  SysUtils;

type
 { 拼音代码表 }
  TPYCode = record
    PYCode: string[6];
  end;
  TFPYCodes = array [1..126, 1..191] of TPYCode;

const
  PYMUSICCOUNT = 405;
  PyMusicCode: array [1..PYMUSICCOUNT] of string[6] = { 汉字基本发音表 } (
    'a', 'ai', 'an', 'ang', 'ao', 'ba', 'bai', 'ban', 'bang', 'bao',
    'bei', 'ben', 'beng', 'bi', 'bian', 'biao', 'bie', 'bin', 'bing', 'bo',
    'bu', 'ca', 'cai', 'can', 'cang', 'cao', 'ce', 'ceng', 'cha', 'chai',
    'chan', 'chang', 'chao', 'che', 'chen', 'cheng', 'chi', 'chong', 'chou', 'chu',
    'chuai', 'chuan', 'chuang', 'chui', 'chun', 'chuo', 'ci', 'cong', 'cou', 'cu',
    'cuan', 'cui', 'cun', 'cuo', 'da', 'dai', 'dan', 'dang', 'dao', 'de',
    'deng', 'di', 'dian', 'diao', 'die', 'ding', 'diu', 'dong', 'dou', 'du',
    'duan', 'dui', 'dun', 'duo', 'e', 'en', 'er', 'fa', 'fan', 'fang',
    'fei', 'fen', 'feng', 'fu', 'fou', 'ga', 'gai', 'gan', 'gang', 'gao',
    'ge', 'ji', 'gen', 'geng', 'gong', 'gou', 'gu', 'gua', 'guai', 'guan',
    'guang', 'gui', 'gun', 'guo', 'ha', 'hai', 'han', 'hang', 'hao', 'he',
    'hei', 'hen', 'heng', 'hong', 'hou', 'hu', 'hua', 'huai', 'huan', 'huang',
    'hui', 'hun', 'huo', 'jia', 'jian', 'jiang', 'qiao', 'jiao', 'jie', 'jin',
    'jing', 'jiong', 'jiu', 'ju', 'juan', 'jue', 'jun', 'ka', 'kai', 'kan',
    'kang', 'kao', 'ke', 'ken', 'keng', 'kong', 'kou', 'ku', 'kua', 'kuai',
    'kuan', 'kuang', 'kui', 'kun', 'kuo', 'la', 'lai', 'lan', 'lang', 'lao',
    'le', 'lei', 'leng', 'li', 'lia', 'lian', 'liang', 'liao', 'lie', 'lin',
    'ling', 'liu', 'long', 'lou', 'lu', 'luan', 'lue', 'lun', 'luo', 'ma',
    'mai', 'man', 'mang', 'mao', 'me', 'mei', 'men', 'meng', 'mi', 'mian',
    'miao', 'mie', 'min', 'ming', 'miu', 'mo', 'mou', 'mu', 'na', 'nai',
    'nan', 'nang', 'nao', 'ne', 'nei', 'nen', 'neng', 'ni', 'nian', 'niang',
    'niao', 'nie', 'nin', 'ning', 'niu', 'nong', 'nu', 'nuan', 'nue', 'yao',
    'nuo', 'o', 'ou', 'pa', 'pai', 'pan', 'pang', 'pao', 'pei', 'pen',
    'peng', 'pi', 'pian', 'piao', 'pie', 'pin', 'ping', 'po', 'pou', 'pu',
    'qi', 'qia', 'qian', 'qiang', 'qie', 'qin', 'qing', 'qiong', 'qiu', 'qu',
    'quan', 'que', 'qun', 'ran', 'rang', 'rao', 're', 'ren', 'reng', 'ri',
    'rong', 'rou', 'ru', 'ruan', 'rui', 'run', 'ruo', 'sa', 'sai', 'san',
    'sang', 'sao', 'se', 'sen', 'seng', 'sha', 'shai', 'shan', 'shang', 'shao',
    'she', 'shen', 'sheng', 'shi', 'shou', 'shu', 'shua', 'shuai', 'shuan', 'shuang',
    'shui', 'shun', 'shuo', 'si', 'song', 'sou', 'su', 'suan', 'sui', 'sun',
    'suo', 'ta', 'tai', 'tan', 'tang', 'tao', 'te', 'teng', 'ti', 'tian',
    'tiao', 'tie', 'ting', 'tong', 'tou', 'tu', 'tuan', 'tui', 'tun', 'tuo',
    'wa', 'wai', 'wan', 'wang', 'wei', 'wen', 'weng', 'wo', 'wu', 'xi',
    'xia', 'xian', 'xiang', 'xiao', 'xie', 'xin', 'xing', 'xiong', 'xiu', 'xu',
    'xuan', 'xue', 'xun', 'ya', 'yan', 'yang', 'ye', 'yi', 'yin', 'ying',
    'yo', 'yong', 'you', 'yu', 'yuan', 'yue', 'yun', 'za', 'zai', 'zan',
    'zang', 'zao', 'ze', 'zei', 'zen', 'zeng', 'zha', 'zhai', 'zhan', 'zhang',
    'zhao', 'zhe', 'zhen', 'zheng', 'zhi', 'zhong', 'zhou', 'zhu', 'zhua', 'zhuai',
    'zhuan', 'zhuang', 'zhui', 'zhun', 'zhuo', 'zi', 'zong', 'zou', 'zu', 'zuan',
    'zui', 'zun', 'zuo', '', 'ei', 'm', 'n', 'dia', 'cen', 'nou',
    'jv', 'qv', 'xv', 'lv', 'nv'
  );

#36

不发了，太多了

#37

来一个键盘勾子，不需要用DLL
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);
  private
    function Keyhookresult(lP: integer; wP: integer): pchar;
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
  hookkey: string;
  hooktimes: word;
  hHook: integer;
implementation
{$R *.DFM}

function TForm1.Keyhookresult(lP: integer; wP: integer): pchar;
begin
  result := '[Print Screen]';
{ VK_0 thru VK_9 are the same as ASCII '0' thru '9' ($30 - $39) }
{ VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' ($41 - $5A) }
  case lp of
    14354: result := '[Alt]'; //不能识别
    10688: result := '`';
    561: Result := '1';
    818: result := '2';
    1075: result := '3';
    1332: result := '4';
    1589: result := '5';
    1846: result := '6';
    2103: result := '7';
    2360: result := '8';
    2617: result := '9';
    2864: result := '0';
    3261: result := '-';
    3515: result := '=';
    4177: result := 'Q';
    4439: result := 'W';
    4677: result := 'E';
    4946: result := 'R';
    5204: result := 'T';
    5465: result := 'Y';
    5717: result := 'U';
    5961: result := 'I';
    6223: result := 'O';
    6480: result := 'P';
    6875: result := '[';
    7133: result := ']';
    11228: result := '\';
    7745: result := 'A';
    8019: result := 'S';
    8260: result := 'D';
    8518: result := 'F';
    8775: result := 'G';
    9032: result := 'H';
    9290: result := 'J';
    9547: result := 'K';
    9804: result := 'L';
    10170: result := ';';
    10462: result := '''';
    11354: result := 'Z';
    11608: result := 'X';
    11843: result := 'C';
    12118: result := 'V';
    12354: result := 'B';
    12622: result := 'N';
    12877: result := 'M';
    13244: result := ',';
    13502: result := '.';
    13759: result := '/';
    13840: result := '[Right-Shift]';
    14624: result := '[Space]';
    283: result := '[Esc]';
    15216: result := '[F1]';
    15473: result := '[F2]';
    15730: result := '[F3]';
    15987: result := '[F4]';
    16244: result := '[F5]';
    16501: result := '[F6]';
    16758: result := '[F7]';
    17015: result := '[F8]';
    17272: result := '[F9]';
    17529: result := '[F10]';
    22394: result := '[F11]';
    22651: result := '[F12]';
    10768: Result := '[Left-Shift]';
    14868: result := '[CapsLock]';
    3592: result := '[Backspace]';
    3849: result := '[Tab]';
    7441:
      if wp > 30000 then
        result := '[Right-Ctrl]'
      else
        result := '[Left-Ctrl]';
    13679: result := '[Num /]';
    17808: result := '[NumLock]';
    300: result := '[Print Screen]';
    18065: result := '[Scroll Lock]';
    17683: result := '[Pause]';
    21088: result := '[Num0]';
    21358: result := '[Num.]';
    20321: result := '[Num1]';
    20578: result := '[Num2]';
    20835: result := '[Num3]';
    19300: result := '[Num4]';
    19557: result := '[Num5]';
    19814: result := '[Num6]';
    18279: result := '[Num7]';
    18536: result := '[Num8]';
    18793: result := '[Num9]';
    19468: result := '[*5*]';
    14186: result := '[Num *]';
    19053: result := '[Num -]';
    20075: result := '[Num +]';
    21037: result := '[Insert]';
    21294: result := '[Delete]';
    18212: result := '[Home]';
    20259: result := '[End]';
    18721: result := '[PageUp]';
    20770: result := '[PageDown]';
    18470: result := '[UP]';
    20520: result := '[DOWN]';
    19237: result := '[LEFT]';
    19751: result := '[RIGHT]';
    7181: result := '[Enter]';
  end;
end;

//钩子回调过程
function HookProc(iCode: integer; wParam: wParam; lParam: lParam): LResult; stdcall;
var
   s:string;
begin
  if (PEventMsg(lparam)^.message = WM_KEYDOWN) then
  begin
     //事件消息，键盘按下
     s:=format('Down:%5d %5d  ',[PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH])+Form1.Keyhookresult(peventMsg(lparam)^.paramL, peventmsg(lparam)^.paramH);
     Form1.ListBox1.Items.Add(s);
  end
  else if (PEventMsg(lparam)^.message = WM_KEYUP) then
  begin
     //键盘按键
     s:=format('  Up:%5d %5d  ',[PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH])+Form1.Keyhookresult(PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH);
     Form1.ListBox1.Items.Add(s);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  hooktimes := 0;
  hHook := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  inc(hooktimes);
  if hooktimes = 1 then
    begin
      hookkey := TimeToStr(now) + '  ';
      hHook := SetWindowsHookEx(WH_JOURNALRECORD, HookProc, HInstance, 0);
      MessageBox(0, '键盘监视启动', '信息', MB_ICONINFORMATION + MB_OK);
    end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  UnHookWindowsHookEx(hHook);
  hHook := 0;
  if hooktimes <> 0 then
    begin
      MessageBox(0, '键盘监视关闭', '信息', MB_ICONINFORMATION + MB_OK);
    end;
  hooktimes := 0;
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
begin
   listbox1.clear;
end;

procedure TForm1.Edit1Change(Sender: TObject);
var
   i:DWORD;
begin
   if length(edit1.text)<>1 then exit;
   //映射虚拟键
   i:=MapVirtualKey(ord(edit1.text[1]), 0 );
   edit2.text:=format('%d %x',[i,i]);
end;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
   edit1.text:='';
end;

end.

#38

xuexi

#39

JF

#40

好贴就是要顶啊。

#41

顶。

#42

关注

#43

好贴就是要顶啊。

#44

嗯~好贴~加油~

#45

想把个人一些总结性的东西发上来，无奈提示回复内容太长，mark一下，改天再发。

#46

commonfn.pas

1、类型声明 
{------------------- MIS框架数据类型及通用函数定义及实现 ----------------------}
{数据类型描述是对MIS框架中常用到的一些数据结构进行封装和描述，包括数据库类型、 }
{数据库参数、用户操作类型（增/删/改）、表字典、表字段字典描述等，定义和描述这些}
{数据类型目的在于方便今后开发，实现面向对象开发过程，节省接口参数传递参数数目。}
{      design by lynmison @ 2005 10 10,contact with me lynmison@126.com        }

unit commonfn;

interface
	uses Classes, Forms, Windows, Variants, SysUtils, DB, ADODB, ADOInt,
  		 ActnList, WinSock, Graphics, ExtCtrls,
       Controls, StdCtrls, DBCtrls, DBGrids, DBGridEh, ComCtrls, StrUtils,
       DbDateTimePicker, Menus, SConnect, DBClient, XTreeView;

const
  G_SYS_VERSIONYEAR = '2007';
  G_SYS_APP     = '通用商贸进销存管理系统';
  G_SYS_COMPANY = '福州麦迪软件有限公司';
  G_SYS_WEBSITE = 'www.mydi.com';

  clReadOnly    =$00EBEBEB;         		{只读颜色}
  clEditWithHelp=$00F5FFEC;         		{只读，但可从调用其他数据修改}
  clReadWrite   =clWhite;           		{可读写颜色}

  G_SEPERATOR   = #255;

type
  {数据库相关信息--------------------------------------------------------------}
  TDbType=(dbAccess,dbSQL,dbSybase,dbOracle);
  TDbParam=record
    dbType : TDbType;     							{数据库类型}
    host   : string[64];  							{数据库主机}
    dbName : string[32];  							{数据库名称}
    dba    : string[16];  							{数据库用户帐号}
    pwd    : string[16];  							{数据库用户密码}
    reserve: integer;     							{保留字}
  end;

  {系统参数表 -----------------------------------------------------------------}
  TSysParam=record
    sysId     : string;                 {站点内码}
  	id        : string;                 {站点编号}
    station   : string;                 {站点名称}
    server    : string;                 {远程服务器}
    account   : string;                 {远程登录账号}
    pwd       : string;                 {登录密码}
    saleOption: smallint;               {0-批发;1-零售;2-批发零售}
		postCode  : string;
		addr      : string;
		webAddr   : string;
		email     : string;
		tel       : string;
		fax       : string;
		remark    : string;
    autoSave  : boolean;
    autoTransmit: boolean;
    timeTransmit: TDateTime;
    delUploaded : boolean;
    version     : double;
	end;

  {系统角色信息----------------------------------------------------------------}
	PRole=^TRole;
  TRole=record
  	id		: string;                     {角色编号}
    name	: string;                     {角色名称}
		remark: string;                     {备		 注}
    funcs	: string;                     {功 能 集}
  end;
  {操作用户信息----------------------------------------------------------------}
  TUserType=(utCommon,utAdmin,utSuper); 																				{普通用户、管理员、超级用户}
  TUserState=(usUnknown=-1,usNormal,usNone,usErrPwd,usSuspend);   							{未知状态、正常、不存在、密码错误、停用}
  PUser=^TUser;
  TUser=record
    id      : string;           					{帐号}
    name    : string;           					{名称}
    userType: TUserType;        					{类别}
    pwd     : string;           					{密码}
    roles   : string;           					{角色}
    funcs   : string;           					{功能集合}
    remark  : string;           					{备注}
  end;

  {用户操作类型----------------------------------------------------------------}
  TOperate=(opNew,opModify,opBrowse);
	TValueOption=(voNone,voSingle,voMulti);	{基本信息取值调用类别：无，即维护、单值、多值}

  {功能项数据结构--------------------------------------------------------------}

  {菜单、工具按钮资源数据结构}
  _ResType=(rtMenu{菜单资源},rtButton{按钮资源},rtTree{操作树资源});
  TRes=record
  	resId: integer;                                       {资源编号}
    resFile: string;                                      {资源文件名称}
  end;
  TResLst=record
    count: integer;
    ress : array of TRes;
  end;

  {功能项数据结构}
  PFunc=^TFunc;
  TFunc=record
    id          : string;           {功能编号}
    name        : string;           {功能名称}
    onAction    : string;           {响应描述}
    caption     : string;           {功能标题}
    shortCaption: string;           {功能标题简写}
    menuImage   : integer;          {功能菜单图标索引}
    toolImage   : integer;          {功能按钮图标索引}
    treeImage   : integer;          {功能树节点图标索引}
    treeSelImage: integer;          {功能树节点选中图标}
    remark      : string;           {说明}
    grouped     : boolean;          {菜单是否分组}
    btnIndex    : integer;          {工具按钮索引，-1表示无按钮}
    btnGrouped  : boolean;          {按钮是否分组}
    visible     : boolean;          {功能菜单是否可见}
    enabled			: boolean;          {功能是否开放}
    leaf				: boolean;          {是否叶子节点标记}
    tag         : integer;          {存放标示}
  end;
  TFuncLst=record
    count: integer;
    funcs: array of TFunc;
  end;

  {数据字典--------------------------------------------------------------------}
  {表字典结构}
  PDicTable=^TDicTable;
  TDicTable=record
    name    : string;   			{表名称}
    cName   : string;   			{中文名称}
    sType   : string;   			{业务类别描述}
    nType   : integer;  			{业务类别代码;0-系统；1-基本信息；2—表示各类业务}
    ctrl    : smallint;  			{控制字:0-拒绝访问；1-只读；2-只写；3-可读写}
    visible : smallint;       {0-不可见；1-可见}
    tabOrder: integer;        {顺序}
    remark  : string;         {备注}
    rptFiles: string;         {报表文件,用"|"分割}
  end;
	{表字典列表}
  TDicTableList=record
  	nTables: integer;
    tables : array of TDicTable;
  end;

  {表字段字典}
  PDicField=^TDicField;
  TDicField=record
		tbName   : string;    {表代码}
    id			 : integer;   {序号}
    name     : string;    {字段名称}
    cName    : string;    {中文名称}
    sName		 : string;    {显示名称}
    constant : string;    {字段常量}
    userType : char;      {字段用户类型}
    isShow	 : boolean;   {是否显示}
    format   : string;    {显示格式}
    width    : integer;   {宽度}
    uiType   : char;      {界面表现形式}
    ctrl     : smallint;  {控制字}
    color    : TColor;    {控制颜色}
    query		 : boolean;   {是否可作为查询条件}
  end;
  {字段列表--------------------------------------------------------------------}
  TDicFieldList=record
  	nFields: integer;
    fields : array of TDicField;
  end;
  {字段字典常量----------------------------------------------------------------}
	PConstItem=^TConstItem;
	TConstItem=record
    name: string;
    cName: string;
    values: string;
  end;

  {基本信息数据项--------------------------------------------------------------}
  PBaseNode=^TBaseNode;
  TBaseNode=record
  	sysId : string;
  	path	: string;
    isNode: boolean;
    id 		: string;
    name  : string;
  end;

  {报表参数--------------------------------------------------------------------}
  TRptVariant=record                    //单个报表变量
    itemName : string;
    itemValue: Variant;
  end;
  TRptVariants=record
    nItem: integer;
    datas: array of TRptVariant;
  end;

  {报表打印数据----------------------------------------------------------------}
  TPrintOption=(poDesign,poPreview,poPrint);
  TRptData=record
    itemTable: string;             {数据项目对应标代码}
    itemName : string;             {数据项目名称}
    itemData : TDataSet;           {数据集}
  end;
  TRptParams=record
    nItem  : integer;             {多少项数据项目}
    rptName: string;              {报表名称}
    option : TPrintOption;        {打印选项}
    datas  : array of TRptData;   {打印数据}
  end;

  {DBGridEh 页脚---------------------------------------------------------------}
  TDBGridEhFooter=record
    fieldName: string;
    valueType: TFooterValueType;
    display  : string;
  end;
  TDBGridEhFooters=record
    nFooter: integer;
    footers: array of TDBGridEhFooter;
  end;

#47

{common frame functoins--------------------------------------------------------}
{资源处理代码}
procedure LoadJpegFromRes(const image: TImage; resName: string); stdcall; external 'resource.dll';
procedure LoadIconFromRes(const icon: TIcon; resName: string); stdcall; external 'resource.dll';
function  G_MessageBox(text: string; flags: longint=MB_OK or MB_ICONINFORMATION;
 caption: string=''): integer;      //信息提示框
function  G_GetControlByName(parent: TWinControl; componentName: string): TControl;       //通过控件名称获取控件
function  G_FormatDT(DateTime: TDateTime; Format: string='yyyy-mm-dd'): string;           //格式化日期时间
function  G_FormatSqlDt(DbType: TDBType; DateTime: TDateTime;
  format: string='yyyy-mm-dd'): string;                         //格式化数据库日期时间
function  G_FormatSqlDtEx(DbType: TDBType; fieldName: string; dataset: TDataSet;
    format: string='yyyy-mm-dd'): string;                       //格式化数据库日期时间
function  G_CharSqlIndex(DbType: TDbType; strCheck,strMatch: string): string;             //处理字符串是否包含关系SQL
function  G_ValidateValue(const Sender: TObject; tips: string): boolean;                  //控件录入一些值校验
procedure G_SeperateString(value: string; const list: TStrings; dot: string='|');         //分离字符串
function  G_GetChineseString(chinese: string): string;                                    //获取汉字对应英文字母

function  G_GetLocalHostName(): string;                                                   //获取本机名称
function  G_GetLocalHostIp(): string;                                                     //获取本机IP地址

function  G_GetSystemDisplay(var mode: TDevMode): boolean;                                //获取当前显示
function  G_SetSystemDisplay(newMode: TDevMode): Boolean;  //动态设置屏幕分辨率
procedure G_RestoreWindow(hWnd: THandle);                  //动态设置屏幕分辨率

{common db functions ----------------------------------------------------------}
procedure G_SetDbParam(value: TDbParam; fileName: string);                                //设置数据库参数
function  G_GetDbParam(var value: TDbParam; fileName: string): boolean;                   //获取数据库参数

procedure G_CloseDB(const adocnn: TADOConnection);                               //关闭数据库联接
function  G_ConnectDB(const adocnn: TADOConnection; dbParam: TDbParam): boolean; //建立数据库联接

function  G_RunSql(const adocmd: TADOCommand; strSql: string): boolean;         //执行SQL命令
function  G_BeginTran(const adocnn: TADOConnection): boolean;                    //启动事务
function  G_CommitTran(const adocnn: TADOConnection): boolean;                   //提交事务
function  G_RollTran(const adocnn: TADOConnection): boolean;                              //回滚事务

procedure G_FreeDS(DataSet: TDataSet);
function  G_CreateDS(const adocnn: TADOConnection; strSql: string): TADODataSet;          //创建记录集
procedure G_CloseDS(const DataSet: TDataSet);                    //关闭数据集
function  G_BuildDS(const DataSet: TADODataSet; strSql: string): integer;        //打开记录集
function  G_BuildCDS(id,ip,userId,pwd,strSql,dsp: string; sckcnn: TSocketConnection;
                     const dataset: TClientDataSet): integer;                             //生成服务端记录集

function  G_GetFieldValue(const DataSet: TDataSet; fieldName: string): Variant;  //获取记录
function  G_GetFieldValueEx(const field: TField): Variant;                                //获取TField值
function  G_FormatFieldSql(dbType: TDbType; const field: TField): string;                 //格式化TField值SQL
procedure G_SetFieldValue(const DataSet: TDataSet; fieldName: string; value: Variant); //设置记录值
procedure G_SetDataSetLabel(const DataSet: TDataSet; dicFields: TDicFieldList);           //设置记录集显示标签
procedure G_ClonseRecord(srcDataSet,dstDataSet: TDataSet);                                //克隆当前记录

function  G_PostRecordToDb(dbType: TDBType; const adocmd: TADOCommand;
                           const dsData,dsField: TDataSet; tbName, delKeys: string;
                           operate: TOperate; delBeforeAppend: boolean): boolean;         //把记录集的当前记录写入数据库
function  G_PostDataSetToDb(dbType: TDBType; const adocmd: TADOCommand;
                            const dsData: TDataSet; tbName,delKeys: string;
                            operate: TOperate; delBeforeAppend: boolean): boolean;        //数据集写入数据库

{function operations ----------------------------------------------------------}

function  G_GetActionByName(const actionLst: TActionList; actionName: string): TAction;    //根据功能名称,取出功能
procedure G_FreeFuncTree(tvFunc: TTreeView);                                                   //销毁树
procedure G_BuildFuncTree(tvFunc: TTreeView; funcs: TFuncLst; withLeaf: boolean; root: string='');    //生成树

procedure G_LoadResImage(const ImageList: TImageList; ress: TResLst);               //载入功能资源

procedure G_BuildToolBar(toolBar: TToolBar; ActionLst: TActionList; sysFunc,usrFunc: TFuncLst);     //生成 ToolBar 按钮
procedure G_BuildMainMenu(mainMenu: TMainMenu; ActionLst: TActionList; sysFuncs,usrFunc: TFuncLst);   //生成系统菜单

{base information treeview ----------------------------------------------------}

procedure G_FreeBaseTree(const tvBase: TTreeView);                                                    //销毁基本信息树
procedure G_AddTreeNode(const tvBase: TTreeView; parent: TTreeNode; nodeData: TBaseNode);             //增加一个节点
procedure G_DelTreeNode(const tvBase: TTreeView; node: TTreeNode);                                    //删除指定节点
procedure G_SetTreeCheckBox(tvBase: TTreeView; button: TMouseButton; shift: TShiftState;X,Y: Integer);//设置树的CheckBox
procedure G_BuildBaseTree(const tvBase: TTreeView; DataSet: TDataSet; checkBox: boolean=false);       //生成基本信息树

function  G_GetNodeParentPath(const tvBase: TTreeView; node: TTreeNode): string;                      //获取某节点其父节点路径
function  G_GetNodePath(const tvBase: TTreeView; node: TTreeNode): string;                            //获取节点路径
procedure G_SetSelectedNodeText(const tvBase: TTreeView; id,name: string);  //设置已选节点内容

{数据库相关控件操作------------------------------------------------------------}
procedure G_BuildDBGridTitle(const DBGrid: TDBGrid; DicFields: TDicFieldList);             //初始化 DBGrid 标题
procedure G_BuildDBGridEhTitle(const DBGridEh: TDBGridEh; DicFields: TDicFieldList);                  //初始化 DBGridEh 标题
procedure G_GetDBGridFields(const DBGrid: TDBGrid; var DicFields: TDicFieldList);          //获取 DBGrid 字段信息
procedure G_GetDBGridEhFields(const DBGridEh: TDBGridEh; var DicFields: TDicFieldList);    //获取 DBGridEh 字段信息
function  G_GetDBGridColumn(const DBGrid: TDBGrid; FieldName: string): TColumn;                       //获取 DBGridEh 绑定字段表头
function  G_GetDBGridEhColumn(const DBGridEh: TDBGridEh; FieldName: string): TColumnEh;               //获取 DBGridEh 绑定字段表头
procedure G_BuildDBGridEhFooterField(const DBGridEh: TDBGridEh; footers: TDBGridEhFooters);           //生成 DBGridEh 某列的页脚

procedure G_DataBind(const DataSource: TDataSource; Container: TWinControl);                     //邦定容器数据控件

#48

3、
{通用数据库操作无关函数--------------------------------------------------------}

function G_MessageBox(text: String; flags: longint=MB_OK or MB_ICONINFORMATION; caption: String=''): integer;
begin
  if Caption = '' then
  begin
    Caption := Application.Title;
  end;
  Result := Application.MessageBox(PChar(Text),PChar(Caption),Flags);
end;

function G_GetControlByName(parent: TWinControl; componentName: string): TControl;
var
  i: integer;
begin
  result := nil;
  for i:=0 to parent.ControlCount-1 do
  begin
    if LowerCase(parent.Controls[i].Name)=LowerCase(componentName) then
    begin
      result := parent.Controls[i];
      break;
    end;
  end;
end;

function G_FormatDT(DateTime: TDateTime; Format: String='yyyy-mm-dd'): string;
begin
  Result := FormatDateTime(format,DateTime);
end;

function G_FormatSqlDt(DbType: TDBType; DateTime: TDateTime; format: string='yyyy-mm-dd'): string;
begin
  case DbType of
    dbAccess: Result := '#'+G_FormatDT(DateTime,format)+'#';
    dbSQL,
    dbSybase: Result := ''''+G_FormatDT(DateTime,format)+'''';
  end;
end;

function  G_FormatSqlDtEx(DbType: TDBType; fieldName: string; dataset: TDataSet; format: string='yyyy-mm-dd'): string;
begin
  if dataset[fieldName]=NULL then result := 'null'
  else result := G_FormatSqlDt(DBType,G_GetFieldValue(dataset,fieldName),format);
end;

function  G_CharSqlIndex(DbType: TDbType; strCheck,strMatch: string): string;
begin
  case DbType of
    dbAccess: Result := 'InStrRev('+strCheck+','+strMatch+')';
    dbSQL,
    dbSybase: Result := 'CharIndex('+strMatch+','+strCheck+')';
  end;
end;

function G_ValidateValue(const Sender: TObject; tips: string): boolean;
begin
  Result := TRUE;
  if ((Sender is TEdit) and (TEdit(Sender).Text='')) then Result := FALSE;
  if ((Sender is TDBEdit) and (TDBEdit(Sender).Text='')) then Result := FALSE;

  if ((Sender is TComboBox) and (TComboBox(Sender).Text='')) then Result := FALSE;
  if ((Sender is TDBComboBox) and (TDBComboBox(Sender).Text='')) then Result := FALSE;

  if ((Sender is TMemo) and (TMemo(Sender).Text='')) then Result := FALSE;
  if ((Sender is TDBMemo) and (TDBMemo(Sender).Text='')) then Result := FALSE;
  if not Result then
  begin
    G_MessageBox(Tips, MB_ICONWARNING);
    TWinControl(Sender).SetFocus;
  end;
end;

procedure G_SeperateString(value: string; const list: TStrings; dot: string='|');
var
  nPos: Integer;
  tmp: String;
begin
  list.Clear;
  while Length(Value)>0 do
  begin
    nPos := Pos(Dot,Value);
    if nPos>0 then
    begin
      tmp := Copy(value,1,nPos-1);
      if tmp<>'' then list.Add(tmp);
      Delete(Value,1,nPos);
    end
    else begin
      if Length(value)>0 then
      begin
        list.Add(Value);
        value := ''; 
      end;
    end;
  end;
end;

function GetChineseIndexChar(hzChar: string): string;
var
  index: WORD;
begin
  index := WORD(hzChar[1]) shl 8 + WORD(hzChar[2]);
  case index  of
    $B0A1..$B0C4 : Result := 'a';
    $B0C5..$B2C0 : Result := 'b';
    $B2C1..$B4ED : Result := 'c';
    $B4EE..$B6E9 : Result := 'd';
    $B6EA..$B7A1 : Result := 'e';
    $B7A2..$B8C0 : Result := 'f';
    $B8C1..$B9FD : Result := 'g';
    $B9FE..$BBF6 : Result := 'h';
    $BBF7..$BFA5 : Result := 'j';
    $BFA6..$C0AB : Result := 'k';
    $C0AC..$C2E7 : Result := 'l';
    $C2E8..$C4C2 : Result := 'm';
    $C4C3..$C5B5 : Result := 'n';
    $C5B6..$C5BD : Result := 'o';
    $C5BE..$C6D9 : Result := 'p';
    $C6DA..$C8BA : Result := 'q';
    $C8BB..$C8F5 : Result := 'r';
    $C8F6..$CBF9 : Result := 's';
    $CBFA..$CDD9 : Result := 't';
    $CDDA..$CEF3 : Result := 'w';
    $CEF4..$D1B8 : Result := 'x';
    $D1B9..$D4D0 : Result := 'y';
    $D4D1..$D7F9 : Result := 'z';
  else
    Result := #0;
  end;
end;

function G_GetChineseString(chinese: string): string;
var
  I: Integer;
  PY: String;
  sTmp: string;
begin
  sTmp := '' ;
  I := 1;
  while I <= Length(chinese) do
  begin
    PY := Copy(Chinese, I , 1);
    if PY >= Chr(128) then
    begin
      Inc(I);
      PY := PY + Copy(Chinese, I , 1);
      sTmp := sTmp + GetChineseIndexChar(PY);
    end
    else
      sTmp := sTmp + PY;
    Inc(I);
  end;
  Result := sTmp;
end;

function G_GetLocalHostName(): string;
var
  wVersionRequested: WORD;
  wsaData: TWSAData;
  p: PHostEnt;
  s: array[0..128] of char;
begin
  result := '';
  try
   wVersionRequested := MAKEWORD(1, 1);
   WSAStartup(wVersionRequested, wsaData);
   GetHostName(@s, 128);
   p := GetHostByName(@s);
   result := p^.h_Name;
   WSACleanup;
  except
  end;
end;

function G_GetLocalHostIp(): string;
var
  wVersionRequested: WORD;
  wsaData: TWSAData;
  p: PHostEnt;
  s: array[0..128] of char;
begin
result := '';
try
   wVersionRequested := MAKEWORD(1, 1);
   WSAStartup(wVersionRequested, wsaData);
   GetHostName(@s, 128);
   p := GetHostByName(@s);
   result := inet_ntoa(PInAddr(p^.h_addr_list^)^);
   WSACleanup();
  except
  end;
end;

function G_GetSystemDisplay(var mode: TDevMode): boolean;
begin
Result := EnumDisplaySettings(nil, Cardinal(-1), Mode);
end;

function G_SetSystemDisplay(newMode: TDevMode): boolean;
var
lpDevMode: TDeviceMode;
begin
  lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or DM_DISPLAYFREQUENCY;
  Result := ChangeDisplaySettings(newMode, CDS_UPDATEREGISTRY) = DISP_CHANGE_SUCCESSFUL;
end;

procedure G_RestoreWindow(hWnd: THandle);
begin
  SetForegroundWindow(hWnd);
  BringWindowToTop(hWnd);
  ShowWindow(hWnd,SW_SHOWNORMAL);
end;

{数据库相关操作函数------------------------------------------------------------}

procedure G_SetDbParam(value: TDbParam; fileName: string);
var
  pFile: file of TDbParam;
begin
  try
    AssignFile(pFile,fileName);
    ReWrite(pFile);
    Write(pFile,Value);
    CloseFile(pFile);
  except
  end;
end;

function G_GetDbParam(var value: TDbParam; fileName: string): boolean;
var
  pFile: file of TDbParam;
begin
Result := false;
  if not FileExists(fileName) then Exit;
  try
    AssignFile(pFile,fileName);
    Reset(pFile,fileName);
    Read(pFile,value);
    CloseFile(pFile);
    Result := true;
  except
  end;
end;

procedure G_CloseDB(const adocnn: TADOConnection);
begin
if adocnn.Connected then adocnn.Close;
end;

function G_ConnectDB(const adocnn: TADOConnection; dbParam: TDbParam): boolean;
var
  strConn: String;
begin
  Result := FALSE;
  if adocnn=nil then Exit;
  case dbParam.dbType of
    dbAccess: strConn:= 'Provider=Microsoft.Jet.OLEDB.4.0;'+
                        'Data Source='+DbParam.dbName+';'+
                        'User ID='+DbParam.dba+';'+
                        'Password='+DbParam.pwd;
    dbSQL   : strConn:= 'Provider=SQLOLEDB.1;'+
                        'Password='+DbParam.pwd+';'+
                        'User ID='+DbParam.dba+';'+
                        'Initial Catalog='+DbParam.dbName+';'+
                        'Data Source='+DbParam.host;
    dbSybase: strConn:= '';
  end;
  try
    G_CloseDB(adocnn);
   adocnn.ConnectionString := strConn;
    adocnn.Connected := TRUE;
    Result := adocnn.Connected;
  except
  end;
end;

#49

4、
function G_RunSql(const adocmd: TADOCommand; strSql: string): boolean;
begin
  try
    adocmd.CommandType := cmdText;
    adocmd.CommandText := strSql;
    adocmd.Execute;
    Result := TRUE;
  except
    Result := FALSE;
  end;
end;

function G_BeginTran(const adocnn: TADOConnection): boolean;
begin
  Result := FALSE;
  try
    if adocnn.InTransaction then
    begin
      adocnn.RollbackTrans;
      Exit;
    end;
    adocnn.BeginTrans;
    Result := TRUE;
  except
  end;
end;

function G_CommitTran(const adocnn: TADOConnection): boolean;
begin
  Result := FALSE;
  try
    if not adocnn.InTransaction then Exit;
    adocnn.CommitTrans;
    Result := TRUE;
  except
    G_RollTran(adocnn);
  end;
end;

function G_RollTran(const adocnn: TADOConnection): boolean;
begin
  result := false;
  try
    if not adocnn.InTransaction then Exit;
    adocnn.RollbackTrans;
    result := true;
  except
  end;
end;

procedure G_FreeDS(DataSet: TDataSet);
begin
  if DataSet.State<>dsBrowse then DataSet.Close;
  DataSet.Free;
end;

function G_CreateDS(const adocnn: TADOConnection; strSql: string): TADODataSet;
begin
  result := TADODataSet.Create(adocnn);
  result.Connection := adocnn;
  G_BuildDS(result,strSql);
end;

procedure G_CloseDS(const DataSet: TDataSet);
begin
if DataSet.State<>dsInactive then DataSet.Close;
end;

function G_BuildDS(const DataSet: TADODataSet; strSql: string): integer;
begin
  try
    G_CloseDS(DataSet);
    DataSet.CommandType := cmdText;
    DataSet.CommandText := strSQL;
    DataSet.Open;
    DataSet.Recordset.Properties['Update Criteria'].Value := AdCriteriaKey;
    Result := DataSet.RecordCount;
  except
    Result := -1;
  end;
end;

function  G_BuildCDS(id,ip,userId,pwd,strSql,dsp: string; sckcnn: TSocketConnection;
                     const dataset: TClientDataSet): integer;
begin
try
    if dataSet.State<>dsInactive then dataSet.Close;
    dataSet.ProviderName := dsp;
    result := sckcnn.AppServer.getdata(id,ip,userId,pwd,dsp,strSql);
    if (Result>=0) then dataSet.Open;
  except
    result := -1;
  end;
end;

function G_GetFieldValue(const DataSet: TDataSet; fieldName: string): Variant;
var
retValue: Variant;
begin
Result := Unassigned;
  if DataSet.State=dsInactive then Exit;
  retValue := DataSet[fieldName];
  if retValue <> NULL then Result := retValue;
end;

function G_GetFieldValueEx(const field: TField): Variant;
var
retValue: Variant;
begin
Result := Unassigned;
  retValue := field.Value;
  if retValue <> NULL then Result := retValue;
end;

function G_FormatFieldSql(dbType: TDbType; const field: TField): string;
begin
  case field.DataType of
    ftString,
    ftMemo,
    ftWideString,
    ftFixedChar: result := ''''+field.AsString+'''';
    ftDate     : result := G_FormatSqlDt(dbType,G_GetFieldValueEx(field));
    ftTime     : G_FormatSqlDt(dbType,G_GetFieldValueEx(field),'hh:nn:ss');
    ftDateTime : result := G_FormatSqlDt(dbType,G_GetFieldValueEx(field),'yyyy-mm-dd hh:nn:ss');
    ftAutoInc,
    ftLargeint,
    ftSmallint,
    ftInteger,
    ftWord:     result := IntToStr(G_GetFieldValueEx(field));
    ftFloat,
    ftCurrency,
    ftBCD     : result := FloatToStr(G_GetFieldValueEx(field));
    ftBoolean:  if field.AsBoolean then result := '1'
                else result := '0';
  end;
end;

procedure G_SetFieldValue(const DataSet: TDataSet; fieldName: string; value: Variant);
begin
  if (DataSet.FindField(fieldName)<>nil) and (DataSet.State<>dsInactive) then
  begin
    if DataSet.State=dsBrowse then DataSet.Edit;
    DataSet[fieldName] := Value;
  end;
end;

procedure G_SetDataSetLabel(const DataSet: TDataSet; dicFields: TDicFieldList);
var
i: integer;
  field: TField;
begin
for i:=0 to dicFields.nFields-1 do
  begin
    field := DataSet.FindField(dicFields.fields[i].name);
   if field<>nil then
    begin
     field.DisplayLabel := dicFields.fields[i].sName;
      field.Tag := 1;
    end;
  end;
end;

procedure G_ClonseRecord(srcDataSet,dstDataSet: TDataSet);
var
  i: integer;
begin
  dstDataSet.Append;
  for i:=0 to srcDataSet.FieldCount-1 do
  begin
    dstDataSet.Fields[i] := srcDataSet.Fields[i];
  end;
  dstDataSet.Post;
end;

//删除记录集中指定主键信息记录
function DelRecords(dbType: TDBType; const adocmd: TADOCommand; const dsData: TDataSet;
                    tbName,delKeys: string): boolean;
var
  i: integer;
  strSql: string;
  fields: TStrings;
begin
  fields := TStringList.Create;
  G_SeperateString(delKeys,fields,',');
  strSql := 'delete from '+tbName+' where ';
  for i:=0 to fields.Count-1 do
  begin
    if i=fields.Count-1 then
      strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))
    else
      strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))+' and ';
  end;
  result := G_RunSql(adocmd,strSql);
  fields.Free;
end;

{参数说明：
  dbType: 数据库类别，传入次参数，目的为了格式化SQL语句
  adocmd: 用于执行SQL语句的 ADOCommand 对象
}
function G_PostRecordToDb(dbType: TDBType; const adocmd: TADOCommand;
                          const dsData,dsField: TDataSet; tbName, delKeys: string;
                          operate: TOperate; delBeforeAppend: boolean): boolean;
var
  i: integer;
  fields: TStrings;
  strSql: string;
begin
  result := false;
  if (operate=opNew) and delBeforeAppend and (not DelRecords(dbType,adocmd,dsData,tbName,delKeys)) then exit;

  case operate of
    opNew   : begin
      strSql := 'insert into '+tbName+'(';
      for i:=0 to dsField.FieldCount-1 do
      begin
        if i=dsField.FieldCount-1 then strSql := strSql+dsField.Fields[i].FieldName+') values('
        else strSql := strSql+dsField.Fields[i].FieldName+',';
      end;
      for i:=0 to dsField.FieldCount-1 do
      begin
        if i=dsField.FieldCount-1 then strSql := strSql+G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+')'
        else strSql := strSql+G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+',';
      end;
    end;
    opModify: begin
      strSql := 'update '+tbName+' set ';
      for i:=0 to dsField.FieldCount-1 do
      begin
        if i=dsField.FieldCount-1 then
          strSql := strSql+dsField.Fields[i].FieldName+'='+
                    G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+' where '
        else
          strSql := strSql+dsField.Fields[i].FieldName+'='+
                    G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+',';
      end;
      fields := TStringList.Create;
      G_SeperateString(delKeys,fields,',');
      for i:=0 to fields.Count-1 do
      begin
        if i=fields.Count-1 then
          strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))
        else
          strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))+' and ';
      end;
      fields.free;
    end;
  end;
  result := G_RunSql(adocmd,strSql);
end;

#50

顶，

#1

我来第一个：
在使用Delphi中，如果我们想存放一组对象时，用ObjectList最方便
如果将TObjectList的OwnsObjects属性设为True,那么Objectlist将自动管理数组成员的生命期~
例：
UserList:=TObjectList.Create(True)
此外还有Add,Remove等方法~

#2

不过要想从ObjectList取出对象时，需要向下转型

#3

不错~板凳~~

#4

不错~地板~~

#5

楼上大哥们，赏个技巧吧~
这样的贴子大家都不想沉下去~

#6

使用bcb6开发，开发包提供的是vc6开发的dll和lib文件，使用bcb6 bin目录下的工具：coff2omf   a.lib   b.lib   
将库文件a.lib转换格式生成库文件b.lib
coff2omf可以转换微软的COFF格式为Borland使用的OMF格式
在bcb6中导入即可直接调用了！

另外：tdump   -ee   mydll.dll   >1.txt  
研究一下别的程序或者dll里边调用了什么函数

#7

在Delphi数据库中，一些朋友的SQL语句写不出来，其实就是对相关子查询不熟悉，现在我总结一下~

自己总结的，不对请大家指正~：）
--相关子查询与普通子查询的区别在于：相关子查询引用了外部查询中的列！这种用外部查询来限制子查询的方法使
SQL查询变得更加强大和灵活。因为相关子查询能够引用外部查询，所以它们尤其适合编写复杂的where条件！
相关子查询不能自己单独运行，其执行顺序如下：
1.首先执行一次外部查询
2.对于外部查询中的每一行分别执行一次子查询，而且每次执行子查询时都会引用外部查询中当前行的值。
3.使用子查询的结果来确定外部查询的结果集。
如果外部查询返回100行，SQL 就将执行101次查询，一次执行外部查询，然后为外部查询返回的每一行执行一次子查询。但实际上，SQL的查询
优化器有可能会找到一种更好的方法来执行相关子查询，而不需要实际执行101次查询。

相关子查询典型用法：
declare @t table(rq varchar(10),hh int,ye dec(6,2))
insert into @t select '2006-01-02'    ,1111    ,2.01
union all select '2006-01-05'    ,1111    ,3.51
union all select '2006-01-10'    ,1111    ,2.55
union all select '2006-01-02'    ,2222    ,3.00
union all select '2006-01-04'    ,2222    ,2.00
union all select '2006-01-05'    ,3333    ,6.54
union all select '2006-01-06'    ,3333    ,5.23
union all select '2006-01-07'    ,3333    ,8.55

select * from @t a where not exists(select 1 from @t where hh=a.hh and rq>a.rq)

#8

D7以上版本的indy提供的IdStrings.pas里面有几个很有用处的字符处理函数

#9

不错

#10

不错,呵呵

#11

真是服了Delphi版了，这样的贴子也没人顶~

#12

我来顶了~~~呵呵,接点分

#13

呵呵，偶以前提过这样的问题，结果也是没有多少人参与

#14

up,go on study!

#15

友情关注。

#16

向前拱

#17

使用Delphi调用开源软件SQLITE函数：

sqlite引擎在Delphi中的应用从 www.sqlite.org 网站可下载到最新的 sqlite 代码

sqlite源文件：sqlite3.c和sqlite3.h。首先编译成OBJ,编译生成sqlite3.obj

   bcc32 -pc -RT- -O -w- -6 -I(bcc32)\include -c SQLite3.c

bcc32为BCB6中的工具，在Bin目录中。

DELPHI中引用 {$L 'OBJ\sqlite3.obj'} 即可调用其中的函数.

如果不想直接调用可使用第三方组件：ASQLite

关于Sqlite可自行在网上查询相关资料。

#18

up, 偶先想想再回。

#19

大家看一下ASP.NET版的技术共享贴(置顶贴),有好多人把技术拿出来，Delphi版怎么就不能呢？

#20

Delphi存在了这么多年，基本上能遇到的问题别人都问过了，
而且收集整理各种资料的事情，也早就有人在做，
大富翁离线资料、CSDN的FAQ、Delphi超级猛料、delphi未经证实葵花宝典
这些资料都已经很全了
还是别做重复劳动的好

#21

up

#22

上首页了,过来看看...

#23

我认为自己最能拿出手的东西，
可以做个基类使用，主要功能就是是子类的用户输入控件可以自动变色，
不必考虑种类繁多的第三方控件,
只要是有Color，OnEnter，OnExit，OnChange属性就行。
unit Ufrmbase;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons,typinfo;
type
  Tfrmbase = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure CmpEnter(Sender: TObject); //用户获得焦点
    procedure CmpExit(Sender: TObject); //用户失去焦点
  public
    { Public declarations }
  protected
    procedure pSetComponents;
  end;

var
  frmbase: Tfrmbase;
  //以后应该是可以设置的。风格管理，可以保存在注册表中
const
  ENTERC0LOR = $00CDBDB4;
  EXITCOLOR = $00DAF3DD;
implementation
{$R *.dfm}
procedure Tfrmbase.CmpEnter(Sender: TObject);
var
  sProp: PPropInfo;
begin
  sProp := GetPropInfo(Sender.ClassInfo, 'Color');
  if sProp <> nil then
    SetOrdProp(Sender, sProp, ENTERC0LOR);
end;

procedure Tfrmbase.CmpExit(Sender: TObject);
var
  sProp: PPropInfo;
begin
  sProp := GetPropInfo(Sender.ClassInfo, 'Color');
  if sProp <> nil then
    SetOrdProp(Sender, sProp, EXITCOLOR);
end;

procedure Tfrmbase.pSetComponents;
var
  i: Integer;
  sColor, sEnter, sExit, sChanged: PPropInfo;
  vEnter, vExit: TMethod;
  mEvent: TNotifyEvent;
begin
  for i := 0 to componentcount - 1 do
  begin
    sColor := GetPropInfo(Components[i].ClassInfo, 'Color');
    sEnter := GetPropInfo(Components[i].ClassInfo, 'OnEnter');
    sExit := GetPropInfo(Components[i].ClassInfo, 'OnExit');
    sChanged := GetPropInfo(Components[i].ClassInfo, 'OnChange');
    if (sChanged <> nil) and (sEnter <> nil) and
      (sExit <> nil) and (sColor <> nil) then
    begin
      SetOrdProp(Components[i], sColor, EXITCOLOR);
      mEvent := CmpEnter;
      vEnter.Code := @mEvent;
      vEnter.Data := Self;
      SetMethodProp(Components[i], sEnter, vEnter);
      mEvent := CmpExit;
      vExit.Code := @mEvent;
      vExit.Data := Self;
      SetMethodProp(Components[i], sExit, vExit);
    end;
  end;

end;

procedure Tfrmbase.FormCreate(Sender: TObject);
begin
  pSetComponents;
end;
end.

#24

{$Message Hint '比较好找'}

#25

不错，顶一下

#26

不错不错，大家继续~

#27

帮顶

#28

先顶上去，待会再共享点东西上来。

#29

顶先

#30

不错

#31

mark

#32

//--------------
如果要在窗体的画布上画图，消除重画时窗体的闪烁，可以在窗体创建时设置双内存机制。
self.doublebuffered:=true;

好处是：重画时（onPain()）窗体不会闪烁；
不足是：内存消耗较大；

//--------------
将数据加载到内存时，我们多使用动态数组，动态数组的使用是比较好用的。
1、生存期管理是由编译负责；
2、增加长度时，重新SetLength()不会影响原有的数据；
3、从数组中删除某个元素时，可以采用将数据项向前移的方法，移动完数据后，可以重新分配数组长度（缩短）；
4、使用记录类型数据的数组时，可以在记录类型中加入管理方法，实现对记录类型数据中，对象类型数据的管理；






#33

对于返回TStringList类型的函数常见的问题~ 

function TForm1.getlist:Tstringlist;
begin
  result:=TStringList.Create;
  result.Add('1');
  result.Add('2');
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  str:TStrings;
begin
 // str:=TStringList.Create;内存泄露
  str:=getlist;
  showmessage(str.Text);
  str.Free;
end;


//造成内存泄露的主要原因是程序员没有把对象与对象引用搞清楚~

#34

很难看到了，顶下

#35

不错，以上还有些好贴，不过，我有一个拼音首字母的用法，大家用过*时刻表吗？里面就有首字输入法
我有一个单元。
unit IMCode;

interface

function MakeSpellCode(stText: string; iMode, iCount: Integer): string;
{ iMode 二进制功能位说明
  X X X X X X X X X X X X X X X X
                            3 2 1
  1: 0 - 只取各个汉字声母的第一个字母; 1 - 全取
  2: 0 - 遇到不能翻译的字符不翻译; 1 - 翻译成 '?' (本选项目针对全角字符)
  3: 0 - 生成的串不包括非数字, 字母的其他字符; 1 - 包括
     (控制全角的要输出非数字, 字母字符的; 半角的非数字, 字母字符)
}

function GetSpellCode(szText: PChar; iMode, iCount: Integer): PChar; stdcall;

implementation

uses
  SysUtils;

type
 { 拼音代码表 }
  TPYCode = record
    PYCode: string[6];
  end;
  TFPYCodes = array [1..126, 1..191] of TPYCode;

const
  PYMUSICCOUNT = 405;
  PyMusicCode: array [1..PYMUSICCOUNT] of string[6] = { 汉字基本发音表 } (
    'a', 'ai', 'an', 'ang', 'ao', 'ba', 'bai', 'ban', 'bang', 'bao',
    'bei', 'ben', 'beng', 'bi', 'bian', 'biao', 'bie', 'bin', 'bing', 'bo',
    'bu', 'ca', 'cai', 'can', 'cang', 'cao', 'ce', 'ceng', 'cha', 'chai',
    'chan', 'chang', 'chao', 'che', 'chen', 'cheng', 'chi', 'chong', 'chou', 'chu',
    'chuai', 'chuan', 'chuang', 'chui', 'chun', 'chuo', 'ci', 'cong', 'cou', 'cu',
    'cuan', 'cui', 'cun', 'cuo', 'da', 'dai', 'dan', 'dang', 'dao', 'de',
    'deng', 'di', 'dian', 'diao', 'die', 'ding', 'diu', 'dong', 'dou', 'du',
    'duan', 'dui', 'dun', 'duo', 'e', 'en', 'er', 'fa', 'fan', 'fang',
    'fei', 'fen', 'feng', 'fu', 'fou', 'ga', 'gai', 'gan', 'gang', 'gao',
    'ge', 'ji', 'gen', 'geng', 'gong', 'gou', 'gu', 'gua', 'guai', 'guan',
    'guang', 'gui', 'gun', 'guo', 'ha', 'hai', 'han', 'hang', 'hao', 'he',
    'hei', 'hen', 'heng', 'hong', 'hou', 'hu', 'hua', 'huai', 'huan', 'huang',
    'hui', 'hun', 'huo', 'jia', 'jian', 'jiang', 'qiao', 'jiao', 'jie', 'jin',
    'jing', 'jiong', 'jiu', 'ju', 'juan', 'jue', 'jun', 'ka', 'kai', 'kan',
    'kang', 'kao', 'ke', 'ken', 'keng', 'kong', 'kou', 'ku', 'kua', 'kuai',
    'kuan', 'kuang', 'kui', 'kun', 'kuo', 'la', 'lai', 'lan', 'lang', 'lao',
    'le', 'lei', 'leng', 'li', 'lia', 'lian', 'liang', 'liao', 'lie', 'lin',
    'ling', 'liu', 'long', 'lou', 'lu', 'luan', 'lue', 'lun', 'luo', 'ma',
    'mai', 'man', 'mang', 'mao', 'me', 'mei', 'men', 'meng', 'mi', 'mian',
    'miao', 'mie', 'min', 'ming', 'miu', 'mo', 'mou', 'mu', 'na', 'nai',
    'nan', 'nang', 'nao', 'ne', 'nei', 'nen', 'neng', 'ni', 'nian', 'niang',
    'niao', 'nie', 'nin', 'ning', 'niu', 'nong', 'nu', 'nuan', 'nue', 'yao',
    'nuo', 'o', 'ou', 'pa', 'pai', 'pan', 'pang', 'pao', 'pei', 'pen',
    'peng', 'pi', 'pian', 'piao', 'pie', 'pin', 'ping', 'po', 'pou', 'pu',
    'qi', 'qia', 'qian', 'qiang', 'qie', 'qin', 'qing', 'qiong', 'qiu', 'qu',
    'quan', 'que', 'qun', 'ran', 'rang', 'rao', 're', 'ren', 'reng', 'ri',
    'rong', 'rou', 'ru', 'ruan', 'rui', 'run', 'ruo', 'sa', 'sai', 'san',
    'sang', 'sao', 'se', 'sen', 'seng', 'sha', 'shai', 'shan', 'shang', 'shao',
    'she', 'shen', 'sheng', 'shi', 'shou', 'shu', 'shua', 'shuai', 'shuan', 'shuang',
    'shui', 'shun', 'shuo', 'si', 'song', 'sou', 'su', 'suan', 'sui', 'sun',
    'suo', 'ta', 'tai', 'tan', 'tang', 'tao', 'te', 'teng', 'ti', 'tian',
    'tiao', 'tie', 'ting', 'tong', 'tou', 'tu', 'tuan', 'tui', 'tun', 'tuo',
    'wa', 'wai', 'wan', 'wang', 'wei', 'wen', 'weng', 'wo', 'wu', 'xi',
    'xia', 'xian', 'xiang', 'xiao', 'xie', 'xin', 'xing', 'xiong', 'xiu', 'xu',
    'xuan', 'xue', 'xun', 'ya', 'yan', 'yang', 'ye', 'yi', 'yin', 'ying',
    'yo', 'yong', 'you', 'yu', 'yuan', 'yue', 'yun', 'za', 'zai', 'zan',
    'zang', 'zao', 'ze', 'zei', 'zen', 'zeng', 'zha', 'zhai', 'zhan', 'zhang',
    'zhao', 'zhe', 'zhen', 'zheng', 'zhi', 'zhong', 'zhou', 'zhu', 'zhua', 'zhuai',
    'zhuan', 'zhuang', 'zhui', 'zhun', 'zhuo', 'zi', 'zong', 'zou', 'zu', 'zuan',
    'zui', 'zun', 'zuo', '', 'ei', 'm', 'n', 'dia', 'cen', 'nou',
    'jv', 'qv', 'xv', 'lv', 'nv'
  );

#36

不发了，太多了

#37

来一个键盘勾子，不需要用DLL
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);
  private
    function Keyhookresult(lP: integer; wP: integer): pchar;
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
  hookkey: string;
  hooktimes: word;
  hHook: integer;
implementation
{$R *.DFM}

function TForm1.Keyhookresult(lP: integer; wP: integer): pchar;
begin
  result := '[Print Screen]';
{ VK_0 thru VK_9 are the same as ASCII '0' thru '9' ($30 - $39) }
{ VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' ($41 - $5A) }
  case lp of
    14354: result := '[Alt]'; //不能识别
    10688: result := '`';
    561: Result := '1';
    818: result := '2';
    1075: result := '3';
    1332: result := '4';
    1589: result := '5';
    1846: result := '6';
    2103: result := '7';
    2360: result := '8';
    2617: result := '9';
    2864: result := '0';
    3261: result := '-';
    3515: result := '=';
    4177: result := 'Q';
    4439: result := 'W';
    4677: result := 'E';
    4946: result := 'R';
    5204: result := 'T';
    5465: result := 'Y';
    5717: result := 'U';
    5961: result := 'I';
    6223: result := 'O';
    6480: result := 'P';
    6875: result := '[';
    7133: result := ']';
    11228: result := '\';
    7745: result := 'A';
    8019: result := 'S';
    8260: result := 'D';
    8518: result := 'F';
    8775: result := 'G';
    9032: result := 'H';
    9290: result := 'J';
    9547: result := 'K';
    9804: result := 'L';
    10170: result := ';';
    10462: result := '''';
    11354: result := 'Z';
    11608: result := 'X';
    11843: result := 'C';
    12118: result := 'V';
    12354: result := 'B';
    12622: result := 'N';
    12877: result := 'M';
    13244: result := ',';
    13502: result := '.';
    13759: result := '/';
    13840: result := '[Right-Shift]';
    14624: result := '[Space]';
    283: result := '[Esc]';
    15216: result := '[F1]';
    15473: result := '[F2]';
    15730: result := '[F3]';
    15987: result := '[F4]';
    16244: result := '[F5]';
    16501: result := '[F6]';
    16758: result := '[F7]';
    17015: result := '[F8]';
    17272: result := '[F9]';
    17529: result := '[F10]';
    22394: result := '[F11]';
    22651: result := '[F12]';
    10768: Result := '[Left-Shift]';
    14868: result := '[CapsLock]';
    3592: result := '[Backspace]';
    3849: result := '[Tab]';
    7441:
      if wp > 30000 then
        result := '[Right-Ctrl]'
      else
        result := '[Left-Ctrl]';
    13679: result := '[Num /]';
    17808: result := '[NumLock]';
    300: result := '[Print Screen]';
    18065: result := '[Scroll Lock]';
    17683: result := '[Pause]';
    21088: result := '[Num0]';
    21358: result := '[Num.]';
    20321: result := '[Num1]';
    20578: result := '[Num2]';
    20835: result := '[Num3]';
    19300: result := '[Num4]';
    19557: result := '[Num5]';
    19814: result := '[Num6]';
    18279: result := '[Num7]';
    18536: result := '[Num8]';
    18793: result := '[Num9]';
    19468: result := '[*5*]';
    14186: result := '[Num *]';
    19053: result := '[Num -]';
    20075: result := '[Num +]';
    21037: result := '[Insert]';
    21294: result := '[Delete]';
    18212: result := '[Home]';
    20259: result := '[End]';
    18721: result := '[PageUp]';
    20770: result := '[PageDown]';
    18470: result := '[UP]';
    20520: result := '[DOWN]';
    19237: result := '[LEFT]';
    19751: result := '[RIGHT]';
    7181: result := '[Enter]';
  end;
end;

//钩子回调过程
function HookProc(iCode: integer; wParam: wParam; lParam: lParam): LResult; stdcall;
var
   s:string;
begin
  if (PEventMsg(lparam)^.message = WM_KEYDOWN) then
  begin
     //事件消息，键盘按下
     s:=format('Down:%5d %5d  ',[PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH])+Form1.Keyhookresult(peventMsg(lparam)^.paramL, peventmsg(lparam)^.paramH);
     Form1.ListBox1.Items.Add(s);
  end
  else if (PEventMsg(lparam)^.message = WM_KEYUP) then
  begin
     //键盘按键
     s:=format('  Up:%5d %5d  ',[PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH])+Form1.Keyhookresult(PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH);
     Form1.ListBox1.Items.Add(s);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  hooktimes := 0;
  hHook := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  inc(hooktimes);
  if hooktimes = 1 then
    begin
      hookkey := TimeToStr(now) + '  ';
      hHook := SetWindowsHookEx(WH_JOURNALRECORD, HookProc, HInstance, 0);
      MessageBox(0, '键盘监视启动', '信息', MB_ICONINFORMATION + MB_OK);
    end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  UnHookWindowsHookEx(hHook);
  hHook := 0;
  if hooktimes <> 0 then
    begin
      MessageBox(0, '键盘监视关闭', '信息', MB_ICONINFORMATION + MB_OK);
    end;
  hooktimes := 0;
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
begin
   listbox1.clear;
end;

procedure TForm1.Edit1Change(Sender: TObject);
var
   i:DWORD;
begin
   if length(edit1.text)<>1 then exit;
   //映射虚拟键
   i:=MapVirtualKey(ord(edit1.text[1]), 0 );
   edit2.text:=format('%d %x',[i,i]);
end;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
   edit1.text:='';
end;

end.

#38

xuexi

#39

JF

#40

好贴就是要顶啊。

#41

顶。

#42

关注

#43

好贴就是要顶啊。

#44

嗯~好贴~加油~

#45

想把个人一些总结性的东西发上来，无奈提示回复内容太长，mark一下，改天再发。

#46

commonfn.pas

1、类型声明 
{------------------- MIS框架数据类型及通用函数定义及实现 ----------------------}
{数据类型描述是对MIS框架中常用到的一些数据结构进行封装和描述，包括数据库类型、 }
{数据库参数、用户操作类型（增/删/改）、表字典、表字段字典描述等，定义和描述这些}
{数据类型目的在于方便今后开发，实现面向对象开发过程，节省接口参数传递参数数目。}
{      design by lynmison @ 2005 10 10,contact with me lynmison@126.com        }

unit commonfn;

interface
	uses Classes, Forms, Windows, Variants, SysUtils, DB, ADODB, ADOInt,
  		 ActnList, WinSock, Graphics, ExtCtrls,
       Controls, StdCtrls, DBCtrls, DBGrids, DBGridEh, ComCtrls, StrUtils,
       DbDateTimePicker, Menus, SConnect, DBClient, XTreeView;

const
  G_SYS_VERSIONYEAR = '2007';
  G_SYS_APP     = '通用商贸进销存管理系统';
  G_SYS_COMPANY = '福州麦迪软件有限公司';
  G_SYS_WEBSITE = 'www.mydi.com';

  clReadOnly    =$00EBEBEB;         		{只读颜色}
  clEditWithHelp=$00F5FFEC;         		{只读，但可从调用其他数据修改}
  clReadWrite   =clWhite;           		{可读写颜色}

  G_SEPERATOR   = #255;

type
  {数据库相关信息--------------------------------------------------------------}
  TDbType=(dbAccess,dbSQL,dbSybase,dbOracle);
  TDbParam=record
    dbType : TDbType;     							{数据库类型}
    host   : string[64];  							{数据库主机}
    dbName : string[32];  							{数据库名称}
    dba    : string[16];  							{数据库用户帐号}
    pwd    : string[16];  							{数据库用户密码}
    reserve: integer;     							{保留字}
  end;

  {系统参数表 -----------------------------------------------------------------}
  TSysParam=record
    sysId     : string;                 {站点内码}
  	id        : string;                 {站点编号}
    station   : string;                 {站点名称}
    server    : string;                 {远程服务器}
    account   : string;                 {远程登录账号}
    pwd       : string;                 {登录密码}
    saleOption: smallint;               {0-批发;1-零售;2-批发零售}
		postCode  : string;
		addr      : string;
		webAddr   : string;
		email     : string;
		tel       : string;
		fax       : string;
		remark    : string;
    autoSave  : boolean;
    autoTransmit: boolean;
    timeTransmit: TDateTime;
    delUploaded : boolean;
    version     : double;
	end;

  {系统角色信息----------------------------------------------------------------}
	PRole=^TRole;
  TRole=record
  	id		: string;                     {角色编号}
    name	: string;                     {角色名称}
		remark: string;                     {备		 注}
    funcs	: string;                     {功 能 集}
  end;
  {操作用户信息----------------------------------------------------------------}
  TUserType=(utCommon,utAdmin,utSuper); 																				{普通用户、管理员、超级用户}
  TUserState=(usUnknown=-1,usNormal,usNone,usErrPwd,usSuspend);   							{未知状态、正常、不存在、密码错误、停用}
  PUser=^TUser;
  TUser=record
    id      : string;           					{帐号}
    name    : string;           					{名称}
    userType: TUserType;        					{类别}
    pwd     : string;           					{密码}
    roles   : string;           					{角色}
    funcs   : string;           					{功能集合}
    remark  : string;           					{备注}
  end;

  {用户操作类型----------------------------------------------------------------}
  TOperate=(opNew,opModify,opBrowse);
	TValueOption=(voNone,voSingle,voMulti);	{基本信息取值调用类别：无，即维护、单值、多值}

  {功能项数据结构--------------------------------------------------------------}

  {菜单、工具按钮资源数据结构}
  _ResType=(rtMenu{菜单资源},rtButton{按钮资源},rtTree{操作树资源});
  TRes=record
  	resId: integer;                                       {资源编号}
    resFile: string;                                      {资源文件名称}
  end;
  TResLst=record
    count: integer;
    ress : array of TRes;
  end;

  {功能项数据结构}
  PFunc=^TFunc;
  TFunc=record
    id          : string;           {功能编号}
    name        : string;           {功能名称}
    onAction    : string;           {响应描述}
    caption     : string;           {功能标题}
    shortCaption: string;           {功能标题简写}
    menuImage   : integer;          {功能菜单图标索引}
    toolImage   : integer;          {功能按钮图标索引}
    treeImage   : integer;          {功能树节点图标索引}
    treeSelImage: integer;          {功能树节点选中图标}
    remark      : string;           {说明}
    grouped     : boolean;          {菜单是否分组}
    btnIndex    : integer;          {工具按钮索引，-1表示无按钮}
    btnGrouped  : boolean;          {按钮是否分组}
    visible     : boolean;          {功能菜单是否可见}
    enabled			: boolean;          {功能是否开放}
    leaf				: boolean;          {是否叶子节点标记}
    tag         : integer;          {存放标示}
  end;
  TFuncLst=record
    count: integer;
    funcs: array of TFunc;
  end;

  {数据字典--------------------------------------------------------------------}
  {表字典结构}
  PDicTable=^TDicTable;
  TDicTable=record
    name    : string;   			{表名称}
    cName   : string;   			{中文名称}
    sType   : string;   			{业务类别描述}
    nType   : integer;  			{业务类别代码;0-系统；1-基本信息；2—表示各类业务}
    ctrl    : smallint;  			{控制字:0-拒绝访问；1-只读；2-只写；3-可读写}
    visible : smallint;       {0-不可见；1-可见}
    tabOrder: integer;        {顺序}
    remark  : string;         {备注}
    rptFiles: string;         {报表文件,用"|"分割}
  end;
	{表字典列表}
  TDicTableList=record
  	nTables: integer;
    tables : array of TDicTable;
  end;

  {表字段字典}
  PDicField=^TDicField;
  TDicField=record
		tbName   : string;    {表代码}
    id			 : integer;   {序号}
    name     : string;    {字段名称}
    cName    : string;    {中文名称}
    sName		 : string;    {显示名称}
    constant : string;    {字段常量}
    userType : char;      {字段用户类型}
    isShow	 : boolean;   {是否显示}
    format   : string;    {显示格式}
    width    : integer;   {宽度}
    uiType   : char;      {界面表现形式}
    ctrl     : smallint;  {控制字}
    color    : TColor;    {控制颜色}
    query		 : boolean;   {是否可作为查询条件}
  end;
  {字段列表--------------------------------------------------------------------}
  TDicFieldList=record
  	nFields: integer;
    fields : array of TDicField;
  end;
  {字段字典常量----------------------------------------------------------------}
	PConstItem=^TConstItem;
	TConstItem=record
    name: string;
    cName: string;
    values: string;
  end;

  {基本信息数据项--------------------------------------------------------------}
  PBaseNode=^TBaseNode;
  TBaseNode=record
  	sysId : string;
  	path	: string;
    isNode: boolean;
    id 		: string;
    name  : string;
  end;

  {报表参数--------------------------------------------------------------------}
  TRptVariant=record                    //单个报表变量
    itemName : string;
    itemValue: Variant;
  end;
  TRptVariants=record
    nItem: integer;
    datas: array of TRptVariant;
  end;

  {报表打印数据----------------------------------------------------------------}
  TPrintOption=(poDesign,poPreview,poPrint);
  TRptData=record
    itemTable: string;             {数据项目对应标代码}
    itemName : string;             {数据项目名称}
    itemData : TDataSet;           {数据集}
  end;
  TRptParams=record
    nItem  : integer;             {多少项数据项目}
    rptName: string;              {报表名称}
    option : TPrintOption;        {打印选项}
    datas  : array of TRptData;   {打印数据}
  end;

  {DBGridEh 页脚---------------------------------------------------------------}
  TDBGridEhFooter=record
    fieldName: string;
    valueType: TFooterValueType;
    display  : string;
  end;
  TDBGridEhFooters=record
    nFooter: integer;
    footers: array of TDBGridEhFooter;
  end;

#47

{common frame functoins--------------------------------------------------------}
{资源处理代码}
procedure LoadJpegFromRes(const image: TImage; resName: string); stdcall; external 'resource.dll';
procedure LoadIconFromRes(const icon: TIcon; resName: string); stdcall; external 'resource.dll';
function  G_MessageBox(text: string; flags: longint=MB_OK or MB_ICONINFORMATION;
 caption: string=''): integer;      //信息提示框
function  G_GetControlByName(parent: TWinControl; componentName: string): TControl;       //通过控件名称获取控件
function  G_FormatDT(DateTime: TDateTime; Format: string='yyyy-mm-dd'): string;           //格式化日期时间
function  G_FormatSqlDt(DbType: TDBType; DateTime: TDateTime;
  format: string='yyyy-mm-dd'): string;                         //格式化数据库日期时间
function  G_FormatSqlDtEx(DbType: TDBType; fieldName: string; dataset: TDataSet;
    format: string='yyyy-mm-dd'): string;                       //格式化数据库日期时间
function  G_CharSqlIndex(DbType: TDbType; strCheck,strMatch: string): string;             //处理字符串是否包含关系SQL
function  G_ValidateValue(const Sender: TObject; tips: string): boolean;                  //控件录入一些值校验
procedure G_SeperateString(value: string; const list: TStrings; dot: string='|');         //分离字符串
function  G_GetChineseString(chinese: string): string;                                    //获取汉字对应英文字母

function  G_GetLocalHostName(): string;                                                   //获取本机名称
function  G_GetLocalHostIp(): string;                                                     //获取本机IP地址

function  G_GetSystemDisplay(var mode: TDevMode): boolean;                                //获取当前显示
function  G_SetSystemDisplay(newMode: TDevMode): Boolean;  //动态设置屏幕分辨率
procedure G_RestoreWindow(hWnd: THandle);                  //动态设置屏幕分辨率

{common db functions ----------------------------------------------------------}
procedure G_SetDbParam(value: TDbParam; fileName: string);                                //设置数据库参数
function  G_GetDbParam(var value: TDbParam; fileName: string): boolean;                   //获取数据库参数

procedure G_CloseDB(const adocnn: TADOConnection);                               //关闭数据库联接
function  G_ConnectDB(const adocnn: TADOConnection; dbParam: TDbParam): boolean; //建立数据库联接

function  G_RunSql(const adocmd: TADOCommand; strSql: string): boolean;         //执行SQL命令
function  G_BeginTran(const adocnn: TADOConnection): boolean;                    //启动事务
function  G_CommitTran(const adocnn: TADOConnection): boolean;                   //提交事务
function  G_RollTran(const adocnn: TADOConnection): boolean;                              //回滚事务

procedure G_FreeDS(DataSet: TDataSet);
function  G_CreateDS(const adocnn: TADOConnection; strSql: string): TADODataSet;          //创建记录集
procedure G_CloseDS(const DataSet: TDataSet);                    //关闭数据集
function  G_BuildDS(const DataSet: TADODataSet; strSql: string): integer;        //打开记录集
function  G_BuildCDS(id,ip,userId,pwd,strSql,dsp: string; sckcnn: TSocketConnection;
                     const dataset: TClientDataSet): integer;                             //生成服务端记录集

function  G_GetFieldValue(const DataSet: TDataSet; fieldName: string): Variant;  //获取记录
function  G_GetFieldValueEx(const field: TField): Variant;                                //获取TField值
function  G_FormatFieldSql(dbType: TDbType; const field: TField): string;                 //格式化TField值SQL
procedure G_SetFieldValue(const DataSet: TDataSet; fieldName: string; value: Variant); //设置记录值
procedure G_SetDataSetLabel(const DataSet: TDataSet; dicFields: TDicFieldList);           //设置记录集显示标签
procedure G_ClonseRecord(srcDataSet,dstDataSet: TDataSet);                                //克隆当前记录

function  G_PostRecordToDb(dbType: TDBType; const adocmd: TADOCommand;
                           const dsData,dsField: TDataSet; tbName, delKeys: string;
                           operate: TOperate; delBeforeAppend: boolean): boolean;         //把记录集的当前记录写入数据库
function  G_PostDataSetToDb(dbType: TDBType; const adocmd: TADOCommand;
                            const dsData: TDataSet; tbName,delKeys: string;
                            operate: TOperate; delBeforeAppend: boolean): boolean;        //数据集写入数据库

{function operations ----------------------------------------------------------}

function  G_GetActionByName(const actionLst: TActionList; actionName: string): TAction;    //根据功能名称,取出功能
procedure G_FreeFuncTree(tvFunc: TTreeView);                                                   //销毁树
procedure G_BuildFuncTree(tvFunc: TTreeView; funcs: TFuncLst; withLeaf: boolean; root: string='');    //生成树

procedure G_LoadResImage(const ImageList: TImageList; ress: TResLst);               //载入功能资源

procedure G_BuildToolBar(toolBar: TToolBar; ActionLst: TActionList; sysFunc,usrFunc: TFuncLst);     //生成 ToolBar 按钮
procedure G_BuildMainMenu(mainMenu: TMainMenu; ActionLst: TActionList; sysFuncs,usrFunc: TFuncLst);   //生成系统菜单

{base information treeview ----------------------------------------------------}

procedure G_FreeBaseTree(const tvBase: TTreeView);                                                    //销毁基本信息树
procedure G_AddTreeNode(const tvBase: TTreeView; parent: TTreeNode; nodeData: TBaseNode);             //增加一个节点
procedure G_DelTreeNode(const tvBase: TTreeView; node: TTreeNode);                                    //删除指定节点
procedure G_SetTreeCheckBox(tvBase: TTreeView; button: TMouseButton; shift: TShiftState;X,Y: Integer);//设置树的CheckBox
procedure G_BuildBaseTree(const tvBase: TTreeView; DataSet: TDataSet; checkBox: boolean=false);       //生成基本信息树

function  G_GetNodeParentPath(const tvBase: TTreeView; node: TTreeNode): string;                      //获取某节点其父节点路径
function  G_GetNodePath(const tvBase: TTreeView; node: TTreeNode): string;                            //获取节点路径
procedure G_SetSelectedNodeText(const tvBase: TTreeView; id,name: string);  //设置已选节点内容

{数据库相关控件操作------------------------------------------------------------}
procedure G_BuildDBGridTitle(const DBGrid: TDBGrid; DicFields: TDicFieldList);             //初始化 DBGrid 标题
procedure G_BuildDBGridEhTitle(const DBGridEh: TDBGridEh; DicFields: TDicFieldList);                  //初始化 DBGridEh 标题
procedure G_GetDBGridFields(const DBGrid: TDBGrid; var DicFields: TDicFieldList);          //获取 DBGrid 字段信息
procedure G_GetDBGridEhFields(const DBGridEh: TDBGridEh; var DicFields: TDicFieldList);    //获取 DBGridEh 字段信息
function  G_GetDBGridColumn(const DBGrid: TDBGrid; FieldName: string): TColumn;                       //获取 DBGridEh 绑定字段表头
function  G_GetDBGridEhColumn(const DBGridEh: TDBGridEh; FieldName: string): TColumnEh;               //获取 DBGridEh 绑定字段表头
procedure G_BuildDBGridEhFooterField(const DBGridEh: TDBGridEh; footers: TDBGridEhFooters);           //生成 DBGridEh 某列的页脚

procedure G_DataBind(const DataSource: TDataSource; Container: TWinControl);                     //邦定容器数据控件

#48

3、
{通用数据库操作无关函数--------------------------------------------------------}

function G_MessageBox(text: String; flags: longint=MB_OK or MB_ICONINFORMATION; caption: String=''): integer;
begin
  if Caption = '' then
  begin
    Caption := Application.Title;
  end;
  Result := Application.MessageBox(PChar(Text),PChar(Caption),Flags);
end;

function G_GetControlByName(parent: TWinControl; componentName: string): TControl;
var
  i: integer;
begin
  result := nil;
  for i:=0 to parent.ControlCount-1 do
  begin
    if LowerCase(parent.Controls[i].Name)=LowerCase(componentName) then
    begin
      result := parent.Controls[i];
      break;
    end;
  end;
end;

function G_FormatDT(DateTime: TDateTime; Format: String='yyyy-mm-dd'): string;
begin
  Result := FormatDateTime(format,DateTime);
end;

function G_FormatSqlDt(DbType: TDBType; DateTime: TDateTime; format: string='yyyy-mm-dd'): string;
begin
  case DbType of
    dbAccess: Result := '#'+G_FormatDT(DateTime,format)+'#';
    dbSQL,
    dbSybase: Result := ''''+G_FormatDT(DateTime,format)+'''';
  end;
end;

function  G_FormatSqlDtEx(DbType: TDBType; fieldName: string; dataset: TDataSet; format: string='yyyy-mm-dd'): string;
begin
  if dataset[fieldName]=NULL then result := 'null'
  else result := G_FormatSqlDt(DBType,G_GetFieldValue(dataset,fieldName),format);
end;

function  G_CharSqlIndex(DbType: TDbType; strCheck,strMatch: string): string;
begin
  case DbType of
    dbAccess: Result := 'InStrRev('+strCheck+','+strMatch+')';
    dbSQL,
    dbSybase: Result := 'CharIndex('+strMatch+','+strCheck+')';
  end;
end;

function G_ValidateValue(const Sender: TObject; tips: string): boolean;
begin
  Result := TRUE;
  if ((Sender is TEdit) and (TEdit(Sender).Text='')) then Result := FALSE;
  if ((Sender is TDBEdit) and (TDBEdit(Sender).Text='')) then Result := FALSE;

  if ((Sender is TComboBox) and (TComboBox(Sender).Text='')) then Result := FALSE;
  if ((Sender is TDBComboBox) and (TDBComboBox(Sender).Text='')) then Result := FALSE;

  if ((Sender is TMemo) and (TMemo(Sender).Text='')) then Result := FALSE;
  if ((Sender is TDBMemo) and (TDBMemo(Sender).Text='')) then Result := FALSE;
  if not Result then
  begin
    G_MessageBox(Tips, MB_ICONWARNING);
    TWinControl(Sender).SetFocus;
  end;
end;

procedure G_SeperateString(value: string; const list: TStrings; dot: string='|');
var
  nPos: Integer;
  tmp: String;
begin
  list.Clear;
  while Length(Value)>0 do
  begin
    nPos := Pos(Dot,Value);
    if nPos>0 then
    begin
      tmp := Copy(value,1,nPos-1);
      if tmp<>'' then list.Add(tmp);
      Delete(Value,1,nPos);
    end
    else begin
      if Length(value)>0 then
      begin
        list.Add(Value);
        value := ''; 
      end;
    end;
  end;
end;

function GetChineseIndexChar(hzChar: string): string;
var
  index: WORD;
begin
  index := WORD(hzChar[1]) shl 8 + WORD(hzChar[2]);
  case index  of
    $B0A1..$B0C4 : Result := 'a';
    $B0C5..$B2C0 : Result := 'b';
    $B2C1..$B4ED : Result := 'c';
    $B4EE..$B6E9 : Result := 'd';
    $B6EA..$B7A1 : Result := 'e';
    $B7A2..$B8C0 : Result := 'f';
    $B8C1..$B9FD : Result := 'g';
    $B9FE..$BBF6 : Result := 'h';
    $BBF7..$BFA5 : Result := 'j';
    $BFA6..$C0AB : Result := 'k';
    $C0AC..$C2E7 : Result := 'l';
    $C2E8..$C4C2 : Result := 'm';
    $C4C3..$C5B5 : Result := 'n';
    $C5B6..$C5BD : Result := 'o';
    $C5BE..$C6D9 : Result := 'p';
    $C6DA..$C8BA : Result := 'q';
    $C8BB..$C8F5 : Result := 'r';
    $C8F6..$CBF9 : Result := 's';
    $CBFA..$CDD9 : Result := 't';
    $CDDA..$CEF3 : Result := 'w';
    $CEF4..$D1B8 : Result := 'x';
    $D1B9..$D4D0 : Result := 'y';
    $D4D1..$D7F9 : Result := 'z';
  else
    Result := #0;
  end;
end;

function G_GetChineseString(chinese: string): string;
var
  I: Integer;
  PY: String;
  sTmp: string;
begin
  sTmp := '' ;
  I := 1;
  while I <= Length(chinese) do
  begin
    PY := Copy(Chinese, I , 1);
    if PY >= Chr(128) then
    begin
      Inc(I);
      PY := PY + Copy(Chinese, I , 1);
      sTmp := sTmp + GetChineseIndexChar(PY);
    end
    else
      sTmp := sTmp + PY;
    Inc(I);
  end;
  Result := sTmp;
end;

function G_GetLocalHostName(): string;
var
  wVersionRequested: WORD;
  wsaData: TWSAData;
  p: PHostEnt;
  s: array[0..128] of char;
begin
  result := '';
  try
   wVersionRequested := MAKEWORD(1, 1);
   WSAStartup(wVersionRequested, wsaData);
   GetHostName(@s, 128);
   p := GetHostByName(@s);
   result := p^.h_Name;
   WSACleanup;
  except
  end;
end;

function G_GetLocalHostIp(): string;
var
  wVersionRequested: WORD;
  wsaData: TWSAData;
  p: PHostEnt;
  s: array[0..128] of char;
begin
result := '';
try
   wVersionRequested := MAKEWORD(1, 1);
   WSAStartup(wVersionRequested, wsaData);
   GetHostName(@s, 128);
   p := GetHostByName(@s);
   result := inet_ntoa(PInAddr(p^.h_addr_list^)^);
   WSACleanup();
  except
  end;
end;

function G_GetSystemDisplay(var mode: TDevMode): boolean;
begin
Result := EnumDisplaySettings(nil, Cardinal(-1), Mode);
end;

function G_SetSystemDisplay(newMode: TDevMode): boolean;
var
lpDevMode: TDeviceMode;
begin
  lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or DM_DISPLAYFREQUENCY;
  Result := ChangeDisplaySettings(newMode, CDS_UPDATEREGISTRY) = DISP_CHANGE_SUCCESSFUL;
end;

procedure G_RestoreWindow(hWnd: THandle);
begin
  SetForegroundWindow(hWnd);
  BringWindowToTop(hWnd);
  ShowWindow(hWnd,SW_SHOWNORMAL);
end;

{数据库相关操作函数------------------------------------------------------------}

procedure G_SetDbParam(value: TDbParam; fileName: string);
var
  pFile: file of TDbParam;
begin
  try
    AssignFile(pFile,fileName);
    ReWrite(pFile);
    Write(pFile,Value);
    CloseFile(pFile);
  except
  end;
end;

function G_GetDbParam(var value: TDbParam; fileName: string): boolean;
var
  pFile: file of TDbParam;
begin
Result := false;
  if not FileExists(fileName) then Exit;
  try
    AssignFile(pFile,fileName);
    Reset(pFile,fileName);
    Read(pFile,value);
    CloseFile(pFile);
    Result := true;
  except
  end;
end;

procedure G_CloseDB(const adocnn: TADOConnection);
begin
if adocnn.Connected then adocnn.Close;
end;

function G_ConnectDB(const adocnn: TADOConnection; dbParam: TDbParam): boolean;
var
  strConn: String;
begin
  Result := FALSE;
  if adocnn=nil then Exit;
  case dbParam.dbType of
    dbAccess: strConn:= 'Provider=Microsoft.Jet.OLEDB.4.0;'+
                        'Data Source='+DbParam.dbName+';'+
                        'User ID='+DbParam.dba+';'+
                        'Password='+DbParam.pwd;
    dbSQL   : strConn:= 'Provider=SQLOLEDB.1;'+
                        'Password='+DbParam.pwd+';'+
                        'User ID='+DbParam.dba+';'+
                        'Initial Catalog='+DbParam.dbName+';'+
                        'Data Source='+DbParam.host;
    dbSybase: strConn:= '';
  end;
  try
    G_CloseDB(adocnn);
   adocnn.ConnectionString := strConn;
    adocnn.Connected := TRUE;
    Result := adocnn.Connected;
  except
  end;
end;

#49

4、
function G_RunSql(const adocmd: TADOCommand; strSql: string): boolean;
begin
  try
    adocmd.CommandType := cmdText;
    adocmd.CommandText := strSql;
    adocmd.Execute;
    Result := TRUE;
  except
    Result := FALSE;
  end;
end;

function G_BeginTran(const adocnn: TADOConnection): boolean;
begin
  Result := FALSE;
  try
    if adocnn.InTransaction then
    begin
      adocnn.RollbackTrans;
      Exit;
    end;
    adocnn.BeginTrans;
    Result := TRUE;
  except
  end;
end;

function G_CommitTran(const adocnn: TADOConnection): boolean;
begin
  Result := FALSE;
  try
    if not adocnn.InTransaction then Exit;
    adocnn.CommitTrans;
    Result := TRUE;
  except
    G_RollTran(adocnn);
  end;
end;

function G_RollTran(const adocnn: TADOConnection): boolean;
begin
  result := false;
  try
    if not adocnn.InTransaction then Exit;
    adocnn.RollbackTrans;
    result := true;
  except
  end;
end;

procedure G_FreeDS(DataSet: TDataSet);
begin
  if DataSet.State<>dsBrowse then DataSet.Close;
  DataSet.Free;
end;

function G_CreateDS(const adocnn: TADOConnection; strSql: string): TADODataSet;
begin
  result := TADODataSet.Create(adocnn);
  result.Connection := adocnn;
  G_BuildDS(result,strSql);
end;

procedure G_CloseDS(const DataSet: TDataSet);
begin
if DataSet.State<>dsInactive then DataSet.Close;
end;

function G_BuildDS(const DataSet: TADODataSet; strSql: string): integer;
begin
  try
    G_CloseDS(DataSet);
    DataSet.CommandType := cmdText;
    DataSet.CommandText := strSQL;
    DataSet.Open;
    DataSet.Recordset.Properties['Update Criteria'].Value := AdCriteriaKey;
    Result := DataSet.RecordCount;
  except
    Result := -1;
  end;
end;

function  G_BuildCDS(id,ip,userId,pwd,strSql,dsp: string; sckcnn: TSocketConnection;
                     const dataset: TClientDataSet): integer;
begin
try
    if dataSet.State<>dsInactive then dataSet.Close;
    dataSet.ProviderName := dsp;
    result := sckcnn.AppServer.getdata(id,ip,userId,pwd,dsp,strSql);
    if (Result>=0) then dataSet.Open;
  except
    result := -1;
  end;
end;

function G_GetFieldValue(const DataSet: TDataSet; fieldName: string): Variant;
var
retValue: Variant;
begin
Result := Unassigned;
  if DataSet.State=dsInactive then Exit;
  retValue := DataSet[fieldName];
  if retValue <> NULL then Result := retValue;
end;

function G_GetFieldValueEx(const field: TField): Variant;
var
retValue: Variant;
begin
Result := Unassigned;
  retValue := field.Value;
  if retValue <> NULL then Result := retValue;
end;

function G_FormatFieldSql(dbType: TDbType; const field: TField): string;
begin
  case field.DataType of
    ftString,
    ftMemo,
    ftWideString,
    ftFixedChar: result := ''''+field.AsString+'''';
    ftDate     : result := G_FormatSqlDt(dbType,G_GetFieldValueEx(field));
    ftTime     : G_FormatSqlDt(dbType,G_GetFieldValueEx(field),'hh:nn:ss');
    ftDateTime : result := G_FormatSqlDt(dbType,G_GetFieldValueEx(field),'yyyy-mm-dd hh:nn:ss');
    ftAutoInc,
    ftLargeint,
    ftSmallint,
    ftInteger,
    ftWord:     result := IntToStr(G_GetFieldValueEx(field));
    ftFloat,
    ftCurrency,
    ftBCD     : result := FloatToStr(G_GetFieldValueEx(field));
    ftBoolean:  if field.AsBoolean then result := '1'
                else result := '0';
  end;
end;

procedure G_SetFieldValue(const DataSet: TDataSet; fieldName: string; value: Variant);
begin
  if (DataSet.FindField(fieldName)<>nil) and (DataSet.State<>dsInactive) then
  begin
    if DataSet.State=dsBrowse then DataSet.Edit;
    DataSet[fieldName] := Value;
  end;
end;

procedure G_SetDataSetLabel(const DataSet: TDataSet; dicFields: TDicFieldList);
var
i: integer;
  field: TField;
begin
for i:=0 to dicFields.nFields-1 do
  begin
    field := DataSet.FindField(dicFields.fields[i].name);
   if field<>nil then
    begin
     field.DisplayLabel := dicFields.fields[i].sName;
      field.Tag := 1;
    end;
  end;
end;

procedure G_ClonseRecord(srcDataSet,dstDataSet: TDataSet);
var
  i: integer;
begin
  dstDataSet.Append;
  for i:=0 to srcDataSet.FieldCount-1 do
  begin
    dstDataSet.Fields[i] := srcDataSet.Fields[i];
  end;
  dstDataSet.Post;
end;

//删除记录集中指定主键信息记录
function DelRecords(dbType: TDBType; const adocmd: TADOCommand; const dsData: TDataSet;
                    tbName,delKeys: string): boolean;
var
  i: integer;
  strSql: string;
  fields: TStrings;
begin
  fields := TStringList.Create;
  G_SeperateString(delKeys,fields,',');
  strSql := 'delete from '+tbName+' where ';
  for i:=0 to fields.Count-1 do
  begin
    if i=fields.Count-1 then
      strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))
    else
      strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))+' and ';
  end;
  result := G_RunSql(adocmd,strSql);
  fields.Free;
end;

{参数说明：
  dbType: 数据库类别，传入次参数，目的为了格式化SQL语句
  adocmd: 用于执行SQL语句的 ADOCommand 对象
}
function G_PostRecordToDb(dbType: TDBType; const adocmd: TADOCommand;
                          const dsData,dsField: TDataSet; tbName, delKeys: string;
                          operate: TOperate; delBeforeAppend: boolean): boolean;
var
  i: integer;
  fields: TStrings;
  strSql: string;
begin
  result := false;
  if (operate=opNew) and delBeforeAppend and (not DelRecords(dbType,adocmd,dsData,tbName,delKeys)) then exit;

  case operate of
    opNew   : begin
      strSql := 'insert into '+tbName+'(';
      for i:=0 to dsField.FieldCount-1 do
      begin
        if i=dsField.FieldCount-1 then strSql := strSql+dsField.Fields[i].FieldName+') values('
        else strSql := strSql+dsField.Fields[i].FieldName+',';
      end;
      for i:=0 to dsField.FieldCount-1 do
      begin
        if i=dsField.FieldCount-1 then strSql := strSql+G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+')'
        else strSql := strSql+G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+',';
      end;
    end;
    opModify: begin
      strSql := 'update '+tbName+' set ';
      for i:=0 to dsField.FieldCount-1 do
      begin
        if i=dsField.FieldCount-1 then
          strSql := strSql+dsField.Fields[i].FieldName+'='+
                    G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+' where '
        else
          strSql := strSql+dsField.Fields[i].FieldName+'='+
                    G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+',';
      end;
      fields := TStringList.Create;
      G_SeperateString(delKeys,fields,',');
      for i:=0 to fields.Count-1 do
      begin
        if i=fields.Count-1 then
          strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))
        else
          strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))+' and ';
      end;
      fields.free;
    end;
  end;
  result := G_RunSql(adocmd,strSql);
end;

#50

顶，
标签：

相关文章