2012年12月15日

クラスヘルパーでTCustomEdit以下のMaxLengthをバイト数での制限に一括変更!

[この記事は"Delphi Advent Calendar"参加記事です]

さて、現在の会社に入社して8年...長いことDelphi7を使い続けていましたが、この度XE3が導入されました〜(^^)

#ちと個人では手が出ない...(^^; どうせならEnterpriseとかが欲しいから...(^^;

その間にUNICODE化、Generics、などなど色んな変化があった模様です。

#すっかり浦島太郎状態...(^^;

そんな中、UNICODE化した事で、TCustomEdit以下のMaxLengthの挙動がバイト数から文字数の判断に変わっているじゃあ〜〜〜りませんか!

#勿論UNICODE化している以上、当然の動きなんですが(^^;

でも現実問題として、XE3でもMaxLengthはバイト数判断で使いたい!(しかもコンポ側には触らずに、自動的に)
そこで、クラスヘルパーに目を付けて試行錯誤してみました。

手法)
 ・フォーム生成時にTCustomEdit継承インスタンスのOnKeyPressイベントを自前のものに差し替える
   →元のイベントは別途記録。
 ・自前のOnKeyPressの中で、入力済みのテキストとキー入力をバイト数で判断、オーバー時はKey := #0で無効化する

...と書くとこれだけでも、ここに至るまでは、なかなか一筋縄では行かなかった(^^;
色々と悩んだものの、VCLの途中に介入できるのは有難いなぁと思いました。


-----------------------------------------------------------------------------
unit VCLHelper;

interface

uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.Generics.Collections,
KEdit;

type
// フォーム生成時に細工をする
TApplicationHelper = class helper for TApplication
procedure CreateForm(InstanceClass: TComponentClass; var Reference);
end;

TCustomEditHelper = class helper for TCustomEdit
// OnKeyPress差し替えの実行箇所
procedure SetKeyPress();
// 差し替えられる側のOnKeyPressイベント
procedure AOnKeyPress(Sender: TObject; var Key: Char);
end;

implementation

var
// 差し替え前のOnKeyPressイベントを記録
// ※クラスヘルパーでフィールドを定義できれば不要なんだけどね...
lstWinCtrlOnKeyPress: TDictionary;

{ TApplicationHelper }

procedure TApplicationHelper.CreateForm(InstanceClass: TComponentClass;
var Reference);
var
i: integer;
begin
inherited CreateForm(InstanceClass, Reference);

// 生成したフォームのTCustomEdit継承インスタンスのOnKeyPressイベントを差し替える
// ※SetKeyPress()もクラスヘルパーで実装
for i := 0 to TForm(Reference).ComponentCount - 1 do begin
if TForm(Reference).Components[i] is TCustomEdit then begin
TCustomEdit(TForm(Reference).Components[i]).SetKeyPress();
end;
end;
end;

{ TCustomEditHelper }

procedure TCustomEditHelper.SetKeyPress();
begin
// 元々のOnKeyPressイベントを記録
lstWinCtrlOnKeyPress.Add(Self, Self.OnKeyPress);
// 差し替え
Self.OnKeyPress := AOnKeyPress;
end;

// 差し替えられる方のOnKeyPressイベント
procedure TCustomEditHelper.AOnKeyPress(Sender: TObject; var Key: Char);
var
orgKeyPress: TKeyPressEvent;
sNew: string;
sAnsiNew: AnsiString;
begin
// 差し替え前のOnKeyPressイベントを召還
orgKeyPress := lstWinCtrlOnKeyPress.Items[TCustomEdit(Sender)];

if Assigned(orgKeyPress) then begin
// 差し替え前のOnKeyPressイベントが実装されている場合、実行
orgKeyPress(Sender, Key);
end;

// これ以下ぐらいがコントロールコードだろうという雑な判断
// ※必要なら厳密に
if Key < #20 then begin
// チェック対象外
exit;
end;

// MaxLengthの設定が存在する場合、バイト数でチェック
if Maxlength > 0 then begin
// 設定あり、チェック
// ※ここも、SelText分を引いたりなど、もっと使い勝手を良くできる部分
sNew := Text + Key;
sAnsiNew := sNew;
if Length(sAnsiNew) > MaxLength then begin
// 含めるとオーバーするので、この入力をキャンセル
Key := #0;
end;
end;
end;

initialization
lstWinCtrlOnKeyPress := TDictionary.Create;

finalization
lstWinCtrlOnKeyPress.Free;

end.
-----------------------------------------------------------------------------


#後は必要に応じて元のOnKeyPressイベントを返す関数を足したり...

これをメインフォームなどでusesすれば、後は勝手に動いてくれます...くれるはずです(^^;
...実は他にもっと良い手があるのかもしれませんが(^^;


posted by ありい at 01:44| Comment(0) | TrackBack(0) | Delphi | このブログの読者になる | 更新情報をチェックする

2011年10月29日

釣銭機のOPOSドライバメモ

※今回の記事に関しては、私の手元に動かせる環境がないため質問などを頂いてもお答えできません。その他の呼び出し手続きに関しても同様です。
※またDelphi7で当方で動かした結果からの推測ですので、いつも以上に記事の正確性は保証しかねますので、参考にされる際には充分にテストを行った上で、飽くまで自己責任でご利用下さい

※※個人の趣味で釣銭機を動かすって人は、かなり少ないと思われるので...(苦笑)

職場で釣銭機の担当者からReadCashCountsを動かすと例外が出るって相談を受けて、一緒に調査。

○問題その1

概要:どうやらドライバ側はvar pDiscrepancy: WordBoolに4バイト書き込んでくるようだ。

"ReadCashCounts"でぐぐった所、↓の文書を発見。

OLE for Retail POS技術解説マニュアル

--- 引用開始 ---
【Q3.2.4】 自動釣り銭機のSO処理で、ReadCashCountsメソッド処理で、pDiscrepancyのBOOL値を書き込むとVBの変数エリアが破壊されますが、何故でしょうか。
【A3.2.4】 VC++のクラスウィザードを使用してReadCashCountsメソッドを追加する際、pDiscrepancyのタイプをBOOL*で指定します。この際、C++のBOOL*型が割り当てられますが、BOOL型はlong型で宣言されており、4バイトの記憶領域サイズが割り当てられます。ところが、VBのBoolean変数は2バイトの記憶領域サイズとなっており、SOで、
*pDiscrepancy = TRUE;
等とコーディングすると、2バイト余計にVBの記憶領域に書き込みます。

--- 引用終了 ---

Delphiのbooleanだって2バイトだし!

生成されたTLBを見てみると...

function ReadCashCounts(var pCashCounts: WideString; var pDiscrepancy: WordBool): Integer;

当初、pDiscrepancy: WordBoolをLongBoolに変えてみたが、COMにはンな型はないと怒られコンパイルが通らない。

#ホント何で中身LongBoolにしたんだ一体?

そこでpDiscrepancy: PWordBoolに変えて、呼び元のpDiscrepancyはLongBoolにしておく作戦で確認した所、確かに4バイト分書き込まれていた!

...そりゃアドレス違反になるわ(--;

○問題その2

概要:var pCashCounts: WideStringにはSysAllocString()で割り当てたポインタ以外だと動きがおかしくなるようだ。
※これはCOMのBSTRに関しては一般的な話っぽい。

これでアドレス違反の問題は解決したけど、デバッガで動かしていると、時々CPU窓が開いたりと挙動不審。再びぐぐった結果から、どうやら元の定義は↓のようだ。

LONG ReadCashCounts (BSTR* pCashCounts, BOOL* pDiscrepancy);

今度はBSTRをぐぐった所、以下の情報が。

http://www2.wbs.ne.jp/~kanegon/doc/bstr.txt

--- 引用開始 ---
しかし、実際には先頭に文字列長さを保持しており、この2つを混同しないこと。
BSTR のポインタはメモリ上の先頭を指していないため、BSTR を要求する関数に
LPOLESTR を渡してはならない。また、その関係で BSTR のメモリ管理は完全に別物
である。通常のメモリアロケート関数で処理しないこと。
ただし、LPOLESTR を要求する関数に BSTR を渡すことは問題ない。
※図を省略)
BSTR の領域の取得/解放は SysAllocString()/SysFreeString() または
その関連 API を使用して行なう。
--- 引用終了 ---

DelphiのWideStringは...UNICODEのNULL終止互換(※うろ覚え(^^;) 担当者はフツーにGetMemしていたので、SysAllocString()/SysFreeString()に変えてみたところ、これまた型が合わないと怒られる(^^; まぁそうだね〜と思いvar pCashCounts: WideStringをPointerに修正(だんだん面倒になったw)
これでCPU窓も開かずに安定した模様...

#これは私のCOMに対する理解不足が原因...(^^;


-----------------------
TLB側
-----------------------
・_DCashChanger = dispinterfaceのReadCashCountsはそのまま。

・TCashChanger = class(TOleControl)のReadCashCountsを変更

function ReadCashCounts(var pCashCounts: WideString; var pDiscrepancy: WordBool): Integer;
 ↓
function ReadCashCounts(pCashCounts: Pointer; pDiscrepancy: PWordBool): Integer;

・TCashChangerの実装を修正

function ReadCashCounts(pCashCounts: Pointer; pDiscrepancy: PWordBool): Integer;
Result := DefaultInterface.ReadCashCounts(WideString(pCashCounts^), pDiscrepancy^);
end;

-----------------------
呼び元側サンプル
※コンポは適当に張ってね。
-----------------------
procedure TForm1.Button1Click(Sender: TObject);
var
pStr: PWideChar;
bRes: LongBool; // 問題1対応。絶対にLongBoolで
p: pointer;
s: string;
begin
with CashChanger1 do begin
s := DupeString(#$20#$0, 100); // stringでUNICODEの空白を100文字分(※手抜きw)
pStr := SysAllocString(PWideChar(s));

if ReadCashCounts(@pstr, @bRes) <> OPOS_SUCCESS then begin
ShowMessage('ReadCashCounts:' + IntToStr(ResultCode));
end;

if bRes then begin
ShowMessage('在高異常');
end;

pnl_Aridaka.Caption := pstr;
pnl_ResultCode.Caption := IntToStr(ResultCode);
pnl_ResultCodeEx.Caption := IntToStr(ResultCodeExtended);
end;

SysFreestring(pStr);
end;

タグ:Delphi7 OPOS
posted by ありい at 16:44| Comment(0) | TrackBack(0) | Delphi | このブログの読者になる | 更新情報をチェックする

2011年04月16日

[Delphi]CDSで縦フィールドを高速一括更新

TClientDataSet(CDS)に大量にレコードが登録されている場合に、あるフィールドの値を一括して書き換える関数。

データ量が多い場合に威力を発揮。当方では1万チョイの件数で、while not Eof 〜 Edit/Post で30秒が、この関数では4秒弱に。

XMLパーサーにはXercesを使用。MSXMLだと7秒強だったので...なので動かす環境にはXercesのDLLが必須。

使い方)
 // cdsList内の'FIELD_X'の値を(フィルター無関係に)全て'A'に書き換える
 CDSFieldUpdate(cdsList, 'FIELD_X', 'A');

 // cdsList内の'FIELD_X'の値を、フィルター対象のレコードを'A'に書き換える
 // →キーフィールドは'FIELD_A','FIELD_B'とする
 CDSFilterFieldUpdate(cdsList, 'FIELD_X', 'A', 'FIELD_A;FIELD_B');


 日付時刻の指定は'yyyy/mm/ddThh:nn:ss'で('T'を挟むのがミソ)

#相変わらずDelphi7で動作確認(^^;




// CDSのデータをXMLにして返す
//  ※呼び元で解放すること!
//  ・MergeChangeLogを呼ぶので以降のUndoなどは不可に
//  ・フィルター使用時も全てのデータが対象に
//  ・呼出時に編集モードの場合、解除される(Postと同様の効果)
function GetCDSXMLDoc(cds: TClientDataSet): TXMLDocument;
var
s: string;
begin
result := TXMLDocument.Create(Application);
with result do begin
DOMVendor := XercesDOM;
cds.MergeChangeLog;
s := cds.XMLData;

// CDS形式XMLの問題回避
XML.Text := ''
+ RightBStr(s, Length(s) - 40);

Active := true;
end;
end;

// CDSのフィールド値を高速に一括書き換え
//  ・フィルターは無関係に全てのレコードに効果が及ぶ
//  ・クローン&インデックス利用時、呼出前にクローン側インデックスの使用を解除する必要あり
//  ・MergeChangeLogを呼ぶので以降のUndoなどは不可に
//  ・フィールドが存在しない場合、例外を発生
//  ・呼出時に編集モードの場合、解除される(Postと同様の効果)
procedure CDSFieldUpdate(cds: TClientDataSet; sField, sVal: string);
var
nDefRec: integer;
idxDefs: TIndexDefs;
sDefIndexName: string;
xmlDoc: TXMLDocument;
bFindField: boolean;
ndFieldDef: IXMLNode;
ndRowData, ndRow: IXMLNode;
i: integer;
nd: IXMLNode;
begin
sField := UpperCase(sField);
nDefRec := cds.RecNo;

//// ※ここは別関数、まだこのブログにアップしてないので、呼び元で
//// インデックスを消して、関数終了後に復元する必要がある。
{
sDefIndexName := cds.IndexName;
idxDefs := BackupCDSIndex(cds);
ClearCDSIndex(cds);
}

xmlDoc := GetCDSXMLDoc(cds);
try
with xmlDoc do begin
// フィールド定義チェック
bFindField := false;
ndFieldDef := DocumentElement.ChildNodes['METADATA'].ChildNodes['FIELDS'];
for i := 0 to ndFieldDef.ChildNodes.Count - 1 do begin
if UpperCase(ndFieldDef.ChildNodes[i].Attributes['attrname']) = sField then begin
// フィールド発見
bFindField := true;
sField := ndFieldDef.ChildNodes[i].Attributes['attrname'];
break;
end;
end;

if not bFindField then begin
// フィールドなし、例外生成
raise Exception.Create('フィールドが見つかりません: ' + sField);
end;

// 書き換えループ
ndRowData := DocumentElement.ChildNodes['ROWDATA'];
for i := 0 to ndRowData.ChildNodes.Count - 1 do begin
ndRow := ndRowData.ChildNodes[i];
if ndRow.HasAttribute(sField) then begin
// 既存の値が存在する
if sVal = '' then begin
// 新値なし、削除
ndRow.AttributeNodes.Delete(sField);
end
else begin
// 新値あり、書き換え
ndRow.Attributes[sField] := sVal;
end;
end
else begin
// 既存なし
if sVal = '' then begin
// 新値もなし、次へ
continue;
end;

// 追加
nd := CreateNode(sField, ntAttribute);
nd.NodeValue := sVal;
ndRow.AttributeNodes.Add(nd);
end;
end;

// 書き戻し
cds.XMLData := XML.Text;
end;

finally
//// 上記同様
{
RestoreCDSIndex(cds, idxDefs);
cds.IndexName := sDefIndexName;
}
if nDefRec <= cds.RecordCount then begin
// 行指定が可能な場合
cds.RecNo := nDefRec;
end;

xmlDoc.Free;
idxDefs.Free;
end;
end;

// CDSのフィールド値を高速に一括書き換え(Filter有効版)
//  ・クローン&インデックス利用時、呼出前にクローン側インデックスの使用を解除する必要あり
//  ・呼び出し後のRecNoは不定
//  ・sKeyFieldsは指定した方が高速(フィールド名を';'区切りで。Locateの指定と同じ)
//  ・MergeChangeLogを呼ぶので以降のUndoなどは不可に
//  ・フィールドが存在しない場合、例外を発生
//  ・呼出時に編集モードの場合、解除される(Postと同様の効果)
procedure CDSFilterFieldUpdate(cds: TClientDataSet; sField, sVal: string;
sKeyFields: string = '');
var
lstKeyFiels: TStringList;
idxDefs: TIndexDefs;
sDefIndexName: string;
xmlDoc: TXMLDocument;
bFindField: boolean;
ndFieldDef: IXMLNode;
ndRowData, ndRow: IXMLNode;
i, j: integer;
nd: IXMLNode;
cdsWk: TClientDataSet;
aryStrs: array of string;
aryVals: array of TVarRec;

// 全フィールドを';'区切り文字列で返す
//  →sKeyFieldsが指定されなかった場合の主キーにする
function GetKeyFields(): string;
var
i: integer;
begin
result := '';
with cdsWk do begin
for i := 0 to Fields.Count - 1 do begin
result := result + IfThen(result <> '', ';') + Fields[i].FieldName;
end;
end;
end;

// FindKeyの検索キー(文字列)をセット(実体側)
procedure SetKeyStrs();
var
i: integer;
s: string;
begin
with lstKeyFiels do begin
for i := 0 to Count - 1 do begin
if ndRow.HasAttribute(lstKeyFiels[i]) then begin
// 中身あり
s := ndRow.Attributes[lstKeyFiels[i]];
end
else begin
// 空
s := '';
end;
aryStrs[i] := s;
end;
end;
end;

// オープン配列パラメータの指定要素にセット
procedure SetKeyElement(i: integer; ary: array of const);
begin
aryVals[i] := ary[0];
//aryVals[i].VString := ary[0].VString;
end;

// FindKeyのキー(オープン配列パラメータ)をセット
procedure SetKeyValue();
var
i: integer;
begin
with lstKeyFiels do begin
for i := 0 to Count - 1 do begin
if aryStrs[i] <> '' then begin
// 中身あり
SetKeyElement(i, [aryStrs[i]]);
end
else begin
// 中身なし
SetKeyElement(i, [nil]);
end;
end;
end;
end;

begin
if (not cds.Filtered) or (cds.Filter = '') then begin
// フィルターがないなら、普通の呼ぶほうが早い
CDSFieldUpdate(cds, sField, sVal);
exit;
end;

sField := UpperCase(sField);

//// 上記同様
{
sDefIndexName := cds.IndexName;
idxDefs := BackupCDSIndex(cds);
ClearCDSIndex(cds);
}

xmlDoc := GetCDSXMLDoc(cds);
cdsWk := TClientDataSet.Create(nil);
lstKeyFiels := TStringList.Create;
try
// CDSワーク構成
CopyDS2DS_WithStream(cds, cdsWk);
with cdsWk do begin
if sKeyFields = '' then begin
// キーフィールド指定なし、全フィールドで
sKeyFields := GetKeyFields();
end;

AddIndex('DEF', sKeyFields, []);
IndexName := 'DEF';

Filter := cds.Filter;
Filtered := true;
end;

with xmlDoc do begin
// フィールド定義チェック
// (書き込みフィールド)
bFindField := false;
ndFieldDef := DocumentElement.ChildNodes['METADATA'].ChildNodes['FIELDS'];
for i := 0 to ndFieldDef.ChildNodes.Count - 1 do begin
if UpperCase(ndFieldDef.ChildNodes[i].Attributes['attrname']) = sField then begin
// フィールド発見
bFindField := true;
sField := ndFieldDef.ChildNodes[i].Attributes['attrname'];
break;
end;
end;

if not bFindField then begin
// フィールドなし、例外生成
raise Exception.Create('フィールドが見つかりません: ' + sField);
end;

// (キーフィールド)
lstKeyFiels.Delimiter := ';';
lstKeyFiels.DelimitedText := sKeyFields;
for j := 0 to lstKeyFiels.Count - 1 do begin
bFindField := false;
for i := 0 to ndFieldDef.ChildNodes.Count - 1 do begin
if UpperCase(ndFieldDef.ChildNodes[i].Attributes['attrname']) = UpperCase(lstKeyFiels[j]) then begin
// フィールド発見
bFindField := true;
lstKeyFiels[j] := ndFieldDef.ChildNodes[i].Attributes['attrname'];
break;
end;
end;

if not bFindField then begin
// フィールドなし、例外生成
raise Exception.Create('フィールドが見つかりません: ' + lstKeyFiels[j]);
end;
end;


SetLength(aryStrs, lstKeyFiels.Count);
SetLength(aryVals, lstKeyFiels.Count);

// 書き換えループ
ndRowData := DocumentElement.ChildNodes['ROWDATA'];
for i := 0 to ndRowData.ChildNodes.Count - 1 do begin
ndRow := ndRowData.ChildNodes[i];

SetKeyStrs();
SetKeyValue();
if not cdsWk.FindKey(aryVals) then begin
// フィルター外、飛ばす
continue;
end;

if ndRow.HasAttribute(sField) then begin
// 既存の値が存在する
if sVal = '' then begin
// 新値なし、削除
ndRow.AttributeNodes.Delete(sField);
end
else begin
// 新値あり、書き換え
ndRow.Attributes[sField] := sVal;
end;
end
else begin
// 既存なし
if sVal = '' then begin
// 新値もなし、次へ
continue;
end;

// 追加
nd := CreateNode(sField, ntAttribute);
nd.NodeValue := sVal;
ndRow.AttributeNodes.Add(nd);
end;
end;

// 書き戻し
cds.XMLData := XML.Text;
end;

finally
//// 上記同様
{
RestoreCDSIndex(cds, idxDefs);
cds.IndexName := sDefIndexName;
}

xmlDoc.Free;
idxDefs.Free;
cdsWk.Free;
lstKeyFiels.Free;
end;
end;



タグ:Delphi CDS xml
posted by ありい at 18:41| Comment(0) | TrackBack(0) | Delphi | このブログの読者になる | 更新情報をチェックする

広告


この広告は60日以上更新がないブログに表示がされております。

以下のいずれかの方法で非表示にすることが可能です。

・記事の投稿、編集をおこなう
・マイブログの【設定】 > 【広告設定】 より、「60日間更新が無い場合」 の 「広告を表示しない」にチェックを入れて保存する。


×

この広告は1年以上新しい記事の投稿がないブログに表示されております。