BlogJava-konhon-随笔分类-Delphi

TClientDataSet

konhon 优华 — Thu, 29 Mar 2007 10:57:00 GMT

http://www.openitpower.com/wenzhang/97/10846_1.html

　　与TTable、TQuery一样，TClientDataSet也是从TDataSet继承下来的，它通常用于多层体系结构的客户端。TClientDataSet最大的特点是它不依赖于BDE(Borland Database Engine)，但它需要一个动态链接库的支持，这个动态链接库叫DBCLIENT.DLL。在客户端，也不需要用TDatabase构件，因为客户端并不直接连接数据库。
　　由于TClientDataSet是从TDataSet继承下来的，所以，它支持诸如编辑、搜索、浏览、纠错、过滤等功能。由于TClientDataSet在内存中建立了数据的本地副本，上述操作的执行速度很快。也正是由于TClientDataSet并不直接连接数据库，因此，客户程序必须提供获取数据的机制。在Delphi 4中，TClientDataSet有三种途径获取数据：
.从文件中存取数据。
.从本地的另一个数据集中获取数据。
.通过IProvider接口从远程数据库服务器获取数据。
　　在一个客户程序中，可以同时运用上述三种机制获取数据。
11.1 浏览和编辑数据
　　和其他数据集构件一样，可以用标准的数据控件显示由TClientDataSet引入的数据集，当然，这需要借助于TDataSource构件。
　　由于TClientDataSet是从TDataSet继承下来的，所以，凡是其他数据集构件支持的功能，TClientDataSet构件也大致具备。不同的是，TClientDataSet能够在内存中建立数据的副本，因此，TClientDataSet比其他数据集构件增加了一些特殊的功能。
11.1.1 浏览数据
　　可以用标准的数据控件显示由TClientDataSet引入的数据集。在运行期，可以调用诸如First、GotoKey、Last、Next和Prior等函数来浏览数据。
　　TClientDataSet也支持书签功能，可以用书签来标记某条记录，以后就可以方便地找到这条记录。
　　对于TTable、TQuery等数据集构件来说，只能读RecNo属性来判断当前记录的序号。对于TClientDataSet构件来说，还可以写RecNo属性，使某一序号的记录成为当前记录。
11.1.2 CanModify属性
　　TDataSet的CanModify属性用于判断数据集中的数据是否可以修改。CanModify属性本身是只读的，也就是说，数据是否能够修改不取决于应用程序。
　　不过，TClientDataSet构件有其特殊性，因为TClientDataSet已经把数据在内存中建立了副本，因此，应用程序可以决定是否允许修改数据。如果不允许用户修改数据，只要把ReadOnly属性设为True，此时，CanModify属性肯定返回False。
　　与其他数据集构件不同，修改TClientDataSet构件的ReadOnly属性时，不需要事先把Active属性设为True。
11.1.3 取消修改
　　TClientDataSet传输数据的基本单位称为数据包，当前的数据包可以由Data属性来访问。不过，用户对数据的修改并不直接反映到Data属性中，而是临时写到一个日志即Delta属性中，这样做的好处是以后随时可以取消修改。
　　不过，这里要说明一点，尽管用户的修改并没有反映到Data，当用户在数据控件中看到的却是最新修改的数据。如果一条记录被反复修改了多次，用户看到的只是最新的数据，但日志中却记载了多次。
　　要取消上一次的修改，调用UndoLastChange函数。UndoLastChange需要传递一个布尔类型的参数叫FollowChange，如果FollowChange参数设为True，光标就移到被恢复的记录上，如果FollowChange参数设为False，光标仍然在当前记录上。
　　ChangeCount属性返回日志中记载的修改次数。如果一条记录被反复修改了多次，每调用一次UndoLastChange能够逐级取消上一次的修改。
　　UndoLastChange只能取消上一次的修改，如果想一下子取消所有的修改，首先要选择一个记录，然后调用RevertRecord。RevertRecord将从日志中取消所有对当前记录的修改。
　　TClientDataSet还有一个SavePoint属性，它能把当前的编辑状态保存起来，以后随时可以返回当时的状态。例如，可以这样保存当前的状态：
　　BeforeChanges := ClientDataSet1.SavePoint;
　　以后，可以这样来恢复当时的状态：
　　ClientDataSet1.SavePoint := BeforeChanges;
　　应用程序可以保存多处状态，可以恢复其中一个状态，不过，一旦某个状态被恢复，在其之后的状态就无效。
　　如果要一下子取消日志中记载的所有修改，可以调用CancelUpdates函数。CancelUpdates将把日志清空，取消所有的修改。
　　如果LogChanges属性设为False，用户对数据的修改就会直接反映到Data属性中。
11.1.4 合并修改
　　要把日志中记载的修改合并到Data属性中，有两种方式，具体使用哪一种方式，取决于应用程序获取数据的机制。不过，不管是哪种机制，合并后，日志自动被清空。
　　对于一个从文件中获取数据的程序来说，只要调用MergeChangeLog函数，就把日志中记载的修改合并到Data属性中。不用担心其他用户同时修改了数据。
　　对于一个从应用服务器获取数据的程序来说，就不能调用MergeChangeLog来合并数据，而要调用ApplyUpdates函数，ApplyUpdates会把日志中记载的修改传递给应用服务器，待应用服务器成功地把数据更新了数据库服务器后，才会合并到Data属性中。
11.1.5 纠错
　　TClientDataSet支持纠错功能。一般情况下，需要自己建立纠错规则，以便对用户输入的数据进行纠错。
　　此外，如果获得了IProvider接口的话，还可以从远程服务器引入纠错规则。
　　有时候，客户端可能需要暂时禁止纠错，因为客户端从应用服务器检索数据是分阶段进行的，在所有的数据检索完毕之前，有些纠错规则很可能会报错。
要暂时禁止纠错，可以调用DisableConstraints，要重新允许纠错，可以调用EnableConstraints函数。DisableConstraints和EnableConstraints实际上都是作用于一个内部的计数。
11.2 索引
　　使用索引有这么几个好处：
.在数据集中定位记录比较快。
.能够在两个数据集之间建立Lookup或Master/Detail关系。
.可以对记录排序。
　　在多层体系结构中，当客户程序从应用服务器检索数据时，它同时获得了默认的索引。默认的索引叫DEFAULT_ORDER，可以使用这个索引排序，但不能修改或删除这个索引。
　　除了默认的索引外，TClientDataSet还对日志中记载的记录自动建立了一个副索引叫CHANGEINDEX。与DEFAULT_ORDER一样，不能修改或删除这个副索引。
　　另外，还可以使用数据集中已建立的其他索引，或者自己建立索引。
11.2.1 创建一个新的索引
　　要创建一个新的索引，可以调用AddIndex。AddIndex需要传递若干个参数：
　　一是Name参数，用于指定索引名。在运行期切换索引时需要用到索引的名称。
　　二是Fields参数，它是一个字符串，用于指定索引中的字段名，彼此之间用分号隔开。
　　三是Options参数，用于设置索引的选项，包含ixDescending元素表示按降序排列，包含ixCaseInsensitive元素表示大小写不敏感。
　　四是DescFields参数，它也是一个字符串，用于指定若干个字段名，这些字段将按照降序排列。
　　五是CaseInsFields参数，它的作用与DescFields参数类似，包含在CaseInsFields参数中的字段将对大小写不敏感。
　　六是GroupingLevel参数，用于指定分组级别，其值不能超过索引中的字段数。
　下面的代码创建了一个索引：
If Edit1.Text <> '' and ClientDataSet1.Fields.FindField(Edit1.Text) then
Begin
ClientDataSet1.AddIndex(Edit1.Text+'Index',Edit1.Text, 　
　 [ixCaseInsensitive],'','',0);
ClientDataSet1.IndexName := Edit1.Text + 'Index';
End;
为了避免创建一个索引，可以临时用IndexFieldNames属性来指定若干个字段，让数据集按这些字段排序。
11.2.2 删除和切换索引
　　要删除一个先前创建的索引，可以调用DeleteIndex并指定要删除的索引名称。注意：DEFAULT_ORDER和CHANGEINDEX不能删除。
　　如果建立了多个索引，可以任意选择其中的一个索引，这就要用到IndexName属性。
11.2.3 用索引把数据分组
　　选择了一个索引后，数据集将自动按其中的字段进行排序。这样，临近的记录往往在关键字段上含有相同的值。例如，假设有一个表是这样的：
SalesRep　Customer　OrderNo　Amount
1　　　　　　1 　　　　5 　　　100
1　　　　　　1　　　　 2　　　 50
1　　　　　　2　　　　 3 　　　200
1 　　　　　2　　　　6　　　75
2　　　　　　1　　　　1　　　10
2　　　　　　3　　　　4　　　200
　　可以看出，SalesRep字段的值有重复的。对于SalesRep字段的值为1的来说，Customer字段的值也有重复的。这就是说，可以按SalesRep字段分组，进而再按Customer字段分组。显然，这里的分组级别是不同的，按SalesRep字段建立的分组属于第一级，按Customer字段建立的分组属于第二级。实际上，分组级别取决于字段在索引中的顺序。
　　TClientDataSet可以决定是否按照分组级别来显示记录的值。例如，也许想以下面这种形式显示数据：
SalesRep　Customer　OrderNo　Amount
1　　　　　　1　　　　5　　　　100
　　　　　　　　　　　2　　　　50
　　　　　　 2　　　　3　　　　200
　　　　　　　　　　　6　　　　75
2　　　　　　1　　　　1　　　　10
2　　　　　　3　　　　4　　　　200
　　要判断当前记录某一级的什么位置，可以调用GetGroupState函数。GetGroupState函数需要传递一个参数，用于指定分组级别。
11.3 计算字段
　　与其他数据集一样，也可以在TClientDataSet建立的数据集中增加计算字段。计算字段的值是基于同一个记录中的其他字段计算出来的。
　　在其他数据集中，只要用户修改了数据或当前记录发生改变，就会触发OnCalcFields事件，换句话说，计算字段的值就被计算一次。
　　TClientDataSet引入了“内部计算字段”的概念。与一般的计算字段不同的是，内部计算字段的值将随其他字段的值一起存取，这样，只有当用户修改了数据才会触发OnCalcFields事件，如果仅仅改变了当前记录，不会触发OnCalcFields事件。也就是说，内部计算字段的值需要重新计算的机会大大减少。
　　在处理OnCalcFields事件的句柄中，首先要判断State属性。如果State属性返回dsInternalCalc，此时需要计算内部计算字段的值。如果State属性返回dsCalcFields，此时需要计算一般的计算字段的值。
11.4 统计值
　　TClientDataSet增加了统计的功能，它可以基于分组自动计算总和、平均、计数、最大、最小值。当用户编辑数据时，这些统计值会自动跟着变化。
11.4.1 指定统计方式
　　要指定怎样进行统计，就要用到Aggregates属性。这个属性是一个TAggregates对象，它用于管理一组TAggregate对象。
　　在设计期，可以单击Aggregates属性边上的省略号按钮打开如图11.1所示
的编辑器。
　　图11.1 管理一组TAggregate对象
　　单击按钮可以增加一个TAggregate对象，单击按钮可以删减一个TAggregate对象，单击按钮可以把TAggregate对象前移，单击按钮可以把TAggregate对象后移。
　　可以用字段编辑器专门创建一个用于表达统计值的字段，该字段的类型必须是“Aggregate”。Delphi 4会自动创建一个TAggregate对象，并加到Aggregates属性中。选择一个TAggregate对象，Object Inpector将显示该对象的属性。
　　其中，Expression属性用于指定统计表达式，例如：
Sum(Field1)
　　也可以是比较复杂的表达式：
Sum(Qty * Price) - Sum(AmountPaid)
　　在表达式中，可以使用下列统计运算符：
.Sum计算一组数据的总和。
.Avg计算一组数据的平均值。
.Count计算一组数据中的非空值的个数。
.Min计算一组数据的最小值。
.Max计算一组数据的最大值。
　　除了上述几个统计运算符外，还可以使用过滤条件中所能使用的运算符，但不能嵌套。在一个表达式中，可以混合出现几个统计值或常量，但不能混合出现统计值和字段。
　　Sum(Qty * Price){合法}
　　Max(Field1) - Max(Field2){合法}
　　Avg(DiscountRate) * 100{合法}
　　Min(Sum(Field1)){非法，不能嵌套}
　　Count(Field1) - Field2{非法，统计值和字段不能混合出现在一个表达式中}
11.4.2 指定分组
　　默认情况下，统计值是基于数据集中所有的记录计算出来的。不过，也可以针对一部分记录计算统计值，这就需要事先建立分组。
　　前面在介绍索引时已经提到分组的概念。可以通过IndexName属性和GroupingLevel属性来选择使用哪个索引以及最大的分组级别。
　　例如，假设有一个表是这样的：
SalesRep　Customer　OrderNo　Amount
1　　　　　　1 　　　　5 　　　100
1　　　　　　1　　　　 2　　　 50
1　　　　　　2　　　　 3 　　　200
1 　　　　　2　　　　6　　　75
2　　　　　　1　　　　1　　　10
2　　　　　　3　　　　4　　　200
　　如果要按SalesRep字段分组，并且指定其中的第一级，程序代码应当这样写：
Agg.Expression := 'Sum(Amount)';
Agg.IndexName := 'SalesCust';
Agg.GroupingLevel := 1;
Agg.AggregateName := 'Total for Rep';
11.4.3 怎样获取统计值
　　要获取统计值，可以调用TAggregate对象的Value函数。如果统计值是基于数据集中所有的记录计算出来的，随时可以调用Value函数。如果统计值是基于分组计算出来的，必须保证当前记录正好位于该分组内。因此，在调用Value之前，最好先调用GetGroupState函数看看当前记录是否位于该分组内。
　　要在数据控件中显示统计值，必须事先在字段编辑器中创建一个永久字段对象，该字段的类型必须是Aggregate。
11.5 数据包
　　通过Data属性可以访问客户程序从应用服务器检索到的数据。程序示例如下：
Procedure TForm1.Button1Click(Sender: TObject);
Begin
ClientDataSet1.Data := ClientDataSet1.Provider.DataRequest(FilterEdit.Text);
End;
11.5.1 直接对Data属性赋值
　　前面讲过，客户程序既可以通过IProvider接口获取数据，也可以从另一个数据集获取数据，后者就是通过Data属性赋值的。程序示例如下：
　　ClientDataSet1.Data := ClientDataSet2.Data;
　　一旦Data被赋值，就可以用标准的数据控件显示这些数据。
　　注意：当从另一个数据集获取数据时，另一个数据集的日志也将被复制过来，但不包括原来的范围和过滤条件。
　　如果要从另一个基于BDE的数据集中获取数据，可以通过数据集构件的Provider属性，程序示例如下：
　　ClientDataSet1.Data := Table1.Provider.Data;
　　如果要从一个自定义的数据集获取数据，首先要创建一个临时的TProvider构件，然后设置其DataSet属性指定这个自定义的数据集。程序示例如下：
TempProvider := TDataSetProvider.Create(Form1);
TempProvider.DataSet := SourceDataSet;
ClientDataSet1.Data := TempProvider.Data;
TempProvider.Free;
11.5.2 在数据包中加入自定义的信息
　　可以把自定义的信息加到数据包中。当把数据保存到文件或流中时，这些自定义的信息也将保存到文件或流中。如果把数据包直接赋值给另一个数据集的话，这些自定义的信息也将被复制。
　　要把自定义的信息加到数据包中，可以调用SetOptionalParam函数。要从数据包中检索自定义的信息，可以调用GetOptionalParam。程序示例如下：
Procedure TAppServer.Provider1UpdateData(Sender: TObject; DataSet: TClientDataSet);
var
WhenProvided: TDateTime;
Begin
WhenProvided := DataSet.GetOptionalParam('TimeProvided');
...
End;
11.5.3 克隆另一个数据集
　　调用TClientDataSet的CloneCursor函数可以获得一个数据集的完全相同的副本。它与直接通过Data属性赋值是有区别的。
　　区别之一：数据在两个数据集之间是共享的，修改其中一个将同时修改另一个。
　　区别之二：除了数据外，CloneCursor函数还复制了一些属性和事件，这取决于Reset和KeepSettings参数怎样设置。
　　　CloneCursor函数需要传递三个参数，其中，Source参数指定源数据集，Reset参数和KeepSettings参数用于设置除了数据外是否还要复制下列属性和事件：Filter、Filtered、FilterOptions、OnFilterRecord、IndexName、MasterSource、MasterFields、ReadOnly、RemoteServer、ProviderName、Provider。
　　如果Reset和KeepSettings参数都设为False，源数据集的上述属性和事件都将被复制给目标数据集。如果Reset参数设为True，目标数据集的上述属性和事件都将被清空。如果Reset参数设为False，而KeepSettings参数设为True，目标数据集的上述属性和事件不变，不过，必须保证这些属性和事件与克隆后的数据相容。
11.6 与应用服务器通讯
　　在多层体系结构中，客户程序通过IProvider接口与应用服务器交换数据。这一章介绍怎样在客户端获得IProvider接口、怎样向应用服务器传递参数、怎样向应用服务器请求数据、怎样把用户对数据的修改写到数据库中。
11.6.1 怎样在客户端获得IProvider接口
　　在单层应用程序以及工作在“公文包”模式下的多层应用程序中，不需要用到IProvider接口。而在多层体系结构中，客户程序要与应用服务器交换数据，首先必须获得IProvider接口，这就要用到RemoteServer属性和ProviderName属性。
　　RemoteServer属性用于指定客户端的MIDAS连接构件。MIDAS连接构件又称Data Broker，用于建立和维护与应用服务器的连接。
　　在设计期，正确设置了RemoteServer属性后，就可以在对象观察器中为ProviderName属性选择一个值，实际上就是选择应用服务器上的一个TProvider构件。
11.6.2 向应用服务器传递参数
　　客户程序可以向应用服务器传递参数，这些参数实际上是传递给应用服务器上的TQuery构件或TStoredProc构件。既可以在设计期也可以在运行期设置参数。
　　在设计期，可以单击Params属性边上的省略号按钮，打开一个如图11.2所示的编辑器。
　　图11.2 设置参数
　　单击按钮可以增加一个参数，单击按钮可以删减一个参数，单击按钮可以把一个参数前移，单击按钮可以把一个参数后移。
　　选择一个参数，对象观察器将显示该参数(TParam对象)的属性。
　　在运行期可以调用TParams的CreateParam函数来创建一个参数。例如，下面的代码创建了一个参数叫CustNo，它的使用类型是ptInput，数据类型是ftInteger，它的值设为605。
With ClientDataSet1.Params.CreateParam(ftInteger, 'CustNo', ptInput) Do
AsInteger := 605;
　　设置好参数以后，如果TClientDataset的Active属性是False，只要把Active属性设为True，这些参数将被自动传递给应用服务器。如果Active属性已经为True，就要调用SendParams函数把参数传递给应用服务器。
　　注意：传递给应用服务器的参数必须与TQuery构件或TStoredProc构件的参数匹配，包括名称、数据类型和参数类型。
11.6.3 怎样向应用服务器请求数据
　　TClientDataSet提供了两个属性和三个方法，用于怎样向应用服务器请求数据：
　　一是FetchOnDemand属性。如果这个属性设为True，TClientDataSet会根据需要自动检索附加的数据包，例如BLOB字段的值或者嵌套表的内容。如果这个属性设为False，程序需要显式地调用GetNextPacket才能获得这些附加的数据包。
　　二是PacketRecords属性，用于设置一个数据包中最多可容纳的记录数，设为-1表示一个数据包可以容纳数据集的所有记录。
　　三是GetNextPacket函数，用于向应用服务器检索下一个数据包，并把检索到的数据包添加到前一次检索到的数据包的后面。这个函数返回实际检索到的记录数。
　　四是FetchBlobs过程，用于从应用服务器检索BLOB字段的值。如果FetchOnDemand属性设为True，就没必要调用FetchBlobs函数。
　　五是FetchDetails过程，用于检索嵌套表中的数据。如果FetchOnDemand属性设为True，就没必要调用FetchDetails函数。
11.6.4 更新数据库
　　在多层体系结构中，用户在客户端修改了数据后，需要把最新的数据写到数据库中，这就要调用TClientDataSet的ApplyUpdates函数。
　　ApplyUpdates只需要传递一个参数叫MaxErrors，用于指定一个整数，当遇到无法更新的记录超过这个数时，此次更新就中止。如果MaxErrors参数设为0，表示只要遇到一个错误更新就中止，客户端的日志保持不变。如果MaxErrors参数设为-1，当应用服务器发现有错误的记录，就尝试更新下一个记录，等所有的记录都尝试过以后才返回。
　　ApplyUpdates会自动调用Reconcile函数，进而调用应用服务器上的TProvider构件的ApplyUpdates函数去更新远程的数据库服务器。没有被DBMS服务器认可的记录通过Reconcile返回给客户端，此时将在客户端触发OnReconcileError事件让您更正错误。最后，ApplyUpdates函数返回仍然没有被认可的记录数。
11.7 在文件中存取数据
　　要从文件中读取数据，可以调用LoadFromFile函数。LoadFromFile函数需要传递一个参数，用于指定文件名。文件名应包含完整的路径。如果客户程序总是从一个固定的文件中读取数据，可以设置FileName属性指定一个文件名，以后，当TClientDataSet引入的数据集打开时，就自动从这个文件中读取数据，不需要调用LoadFromFile。
　　要从流中读取数据，可以调用LoadFromStream。LoadFromStream需要传递一个参数，用于指定一个流对象。
　　注意：LoadFromFile(LoadFromStream)只能从先前用SaveToFile(SaveToStream)保存的文件中读取数据。
　　要把数据保存到文件中，可以调用SaveToFile函数。SaveToFile需要传递一个参数，用于指定文件名。如果指定的文件已存在，文件中的数据将被覆盖。如果客户程序总是把数据保存到一个固定的文件中，可以设置FileName属性指定一个文件名，当TClientDataSet引入的数据集关闭时，就自动把数据保存到这个文件中，不需要调用SaveToFile。
　　要把数据保存到流中，可以调用SaveToStream。SaveToStream需要传递一个参数，指定一个流对象。
　　注意：当把数据保存到文件或流中时，日志中记载的修改仍然保留。这样，当下次调用LoadFromFile或LoadFromStream读取数据时，仍然可以恢复原来的数据。

konhon 优华 2007-03-29 18:57 发表评论

[轉]物流信息系统开发手记-Delphi的三层开发

konhon 优华 — Wed, 28 Mar 2007 10:07:00 GMT

近日（呵呵，这篇文章是去年写的）用了两个月开发了一个物流信息系统，这个系统是两层、三层相结合，C/S、B/S相结合的系统。虽然限于时间的紧张和人手的原因，系统规模不是很大，但是其中涉及的技术却很全面。在这个《开发技术篇》中我们将讲解我在开发系统中遇到的技术问题及解决方案，希望对大家有帮助。对于物流信息系统的分析设计问题，我将在另一篇文章《物流信息系统开发手记――系统构架篇》中讲解。

一、Midas的安全问题。

Midas技术是Delphi中进行三层开发的首选技术，它不仅有纯DCOM/COM+(COM+技术是.NET技术的基础)的优点，而且也结合了Delphi的快速开发特性，可以快速开发出想要的系统，其开发速度是用VC,PB等开发DCOM的数十倍，把程序员从烦杂的代码中解脱出来，从而将更多的精力投入到业务逻辑的设计中去。

但是Midas技术的一个最令人担忧的就是它的安全问题：

远端只要知道应用服务器的端口号即可访问到应用服务器，而一旦访问到应用服务器，TClientDataSet即可获得ProviderNames列表。一旦知道了ProviderNames列表，这就相当于将数据库暴露在外了。

关于可轻易获得ProviderNames列表的问题，我使用下面的方法解决：

在服务器端定义一个

LoginMTS(const AUserId, APassword: WideString): WordBool;

方法。初始状态下，所有的DataSetProvider和数据集的连接断开。用户必须调用LoginMTS并传递用户名和密码，登陆成功才将DataSetProvider和数据集的连接打开。这样如果用户验证没有通过，即使它获得了ProviderNames列表也没法调用接口中的方法对数据库进行操作。

二、Midas中主从表的实现

主从表的应用在信息系统中应用很广。在两层开发中我们可以通过直接建立两个数据集之间为主从关系来实现主从表；在三层中虽然我们仍然可以通过直接建立两个数据集之间为主从关系来实现主从表，但是这样就要求把数据库中所有相关的数据行都下载到本地，丧失了三层开发的优势。我在实际中使用下面的方法实现。这里我以实现入库单查询、添加、修改、删除(CRUD)为例来讲解：

（1）新建一个MTS Data Module，命名为TmtsStockInListBiz,增加如下方法：

function QueryStockInListMasterById(const AId: WideString;

var ADatas: OleVariant): WordBool; safecall;

function QueryStockInListSlaveByMasterId(const AId: WideString;

var ADatas: OleVariant): WordBool; safecall;

procedure UpdataStockInListMaster(var ADatas: OleVariant); safecall;

procedure UpdataStockInListSlave(var ADatas: OleVariant); safecall;

function GenerateStockInListId: WideString; safecall;

QueryStockInListMasterById作用是根据入库单单号查询入库单的基本信息（入库日期、负责人等），Aid为入库单单号，Adatas为返回值，其格式就是Midas的数据包，可以将其附给ClientDatSet的Data属性。

QueryStockInListSlaveByMasterId作用是根据入库单单号查询入库单的详细信息（商品条码，数量）

UpdataStockInListMaster是对入库单主表进行删除、添加、修改操作。只要将ClientDataSet的Delta属性做为传递即可。

UpdataStockInListSlave是对入库单从表进行删除、添加、修改操作。

GenerateStockInListId是产生一个唯一的入库单号。

下面是几个方法的代码，都很简单，就不多解释了，可以查看Delphi的帮助。

function TmtsStockInListBiz.QueryStockInListMasterById(

const AId: WideString; var ADatas: OleVariant): WordBool;

begin

result := false;

ADatas := null;

try

cdsQuery.Close;

cdsQuery.CommandText := 'select * from t_StockInListMaster where Id=:Id';

cdsQuery.Params.ParamByName('Id').AsString := AId;

cdsQuery.Open;

if cdsQuery.RecordCount > 0 then

begin

result := true;

ADatas := cdsQuery.Data;

end;

finally

cdsQuery.Close;

end;

procedure TmtsStockInListBiz.UpdataStockInListMaster(

var ADatas: OleVariant);

var

eCount: Integer;

OwnerData: OleVariant;

begin

DCOMConStockInList.GetServer.AS_ApplyUpdates('dspStockInListMaster',

ADatas, -1, eCount, OwnerData);

end;

function TmtsStockInListBiz.GenerateStockInListId: WideString;

var

LPrior: string;

i: Integer;

begin

cdsQuery.Close;

cdsQuery.CommandText := 'select top 1 id from t_StockInListMaster order by id desc';

cdsQuery.Open;

LPrior := cdsQuery.FieldByName('Id').AsString;

i := StrToIntDef(RightStr(LPrior,8),0);

Inc(i);

result := 'RK' + FormatFloat('00000000',i);

cdsQuery.Close;

end;

（2）、新建一个应用程序，通过DCOMConnection、SocketConnection等连接到MTS组件，然后就可以调用MTS的相应的方法实现客户端功能了。

放入cdsStockInListMaster、cdsStockInListSlave两个ClientDataSet控件，在控件上点击右键，选择“FieldsEditor”新建于服务器中的字段同样的字段，然后再次在控件上单击右键，选择“CreateDataSet”，建立一个本地数据库。

（3）

根据入库单号查询入库单的方法实现：

procedure TFormStockInList.BtnFindClick(Sender: TObject);

var

v,vs: OleVariant;

begin

if SocketConStockInList.AppServer.QueryStockInListMasterById(Trim(LEdtId.Text), v) then

begin

cdsStockInListMaster.Data := v;//显示入库单主表（主要信息）

if SocketConStockInList.AppServer.QueryStockInListSlaveByMasterId(Trim(LEdtId.Text), vs) then

cdsStockInListSlave.Data := vs; ;//显示入库单从表（明细信息）

end

else

ShowMessage('此单不存在！');

end;

（4）新建入库单的实现

procedure TFormStockInList.BtnNewClick(Sender: TObject);

var

LId: string;

begin

ClearCDSRecord;

cdsStockInListMaster.Open;

cdsStockInListMaster.Insert;

LId := SocketConStockInList.AppServer.GenerateStockInListId;

LEdtId.Text := LId;

cdsStockInListMaster.FieldByName('Id').AsString := LId;

cdsStockInListMaster.FieldByName('GenerateDate').AsDateTime := Now();

end;

（5）提交功能的实现

procedure TFormStockInList.BtnPostClick(Sender: TObject);

var

LQuerymts: ImtsQueryObjDisp;

LBar: string;

begin

SetSocketConnectionConnect(SocketConQuery);

LQuerymts := ImtsQueryObjDisp(SocketConQuery.GetServer);

SocketConQuery.Close;

if cdsStockInListMaster.RecordCount > 0 then

SocketConStockInList.AppServer.UpdataStockInListMaster(cdsStockInListMaster.Delta);

if cdsStockInListSlave.RecordCount > 0 then

SocketConStockInList.AppServer.UpdataStockInListSlave(cdsStockInListSlave.Delta);

end;

注：本文中ClientDataSet控件的名称开头一般为cds、TsocketConnection控件的名称开头一般为SocketCon。

三、动态设置TsimpleObjectBroker的服务器列表

procedure SetSocketConnectionConnect(AValue: TSocketConnection);

procedure FillAppServerList(ABroker: TSimpleObjectBroker);

var

sl: TStringList;

i, n: Integer;

begin

sl := TStringList.Create;

从配置文件中读取服务器列表，并保存到sl中;

n := sl.Count - 1;

ABroker.ServerData := null;

for i := 0 to n do

begin

ABroker.Servers.Add;

ABroker.Servers[i].ComputerName := sl.Strings[i]

end;

sl.Free;

end;

var

LBroker: TSimpleObjectBroker;

begin

LBroker := TSimpleObjectBroker.Create(nil);

FillAppServerList(LBroker);

AValue.ObjectBroker := LBroker;

try

AValue.Connected := true;

except

raise Exception.Create('应用服务器连接错误！');

end;

LBroker.Free;

end;

konhon 优华 2007-03-28 18:07 发表评论

动态设置DNS的例子

konhon 优华 — Fri, 02 Dec 2005 01:21:00 GMT

一个在普通用户下设置DNS的例子

unit uMain;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Registry;

type
_STARTUPINFOW = record
    cb: DWORD;
    lpReserved: LPWSTR;
    lpDesktop: LPWSTR;
    lpTitle: LPWSTR;
    dwX: DWORD;
    dwY: DWORD;
    dwXSize: DWORD;
    dwYSize: DWORD;
    dwXCountChars: DWORD;
    dwYCountChars: DWORD;
    dwFillAttribute: DWORD;
    dwFlags: DWORD;
    wShowWindow: Word;
    cbReserved2: Word;
    lpReserved2: PByte;
    hStdInput: THandle;
    hStdOutput: THandle;
    hStdError: THandle;
end;
STARTUPINFOW = _STARTUPINFOW;

TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
    { Private declarations }
    procedure DoOperation(aCmd: string);
public
    { Public declarations }
end;

var
Form1: TForm1;

function CreateProcessWithLogonW(lpUserName, lpDomain, lpPassword: LPCWSTR;
dwLogonFlags: DWORD; lpApplicationName: LPCWSTR; lpCommandLine: LPWSTR;
dwCreationFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: LPCWSTR;
const lpStartupInfo: STARTUPINFOW; var lpProcessInformation: PROCESS_INFORMATION): BOOL; stdcall;
external advapi32 Name 'CreateProcessWithLogonW'

implementation

{$R *.dfm}

procedure DelRegCache;
begin
with TRegistry.Create do
try
    RootKey := HKEY_CURRENT_USER;
    DeleteKey('Software\Microsoft\Internet Explorer\TypedURLs');
finally
    Free;
end;
end;

procedure TForm1.DoOperation(aCmd: string);
var
STARTUPINFO: StartupInfoW;
ProcessInfo: TProcessInformation;
AUser, ADomain, APass, AExe: WideString;
const
LOGON_WITH_PROFILE = $00000001;
LOGON_NETCREDENTIALS_ONLY = $00000002;
begin
Screen.Cursor := crHourGlass;
try
    FillChar(STARTUPINFO, SizeOf(StartupInfoW), #0);
    STARTUPINFO.cb := SizeOf(StartupInfoW);
    STARTUPINFO.dwFlags := STARTF_USESHOWWINDOW;
    STARTUPINFO.wShowWindow := SW_SHOW;
    AUser := 'administrator';
    APass := '123';
    ADomain := 'domain';
    AExe := aCmd;
    if not CreateProcessWithLogonW(PWideChar(AUser), PWideChar(ADomain),
      PWideChar(APass),
      LOGON_WITH_PROFILE, nil, PWideChar(AExe),
      NORMAL_PRIORITY_CLASS, nil, nil, STARTUPINFO, ProcessInfo) then
      RaiseLastOSError;
    WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
finally
    Screen.Cursor := crDefault;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
DoOperation('netsh interface ip add dns "區域連線" 192.168.10.81 1');
DoOperation('netsh interface ip add dns "區域連線" 202.96.128.166 2');
Application.MessageBox('操作完成!', 'CrackNet', MB_OK + 64);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
DelRegCache;
DoOperation('netsh interface ip set dns "區域連線" dhcp');
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Hide;
Button2.Click;
end;

end.

konhon 优华 2005-12-02 09:21 发表评论

Delphi 中如何用另外一个用户的身份来运行一人程序

konhon 优华 — Tue, 15 Nov 2005 00:15:00 GMT

如一个程序要有以下的命令来运行
runas /env /savecred /user:hhql "c:\qlnetbar\bc2\bc2"
我现在的问题是如何在Delphi中用代码来代替 runas /env /savecred /user:hhql 的功能，因为我要监视 c:\qlnetbar\bc2\bc2 的运行情况，所以 c:\qlnetbar\bc2\bc2 必须要由我用Delphi写的程序来运行

请高手指教。。。。

果你用XP或2000，可以用下面的API：CreateProcessWithLogonW
type
_STARTUPINFOW = record
    cb: DWORD;
    lpReserved: LPWSTR;
    lpDesktop: LPWSTR;
    lpTitle: LPWSTR;
    dwX: DWORD;
    dwY: DWORD;
    dwXSize: DWORD;
    dwYSize: DWORD;
    dwXCountChars: DWORD;
    dwYCountChars: DWORD;
    dwFillAttribute: DWORD;
    dwFlags: DWORD;
    wShowWindow: Word;
    cbReserved2: Word;
    lpReserved2: PByte;
    hStdInput: THandle;
    hStdOutput: THandle;
    hStdError: THandle;
end;
STARTUPINFOW = _STARTUPINFOW;

procedure TForm1.Button2Click(Sender: TObject);
var
STARTUPINFO: StartupInfoW;
ProcessInfo: TProcessInformation;
AUser, ADomain, APass, AExe: WideString;
const
LOGON_WITH_PROFILE = $00000001;
LOGON_NETCREDENTIALS_ONLY = $00000002;
begin
FillChar(STARTUPINFO, SizeOf(StartupInfoW), #0);
STARTUPINFO.cb := SizeOf(StartupInfoW);
STARTUPINFO.dwFlags := STARTF_USESHOWWINDOW;
STARTUPINFO.wShowWindow := SW_SHOW;
AUser := edtUser.Text;
ADomain := edtDomain.Text;
APass := edtPass.Text;
AExe := edtExe.Text;
if not CreateProcessWithLogonW(PWideChar(AUser), PWideChar(ADomain),
    PWideChar(APass),
    LOGON_WITH_PROFILE, nil, PWideChar(AExe),
    NORMAL_PRIORITY_CLASS, nil, nil, STARTUPINFO, ProcessInfo) then
    RaiseLastOSError;
end;

已经测试通过

代码修改了一下：

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
end;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
STARTUPINFO: StartupInfoW;
ProcessInfo: TProcessInformation;
AUser, ADomain, APass, AExe: WideString;
const
LOGON_WITH_PROFILE = $00000001;
LOGON_NETCREDENTIALS_ONLY = $00000002;
begin
FillChar(STARTUPINFO, SizeOf(StartupInfoW), #0);
STARTUPINFO.cb := SizeOf(StartupInfoW);
STARTUPINFO.dwFlags := STARTF_USESHOWWINDOW;
STARTUPINFO.wShowWindow := SW_SHOW;
AUser := 'pcmax';
//ADomain := edtDomain.Text;
APass := 'pcmax';
AExe := 'c:\windows\system32\mspaint.exe';
if not CreateProcessWithLogonW(PWideChar(AUser), PWideChar(ADomain),
    PWideChar(APass),
    LOGON_WITH_PROFILE, nil, PWideChar(AExe),
    NORMAL_PRIORITY_CLASS, nil, nil, STARTUPINFO, ProcessInfo) then
    RaiseLastOSError;
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
ShowMessage('over now');
end;

end.

运行上面的代码，点击button1就会以用户pcmax运行 c:\windows\system32\mspaint.exe。然后等待运行结束后弹出提示对话框。

konhon 优华 2005-11-15 08:15 发表评论

抓图

konhon 优华 — Sat, 12 Nov 2005 00:59:00 GMT

抓图实际上是位图的复制， Windows在复制位图时是不会受鼠标
光标的影响的。可以先抓图，然后在使用 DrawIcon将鼠标光标画上去。

procedure TForm1.FormClick(Sender: TObject);
var
winHWND, hCur: integer;
winDC: integer;
rect: TRect;
pt: TPoint;
fBitmap: TBitmap;
begin
hCur := GetCursor(); // 取得光标句柄
GetCursorPos(pt); // 取得光标位置
winHWND := GetDesktopWindow();
winDC := GetDC(winHWND);
GetWindowRect(winHWND, rect);
fBitmap := TBitmap.create;
try
    fBitmap.width := rect.right - rect.left;
    fBitmap.height := rect.bottom - rect.top;
    BitBlt(fBitmap.canvas.handle, 0, 0, fBitmap.width, fBitmap.height, winDC, 0, 0, SRCCOPY);
    DrawIcon(fBitmap.canvas.handle, pt.x, pt.y, hCur); // 画光标
    ReleaseDC(winHWND, winDC);
    Image1.Picture.Bitmap.Assign(fBitmap);
finally
    fBitmap.Free;
end;
end;

konhon 优华 2005-11-12 08:59 发表评论

字符串与二进制数之间的互相转换

konhon 优华 — Wed, 02 Nov 2005 10:37:00 GMT

将一个字符串转为二进制，再从二进制转为原字符串。

把字符串(可含中文字符)转为二进制数的函数:ConvertStrToBin();把二进制数转换为字符串的函数：ConvertBinToStr()。
以下两个函数亦可以对包含有中文字符的字符串进行处理,逆转时亦可正常转为中文。
Function ConvertStrToBin(Value : string):string;//把字符串转化为二进制数
var tempHex : string[2];
i : integer;
begin
Result := '';
if trim(Value) = '' then Exit;
tempHex := '';
for i := 1 to Length(Value) do
begin
tempHex := IntToHex(Ord(Value[i]),2);//每个字符转成两位十六进制数
Result := Result + BinToHexEachOther(tempHex,False);//十六进制转成二进制
end;
end;

Function ConvertBinToStr(Value : string):string; //把二进制数据转化为字符串
Var tempHex : string;
i, tempInt : integer;
begin
Result := '';
if trim(Value) = '' then Exit;
tempHex := BinToHexEachOther(Value,true);//二进制转成十六进制
i := 0;
Repeat
begin
i := i + 1;
tempInt := HexCharToInt(tempHex[i]);
i := i + 1;
tempInt := tempInt * 16 + HexCharToInt(tempHex[i]);
//以上将两位十六进制数转变为一个十进制数
Result := Result + chr(TempInt); //转成ASCII码
end;
Until i >= length(tempHex)
end;

上两个互逆的函数中要调用到的函数HexCharToInt()和BinToHexEachOther()如下：

function BinToHexEachOther(ValueA : string; Action : Boolean) : string;
//把二进制串转换成十六进制串或相反
var
ValueArray1 : Array [0..15] of string[4];
ValueArray2 : Array [0..15] of char;
i : shortint;
begin
//数组初始化
ValueArray1[0] := '0000'; ValueArray1[1] := '0001'; ValueArray1[2] := '0010';
ValueArray1[3] := '0011'; ValueArray1[4] := '0100'; ValueArray1[5] := '0101';
ValueArray1[6] := '0110'; ValueArray1[7] := '0111'; ValueArray1[8] := '1000';
ValueArray1[9] := '1001'; ValueArray1[10] := '1010'; ValueArray1[11] := '1011';
ValueArray1[12] := '1100'; ValueArray1[13] := '1101'; ValueArray1[14] := '1110';
ValueArray1[15] := '1111';
for i := 0 to 15 do
if i >= 10 then ValueArray2[i] := chr(65 + (i - 10))
else ValueArray2[i] := inttostr(i)[1];

Result := '';
if Action then
begin //二进制串转换成十六进制串
if (Length(ValueA) MOD 4 <> 0) then
ValueA := stringofchar('0',Length(ValueA) MOD 4) + ValueA;
while (Length(ValueA) >= 4) do
begin
for i := 0 to 15 do
if Copy(ValueA,1,4) = ValueArray1[i] then
Result := Result + ValueArray2[i];
ValueA := Copy(ValueA,5,Length(ValueA) - 4);
end;
end
else begin //十六进制串转换成二进制串
while (Length(ValueA) >= 1) do
begin
for i := 0 to 15 do
if Copy(ValueA,1,1) = ValueArray2[i] then
Result := Result + ValueArray1[i];
ValueA := Copy(ValueA,2,Length(ValueA) - 1);
end;
end;
end;

function HexCharToInt(HexToken : char):Integer;
begin
Result:=0;
if (HexToken>#47) and (HexToken<#58) then { chars 0....9 }
Result:=Ord(HexToken)-48
else if (HexToken>#64) and (HexToken<#71) then { chars A....F }
Result:=Ord(HexToken)-65 + 10;
end;

十六进制字串转十进制又一法：
procedure TForm1.BitBtn1Click(Sender: TObject);
var myint : integer;
begin
myint := StrToInt('$' + '3A'); // myint = 58
showmessage(inttostr(myint));
end;

konhon 优华 2005-11-02 18:37 发表评论

設置系統時間

konhon 优华 — Wed, 12 Oct 2005 05:49:00 GMT

function SetSystemtime(ATime: TDateTime): Boolean;
var
ADateTime: TSystemTime;
yy, mon, dd, hh, min, ss, ms: Word;
begin
decodedate(ATime, yy, mon, dd);
decodetime(ATime, hh, min, ss, ms);
with ADateTime do
begin
    wYear := yy;
    wMonth := mon;
    wDay := dd;
    wHour := hh;
    wMinute := min;
    wSecond := ss;
    wMilliseconds := ms;
end;
Result := SetLocalTime(ADateTime);
SendMessage(HWND_BROADCAST, WM_TIMECHANGE, 0, 0);
end;

konhon 优华 2005-10-12 13:49 发表评论

按分隔符取字符串

konhon 优华 — Tue, 30 Aug 2005 00:21:00 GMT

function TForm1.ExtractString(const aString: string; const aSeparator: char; var aPos: Integer): string;
var
I: Integer;
begin
I := aPos;
while (I <= Length(aString)) and (aString[I] <> aSeparator) do Inc(I);
Result := Trim(Copy(aString, aPos, I - aPos));
if (I <= Length(aString)) and (aString[I] = aSeparator) then Inc(I);
aPos := I;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
lString, lSubString: string;
lPos, j: integer;
begin
lString := '023842394201342|343242423423|342342424|533423|2455';
lPos := 1;
j := 0;

while lPos <= Length(lString) do
begin
    lSubString := ExtractString(lString, '|', lPos);
    inc(j);
    if j = 2 then    // 第二個
      showmessage(lSubString);
end;
end;

konhon 优华 2005-08-30 08:21 发表评论

動態設定Menu快捷键的问题

konhon 优华 — Sat, 27 Aug 2005 02:29:00 GMT

MenuItem1.ShortCut := ShortCut(Word(VK_RIGHT), [ssCtrl])

konhon 优华 2005-08-27 10:29 发表评论

啟用禁用要地連接

konhon 优华 — Fri, 26 Aug 2005 09:11:00 GMT

http://www.blogjava.net/Files/konhon/EnableNetCard.rar

在Delphi中选Project Import Type Library命令，在对话框中选Import Microsoft Shell Controls And Automation类型库，点Install后，在Delphi的ActiveX控件板上就多了TShellFolderItem，TShellLinkObject，TShellFolderView，TShell，TSearchCommand等几个组件

const
discVerb = '禁用(&B)';
connVerb = '启用(&A)';

function TForm1.DisableEthernet(const EthName,State: String): Boolean;
var
cpFolder: Folder;
nwFolder: Folder;
nVerbs: FolderItemVerbs;
i,j,k: integer;
aItem: TListItem;
begin
result := false;
cpFolder := Form1.shell1.NameSpace(3);
if cpFolder <> nil then
begin
    for i := 0 to cpFolder.items.Count-1 do
    begin
      if cpFolder.Items.Item(i).Name = '网络和拨号连接' then
      begin
        nwFolder := cpFolder.items.item(i).GetFolder as Folder;
        if nwFolder <> nil then
        begin
          for j :=0 to nwFolder.items.Count-1 do
          begin
            if nwFolder.Items.Item(j).Name = EthName then
            begin
              nVerbs := nwFolder.Items.Item(j).Verbs;
              for k := 0 to nVerbs.Count-1 do
             begin
                if nVerbs.Item(k).Name = State then
                begin
                  nVerbs.Item(k).DoIt;
                  aItem := Form1.lvLog.Items.Add;
                  aItem.Caption := FormatDateTime('yyyy-mm-dd hh:mm:ss',now);
                  aItem.SubItems.Add(EthName);
                  aItem.SubItems.Add(State);
                  Result := True;
                end;
              end;
            end;
          end;
        end;
      end;
    end;
    if nwFolder = nil then
       showmessage('Network and Dial-up Connections not found');
end
else
    showmessage('control panel not found');

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
DisableEthernet('本地连接',discVerb);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
DisableEthernet('本地连接',connVerb);
end;

konhon 优华 2005-08-26 17:11 发表评论

向CGI提交數據

konhon 优华 — Fri, 26 Aug 2005 03:13:00 GMT

procedure TForm1.Button1Click(Sender: TObject);
var
lUrl: string;
lParams: TStrings;
lHtml: string;
begin
lUrl := 'http://snixxx.co.uk/cgi-bin/mt-comments.cgi';
lParams := TStringList.Create;
try
    lParams.Add('entry_id=1302');
    lParams.Add('author=dqxhyy');
    lParams.Add('dqxhyy@sina.com');
    lParams.Add('dqxhyydqxhyydqxhyydqxhyy');
    try
      lHtml := IdHttp1.Post(lUrl, lParams);
    except
      showmessage(lhtml);
    end;
    showmessage(lhtml);
finally
    lParams.Free;
end;
end;

konhon 优华 2005-08-26 11:13 发表评论

如何通过发送WM_COMMAND消息模拟点击其他程序窗体上的菜单项?

konhon 优华 — Fri, 26 Aug 2005 02:05:00 GMT

procedure TForm1.Button1Click(Sender: TObject);
var
   h,m,s,s1:hwnd;
begin
h:=FindWindow('notepad',nil);
   if h<>0 then
   begin
     m:=GetMenu(h);
     s:=GetSubMenu(m,1);
     s1:=GetSubMenu(s,7);
     SendMessage(h,WM_COMMAND,MakeLong(GetMenuItemId(s,7),0),s1);
end;
end;

konhon 优华 2005-08-26 10:05 发表评论

在Lalel上单击，然后在Label下文出现下拉框（popupmenu），怎样让下拉框紧挨着Label下方出现。

konhon 优华 — Thu, 25 Aug 2005 11:58:00 GMT

procedure TForm1.Label1Click(Sender: TObject);
var
lPoint: TPoint;
begin
lPoint.X := TLabel(Sender).Left;
lPoint.Y := TLabel(Sender).Top + TLabel(Sender).Height;
lPoint:=ClientToScreen(lPoint);
PopupMenu1.Popup(lPoint.X, lPoint.Y);
end;

konhon 优华 2005-08-25 19:58 发表评论

DBGrid不夠寬加'...'

konhon 优华 — Thu, 25 Aug 2005 11:57:00 GMT

procedure TForm1.ADODataSet1MaterielNameGetText(Sender: TField;
var Text: string; DisplayText: Boolean);
var
lSingleWidth: integer;
lDBGridWidth: integer;
begin
lSingleWidth := DBGrid1.Canvas.TextWidth('壹');
lDBGridWidth := DBGrid1.Columns[1].Width;
if DBGrid1.Canvas.TextWidth(Sender.AsString) <= lDBGridWidth then
    Text := Sender.AsString
else if DBGrid1.Canvas.TextWidth(Sender.AsString) > lDBGridWidth then
begin
    lSingleWidth := lDBGridWidth div lSingleWidth - 1;
    if lSingleWidth mod 2 = 1 then
      lSingleWidth := lSingleWidth + 1;
    Text := Copy(Sender.AsString, 1, lSingleWidth) + '...';
end
end;

konhon 优华 2005-08-25 19:57 发表评论

如何得到鼠标经过listview每一行的各列信息

konhon 优华 — Thu, 25 Aug 2005 11:45:00 GMT

uses CommCtrl;

procedure TForm1.ListView1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
item: TListItem;
lvhti: LV_HITTESTINFO;
begin
item := ListView1.GetItemAt(X, Y);
if (item <> nil) then
    Caption := 'Mouse at: ' + item.Caption
else
begin
    lvhti.pt.X := X;
    lvhti.pt.Y := Y;
    ListView_SubItemHitTest(ListView1.Handle, @lvhti);
    if Assigned(ListView1.Items[lvhti.iItem])
      and (ListView1.Items[lvhti.iItem].SubItems.Count >= lvhti.iSubItem) then
      Caption := 'Mouse at:' + ListView1.Items[lvhti.iItem].SubItems[lvhti.iSubItem - 1];
end;
end;

konhon 优华 2005-08-25 19:45 发表评论

BlogJava-konhon-随笔分类-Delphi

TClientDataSet

[轉]物流信息系统开发手记-Delphi的三层开发

动态设置DNS的例子

Delphi 中如何用另外一个用户的身份来运行一人程序

抓 图

字符串与二进制数之间的互相转换

設置系統時間

按分隔符取字符串

動態設定Menu快捷键的问题

啟用禁用要地連接

向CGI提交數據

如何通过发送WM_COMMAND消息模拟点击其他程序窗体上的菜单项?

在Lalel上单击，然后在Label下文出现下拉框（popupmenu），怎样让下拉框紧挨着Label下方出现。

DBGrid不夠寬加'...'

如何得到鼠标经过listview每一行的各列信息

抓图