| Delphi-Tips-1 (Delphiの情報) |
|---|
'97-Jan-30th 初出
[A] インラインアセンブラで記述できます。
しかし、これはWindows95だけです。 NTではドライバを書かなければなりません。
{ 任意のポートからバイトデータを読む }
function PortR( PortNo: word): byte;
begin
asm
mov dx, PortNo
cli
in al, dx // 読み込み
sti
mov Result, al
end;
end;
{ 任意のポートへバイトデータを書き出す }
procedure PortW( PortNo: word; value: byte);
begin
asm
mov dx, PortNo
mov al, value
cli
out dx, al // 書き出し
sti
end;
end;
{ 任意のポートからバイトデータを読み、書き戻す }
function PortRW( PortNo: word): byte;
begin
asm
mov dx, PortNo
cli
in al, dx // 読み込み
out dx, al // 再書き出し(読むだけで破壊されるポートのため)
sti
mov Result, al
end;
end;補足：('97-07-29)[A] GetTempFileNameというAPIがあります。これを使えば、ユニークな名前を生成できます。
var
Junk: array[0..144] of char;
begin
GetTempFileName('.', 'TMP', 0, @junk[0]);
ShowMessage(StrPas(@junk[0]));
end;[A] 下の関数で行なえます。
{ 再帰的にSFN(Short File Name)をLFN(Long File Name)に変換する }
function TMainForm.ExpandShortName(const ShortName: string): string;
var
FindData: TWin32FindData;
Handle: THandle;
Path, Tail: string;
begin
Path := ExtractFilePath(ShortName);
Tail := ExtractFileName(ShortName);
if Tail = '' then Result := ShortName else // ドライブ名だけの時 (例 D:\)
begin
if (Length(Path) > 0) and (Path[Length(Path)] = '\') then Delete(Path, Length(Path), 1);
Path := ExpandShortName(Path);
if (Length(Path) > 0) and (Path[Length(Path)] <> '\') then AppendStr(Path, '\');
Handle := FindFirstFile(PChar(Path + Tail), FindData);
if Handle = Invalid_Handle_Value then Result := Path + Tail else // ファイルが無い時
try
Result := Path + FindData.cFilename;
finally
Windows.FindClose(Handle);
end;
end;
end;
function TMainform.GetLongFileName(ShortName: string): string;
begin
if Copy(ShortName, 1, 2) = '\\' then Exit else
Result := ExpandShortName(ExpandFileName(ShortName));
end;補足：('97-07-29)[A] SDIアプリの様にいかないのは、Windowsの仕様です。下の様な方法で可能になります。
(1) 親フォームにVCLからImageを貼り付けます。
(2) メインのPrivate宣言のところに、以下の変数と手続きを加えます。
private
{ Private 宣言 }
FClientInstance, FPrevClientProc: TFarProc;
procedure ClientWndProc(var Message: TMessage);(3)
実現部分に手続きの処理を記述します。 procedure TMainForm.ClientWndProc(var Message: TMessage);
var
MyDC: hDC;
Ro,Co: Word;
begin
with Message do
begin
if Msg = WM_ERASEBKGND then
begin
MyDC := TWMEraseBkGnd(Message).DC;
for Ro := 0 to ClientHeight div Image1.Picture.Height do
begin
for Co := 0 to ClientWidth div Image1.Picture.Width do
BitBlt( MyDC,
Co * Image1.Picture.Width,
Ro * Image1.Picture.Height,
Image1.Picture.Width,
Image1.Picture.Height,
Image1.Picture.Bitmap.Canvas.Handle,
0,
0,
SRCCOPY);
end;
Result := 1;
Invalidate; // Delphi4ではこの行が無いと更新されません
end else
Result := CallWindowProc(FPrevClientProc,
ClientHandle,
Msg,
wParam,
lParam);
end;
end;[A] RichEditにはHideScrollBarsというプロパティがありますが、これをオフにすれば直ります。
ヘルプには、
とありますが、ScrollBars プロパティと密接な関係があり、
ScrollBarsプロパティをSsBothなどにした時は、
HideScrollBarsプロパティをoffに設定しておくことが必要です。
補足：(97-05-03)
この方法を使用しても縦方向にリサイズすると不具合が出ます。
対処には２つの方法があります。
（１）タイマーを使う
Interval = 50msec、Enabled = False に設定したタイマーを置き、
procedure TForm1.FormResize(Sender: TObject); begin Timer1.Enabled := True; end; procedure TForm1.Timer1Timer(Sender: TObject); begin RichEdit1.Refresh; Timer1.Enabled := False; end;とします。
（２）EM_SETRECTメッセージを使う
procedure TForm1.SetEditRect;
var
R: TRect;
begin
with RichEdit1 do
begin
R := Rect(0, 0, ClientWidth, ClientHeight);
Perform(EM_SETRECT, 0, Longint(@R));
end;
end;
という手続きを用意して、Form の Paint と Resize イベント時に呼び出します。
補足(97-05-11)
一見、(2)の方がスマートなようですが、これもおかしくなる時があるようです。
ダサいけれども(1)が確実。[A] 次の関数で可能です。また、逆のSJISからJISコードへの変換も載せます。
ついでに EUCとの変換も載せます。
{ JISコードをSJISコードに変換 }
function JisToSJis(c0,c1: char): string;
var
v0: byte absolute c0;
v1: byte absolute c1;
begin
if (v0>=$21) and (v0<=$7E) then
begin
if (v0 and 1) = 1 then
begin
if v1 < $60 then Inc(v1,$1F) else Inc(v1,$20);
end else
Inc(v1,$7E);
if v0 < $5F then v0 := (v0 + $E1) shr 1
else v0 := (v0 + $161) shr 1;
Result := c0 + c1;
end else
Result := '';
end;
{ SJISコードをJISコードに変換 }
function SJisToJis(c0,c1: char): string;
var
v0: byte absolute c0;
v1: byte absolute c1;
begin
Result := '';
if ((v0>=$81) and (v0<=$9F)) or ((v0>=$E0) and (v0<=$FC)) then
begin
if ((v1>=$40) and (v1<=$FC) and (v1<>$7F)) then
begin
if v0<=$9F then
begin
if v1<$9F then v0:=(v0 shl 1)-$E1 else v0:=(v0 shl 1)-$E0;
end else
begin
if v1<$9F then v0:=(v0 shl 1)-$161 else v0:=(v0 shl 1)-$160;
end;
if (v1<$7F) then Dec(v1,$1F) else
begin
if (v1<$9F) then Dec(v1,$20) else Dec(v1,$7E);
end;
Result := C0 + c1;
end;
end;
end;
{ EUCをSJISコードに変換 }
function EucToSJis(c0,c1: char): string;
var
v0: byte absolute c0;
v1: byte absolute c1;
begin
if (v0>=$A1) and (v0<=$FE) then
begin
if (v0 and 1) = 1 then
begin
if v1 < $E0 then Dec(v1,$61) else Dec(v1,$60);
end else
Dec(v1,2);
if v0 < $DF then v0 := (v0 + $61) shr 1
else v0 := (v0 + $E1) shr 1;
Result := c0 + c1;
end else
Result := '';
end;
{ SJISコードをEUCに変換 }
function SJisToEuc(c0,c1: char): string;
var
v0: byte absolute c0;
v1: byte absolute c1;
begin
Result := '';
if ((v0>=$81) and (v0<=$9F)) or ((v0>=$E0) and (v0<=$FC)) then
begin
if ((v1>=$40) and (v1<=$FC) and (v1<>$7F)) then
begin
if v0<=$9F then
begin
if v1<$9F then v0:=(v0 shl 1)-$E1 else v0:=(v0 shl 1)-$E0;
end else
begin
if v1<$9F then v0:=(v0 shl 1)-$161 else v0:=(v0 shl 1)-$160;
end;
if (v1<$7F) then Dec(v1,$1F) else
begin
if (v1<$9F) then Dec(v1,$20) else Dec(v1,$7E);
end;
v0 := v0 or $80;// EUC は JISのMSBを1にしたものです。
v1 := v1 or $80;
Result := C0 + c1;
end;
end;
end;
[A] RichEditでの例を示します。OnKeyPressイベントの発生に対して、以下のようにします。
アプリケーション内での処理は、OnKeyPress→画面書き換え→OnKeyDownと進むので、
画面書き換え前に処理してやればいいのです。
(* キー押下 *)
procedure TMainForm.RichEdit1KeyPress(Sender: TObject; var Key: Char);
var
CurrentLine : string;
LineNo,Column: LongInt;
i : integer;
begin
if Key = #13 then // CR
begin
with RichEdit1 do
begin
LineNo := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0); // 現在の行位置を求める
Column := SelStart - SendMessage(Handle, EM_LINEINDEX, LineNo, 0); // 現在の桁位置を求める
end;
CurrentLine := RichEdit1.Lines[LineNo]; // 現在のキャレットのある行を取り込む
if (Length(CurrentLine) > 0) and (Column > 0) then
begin
{ space、TAB の数を数える }
i := 0;
while (CurrentLine[i+1] = #$20) or (CurrentLine[i+1] = #$09) do
begin
Inc(i);
end;
// 例えば5個のSPACEだけの行があり3桁目にキャレットがある場合に対応
if i > Column then i := Column;
RichEdit1.SelText := #13 + #10 + Copy(CurrentLine, 1, i); // 現在のキャレットの位置に挿入
end else
RichEdit1.SelText := #13 + #10;
Key := #0;
end;
end;[A] SystemParametersInfo
というAPIを使います。敷き詰めるにはレジストリを書き換えます。
また、オープンになっている仕様ではありませんが、
Windows95ではX方向、Y方向にオフセットつけて表示も可能です。 Windows98では効果がありません。
(* BMPファイルを壁紙にする *)
procedure WChange(Sender: TObject; DrawFileName: string);
const
WPaperKey = '\Control Panel\desktop';
var
Ss : string;
Reg: TRegistry;
begin
if (UpperCase(ExtractFileExt(DrawFileName)) = '.BMP') then
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKey_Current_User;
if not Reg.OpenKey(WPaperKey, False) then Exit else
begin
if TileCheckBox.Checked // 別途チェックボックスを用意しておく
then Reg.WriteString('TileWallpaper', '1') // タイリング
else Reg.WriteString('TileWallpaper', '0'); // 中央に表示
end;
// オフセットをつける。
Reg.WriteString('WallPaperOriginX', IntToStr(SpinEdit1.Value)); // 別途SpinEditを用意しておく
Reg.WriteString('WallPaperOriginY', IntToStr(SpinEdit2.Value));
finally
Reg.Free;
end;
Ss := DrawFileName + #0;
SystemParametersInfo(SPI_SETDESKWALLPAPER,
0,
@Ss[1],
SPIF_UPDATEINIFILE);
end;
end;[A] GetDeviceCaps というAPIを使います。
下の例では、BITSPIXELという予約された値を与えて色解像度を調べてますが、
HORZSIZE、VERTSIZEという値を与えることにより、 画面の解像度も調べることができます。
(* ピクセルあたりの色のビット数を調べる *) var ColorPerPixel : integer; DC : HDC; begin DC := GetDC(handle); ColorPerPixel := GetDeviceCaps(DC, BITSPIXEL); ReleaseDC(handle, DC); end; 補足： 画面の縦、横のサイズを調べるだけならば、 Screen.Height Screen.Width の方が簡単です。
[A] すでにNetscapeが動いている時はそのWindowを目的のURLに変更し、
まだ動いていない時は新しくNetscapeを起動するような例を挙げます。
ただし、Delphi
Ver3.1のみ動作しません。Ver.3.0、Ver.4.0はOKです。
Netscape DDEのAPIの詳細は、 http://home.netscape.com/newsref/std/ddeapi.htmlで得られます。
(* Netscape 3/4のDDE機能を使う *)
uses
DDEMan;
procedure GotoURL(sURL: string);
var
DDE : TDDEClientConv;
begin
DDE := TDDECLientConv.Create(nil);
with DDE do
begin
ServiceApplication := 'c:\ns32\program\netscape.exe';
SetLink('Netscape', 'WWW_OpenURL');
RequestData(sURL + ',,0xFFFFFFFF,0x3,,,');
CloseLink;
end;
DDE.Free;
end;
また、Internet Explorer 4でも同様に以下のようにして可能となります。
(* Internet Explorer4のDDE機能を使う *)
uses
DDEMan;
procedure GotoURL(sURL: string);
var
DDE : TDDEClientConv;
begin
DDE := TDDECLientConv.Create(nil);
with DDE do
begin
ServiceApplication := 'c:\Program Files\Internet Explorer\Iexplore.exe';
SetLink('Iexplore', 'WWW_OpenURL');
RequestData(sURL + ',,0xFFFFFFFF,0x3,,,');
CloseLink;
end;
DDE.Free;
end;
[A] SenMessage API ファンクションを使います。
(* デフォルトの Screen Saver を起動する *) begin SendMessage(GetDesktopWindow(), WM_SYSCOMMAND, SC_SCREENSAVE, 0); end;
[A] SendMessage API ファンクションで、EM_GETLINECOUNT メッセージを使います。
(* 総行数を調べる *) var TotalLine: integer; begin TotalLine := SendMessage(RichEdit1.Handle, EM_GETLINECOUNT, 0, 0); end;
[A] 以下の方法は、news:fj.lang.pascal に於いて、 比企さんが発表された方法です。
この方法には、Delphi
1も必要です。 なお、Delphi1を所有していない場合は、『Win32 APIのメッセージである
EM_FINDTEXTかEM_FINDTEXTEXを使えばできる。』という情報を得てますが、
私(CASA)は試していないので分かりません。
この情報の転載に快諾していただいた比企さんに感謝します。
１．Delphi1.0 の、Demos\Textdemo にある Search.pas を改造します。
なぜならば、
１．これは Memo 用である
２．スクロールしてくれない
からです。
２．Uses 節を以下のように変更します。
uses
Windows, Messages, SysUtils, StdCtrls, Dialogs, ComCtrls;
３．function SearchMemo(Memo: TCustomEdit; const SearchString: String; Options: TFindOptions): Boolean;
以下を次のように変更します。
function SearchMemo(Memo: TCustomEdit; const SearchString: String; Options: TFindOptions): Boolean;
var
Buffer, P: PChar;
Size : Longint; // Wordでしたが、64kを越えるデータに対応のため変更(CASA)
FindLine : integer;
begin
Result := False;
if (Length(SearchString) = 0) then exit;
Size := Memo.GetTextLen;
if (Size = 0) then exit;
Buffer := StrAlloc(Size + 1);
try
Memo.GetTextBuf(Buffer, Size + 1);
P := SearchBuf(Buffer, Size, Memo.SelStart, Memo.SelLength,
SearchString, Options);
if P <> nil then
begin
with Memo do
begin
SelStart := P - Buffer;
SelLength := Length(SearchString);
FindLine := Perform(EM_LINEFROMCHAR, Selstart, 0);
if frDown in Options
then Perform(WM_VSCROLL, SB_LINEDOWN, FindLine)
else Perform(WM_VSCROLL, SB_LINEUP, FindLine);
end;
Result := True;
end;
finally
StrDispose(Buffer);
end;
end;
４．TCustomEdit を TRichEdit に置換します。
５．次に、Search.pasを呼び出す部分を手直しします。
Delphi1.0の \Demos\Textdemo の Main.pas の
Find1click、Find、Replace1Click、
FindNextClick、Replace イベントの中のコードを丸写しします。
６．Memo1 のところを、実際に使用している RichEdit の Name に置換します。
７．RichEdit の HideSelection プロパティをFalseにします。
さらに、私が見つけた項目です。
１．Options設定を［検索する方向］を［上へ向って(U)］にし、
［単語単位で検索(W)］を選択すると、一番上の選択ワードまで検索したあと、
もう検索ワードが無いにもかかわらず、ハングアップしてしまいます。
簡単な対処方法は、
function SearchBuf(Buf: PChar; BufLen: Integer;
SelStart, SelLength: Integer;
SearchString: String;
Options: TFindOptions): PChar;
の関数の中で、
while SearchCount >= 0 do
の行を
while SearchCount > 0 do
に変更します。
２．以下は漢字などの２バイトコードに対応した場合にのみ必要な処理です。
２バイトコードを検索する場合、［大文字と小文字を区別する(C)］をチェックしていないと、
検索できないことがあります。
これは、このルーチンが Ansiキャラクタに特化したルーチンだからです。
２バイトコードに対応するには、
function SearchBuf(Buf: PChar; BufLen: Integer;
SelStart, SelLength: Integer;
SearchString: String;
Options: TFindOptions): PChar;
var
SearchCount, I: Integer;
C : Char;
Direction : Shortint;
CharMap : array [Char] of Char;
AnsiFlg : Boolean; // この行を追加する
のようにフラグを設け、以下の追加・修正を行ないます。
{ Using a Char map array is faster than calling AnsiUpper on every character }
for C := Low(CharMap) to High(CharMap) do
CharMap[C] := C;
{ 漢字が検索ワードかどうかチェック }
AnsiFlg := True; // ^
for i := 1 to Length(SearchString) do // | この部分を追加
begin // |
if SearchString[i] >= #$80 then AnsiFlg := false; // V
end;
{ 大文字小文字をチェックしないならば }
if not (frMatchCase in Options) and AnsiFlg then // 先のフラグも条件に加える
begin
// AnsiUpperBuff(PChar(@CharMap), sizeof(CharMap));
// AnsiUpperBuff(@SearchString[1], Length(SearchString));
CharUpperBuff(PChar(@CharMap), sizeof(CharMap)); // ついでに32bits APIに変更
CharUpperBuff(@SearchString[1], Length(SearchString)); // ついでに32bits APIに変更
end;
３．また、［単語単位で検索(W)］を選択すると、漢字などの２バイトコードでうまくいきませんから、
漢字対応のアプリケーションの場合は、このOptionsの項目を使うのをあきらめます。
Search.pas を呼び出す部分で、FindDialogを実行する直前に、
FindDialog1.Options := [frHideWholeWord]; // この行を追加する
FindDialog1.Execute;
４．次にこれがまた厄介なのですが、'b'(#$62)などの１文字だけを検索すると、
シフトJISの'臣'(#$90+#$62)もＨｉｔしてしまいます。
英語文化で育った人間が組んだプログラムですから仕方が無いけど、ちょっと愚痴りたくもなります。
で、小修正でしかもエレガントな解法は見つけてないのですが、
取りあえず、ラベルを使った汚い方法は見つけてあります。
先の、SearchMemoに追加します。
function SearchMemo(Memo: TRichEdit;
const SearchString: String;
Options: TFindOptions): Boolean;
label // ラベルを導入
ReSearch;
var
Buffer, P: PChar;
Size : Longint;
FindLine : integer;
begin
Result := False;
if (Length(SearchString) = 0) then Exit;
Size := Memo.GetTextLen;
if (Size = 0) then Exit;
Buffer := StrAlloc(Size + 1);
try
Memo.GetTextBuf(Buffer, Size + 1);
ReSearch: // ここにラベルを設定
P := SearchBuf(Buffer, Size, Memo.SelStart, Memo.SelLength,
SearchString, Options);
if P <> nil then
begin
with Memo do
begin
SelStart := P - Buffer;
SelLength := Length(SearchString);
FindLine := Perform(EM_LINEFROMCHAR, Selstart, 0);
// MainForm.Caption := Buffer[Memo.SelStart] + Buffer[Memo.SelStart + 1]; デバグ用です。
{ 以下を追加。1文字を検索し、バッファ先頭がAnsiコード以外なら・・・ }
{ ふつうならば、バッファの先頭には検索ワードの先頭と等しいコードとなるはずが、 }
{ なぜか、この時だけは、SJISの１バイト目が入ってます。 }
if (Length(SearchString) = 1) and (Buffer[Memo.SelStart] > #$80) then
begin
if frDown in Options then SelStart := SelStart + 2
else SelStart := SelStart - 1;
goto Research;
end
else
if frDown in Options
then Perform(WM_VSCROLL, SB_LINEDOWN, FindLine)
else Perform(WM_VSCROLL, SB_LINEUP, FindLine);
end;
Result := True;
end;
finally
StrDispose(Buffer);
end;
end;
長くなりましたが、以上で高機能な検索ルーチンがTRichEditで使えるようになります。[A] 以下の方法は、 比企さんから直接頂いたものです。
この方法では、先に示したような２バイトコード対策がなされていませんので、
２バイトコード対応が必要な時には、先の情報を参考に改造してください。
なお、Delphi1はまだ販売中ですから、全ソースを掲載しておりませんので、ご了承ください。
この情報の転載に快諾していただいた比企さんに感謝します。
１．Uses 節を以下のように変更します。
uses
Windows, Messages, SysUtils, StdCtrls, Dialogs;
２．TCustomEdit を TMemo に置換します。
３．Interface部に、MemoLinesShowingという新しい関数を宣言します。
function MemoLinesShowing(Memo: TMemo): integer;
４．implementation部に実際の動作を記述します。
{ Memoの見えている行数を調べる }
function MemoLinesShowing(Memo: TMemo: integer;
var
OldFont: HFont; { the old font }
DC : THandle; { Device context handle }
Tm : TTextMetric; { text metric structure }
TheRect: TRect;
begin
DC := GetDC(Memo.Handle); { Get the memo's device context }
try
{ Select the memo's font }
OldFnt := SelectObject(DC, Memo.Font.Handle);
try
GetTextMetrics(DC, Tm); { Get the text metric info. }
Memo.Perform(EM_GETRECT, 0, longint(@TheRect));
Result := (TheRect.Bottom - TheRect.Top) div (Tm.tmHeight + Tm.tmExternalLeading);
finally
SelectObject(DC, OldFont); { Select the old font }
end;
finally
ReleaseDC(Memo.Handle, DC); { Release the device context }
end;
end;
５．function SearchMemo(Memo: TMemo; const SearchString: String; Options: TFindOptions): Boolean;
以下を次のように変更します。
function SearchMemo(Memo: TMemo; const SearchString: String; Options: TFindOptions): Boolean;
var
Buffer, P : PChar;
Size : Word;
SeeLines : integer; { 見えている行数 }
TopLine,BotomLine: integer;
FindLine : integer;
Scrolling : integer; { スクロール行数 }
begin
Result := False;
if (Length(SearchString) = 0) then exit;
Size := Memo.GetTextLen;
if (Size = 0) then exit;
Buffer := StrAlloc(Size + 1);
try
Memo.GetTextBuf(Buffer, Size + 1);
P := SearchBuf(Buffer, Size, Memo.SelStart, Memo.SelLength,
SearchString, Options);
if P <> nil then
begin
SeeLines := MemoLinesShowing(Memo);
with Memo do
begin
TopLine := Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
SelStart := P - Buffer;
SelLength := Length(SearchString);
FindLine := Perform(EM_LINEFROMCHAR, Selstart, 0);
BottomLine := TopLine + SeeLines;
if (FindLine >= BottomLine) and (frDown in Options) then
begin
Scrolling := FindLine - TopLine - (SeeLines div 2);
Perform(EM_LINESCROLL, 0, Scrolling);
end if (FindLine <= TopLine) and not (frDown in Options) then
begin
Scrolling := FindLine - TopLine - (SeeLines div 2);
Perform(EM_LINESCROLL, 0, Scrolling);
end;
end;
Result := True;
end;
finally
StrDispose(Buffer);
end;
end;
以上でスクロールを行なう高機能な検索ルーチンがTMemoで使えるようになります。[A] Windows95にはGlobalAtomという、複数のプログラムから共有できるメモリエリアがあります。
詳細は、APIのオンラインマニュアルを見てください。
実際の例を述べます。
１．送り出し側（書き込み側）の記述例
const
MessageIDStr = 'Original Program ID by Quebnoi Casa'; // 特異なメッセージを定める
var
s : string;
MessageID: longint;
Atom : TAtom;
begin
s := 'あぅ、これは送るテスト文字列さっ。';
MessageID := RegisterWindowMessage( MessageIDStr);
Atom := GlobalAddAtom(@s[1]); // GlobalAtomに書き込む
if Atom <> 0 then PostMessage(hwnd_Broadcast, MessageID, 1, Atom) // wParam=1にして、書いた事を通知
else ShowMessage('ＡＴＯＭ生成に失敗！');
end;
２．受け取り側（読み出し側）の記述例
２−１．Private宣言部にメッセージの受け皿を追加する。
private
{ Private 宣言 }
:
procedure AppMessage(var Msg: TMsg; var Handled: boolean);
:
２−２．実装部のすぐ上に送り出し側と同じメッセージを宣言する。
:
const
MessageIDStr = 'Original Program ID by Quebnoi Casa'; // 送り出し側と同じメッセージ
var
MessageID: longint;
implementation
:
２−３．フォーム作成時の処理に、メッセージ受け取りのＩＤ取得と、メッセージを横取りする旨を、追加する。
procedure TMainForm.FormCreate(Sender: TObject);
begin
:
MessageID := RegisterWindowMessage( MessageIDStr);
Application.OnMessage := AppMessage;
:
end;
２−４．実際の処理を記述します。
procedure TMainForm.AppMessage(var Msg: TMsg; var Handled: boolean);
var
Exist : integer;
Buffer: array[0..255] of Char;
begin
with Msg do
begin
if Message = MessageID then
begin
if wParam = 1 then // ATOM あり
begin
Exist := GlobalGetAtomName(lParam, Buffer, 255); // lParamはAtomを指す
if Exist > 0 then
begin
GlobalDeleteAtom(lParam); // Atomを削除
ShowMessage(Buffer);
:
end;
end;
Handled := True;
end;
end;
end;
wParamをいろいろ変え、受信するアプリケーション側で動作を変えることもできます。[A] TMemoryStreamは強力なクラスです。
DOSの時代は、64kbyteを越えてメモリの読み書きを行なうのに、
いちいち読み書きしたサイズや読み書きするポインタを管理しなければなりませんでした。
TMemoryStreamはこの作業をたいへん軽減してくれます。
ここでは、ファイルのテキストデータを大文字に加工してMemoryStreamに書き込み、 最後に、いっぺんにMemoに転送する例をあげます。
{ メモリオーバーフロー対策は行なっていません }
var
fi : TextFile;
MemoryStream: TMemoryStream;
c : Char;
begin
AssignFile(fi, 'c:\data\hogehoge.txt');
try
Reset(fi);
MemoryStream :=TMemoryStream.Create; // MemoryStreamの生成
while not Eof(fi) do
begin
Read(fi,c);
c := UpCase(c);
MemoryStream.Write(c, 1); // 1バイト書き込み
end;
MemoryStream.Seek(0, 0); // アクセス位置をストリームの先頭に
Memo1.Lines.LoadFromStream(MemoryStream); // Memoに読み込む
finally
MemoryStream.Free; // MemoryStreamの破棄
CloseFile(fi);
end;
end;
TmemoryStreamは、TStream→TCustomMemoryStreamから派生したクラスで、Seekメソッドの説明は
TCustomMemoryStreamまたはTStreamにあります。
[A] 型変換を行なうのが正直な方法ですが、以下の方法でも行なえます。
type
TLongintPart = record
case Byte of
0: ( Long: Longint);
1: ( Word1, Word2: Word);
2: ( Byte1, Byte2, Byte3, Byte4: Byte);
end;
var
MyPart: TLongintPart;
begin
MyPart.Long := $01234567;
Label1.Caption := IntToStr(MyPart.Byte2);
Label2.Caption := IntToStr(MyPart.Word2);
end;
注意しなければならないのは、メモリ上の変数の並びは上位と下位がひっくり返っており、
Byte1 = $67
Byte2 = $45
Byte3 = $23
Byte4 = $01
Word1 = $4567
Word2 = $0123
Long = $01234567
となっていることです。
[A] VCLのAnimateコンポネントが使えます。 APIを使うならばファイルの移動・複写・削除の時にSHFileOperationというAPIを使います。
(* SHFileOperationを使う例 *)
uses ShellAPI;
var
SFO: TSHFileOpStruct;
Res: integer;
begin
with SFO do
begin
Wnd := Handle;
wFunc := FO_COPY; // コピー
pFrom := PChar('d:\data'#0#0);
pTo := PChar('c:\temp'#0#0);
fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMMKDIR;
fAnyOperationsAborted := False;
hNameMapping := nil;
end;
try
Res := SHFileOperation(SFO);
finally
end;
end;
複数のファイルやフォルダを選ぶ場合は、
pFrom := PChar('d:\data'#0'd:\tool'#0#0);
のように、#0（null）キャラクタを挿みます。
また、デスクトップのごみ箱に移動する場合は、
wFunc := FO_DELETE;
を使います。[A] できます。
C/S版、Delphi3.1 Professional版、Delphi4 +WebBroker for Delphi 4では、
CGI作成用のウィザードとコンポーネントが用意されていますので、 そちらを使う方がいいです。
これらを使わない場合でも可能です。
その場合標準入出力（STDIN/STDOUT）を使わなければなりませんので、 コンソールアプリケーションにします。
フォームは不要ですから、「メニュー→プロジェクト→プロジェクトから削除」を選び、 フォームを削除し、dprに以下の記述を行ないます。
program Project1;
{$AppType Console}
var
aLine: string;
begin
Readln(aLine); // 標準入力から読み込む
Writeln('content-type: text/html');
Writeln(''); // 空白行が必要です
Writeln('<HTML>');
Writeln('<HEAD><TITLE>Delphi-TIPS</TITLE></HEAD>');
Writeln('<BODY TEXT="#104020" BGCOLOR="#EEEEEE" LINK="#0060F0" VLINK="#A02060" onLoad="return true;">');
:
Writeln('</HTML>');
end;[A] サンプルを見てください。
var
UserName: array[0..127] of char;
UserSize: integer;
begin
UserSize := 128;
GetUserName(@UserName, UserSize);
ShowMessage('User "' + StrPas(UserName) + '"');
end;[A] TRichEditのバグ？。
MaxLengthプロパティが0
ならばコントロールに入力できる文字数は制限されません。
とヘルプにありますが、このプロパティをきちんとバイト単位で設定するか、以下のコードを追加してください。
RichEdit1.Perform(EM_LIMITTEXT, 0, 20000000); // 20MBまで可
[A] Delphiのアプリケーション内ではDragModeプロパティでやり取りできますが、
他のアプリケーションからDrag and
Dropするには、メッセージを処理します。
以下のコードはエクスプローラーからMemoへドラッグ＆ドロップを可能にします。
uses ShellAPI;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
DragAcceptFiles( Form1.Handle, True);
end;
procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
const
BufferLength = 255;
var
DroppedFileName: string;
begin
if Msg.Message = WM_DROPFILES then
begin
SetLength( DroppedFileName, BufferLength);
DragQueryFile(Msg.wParam, 0, PChar(DroppedFileName), BufferLength);
Memo1.Lines.LoadFromFile( DroppedFileName);
DragFinish(Msg.wParam);
Handled := True;
end;
end;[A] OnMinimizeイベントを使います。
しかし、Formで、
procedure TForm1.OnMinimize(Sender: TObject);としても処理できません。Applicationで検出します。
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
procedure AppMin(Sender: TObject);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMinimize := AppMin;
end;
procedure TForm1.AppMin(Sender: TObject);
begin
ShowMessage('最小化検出成功');
end;[A] 次のマジックナンバーを使うと、フォームのどこをクリックしても窓のドラッグできます。
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); const SC_DragMove = $F012; begin ReleaseCapture; Perform(WM_SYSCOMMAND, SC_DragMove, 0); end;補足:(95-05-11)
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
ReleaseCapture;
DefWindowProc( handle, WM_NCLBUTTONDOWN, HTCAPTION, X+Y*$10000);
end;
end;lParam の X+Y*$10000 は、0 でも構わないようです。 [A] KeyboardStateクラスがあります。
procedure TForm1.Button1Click(Sender: TObject);
var
KeyState: TKeyboardState;
begin
GetKeyboardState(KeyState);
if (KeyState[VK_NUMLOCK] = 0)
then KeyState[VK_NUMLOCK] := 1 else KeyState[VK_NUMLOCK] := 0;
SetKeyboardState(KeyState);
end;VK_NUMLOCKの代わりにVK_CAPITALを使うとCaps Lockキーを制御できます。