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;