| Delphi-Tips-2 (Delphiの情報) |
|---|
'97-Jun-08th 初出
[A] OnSelectionChangeイベントで、APIの
CreateCaret、ShowCaretを使います。
以下のコードは、フォント幅いっぱいにキャレットを大きくします。(2バイトコードに対応)
procedure TForm1.RichEdit1SelectionChange(Sender: TObject);
const
SJISTOP = #$81+#$40;
var
w: integer;
LineNo,Column: integer;
ts,s: string;
begin
with RichEdit1 do
begin
LineNo := Perform(EM_GETLINEFROMCHAR, SelStart, 0); // 行取得
Column := SelStart - Perform(EM_LINEINDEX, LineNo, 0); // 桁位置取得
ts := RichEdit1.Lines.String[LineNo];
if Length(ts) > 0 then s := ts[Column + 1] else s := #$20; // CRLFだけの行に対応
if CompareStr(s, SJISTOP) >= 0 then s := ts[Column + 1]; // 簡易的に比較
w := Form1.Canvas.TextWidth(s); // キャレット位置の文字幅を取得
CreateCaret( Handle, 0, w, Abs(Font.Height));
ShowCaret(Handle);
end;
end;キャレット位置は Lines.Text プロパティでも取得できますが、[A] CreateProcess APIを使用する方法があります。
private
function ExecuteAndWait(App,CmdLine: string): integer;
end;
function TForm1.ExecuteAndWait(App,CmdLine: string): integer;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
s: array[0..MAX_PATH] of char;
begin
GetStartupInfo(StartupInfo); // スタートアップ情報を得る
StartupInfo.wShowWindow := SW_MINIMIZE; // 最小化で実行
ExpandEnviromentStrings(Pchar(App), @s, MAX_PATH);
App := string(Pchar(@s));
if CreateProcess(PChar(App),
PChar(App + ' ' + CmdLine),
nil,nil,FALSE,0,nil,
PChar(GetCurrentDir),
StartupInfo,
ProcessInfo) then
begin
CloseHandle(ProcessInfo.hThread);
WaitforSingleObject(ProcessInfo.hProcess, INFINITE); // タイムアウト無しで終了を待つ
GetExitCodeProcess(ProcessInfo.hProcess,Result);
CloseHandle(ProcessInfo.hProcess);
end else
raise Exception.CreateFmt('Err:could not create process %s %s: %d' ,
[App, CmdLine, GetLastError]);
end;
begin
ExecuteAndWait('c:\command.com','/c dir');
:
end;NTにも対応するため、与えるパラメータはたくさんあります。[A] GetEnvironmentStrings APIを使用し、環境変数の位置を得て処理します。
各環境変数の区切りは #0
で、一番最後は #0+#0 となっているようです。(ちゃんとした文献で調べてません)
Procedure TForm1.Form1Create(Sender: TObject);
var
Ptr: PChar;
s: string;
Done: Boolean;
begin
Memo1.Clear; // Memoに出力することにします
Ptr := GetEnvironmentStrings;
Done := FALSE;
s := '';
while not Done do
begin
if Ptr^ = #0 then
begin
Memo1.Line.Add(s);
Inc(Ptr);
if Ptr^ = #0 then Done := TRUE else s := Ptr^;
end else s := s + Ptr^;
Inc(Ptr);
end
end;なお、個々の環境変数にアクセスする場合は、
GetEnvironmentVariable関数および[A]
直接フォーム上に配置せず、Panelを置き、その上にボタンを配置すれば、
PanelのVisibleを変更していっぺんに見えなくすることができます。
また、動的にボタンを生成する場合、ParentをPanelに指定します。
[A] Delphiのアプリケーションは、非表示のApplicationウィンドウがフォームを管理しています。
フォームを最小化しても、非表示のApplicationが最小化されるので、アニメーションは表示されません。
最小化・復元を行なう時に、フォーム上にApplicationウィンドウを表示すれば、アニメーションを表示させることができます。
具体的なコーディングについては、
http://www.borland.co.jp/support/technote/dh/9611q4.htmをご覧下さい。
[A] グローバル変数 Screenには Imageプロパティがありませんので、画面のデバイスコンテキストを得て処理します。
{ Imageコンポネントを用意しておきます }
var
hdcScreen: HDC;
begin
hdcScreen := GetDC(0); // デスクトップのデバイスコンテキストを得る
try
Image1.Picture.Bitmap.Handle := CreateCompatibleBitmap(hdcScreen,Screen.Width,Screen.Height);
BitBlt(Image1.Picture.Bitmap.Canvas.Handle,0,0,Screen.Width,Screen.Height,hdcScreen,0,0,SRCCOPY);
finally
ReleaseDC(0,hdcScreen);
end;
end;[A] パネルは OnClickイベントが用意されてますので、以下のような記述ができます。
public
PanelX : array[0..99] of TPanel;
procedure MyPanelClick(Sender: TObject); // このように自前で用意します
end;
{ Form作成時に Panelを動的に生成 }
procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
begin
for i := 0 to 99 do
begin
PanelX[i] := TPanel.Create(Self);
PanelX[i].Parent := Self; // 親の指定も忘れずに
PanelX[i].Top := (i div 10)* 30;
PanelX[i].Left := (i mod 10)* 30;
PanelX[i].Width := 28;
PanelX[i].Height := 28;
PanelX[i].Caption := IntToStr(i);
PanelX[i].OnClick := MyPanelClick; // このように結び付けます
end;
end;
{ OnClickした時の処理 }
procedure TForm1.MyPanelClick(Sender: TObject);
begin
{ Panelであることを確認して処理する }
with Sender as TPanel do
begin
Form1.Caption := Caption;
Color := clAqua;
end;
end;[A] 以下の情報はMicrosoftのKnowledgebaseでも確認してください。 また、このコードでは
Windows-95でのみ可能です。Windows-NTでは効きません。
const
SPI_SCREENSAVERRUNNING = 97; // MS KB Q161133,Oct-13th,1997
{ 95のみ有効。NTでは無効 }
{ キーの無効化 }
procedure TurnSystemKeysOff;
var
dummy: integer;
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING, Integer(TRUE), @Dummy, 0);
end;
{ キーの有効化 }
procedure TurnSystemKeysOn;
var
dummy: integer;
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING, Integer(FALSE), @Dummy, 0);
end;[A] ShellExecute関数を使います。
uses
......., ShellAPI; // ShellAPIを追加します
private
function Execute(FileName: string; ShowMode: integer):integer;
:
implementation
:
function TForm1.Execute(FileName: string; ShowMode: integer):integer;
begin
Result := ShellExecute(Handle,nil,PChar(FileName),nil,nil,ShowMode);
end;
// 通常サイズで起動
procedure TForm1.Button1Click(Sender: TObject);
begin
Execute('calc.exe', SW_SHOWNORMAL);
end;
// 最大化サイズで起動
procedure TForm1.Button2Click(Sender: TObject);
begin
Execute('calc.exe', SW_MAXIMIZE);
end;
// 最小化サイズで起動
procedure TForm1.Button3Click(Sender: TObject);
begin
Execute('calc.exe', SW_MINIMIZE);
end;[A] APIのGetDriveType関数を使います。
procedure TForm1.Button1Click(Sender: TObject);
var
Drive: Char;
DriveLetter: string;
begin
for Drive := 'A' to 'Z' do
begin
DriveLetter := Drive + ':\';
case GetDriveType(PChar(DriveLetter)) of
DRIVE_REMOVABLE:
Memo1.Lines.Add(DriveLetter+' Floppy Drive');
DRIVE_FIXED:
Memo1.Lines.Add(DriveLetter+' Fixed Drive');
DRIVE_REMOTE:
Memo1.Lines.Add(DriveLetter+' Network Drive');
DRIVE_CDROM:
Memo1.Lines.Add(DriveLetter+' CD-ROM Drive');
end;
end;
end;[A] APIのGetComputerName関数が使えます。
procedure TForm1.Button1Click(Sender: TObject);
var
CName: array[0..MAX_COMPUTERNAME_LENGTH+1] of Char;
Buffer: DWORD;
begin
Buffer := MAX_COMPUTERNAME_LENGTH+1;
if GetComputerName(@CName,Buffer)
then Label1.Caption := CName
else Label1.Caption := '';
end;[A] StringGridは他の入力支援のVCLやImageを組み合わせて、おもしろい効果をあげることができます。
実際の画面を一回見ると納得できるでしょう。
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.DefaultRowHeight :=ComboBox1.Height;
end;
procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
var
R: TRect;
begin
if (Col>=StringGrid1.FixedCols)and(Row>=StringGrid1.FixedRows)and
(gdFocused in State) then
with ComboBox1 do
begin
BringToFront; // ComboBoxを動的に作り、ParentをStringGridにすれば不要かも
CopyRect(R,Rect);
R.TopLeft := Form1.ScreenToClient(StringGrid1.ClientToScreen(R.TopLeft));
R.BottomRight := Form1.ScreenToClient(StringGrid1.ClientToScreen(R.BottomRight));
SetBounds(R.Left,R.Top,R.Right-R.Left,R.Bottom-R.Top);
end;
end;
procedure TForm1.StringGrid1TopLeftChanged(Sender: TObject);
var
R: TRect;
begin
with StringGrid1 do
CopyRect(R,CellRect(Col,Row));
with ComboBox1 do
begin
Visible := False;
BringToFront; // ComboBoxを動的に作り、ParentをStringGridにすれば不要かも
R.TopLeft := Form1.ScreenToClient(StringGrid1.ClientToScreen(R.TopLeft));
R.BottomRight := Form1.ScreenToClient(StringGrid1.ClientToScreen(R.BottomRight));
SetBounds(R.Left,R.Top,R.Right-R.Left,R.Bottom-R.Top);
end;
with StringGrid1 do
if (TopRow<=Row)and(TopRow+VisibleRowCount>Row) then ComboBox1.Show;
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
with StringGrid1 do
Cells[Col,Row] := ComboBox1.Text;
end;[A] GetVersionEx APIを使うことになりますが、その時使う OsVersionInfo構造体が
TOsVersionInfoという型で用意されてます。
Ver3.1から加わったコード補完自動支援機能も対応しています。
なお、私の環境はスタンダードのWin95とWin98です。
他の環境がきちんと認識できるかどうか未確認ですので、ご容赦下さい。
procedure TForm1.FormCreate(Sender: TObject);
var
OSVersionInfo : TOSVersionInfo;
begin
// この書き方は Cを移植したへその緒だと思ってあきらめましょうか。
OsVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
GetVersionEx(OsVersionInfo);
with OSVersionInfo do
begin
case OsVersionInfo.dwPlatformId of
VER_PLATFORM_WIN32s : Platform :='Win32s on Windows 3.1';
VER_PLATFORM_WIN32_WINDOWS:
begin
BuildNumber := LoWord(dwBuildNumber);
case Win32MinorVersion of
0: begin
Platform :='Win32 on Windows 95';
if BuildNumber > 1000 then Platform := Platform + '(OSR2)';
end;
10: Platform :='Win32 on Windows 98';
end;
end;
VER_PLATFORM_WIN32_NT :
begin
Platform :='Windows NT';
BuildNumber := dwBuildNumber;
end;
end;
Label1.Caption := Format('%s (Windows Ver.%d.%d Build %d)',
[Platform, dwMajorVersion,dwMinorVersion, BuildNumber]);
end;
end;[A] もちろんできます。
が、参考資料がすごく少ないのでたいへんです。 Visio
Ver5Jでようやく英語版のOLE関連の資料がマニュアル化され、 ヘルプファイルも供給されるようになりましたが、
試行錯誤で手探りしながらプログラミングしている状態です。
でも、Visioは図形描画ソフトとして一級品ですし、
DTP用ソフトとしてもWordより上だと個人的に思ってますので、
Word、Excelのようにだんだん資料が出てくれればいいのですが・・・。
以下はプログラミングしていて良く使いそうな部分を抜粋してます。
uses ComObj;
var
Visio: Variant;
(* Visioを新たに開く *)
procedure OpenNewVisio;
begin
try
Visio := CreateOleObject('Visio.Application');
except
ShowMessage('Visioを起動できません.');
Exit;
end;
end;
(* すでにVisioが開いている場合、そのプロセスにアクセスする *)
procedure ConnectVisio;
begin
try
Visio := GetActiveOleObject('Visio.Application');
except
ShowMessage('Visioは開いてません.');
Exit;
end;
end;
(* ファイルを開く *)
procedure OpenVsd;
begin
if OpenDialog1.Execute then
try
Visio.Documents.Open(OpenDialog1.FileName);
except
ShowMessage('ファイルを開けません.');
Exit;
end;
end;
// 既存ファイルのID＝4のテキストの内容を変更する
Visio.ActiveDocument.Pages.Item(1).Shapes.ItemFromID(4).Text := Label1.Caption;
// そのテキスト長が長ければフォントサイズを変更する
if Length(Label1.Caption) > 24 then
Visio.ActiveDocument.Pages.Item(1).Shapes.ItemFromID(4).
Characters.CharProps(visCharacterSize) := 18 else
Visio.ActiveDocument.Pages.Item(1).Shapes.ItemFromID(4).
Characters.CharProps(visCharacterSize) := 20; // with文を使いたくなるけどできません
// 印刷する
Visio.ActiveDocument.Pages.Item(1).Print;
// 線を引く
for i := 0 to 9 do
Visio.Documents[1].Pages[1].DrawLine(i/10, 0, i/10,1);
Visioをオートメーションで制御する際に参考になる資料は、[A] ExtractIcon APIを使います。
// Image型のImage1に表示する例 var Icon: TIcon; begin Icon := TIcon.Create; // Icon生成 Icon.Handle := ExtractIcon(Handle,'c:\windows\calc.exe',0); Image1.Canvas.Draw(0,0,Icon); Icon.Free; // Icon破棄 end;
[A] これもRicheditのバグとみなしていいかもしれません。 対処方法は簡単でstring型の変数に読み直して貼り付けます。
既存のプロパティを使って簡略化した例は以下のようにします。
uses
Clipbrd;
// RichEdit1.PasteFromClipboard を次のように書き換えます
if Clipboard.HasFormat(CF_TEXT) then
RichEdit1.SelText := Clipboard.AsText;[A] FormShowハンドラにて次の記述を行ないます。
procedure TForm1.FormShow(Sender: TObject); var WInfo: integer; begin ShowWindow( Application.Handle, SW_HIDE); WInfo := GetWindowLong( Application.Handle,GWL_STYLE); WInfo := WInfo or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW; SetWindowLong( Application.Handle, GWL_EXSTYLE, WInfo); ShowWindow( Application.Handle, SW_HIDE); end;
[A] SetWindowPos APIが使えます。
procedure TForm1.Button1Click(Sender: TObject);
var
hwnd: THandle;
begin
ShellExecute(Handle,'Open','Explorer.exe','c:\Windows\SendTo',nil,SW_SHOW);
ShellExecute(Handle,'Open','Explorer.exe','c:\Windows\System',nil,SW_SHOW);
repeat
hwnd := FindWindow('CabinetWClass','SendTo');
until hwnd <> 0;
SetWindowPos(hwnd,HWND_TOP,0,0,Screen.Width,Screen.Height div 2,SWP_SHOWWINDOW);
repeat
hwnd := FindWindow('CabinetWClass','System');
until hwnd <> 0;
SetWindowPos(hwnd,HWND_TOP,0,Screen.Height div 2,Screen.Width,Screen.Height div 2,SWP_SHOWWINDOW);
end;[A] SetSystemTime APIを使います。
procedure TForm1.Button1Click(Sender: TObject);
var
SystemTime: TSystemTime;
begin
GetSystemTime(SystemTime);
Memo1.Lines.Add(IntToStr(SystemTime.wYear)+'年');
Memo1.Lines.Add(IntToStr(SystemTime.wMonth)+'月');
Memo1.Lines.Add(IntToStr(SystemTime.wDay)+'日');
Memo1.Lines.Add( '(' + Copy(DayOfWeek,2*SystemTime.wDayOfWeek+1,2) + ')');
Memo1.Lines.Add(IntToStr((SystemTime.wHour+9) mod 24)+'時');
Memo1.Lines.Add(IntToStr(SystemTime.wMinute)+'分');
Memo1.Lines.Add(IntToStr(SystemTime.wSecond)+'秒');
Memo1.Lines.Add(IntToStr(SystemTime.wMilliseconds)+'msec');
SetSystemTime(SystemTime);
end;[A] デスクトップ画面のハンドルを得て、BitBlt関数で画像を転送します。
// ButtonとImageを用意しておきます
procedure TForm1.Button1Click(Sender: TObject);
var
ScreenDC: HDC;
begin
ScreenDC := GetDC(0);
try
GDIFlush;
BitBlt(Image1.Canvas.Handle,0,0,Screen.Width,Screen.Height,
ScreenDC,0,0,SRCCOPY);
finally
ReleaseDC(0,ScreenDC);
end;
end;[A] ListViewをFileStreamに保存し、読み出す例です。
procedure TForm1.Button1Click(Sender: TObject);
var
FileStream: TFileStream;
begin
FileStream := TFileStream.Create('c:\temp\test.lvw', fmCreate or fmShareDenyNone);
FileStream.WriteComponent(ListView1);
FileStream.Free;
ListView1.Items.Clear;
FileStream := TFileStream.Create('c:\temp\test.lvw', fmOpenRead or fmShareDenyNone);
TComponent(ListView1) := FileStream.ReadComponent(ListView1);
FileStream.Free;
end;[A] SplashFormという名前のフォームを追加し、
メニュー→プロジェクト→オプション→フォームで選択可能なフォームにしておきます。
次に、このフォームをデザインします。
フォームのプロパティは、BorderStyle=bsNoneに、FormStyle=fsStayOnTopに、Position=poScreenCenterに
通常設定します。
まだプロジェクトのソースが表示されていないならば、メニュー→表示→プロジェクトソースを選び、
ソースを表示し、以下の様に追加します。
uses
Forms, Windows,・・・ // Windowsを追加
var
tc: integer;
begin
Application.Initialize;
// 以下を追加します
SplashForm := TSplashForm.Create(Application);
SplashForm.Show;
SplashForm.Update;
tc := GetTickCount;
repeat
Application.ProcessMessages;
until GetTickCount -tc >= 2000;
Application.CreateForm(TForm1, Form1);
// 以下を追加します
SplashForm.Close;
SplashForm.Free;
Application.Run;
end.[A]
FAT32システムで、GetDiskFreeSpaceExAというAPIがkernel32.dllに追加されています。
コーディングの際には、このAPIが使えるかどうか調べてから処理します。
なお、Delphi4になってから、int64(符号付き64bit)が使えます。
下の例ではCOMP型を使っています。
var
DiskSapceEx_Loaded: Boolean;
lngFreeSpace: comp; // Delphi4 では INT64型が使用できる
lngTotalBytes: comp;
GetDiskFreeSpaceEx: function(lpDirectoryName: PChar;
lpFreeBytesAvailableToCaller,
lpTotalNumberOfBytes,
lpTotalNumberOfFreeBytes:
PLargeInteger) : Bool; STDCALL;
procedureLoadDiskFreeEx;
var
DiskSpLib: THandle;
begin
if not DiskSapceEx_Loaded then
begin
DiskSapceEx_Loaded := True;
DiskSpLib := GetModuleHandle('kernel32.dll');
if DiskSpLib <> 0 then
GetDiskFreeSpaceEx := GetProcAddress(DiskSpLib, 'GetDiskFreeSpaceExA')
else
GetDiskFreeSpaceEx := nil;
end;
end;
procedureCheckDrive(DriveChar: string);
var
lngSectors,lngBytes,lngFreeClusters,lngTotalClusters: integer;
lngUser: comp;
begin
DiskSapceEx_Loaded := False;
LoadDiskFreeEx; // kernel32.dll内にGetDiskFreeSpaceExAがあるかチェック
if @GetDiskFreeSpaceEx <> nil then
// FAT32システム
begin
// 容量チェック。失敗したら0を代入
if not GetDiskFreeSpaceEx(PChar(DriveChar), @lngUser,
@lngTotalBytes, @lngFreeSpace) then
begin
lngFreeSpace := 0;
lngTotalBytes := 0;
end;
end else
// FAT16システム
begin
// 従来のGetDiskFreeSpace APIを使って調べる
if Windows.GetDiskFreeSpace(PChar(DriveChar),lngSectors,
lngBytes, lngFreeClusters, lngTotalClusters) then
begin
lngFreeSpace := lngFreeClusters * lngSectors * lngBytes;
lngTotalBytes := lngTotalClusters * lngSectors * lngBytes;
end else
// 失敗したら0を代入
begin
lngFreeSpace := 0;
lngTotalBytes := 0;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
CheckDrive('C:\');
Label1.Caption := Format('空き容量＝ %12.0n バイト',[lngFreeSpace]);
Label2.Caption := Format('容量＝ %12.0n バイト',[lngTotalBytes]);
end;[A]GetFileVersionInfoというAPIがあります。
これは、実行形式のファイルからバージョンを読み取ります。
なお、Delphi4になってから、API関数の呼び出しでintger(符号付き32bit)を使用している個所は、
コンパイルエラーを起こします。Delphi4ではLongword(符号無し32bit)が新たに加わっています。
下の例ではコーディングでは条件コンパイルで対処しています。
なお、DWORDでの定義ならばDelphi3でもDelphi4でも大丈夫です。
procedure TForm1.FormCreate(Sender: TObject);
var
iBufSize: integer;
pBuf: Pointer;
pData: Pointer;
{$IFDEF VER120} // Delphi 4
iDummy: LongWord;
iDataLen: Longword;
{$ENDIF}
{$IFDEF VER100} // Delphi 3
iDummy: integer;
iDataLen: integer;
{$ENDIF}
sLocale: String;
sData: String;
p: integer;
begin
iDummy := 0;
iBufSize := GetFileVersionInfoSize(PChar(Application.ExeName), iDummy);
if iBufSize <> 0 then
begin
GetMem(pBuf, iBufSize);
try
GetFileVersionInfo(PChar(Application.ExeName), 0, iBufSize, pBuf);
VerQueryValue(pBuf, PChar('\VarFileInfo\Translation'), pData, iDataLen);
if iDataLen > 0 then sLocale := IntToHex(Integer(pData^), 8) else Exit;
sLocale := Copy(sLocale, 5, 4) + Copy(sLocale, 1, 4);
VerQueryValue(pBuf, PChar('\StringFileInfo\' + sLocale +
'\FileVersion'), pData, iDataLen);
if iDataLen > 0 then
begin
sData := '';
SetLength(sData, iDataLen);
StrLCopy(PChar(sData), pData, iDataLen);
// マイナーバージョンまでをキャプションに表示
p := Pos('.',sData);
Caption := Caption + ' Ver.' + Copy(sData,1,p);
Delete(sData,1,p);
p := Pos('.',sData);
Caption := Caption + Copy(sData,1,p-1);
end;
finally
FreeMem(pBuf);
end;
end;
end;[A]Webサーバーアプリケーションなどでは
Application変数が使えませんので、
Application.ProcessMessagesのようなメッセージキューを処理することが
そのままでは行なえません。
例えば、CGIアプリケーションの中でClientSocketコンポーネントを用いてネットワークアクセスするような
アプリケーションの場合、
ClientSocketをOpenしたあと自前のループで
OnConnectかOnErrorを
待たなければなりませんが、ループの中で随時メッセージキューの処理を行なわなければなりません。
Application変数は
Formsユニットで定義されています。
CGIアプリケーションでは設計時にフォームをおけません。
しかし、よくソースを読むとそのまま呼び出しても問題ないようですので、
uses XXXXX, forms; // Formsユニットを追加する。とすれば、
： Forms.Application.ProcessMessages; ：と使えます。
{ Webアプリで、ClientSocketコンポネントを追加しておく。}
procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
const
Timeout = 10;
var
tc0,tc1: TDateTime;
hh,mm,msec: word;
Msg: TMsg;
begin
// queryの解析その他
:
// Connectingは接続中を示すフラグ。(ユーザー指定の変数)
Connecting := True;
ClientSocket1.Open;
// 待機ループ
tc0 := Time;
repeat
// 自前メッセージ処理
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
begin
if Msg.Message <> WM_QUIT then // 処理不要なメッセージを加える
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
// もしTimeoutならば終了
tc1 := Time;
DecodeTime(tc1-tc0,hh,mm,ss,msec);
if ss > TimeOut then
begin
ClientSocket1.Close;
Connecting := False;
end;
until Connecting = False;
// 接続成功・失敗の結果で処理を切り替える。(ユーザー指定の変数)
if Success then
:
(以下省略)
end;
// 接続成功
procedure TWebModule1.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Success := True;
ClientSocket1.Close;
Connecting := False;
end;
// 接続失敗
procedure TWebModule1.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
ErrorCode := 0; // エラー発生抑止
Success := False;
ClientSocket1.Close;
Connecting := False;
end;
[A]MicrosoftのWebサーバーIISではAliasディレクトリが使えます。
Network関連APIで変換を行なうTranslateURI関数も用意されてます。
TISAPIRequest.TranslateURIというのがDelphiに取り込まれたものです。
ISAPI/NSAPI
DLLでのみこれは使えます。
ISAPIアプリケーションでは、TISAPIApplicationクラスのApplicationというインスタンスが自動生成され、
この中で
TISAPIRequestオブジェクトも生成されるので、
他のCGIと変わることなく、下記のような感じで使えます。
procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
RealDir: string;
begin
RealDir := Request.TranslateURI('/user/sakai/index.htm');
:のように。// URLからNTFSパス名に変換する。エイリアスに対応
function TWebModule1.ChangeURL(si: string): string;
const
AliasPath = '\SYSTEM\CurrentControlSet\Services\W3SVC\Parameters\Virtual Roots';
var
i: integer;
j,slaCntr: integer;
SlaPos: array[0..127] of integer;
Reg: TRegistry;
Found: Boolean;
ts: string;
RootDir: string;
AliasDir: string;
KeyString: string;
begin
Result := '';
// レジストリ
Reg := Tregistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
// ルートディレクトリの取得
Found := Reg.OpenKey(AliasPath, False);
if not Found then
begin
Result := 'Registry Key "\Virtual Roots" not found.';
Reg.Free;
Exit;
end;
RootDir := Reg.ReadString('/,'); // Ex. "c:\InetPub\wwwroot,,1"
RootDir := Copy(RootDir,1,Length(RootDir)-3); // Ex. "c:\InetPub\wwwroot"
ts := si;
// チルダのURLエンコード対応
repeat
i := Pos('%7E',ts);
if i > 0 then ts := Copy(ts,1,i-1) + '~' + Copy(ts,i+3,Length(ts)-i-2);
until i=0;
// Refererが "http://xxxx" 付きのものに対応
i := Pos('//',ts);
if i > 0 then
begin
Delete(ts,1,i+1); // Ex. www.xxxxx.co.jp/sakai/hoge/index.html
i := Pos('/',ts);
Delete(ts,1,i-1); // Ex. /sakai/hoge/index.html
end;
// Alias解析
AliasDir := '';
// "/"の数と位置を数え配列にストア
SlaCntr := 0;
for j := 1 to Length(ts) do
begin
if ts[j] = '/' then
begin
SlaPos[SlaCntr] := j;
Inc(SlaCntr);
end;
end;
// もしも "/"があるならばディレクトリの深い方から一致するか試みる
if SlaCntr > 0 then
begin
j := SlaCntr-1;
repeat
KeyString := Copy(ts,1,SlaPos[j]-1);
try
AliasDir := Reg.ReadString(KeyString + ',');
except
on EAccessViolation do AliasDir := '';
end;
if AliasDir <> '' then Break;
Dec(j);
until j < 0;
// 結局キーが無かったらルートディレクトリである
if AliasDir <> ''
then
ts := Copy(AliasDir,1,Length(AliasDir)-3) +
Copy(ts, SlaPos[j], Length(ts)-Slapos[j]+1)
else
ts := RootDir + '\' + KeyString + '\' + ts;
end;
finally
Reg.Free;
end;
// Slash -> \
for i := 1 to Length(ts) do
if ts[i] = '/' then ts[i] := '\';
Result := ts;
// #がある場合、これを削る
i := Pos('#',Result);
if i > 0 then Result := Copy(Result, 1,i-1);
// デフォルトファイル名使用の場合(index.htmlに)
if Result[Length(Result)] = '/' then Result := Result + 'index.html';
end;