Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2007年03月25日] [更新 2015年02月28日] Delphi サンプルプログラム集
   
770_インターネット関係の関数 ( WinInet.dll の利用 )
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro + WinInet.dll Ver.11.00.9600.17631
770_WinInetTest.zip [7,435 KB] 2017年04月15日版(EXE同梱)



  • 2007年10月29日
  • コードをコピペして使用した場合に発生する [リストのインデックスが範囲を超えています] に対する修正
  • 2008年11月11日
  • URL 等の入力欄を設けてテストしやすくした
  • ファイル情報の取得の一部で,ローカルの日付を取得するようにした
  • FTP サーバのファイルリストにアイコンを表示するようにした
  • コールバックではなく,派生ストリームでダウンロードの状況を表示するサンプルを追加
  • Windows Vista + Delphi 2007-R2 で動作確認
  • 2008年11月19日
  • おんぷ村のリンクが切れていたので削除
  • 2015年02月19日
  • 一部のサンプルに,サーバ側のファイルの存在の確認やリダイレクト関係の処理を追加
  • Windows 7 U64(SP1) + Delphi XE(UP1) Pro で動作確認
  • ページ内の目次に番号を付け,サンプルのフォルダも同じ番号にした
  • 2015年02月21日
  • 非同期と WinHTTP 関係の記事を追加
  • 記事の間違いの一部を修正
  • 2015年02月28日
  • HttpQueryInfo でステータスの値を整数値で取得する参考コード追加
  • HttpQueryInfo で文字化けする場合の対処方法の記事を追加
  • ダウンロードの際の保存ファイル名の自動生成コードを変更修正
  • 記事の修正等




インターネットサービス関係の関数


以下は,WinInet.pas で定義されている関数の一部の引数と使用法の説明です.WinInet.pas というのは,Internet Explorer で使われている WinInet.dll を Delphi で使用するためのものです.

この WinInet の関数類ばどのようなものか知るための資料として掲載しました.サンプルプログラム類で利用している関数が全てあるわけではありません.詳しくは WinInet.pas を参考にして下さい.HTTP 関係の関数は先頭に HTTP が,FTP 関係の関数は先頭に FTP が付いています.
WinINet 関係のエラー情報の取得には,GetLastError 関数の他に,InternetGetLastResponseInfo 関数が使用できます.参考リンクの [Error Messages (Windows) - WinINet] に,WinInet 関係のエラーコードの一覧があります.

この他,ネットワークサービス (特に TCP/IP) にアクセスする技術仕様である,WinSock を使用した具体的なサンプルが,例えば,[Delphi で WinSock] のページにあります.
Torry's Delphi にも HTTP 関係のコンポーネント類があります.



以下は,ファイルのダウンロードや Indy 関係のコンポーネントを使用した HTTP, FTP 関係のサンプルの記事です.






01_インターネットサービスのハンドルを取得 ( WinInet 使用開始 )


function InternetOpen(lpszAgent,
                      dwAccessType, 
                      lpszProxy, 
                      lpszProxyBypass,
                      dwFlags):

インターネットのサービスを使用するには,このInternetOpen でインターネットサービスをオープンして,InternetCloseHandle でインターネットサービスのクローズを実行します.

組織内の LAN からインターネットに接続するには,プロキシの設定を行った上で,プロキシサーバーを使用します.例えば次のようになります.


InternetOpen('XRAY_Test', INTERNET_OPEN_TYPE_PROXY, 'proxy:8080', nil, 0);
InternetOpen('XRAY_Test', INTERNET_OPEN_TYPE_PROXY, '123.45.6.7:8080', nil, 0);

イントラネットのページでプロキシを使用しないようにするには,4 番目の引数に <local> を指定して,ローカルなアドレスにはプロキシを使用しないようにします.

InternetOpen('XRAY_Test', INTERNET_OPEN_TYPE_PROXY, 'proxy:8080', '<local>', 0);



lpszAgent PChar HTTP でインターネットにアクセスする時のユーザーエージェント名 (環境変数の HTTP_USER_AGENT) か任意の文字列.
省略時は nil
dwAccessType DWORD 接続方法.基本的には既定の設定を使用
下記以外は MSDN の記事を参照
  • 全てのホスト名をローカルで解決
    INTERNET_OPEN_TYPE_DIRECT
  • 既定の設定 (レジストリ内の IE の設定)を使用
    INTERNET_OPEN_TYPE_PRECONFIG
  • プロクシサーバー経由で接続
    INTERNET_OPEN_TYPE_PROXY
lpszProxy PChar プロクシサーバ経由で接続するときにプロクシサーバ名を指定.nilにするとレジストリの情報を使用する.
dwAccessTypeにINTERNET_OPEN_TYPE_PRECONFIG を指定した時はnil にする
lpszProxyBypass PChar プロキシサーバ経由で接続するときの指定.ローカルでの既知のホスト名またはIPアドレスのリスト
dwAccessType が INTERNET_OPEN_TYPE_PRECONFIG の時は nil
dwFlags DWORD オプションのフラグで,以下の組み合わせ
  • 非同期アクセス
    INTERNET_FLAG_ASYNC
  • キャッシュから取得
    INTERNET_FLAG_FROM_CACHE
戻値 HINTERNET インターネットサービスハンドルのポインタ
このハンドルを WinInet の各関数で使用する


タイムアウトの時間は,次のように InternetSetOption 関数で設定できます.
InternetSetOption 関数には,この他にも設定可能なオプションがあります.下記の MSN の記事で確認してください.


var
  LhSession : HINTERNET;
  LTimeOut  : integer;
begin
  LhSession := InternetOpen( nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0 );

  if Assigned(LhSession) then begin
    //60秒をmsに変換
    LTimeOut := 60 * 1000;
    InternetSetOption(LhSession,
                      INTERNET_OPTION_RECEIVE_TIMEOUT,
                      @LTimeOut,
                      SizeOf(LTimeOut));




02_インターネットサービスを閉じる ( WinInet 使用終了 )


function InternetCloseHandle(hInternet):

インターネットサービスのハンドルを閉じて切断します.この処理を行わないと,次回正常接続ができなくなる場合があります.他のハンドルを必要とする関数を実行した場合も後処理として,そのバンドル値を引数としてこの関数を実行します.


hInternet Pointer InternetOpen 等の関数を実行した時の戻値




03_HTTP, HTTPS または FTP サーバへ接続


function InternetConnect(hInet,
                         lpszServerName,
                         nServerPort,
                         lpszUsername,
                         lpszPassword,
                         dwService,
                         dwService,
                         dwFlags,
                         dwContext):

InternetOpen でインターネットサービスをオープンしてそのハンドル値を取得した後,この関数を使用して接続します.
接続を切断するには,この関数の戻値を引数にして,InternetCloseHandle を実行します.

HTTPS サーバに (SSL) 接続するには,第 3 引数に INTERNET_DEFAULT_HTTPS_PORT を指定します.



hInet HINTERNET InternetOpen 関数で取得したハンドル
lpszServerName PChar 接続先のホスト名またはドット表記のIPアドレス
nServerPort INTERNET_PORT

接続するサーバの TCP/IP ポート
下記以外は MSDN の記事を参照

HTTP 接続時は INTERNET_DEFAULT_HTTP_PORT
HTTPS 接続時は INTERNET_DEFAULT_HTTPS_PORT
FTP 接続時は INTERNET_DEFAULT_FTP_PORT

lpszUserName PChar FTP サービスを使用するときはログインユーザ ID
lpszPassword PChar FTP サービスを使用するときはログインパスワード
dwService DWORD HTTP を使う時は INTERNET_SERVICE_HTTP
FTP サービスを使う時は INTERNET_SERVICE_FTP
dwFlags DWORD FTP サービスでPASSIVEモードを使用するときはINTERNET_FLAG_PASSIVE
使用しないときは 0
HTTP サービスを使用するときは 0
dwContext DWORD コールバック関数に渡されるアプリケーション定義の 32 ビット値.通常は 0 でよい
戻値 HINTERNET サーバを使用するためのコネクションハンドル




04_URL のオープン


function InternetOpenUrl(hInet,
                         lpszUrl,
                         lpszHeaders,
                         dwHeaderLenght,
                         dwFlag,
                         dwCntext):

指定されたURLをオープンし,接続を確立し,データ読み込みの準備を行ってハンドルを返します.


hInet HINTERNET InternetOpen 関数で取得したハンドル
lpszUrl PChar オープンする URL の文字列
lpszHeaders DWORD HTTP サーバに送るヘッダ.0 でよい
dwHeaderLenght DWORD Headers の文字数
dwFlag DWORD オープンの種別を指定するビットマスク値
下記以外は MSDN の記事を参照
  • ローカルのキャッシュを無視して常にサーバから取得
    INTERNET_FLAG_NO_AUTO_REDIRECT
  • ローカルのキャッシュを無視して常にサーバから取得
    INTERNET_FLAG_RELOAD
  • ローカルおよびケートウェイにキャッシュしない
    INTERNET_FLAG_DONT_CACHE
  • 生のデータを返す
    このフラグがない場合はディレクトリ一覧を HTML で返す
    INTERNET_FLAG_RAW_DATA
  • SSL や PCT を使用する (HTTP の場合のみ)
    INTERNET_FLAG_SECURE
  • 可能な限りサーバとの接続を再利用する
    INTERNET_FLAG_EXISTING_CONNECT
dwCntext DWORD コールバック関数に渡されるアプリケーション定義の 32 ビット値.通常は 0 でよい
戻値 HINTERNET URL のハンドル.失敗した時は nil
URL に間違いがあっても nil とはならないようである




05_HTTP サーバへのリクエスト初期化


function HttpOpenRequest(hConnect,
                         lpszVerb,
                         lpszObjectName,
                         lpszVersio,
                         lpszReferrer,
                         lplpszAcceptType,
                         dwFlags,
                         dwContext):

HTTP サーバから情報を取得したり,送信する際の各種設定を行うために使用します.
  • (1) InternetOpen でインターネットサービスのハンドを取得
  • (2) InternetConnect で HTTP サーバを指定してインターネットに接続
  • (3) HttpOpenRequest でリクエストの初期化
  • (4) HttpSendRequest でリクエストの送信
という手順で行うことになります.
本ページには,この関数を使用したサンプルはありません.全て HttpQueryInfo 関数を使用することで済ませています.


hConnect HINTERNET InternetConnect を実行した時の戻り値
(コネクションハンドル)
lpszVerb PChar GET 形式なら文字列 GET
POST 形式なら文字列 POST
lpszObjectName PChar ドメイン名を除いた HTTP サーバ上のパス
lpszVersio PChar HTTP のバージョン.通常 HTTP/1.1
lpszReferrer PChar nil でよい
lplpszAcceptType PLPSTR nil でよい
dwFlags DWORD ダウンロード方法.通常は INTERNET_FLAG_RELOAD でよい
下記以外は MSDN の記事を参照
  • キャッシュを無視してサーバから強制的にダウンロード
    INTERNET_FLAG_RELOAD
  • ダウンロードファイルをキャッシュに加えない
    INTERNET_FLAG_DONT_CACHE
  • サーバから再読み込み
    INTERNET_FLAG_RESYNCHRONIZE
  • キャッシュできないときに一時ファイルを生成
    INTERNET_FLAG_NEED_FILE
dwContext DWORD コールバック関数に渡されるアプリケーション定義の 32 ビット値.通常は 0 でよい
戻値 HINTERNET リクエストを使用するためのリクエストハンドル




06_HTTP サーバへのリクエスト送信


function HttpSendRequest(hRequest,
                         lpszHeaders,
                         dwHeadersLength,
                         lpOptional,
                         dwOptionalLenght):

HTTP サーバから情報を取得したり,送信するには,
  • (1) InternetOpen でインターネットサービスのハンドを取得
  • (2) InternetConnect で HTTP サーバを指定してインターネットに接続
  • (3) HttpOpenRequest でリクエストの初期化
  • (4) HttpSendRequest でリクエストの送信して取得
という手順で行うことになります.
本ページには,この関数を使用したサンプルはありません.全て HttpQueryInfo 関数を使用することで済ませています.


hRequest HINTERNET HttpOpenRequest で取得したリクエストハンドル
lpszHeaders PChar リクエストに追加する HTTP ヘッダ
必要ない場合は nil
dwHeadersLength DWORD lpszHeaders で指定した追加ヘッダーの文字列長
lpszHeaders が 0 の時は 0
lpOptional Pointer POST 形式の時は送信するデータ
GET 形式のときは nil
dwOptionalLenght DWORD lpOptional に指定したデータの長さで,
データ参照元の URL (HTTP_REFERER) を指定
lpOptional が nil の場合は 0
戻値 BOOL リクエストの送信に成功したら True
失敗したら False




07_HTTP サーバから情報を取得


function HttpQueryInfo(hRequest,
                       dwInfoLevel,
                       lpvBuffer,
                       lpdwBufferLength,
                       lpdwReserved):

HttpOpenRequest は,HTTP サーバの各種情報を取得します.取得する情報の種類は,2 番目の引数で指定します.
取得可能な情報に関係するフラグの値については,MSDN の記事で確認できます.


hRequest HINTERNET InternetOpenUrl または HttpOpenRequest で取得した HTTP リクエストハンドル
dwInfoLevel DWORD 取得したい情報の種類
InternetOpenUrl ではそのURLの種類,HttpOpenRequest によって取得可能な種類があるので注意
下記以外は MSDN の記事を参照
  • コンテンツの種類
    HTTP_QUERY_CONTENT_TYPE
  • データ長
    HTTP_QUERY_CONTENT_LENGTH
  • サーバ日付
    HTTP_QUERY_DATE
  • 更新日時
    HTTP_QUERY_LAST_MODIFIED
  • HTTPリ クエストの結果コード
    HTTP_QUERY_STATUS_CODE
  • ヘッダー情報
    HTTP_QUERY_RAW_HEADERS_CRLF
  • サーバ情報
    HTTP_QUERY_SERVER
  • 要求したメソッドの種類
    HTTP_QUERY_REQUEST_METHOD
以上の他,以下を論理和で指定できる
  • 最終更新時刻などを SYSTEMTIME で返す
    HTTP_QUERY_FLAG_SYSTEMTIME
  • 状態コードを 32 ビットで返す
    HTTP_QUERY_FLAG_NUMBER
lpvBuffer Pointer 結果を受け取るための領域
var lpdwBufferLength DWORD 受取り領域の長さを指定
実行後は受取った長さが戻ってくる
var lpdwReserved DWORD 同一ヘッダが存在する時のヘッダの識別番号
戻値 BOOL リクエストを受付けた場合は True
受付けなかった場合はは False


HTTP サーバ上のファイルの最終更新日時を取得する例です.
WinInet では,InternetOpenUrl 関数で INTERNET_FLAG_NO_AUTO_REDIRECT を指定しない場合,自動的にリダイレクトします.そのリダイレクトしたファイルの情報を表示します.



図1
設計時画面

図2
実行結果
  • HTTP サーバ上の指定ファイルの最終更新日時とサイズを取得して表示

リスト1
HTTP サーバ上のファイル情報を取得
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    function  GMTToDateTime(ASysTime: TSystemTime): TDateTime;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinInet;

{$R *.dfm}

//=============================================================================
//  テスト用のURLをセット
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/index.htm';
end;

//=============================================================================
//  指定URLのヘッダ情報を取得
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LURL         : String;
  LhSession    : HINTERNET;
  LhService    : HINTERNET;
  LlpvBuffer   : array[0..MAX_PATH-1] of Char;
  LdwSize      : DWORD;
  LReserved    : DWORD;
  LBufferValue : Integer;
begin
  LURL := Trim(Edit1.Text);

  Memo1.Lines.Clear;
  LhSession := InternetOpen( nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0 );

  if Assigned(LhSession) then begin
    LhService := InternetOpenUrl(LhSession,
                                PChar(LURL),
                                nil,
                                0,
                                0,
                                0);
    if Assigned(LhService) then begin
      FillChar(LlpvBuffer, SizeOf(LlpvBuffer), #0);
      LdwSize    := SizeOf(LlpvBuffer);
      LReserved  := 0;
      HttpQueryInfo(LhService,
                    HTTP_QUERY_STATUS_CODE,
                    @LlpvBuffer,
                    LdwSize,
                    LReserved);
      LBufferValue := StrToIntDef(LlpvBuffer, 0);

      if (LBufferValue < 200) or (LBufferValue >= 300) then begin
        Memo1.Lines.Add('StatusCode : ' + LlpvBuffer);
        Memo1.Lines.Add('該当するファイルがサーバにありません');
      end else begin
        FillChar(LlpvBuffer, MAX_PATH, #0);
        LdwSize   := SizeOf(LlpvBuffer);
        LReserved := 0;
        HttpQueryInfo(LhService,
                      HTTP_QUERY_RAW_HEADERS_CRLF,
                      @LlpvBuffer,
                      LdwSize,
                      LReserved);
        Memo1.Lines.Add(LlpvBuffer);
      end;
    end;
    InternetCloseHandle(LhService);
  end;
  InternetCloseHandle(LhSession);
end;

//=============================================================================
//  指定URLの更新日時とファイルサイズを取得
//  存在しないURLの場合を考えてHttpQueryInfoの結果(BOOL)で分岐が良
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LURL            : String;
  LhSession       : HINTERNET;
  LhService       : HINTERNET;
  LLastSystemDate : SYSTEMTIME;
  LLastDate       : TDateTime;
  LDateStr        : String;
  LFileSize       : Longint;
  LdwSize         : DWORD;
  LReserved       : DWORD;
  LlpvBuffer      : array[0..MAX_PATH-1] of Char;
  LBufferValue    : Integer;
  LContentType    : String;
begin
  LURL := Trim(Edit1.Text);

  Memo1.Lines.Clear;
  LhSession := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0 );
  if Assigned( LhSession ) then begin
    LhService := InternetOpenUrl(LhSession,
                                 PChar(LURL),
                                 nil,
                                 0,
                                 INTERNET_FLAG_RELOAD or INTERNET_FLAG_RAW_DATA,
                                 0);

    if LhService <> nil then begin
      FillChar(LlpvBuffer, MAX_PATH, #0);
      LdwSize   := SizeOf(LlpvBuffer);
      LReserved := 0;
      HttpQueryInfo(LhService,
                    HTTP_QUERY_STATUS_CODE,
                    @LlpvBuffer,
                    LdwSize,
                    LReserved);
      LBufferValue := StrToIntDef(LlpvBuffer, 0);

      if (LBufferValue < 200) or (LBufferValue >= 300) then begin
        Memo1.Lines.Add('StatusCode : ' + LlpvBuffer);
        Memo1.Lines.Add('該当するファイルがサーバにありません');
      end else begin
        FillChar(LlpvBuffer, MAX_PATH, #0);
        LdwSize   := SizeOf(LlpvBuffer);
        LReserved := 0;
        HttpQueryInfo(LhService,
                      HTTP_QUERY_CONTENT_TYPE,
                      @LlpvBuffer,
                      LdwSize,
                      LReserved);
        LContentType := LlpvBuffer;

        LdwSize   := SizeOf(LLastSystemDate);
        LReserved := 0;
        HttpQueryInfo(LhService,
                      HTTP_QUERY_LAST_MODIFIED or HTTP_QUERY_FLAG_SYSTEMTIME,
                      @LLastSystemDate,
                      LdwSize,
                      LReserved);
        LLastDate :=  GMTToDateTime(LLastSystemDate);

        LdwSize   := SizeOf(LFileSize);
        LReserved := 0;
        HttpQueryInfo(LhService,
                      HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER,
                      @LFileSize,
                      LdwSize,
                      LReserved);

        LDateStr := FormatDateTime('最終更新日時 : yyyy年mm月dd日 hh時nn分', LLastDate);
        Memo1.Lines.Add('CONTENT TYPE : ' + LContentType);
        Memo1.Lines.Add(LDateStr);
        Memo1.Lines.Add('ファイルサイズ : '+ IntToStr(LFileSize) + ' バイト' );
      end;
    end;
    InternetCloseHandle(LhService);
  end;
  InternetCloseHandle(LhSession);
end;

//-----------------------------------------------------------------------------
//  GMT(グリニッジ標準時)をローカルの時刻にしてDelphiのTDateTimeに変換
//-----------------------------------------------------------------------------
function TForm1. GMTToDateTime(ASysTime: TSystemTime): TDateTime;
var
  TempTime  : TFileTime;
  LocalTime : TFileTime;
begin
  try
    //システム形式をFileTime形式に変換
    SystemTimeToFileTime(ASysTime, TempTime);
    //FileTime形式(世界協定時刻)を地域にあわせる
    FileTimeToLocalFileTime(TempTime, LocalTime);
    //FileTime形式をSystemTime形式にする
    FileTimeToSystemTime(LocalTime, ASysTime);
    //SystemTime形式をDelphiのTDateTime形式に変換
    Result := SystemTimeToDateTime(ASysTime);
  except
    Result := 0;
  end;
end;

end.


上のコードでは,ステータスコードを取得する際,バッファとして文字列を使用しています.
以下のように,第 2 引数のフラグに HTTP_QUERY_FLAG_NUMBER を含めると,32 ビットの整数値で取得することができます.


      HttpQueryInfo(LhService,
                    HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER,
                    @LStatus,  //LStatusはInteger型
                    LdwSize,
                    LReserved);

      if (LStatus < 200) or (LStatus >= 300) then begin


ヘッダ部の情報を取得する際,取得結果が文字化けすることがあるようです.
例えば以下のページの場合に文字化けしています.

  //Delphi XE7 のオンラインヘルプのウェブページ
  Edit1.Text := 'http://docwiki.embarcadero.com/RADStudio/XE7/ja/Main_Page';

この場合,TMemoryStream や TStringStream を介して,文字コードをエンコードすると文字化けしないで取得できるようです.Delphi 2009 以降の TMemoryStream や TStringStream には,エンコードの機能が追加されています.


文字化けするウェブページの例

文字コードをエンコードして取得した結果

        LStream := TStringStream.Create;
        try
          LStream.Encoding.UTF8;

          FillChar(LlpvBuffer, MAX_PATH, #0);
          LdwSize   := SizeOf(LlpvBuffer);
          LReserved := 0;
          HttpQueryInfo(LhService,
                        HTTP_QUERY_RAW_HEADERS_CRLF,
                        @LlpvBuffer,
                        LdwSize,
                        LReserved);
          LStream.Write(LlpvBuffer[0], LdwSize);
          LStream.Position := 0;
          Memo1.Lines.LoadFromStream(LStream);
        finally
          FreeAndNil(LStream);
        end;




08_一度に読込み可能なバイト数を取得


function InternetQueryDataAvailable(hFile,
                                    lpdwNumberOfBytesAvilable,
                                    dwFlag,
                                    dwContext):


hFile HINTERNET InternetOpenUrl または FtpOpenFile の戻値
var
lpdwNumberOfBytesAvilable
DWORD 読込み可能なバイト数
dwFlag DWORD 0 でよい
dwContext DWORD コールバック関数に渡されるアプリケーション定義の 32 ビット値.通常は 0 でよい
戻値 BOOL リクエストを受付けた場合は True
受付けなかった場合はは False




09_HTTP サーバからデータを取得 - ダウンロード


function InternetReadFile(hFile,
                          lpBuffer,
                          dwNuberOfByteToRead,
                          lpdwNumberOfBytesRead):

HTTP サーバへリクエストを送信した後,この InternetReadFile 関数でダウンロードします.画像などもダウンロード可能もできます.
読込みがファイルの最後になると,戻値が True となります.


hFile HINTERNET InternetOpenUrl
FtpOpenFile
HttpOpenRequest
のいずれかのハンドル
lpBuffer Pointer 取得データ用バッファ
dwNuberOfByteToRead DWORD lpBuffer のサイズ
var lpdwNumberOfBytesRead DWORD 読込んだデータのバイト数が戻ってくる
ファイルの終端になると 0 が戻ってくる
戻値 BOOL リクエストを受付けた場合は True
受付けなかった場合はは False


HTTP サーバ上のファイルをダウンロードするサンプルです.

このサンプルはウェブページのファイル名から自動的に保存ファイル名を決定するようにしています.しかし,WinINet では特に指定しない限り自動でリダイレクト処理をします.
そこで,本サンプルでは,このリダイレクトの機能を無効にして,リダイレクトかそうでないのかを判定して,保存ファイル名設定の参考にしています.

ディレクトリ名だけで,ファイル名がない URL アドレスの場合,常にファイル名が取得できるとは限りません.サーバ側のディレクトリインデックス (DirectoryIndex) の機能により,デフォルトドキュメントが設定してある場合は取得できません.その場合は,最後のディレクトリ名に .html という拡張子を付けて保存するようにしています.




図3
設計時画面
図4
実行
  • Edit にダウンロードするファイルのフルパスを入力して [Read File] ボタンをクリック
図5
ダウンロード終了

リスト2
HTTP サーバからファイルを取得 (ダウンロード)
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinInet, StrUtils, IOUtils;

{$R *.dfm}

//=============================================================================
//  ダウンロードの対象ファイルのURLをEdit1に設定
//  アドレスがhtml,aspx等を指定した場合は,テキストファイルとなる
//  この場合,画像などは保存されない
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/Delphi/zip/003_StopWatch.zip';
end;

//=============================================================================
//  IntenetReadFileでファイルストリームにダウンロードする
//  リダイレクト機能の制御付き
//
//  LSourceURL : ダウンロードするファイルのURLアドレス
//  LSaveFile  : ダウンロード後のファイル名
//
//  UnixPathToDosPath関数にはusesにHTTPAppが必要
//  MatchTextの使用にはusesにStrUtilsが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LStream      : TFileStream;
  LSourceURL   : String;
  LSaveFile    : String;
  LResultFlag  : Boolean;
  hSession     : HINTERNET;
  LhService    : HINTERNET;
  LFileSize    : Longint;
  LdwBytesRead : DWORD;
  LReserved    : DWORD;
  LlpvBuffer   : array[0..1023] of Char;
  LDownloadURL : String;
  LIsNoFile    : Boolean;
begin
  Screen.Cursor := crHourGlass;

  LSourceURL := Edit1.Text;

  LResultFlag  := False;
  LIsNoFile    := False;
  LDownloadURL := '';

  hSession := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(hSession) then begin
    //INTERNET_FLAG_NO_AUTO_REDIRECTはリダイレクト回避
    //WinInetはリダイレクトを自動でやってくれる
    //勝手にリダイレクトされてしまうと保存先のファイル名の設定ができない
    //そこで,リダイレクトを回避してステータスコードで判定して処理
    LhService := InternetOpenUrl(hSession,
                                 PChar(LSourceURL),
                                 nil,
                                 0,
                                 INTERNET_FLAG_NO_AUTO_REDIRECT or INTERNET_FLAG_RELOAD,
                                 0);
    if Assigned(LhService) then begin
      //HTTP_QUERY_STATUS_CODEでステータスコードを取得
      FillChar(LlpvBuffer, SizeOf(LlpvBuffer), #0);
      LdwBytesRead := SizeOf(LlpvBuffer);
      LReserved    := 0;
      HttpQueryInfo(LhService,
                    HTTP_QUERY_STATUS_CODE,
                    @LlpvBuffer[0],
                    LdwBytesRead,
                    LReserved);

      if MatchText(LlpvBuffer, ['404', '407']) then begin
        LIsNoFile := True;
      end else
      if not MatchText(LlpvBuffer, ['200','203','301','302','303','307']) then begin
        LIsNoFile := True;
      end;

      //サーバにファイルが存在するなら処理続行
      if not LIsNoFile then begin
        //HTTP_QUERY_LOCATIONを指定してリダイレクト先を取得
        //ステータスコードが301等がリダイレクト
        FillChar(LlpvBuffer, SizeOf(LlpvBuffer), #0);
        LdwBytesRead := SizeOf(LlpvBuffer);
        LReserved    := 0;
        HttpQueryInfo(LhService,
                      HTTP_QUERY_LOCATION,
                      @LlpvBuffer[0],
                      LdwBytesRead,
                      LReserved);
        //リダイレクトではない場合              
        if String(LlpvBuffer) = '' then begin
          //リダイレクトではない場合(あるいはリダイレクトに失敗)
          LDownloadURL := LSourceURL;
        end else begin
          //リダイレクトされている場合              
          LDownloadURL := LlpvBuffer;
        end;

        //保存ファイル名はこのプロジェクトのフォルダでサーバ上と同名
        //ファイル名部分が取得できない場合は最後のディレクトリ名とする
        if TPath.GetFileName(LDownloadURL) = '' then begin
          LSaveFile := ExtractFilePath(ParamStr(0)) +
            TPath.GetFileName(TPath.GetDirectoryName(LDownloadURL)) + '.html';
        end else begin
          LSaveFile := ExtractFilePath(ParamStr(0)) +
            TPath.GetFileName(LDownloadURL);
        end;

        //対象のファイルがサーバに存在することが分かったので
        //今度はリダイレクトを有効にしてInternetOpenUrlを実行
        InternetCloseHandle(LhService);
        LhService := InternetOpenUrl(hSession,
                                    PChar(LSourceURL),
                                    nil,
                                    0,
                                    INTERNET_FLAG_RELOAD,
                                    0);

        //ファイルサイズを取得
        LFileSize    := 0;
        LdwBytesRead := SizeOf(LdwBytesRead);
        LReserved    := 0;
        HttpQueryInfo(LhService,
                      HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER,
                      @LFileSize,
                      LdwBytesRead,
                      LReserved);

        try
          //保存するファイルを作成
          //TMemoryStreamに保存,ダウンロード終にディスクに保存する方法も考えられる
          LStream := TFileStream.Create(LSaveFile, fmCreate);
          //Loopにrepeatを用いた例
          try
            LdwBytesRead := SizeOf(LlpvBuffer);
            repeat
              LlpvBuffer := #0;
              if InternetReadFile(LhService,
                                  @LlpvBuffer,
                                  SizeOf(LlpvBuffer),
                                  LdwBytesRead) then begin
                LStream.WriteBuffer(LlpvBuffer, LdwBytesRead);
                LResultFlag := True;
              end else begin
                LResultFlag := False;
                break;
              end;
              Application.ProcessMessages;
              Sleep(1);
            until LdwBytesRead = 0;
          finally
            FreeAndNil(LStream);
          end;
        except
          //保存ファイルが作成できなかった場合
          //リダイレクト先が取得できなかった場合等
          LResultFlag := False;
        end;
      end;
    end;
    InternetCloseHandle(LhService);
  end;
  InternetCloseHandle(hSession);
  Screen.Cursor := crDefault;

  if LResultFlag then begin
    MessageDlg('ダウンロードが終了しました', mtInformation, [mbOK], 0);
  end else begin
    if LIsNoFile then begin
      MessageDlg('該当するファイルがサーバにありません', mtInformation, [mbOK], 0);
    end else begin
      MessageDlg('ダウンロードに失敗しました', mtInformation, [mbOK], 0);
    end;
  end;
end;

end.




10_HTTP サーバからデータを取得 ( 派生ストリームの使用 )


上のサンプルでは,ダウンロードの進行状況の表示はしていません.
下のコードでは,ファイルストリームを作成し,ダウンロード状況をプログレスバーに表示するようにしてみました.コールバック関数を使用して進捗状況を表示する方法もありますが,このような方法も使用できるという例です.

このサンプルはリダイレクト機能を有効にしたままダウンロードします.したがって,入力したアドレスからリダイレクトされているファイルは取得またはダウンロードできない場合があります.保存ファイル名を自動で設定しないで,名前を指定すれば保存可能な場合もあります.



図6
設計時画面
図7
ダウンロード中

リスト3
HTTP サーバからファイルを取得 (ダウンロード)
進捗状況を表示するプログレスバー付き
unit Unit1;

interface

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

type
  TFileStreamEx = class(TFileStream)
  protected
    FOnRead: TNotifyEvent;
    FOnWrite: TNotifyEvent;
  public
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    property OnRead: TNotifyEvent read FOnRead write FOnRead;
    property OnWrite: TNotifyEvent read FOnWrite write FOnWrite;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    ProgressBar1 : TProgressBar;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    FileSize : Longint;
    procedure OnFileStreamWrite(Sender: TObject);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  WinInet, IOUtils;

{$R *.dfm}

{ TFileStreamEx }

//-----------------------------------------------------------------------------
//  拡張TFileStream
//  イベント処理機能を加えたReadメソッド
//-----------------------------------------------------------------------------
function TFileStreamEx.Read(var Buffer; Count: Integer): Longint;
begin
  Result := inherited Read(Buffer, Count);
  if Assigned(FOnRead) then FOnRead(Self);
end;

//-----------------------------------------------------------------------------
//  拡張TFileStream
//  イベント処理機能を加えたWriteメソッド
//-----------------------------------------------------------------------------
function TFileStreamEx.Write(const Buffer; Count: Integer): Longint;
begin
  Result := inherited Write( Buffer, Count);
  if Assigned(FOnWrite) then FOnWrite(Self);
end;

//=============================================================================
//  ダウンロードの対象ファイルのURLをEdit1に設定
//  アドレスがhtml,aspx等を指定した場合は,テキストファイルとなる
//  この場合には画像などは保存されない
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/Delphi/ZipExe/plSetPrinter.zip';
end;

//=============================================================================
//  IntenetReadFileでファイルストリームにダウンロードする
//  TStreamの派生クラスを使用して進行状況をプログレスバーに表示
//
//  本サンプルはリダイレクトされているファイルは取得または保存できない
//  保存ファイル名を指定すれば,リダイレクトしたファイルも保存可能な場合がある
//
//  UnixPathToDosPath関数にはusesにHTTPAppが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LStream      : TFileStreamEx;
  LSourceFile  : String;
  LSaveFile    : String;
  LResultFlag  : Boolean;
  LhSession    : HINTERNET;
  LhService    : HINTERNET;
  LdwBytesRead : DWORD;
  LlpvBuffer   : array[0..1023] of Char;
  LReserved    : DWORD;
  LBufferValue : Integer;
  LIsNoFile    : Boolean;
begin
  Screen.Cursor := crHourGlass;

  LSourceFile := Edit1.Text;
  LResultFlag := False;
  LIsNoFile   := False;

  //保存ファイル名はこのプロジェクトのフォルダでサーバ上と同名
  //ファイル名部分が取得できない場合は最後のディレクトリ名とする
  if TPath.GetFileName(LSourceFile) = '' then begin
    LSaveFile := ExtractFilePath(ParamStr(0)) +
      TPath.GetFileName(TPath.GetDirectoryName(LSourceFile)) + '.html';
  end else begin
    LSaveFile := ExtractFilePath(ParamStr(0)) +
      TPath.GetFileName(LSourceFile);
  end;
  LSaveFile := 'AAAA.txt';

  LhSession := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(LhSession) then begin
    LhService := InternetOpenUrl(LhSession,
                                 PChar(LSourceFile),
                                 nil,
                                 0,
                                 INTERNET_FLAG_RELOAD,
                                 0);
    if Assigned(LhService) then begin
      FillChar(LlpvBuffer, SizeOf(LlpvBuffer), #0);
      LdwBytesRead := SizeOf(LlpvBuffer);
      LReserved    := 0;
      HttpQueryInfo(LhService,
                    HTTP_QUERY_STATUS_CODE,
                    @LlpvBuffer,
                    LdwBytesRead,
                    LReserved);
      LBufferValue := StrToIntDef(LlpvBuffer, 0);

      if (LBufferValue < 200) or (LBufferValue >= 300) then begin
        LIsNoFile := True;
      end else begin
        LdwBytesRead := SizeOf(FileSize);
        LReserved    := 0;
        if HttpQueryInfo(LhService,
                         HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER,
                         @FileSize,
                         LdwBytesRead,
                         LReserved) then begin

          //Loopにrepeatを用いた例
          LStream := TFileStreamEx.Create(LSaveFile, fmCreate);
          //イベントハンドラをセット
          LStream.OnWrite := OnFileStreamWrite;
          try
            LdwBytesRead := SizeOf(LlpvBuffer);
            repeat
              LlpvBuffer := #0;
              if InternetReadFile(LhService,
                                  @LlpvBuffer,
                                  SizeOf(LlpvBuffer),
                                  LdwBytesRead) then begin
                LStream.WriteBuffer(LlpvBuffer, LdwBytesRead);
                LResultFlag := True;
              end else begin
                LResultFlag := False;
                break;
              end;
              Application.ProcessMessages;
              Sleep(1);
            until LdwBytesRead = 0;
          finally
            FreeAndNil(LStream);
          end;
        end;
      end;
      InternetCloseHandle(LhService);
    end;
  end;
  InternetCloseHandle(LhSession);
  Screen.Cursor := crDefault;

  if LResultFlag then begin
    MessageDlg('ダウンロードが終了しました', mtInformation, [mbOK], 0);
  end else begin
    if LIsNoFile then begin
      MessageDlg('該当するファイルがサーバにありません', mtInformation, [mbOK], 0);
    end else begin
      MessageDlg('ダウンロードに失敗しました', mtInformation, [mbOK], 0);
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  拡張したTFileStreamのOnWriteイベント処理
//  プログレスバーの位置を更新
//  ファイルのサイズFileSizeはHttpQueryInfo関数で取得している
//-----------------------------------------------------------------------------
procedure TForm1.OnFileStreamWrite(Sender: TObject);
var
  LStream: TStream;
begin
  LStream := Sender as TStream;
  ProgressBar1.Position := Trunc(LStream.Position / FileSize * 100);
end;

end.




11_FTP サーバからファイルをダウンロード


function FtpGetFile(hConnect,
                    lpszRemoteFile,
                    lpszNewFile,
                    fFailIFExists,
                    dwFlagsAndAttibutes,
                    dwFlags,
                    dwContext):

InternetOpen と InternetConnect で FTP サーバへ接続後,この FtpGetFile 関数を使用してダウンロードします.


hConnect HINTERNET InternetConnect で取得したFTPハンドル
lpszRemoteFile PChar ダウンロードするサーバ上のファイル(フルパス)
lpszNewFile PChar ローカルの保存先 (フルパス望ましい)
fFailIFExists BOOL 上書き指定
False で上書き.True の場合は,同じ名前のファイルが無いときだけダウンロードする.
dwFlagsAndAttibutes DWORD ローカルに保存するファイルの属性.通常はFILE_ATTRIBUTE_NORMAL でよい
下記以外は MSDN の記事を参照
  • 読み込み専用
    FILE_ATTRIBUTE_READONLY
  • 隠しファイル
    FILE_ATTRIBUTE_HIDDEN
  • システムファイル
    FILE_ATTRIBUTE_SYSTEM
  • ディレクトリ(フォルダ)
    FILE_ATTRIBUTE_DIRECTORY
  • アーカイブファイル
    FILE_ATTRIBUTE_ARCHIVE
  • 通常のファイル
    FILE_ATTRIBUTE_NORMAL
dwFlags DWORD 転送モード.下記以外は MSDN の記事を参照
  • アスキーモード
    FTP_TRANSFER_TYPE_ASCII
  • バイナリモード
    FTP_TRANSFER_TYPE_BINARY
dwContext DWORD コールバック関数に渡されるアプリケーション定義の 32 ビット値.通常は 0 でよい
戻値 BOOL リクエストを受付けた場合は True
受付けなかった場合はは False


FTP サーバからファイルをダウンロードする例です.
入力したサーバー名,アカウント,ハスワード等は,FTPInfo.ini というファイルに保存します.
転送モードを FTP_TRANSFER_TYPE_BINARY でバイナリにしていますが,テキストファイル (プレインテキスト) もダウンロードできます.



図8
設計時画面
図9
実行画面
  • ファイルのダウンロードが終了

リスト4
FTP サーバからファイルを GET (ダウンロード)
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    LabeledEdit1 : TLabeledEdit;
    LabeledEdit2 : TLabeledEdit;
    LabeledEdit3 : TLabeledEdit;
    LabeledEdit4 : TLabeledEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName  : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinInet, HTTPApp, IniFiles;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabelEdit4.textはダウンロードするファイル
//  ex. mrxray.on.coocan.jp/homepage/Delphi/zip/003_StopWatch.zip
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  LIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  LIni := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := LIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := LIni.ReadString('FTPInfo', 'UserID', '');
     LabeledEdit3.Text := LIni.ReadString('FTPInfo', 'PassWord', '');
     LabeledEdit4.Text := LIni.ReadString('Others',  'GetFileName', '');
   end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LIni : TInifile;
begin
  LIni := TIniFile.Create(IniFileName);
  try
    try
      LIni.WriteString('FTPInfo', 'ServerName',  LabeledEdit1.Text);
      LIni.WriteString('FTPInfo', 'UserID',      LabeledEdit2.Text);
      LIni.WriteString('FTPInfo', 'PassWord',    LabeledEdit3.Text);
      LIni.WriteString('Others',  'GetFileName', LabeledEdit4.Text);
    except
    end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  FTPでファイルをダウンロードする(バイナリデータ)
//
//  LSourceFile : ダウンロードするサーバ上のファイル名
//                ホスト名+サーバ上のバス等で指定
//  LSaveFile   : ダウンロード後のファイル名(フルパス)
//
//  UnixPathToDosPath関数にはusesにHTTPAppが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LServerName : String;
  LUserID     : String;
  LPassWord   : String;
  LSourceFile : String;
  LSaveFile   : String;
  LResultFlag : Boolean;
  LhSession   : HINTERNET;
  LhConnect   : HINTERNET;
  LhFile      : HINTERNET;
  LFileData   : TWin32FindData;
  LIsNoFile   : Boolean;
begin
  Screen.Cursor := crHourGlass;

  LServerName := LabeledEdit1.Text;
  LUserID     := LabeledEdit2.Text;
  LPassWord   := LabeledEdit3.Text;

  LSourceFile := LabeledEdit4.Text;

  //保存ファイル名はこのプロジェクトのフォルダでサーバ上と同名
  LSaveFile := ExtractFilePath(ParamStr(0))+
               ExtractFileName(UnixPathToDosPath(LSourceFile));

  LResultFlag := False;
  LIsNoFile   := False;

  LhSession := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if Assigned(LhSession) then begin
    //LServerName,LUserID,LPassWordのどれかが不正だと失敗する
    LhConnect := InternetConnect(LhSession,
                                PChar(LServerName),
                                INTERNET_DEFAULT_FTP_PORT,
                                PChar(LUserID),
                                PChar(LPassWord),
                                INTERNET_SERVICE_FTP,
                                0,
                                0);
    //サーバ上のファイルの存在を確認                            
    if Assigned(LhConnect) then begin
      LhFile := FtpFindFirstFile(LhConnect,
                                 PChar(LSourceFile),
                                 LFileData,
                                 INTERNET_FLAG_RELOAD,
                                 0);
      if LhFile = nil then begin
        LIsNoFile := True;
      end else begin
        LResultFlag := FtpGetFile(LhConnect,
                                  PChar(LSourceFile),
                                  PChar(LSaveFile),
                                  False,
                                  FILE_ATTRIBUTE_NORMAL,
                                  FTP_TRANSFER_TYPE_BINARY,
                                  0);
        InternetCloseHandle(LhFile);
      end;
    end;
    InternetCloseHandle(LhConnect);
  end;
  InternetCloseHandle(LhSession);
  Screen.Cursor := crDefault;

  if LResultFlag then begin
    MessageDlg('ダウンロードが終了しました', mtInformation, [mbOK], 0);
  end else begin
    if LIsNoFile then begin
      MessageDlg('該当ファイルが見つかりませんでした', mtInformation, [mbOK], 0);
    end else begin
      MessageDlg('ダウンロードに失敗しました', mtInformation, [mbOK], 0);
    end;
  end;
end;

end.




12_FTP サーバへファイルをアップロード


function FtpPutFile(hConnect,
                    lpszLocalFile,
                    lpszNewRemoteFile,
                    dwFlag,
                    dwContext):

InternetOpen と InternetConnect で FTP サーバへ接続した後,この FtpPutFile 関数を使用して転送します.


[備考]
ファイルをアップロードするには,サーバーの,アップロードしたファイルを保存するディレクトリの属性 (パーミッション・アクセス権) を書き込み可能にしておく必要があります.
属性の設定が必要なのはファイルを保存するディレクトリだけです.そのディレクトリの上位のディレクトリは書き込み可能にする必要はありません.


hConnect HINTERNET InternetConnect で取得した FTP ハンドル
lpszLocalFile PChar アップロードするローカルファイルのフルパス名
lpszNewRemoteFile PChar アップロード先のファイル名 (フルパスが素望ましい)
dwFlag DWORD 転送モードで以下の組合わせ
下記以外は MSDN の記事を参照
  • アスキーモード
    FTP_TRANSFER_TYPE_ASCII
  • バイナリモード
    FTP_TRANSFER_TYPE_BINARY
dwContext DWORD コールバック関数に渡されるアプリケーション定義の 32 ビット値.
戻値 BOOL アップロードが成功すれば True.失敗した場合は False


FTP サーバにファイルを転送 (アップロード) する例です.
入力したサーバー名,アカウント,ハスワード等は,FTPInfo.ini というファイルに保存します.



図10
実行画面

リスト5
FTP サーバへファイルをアップロード (転送)
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    LabeledEdit5: TLabeledEdit;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName  : String;
    function IsBinaryFile(AFilename: string): Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  WinInet,
  IniFiles,
  UrlMon,
  StrUtils;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabelEdit5.textはPUT(アップロード)先のサーバ上のディレクトリ名
//  ex. LabeledEdit5.Text := 'mrxray.on.coocan.jp/homepage/Delphi/';
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  LIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  LIni := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := LIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := LIni.ReadString('FTPInfo', 'UserID', '');
     LabeledEdit3.Text := LIni.ReadString('FTPInfo', 'PassWord', '');
     LabeledEdit4.Text := LIni.ReadString('Others',  'SourceFile', '');
     LabeledEdit5.Text := LIni.ReadString('Others',  'PutDir', '');
   end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LIni : TInifile;
begin
  LIni := TIniFile.Create(IniFileName);
  try
    try
      LIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      LIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      LIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      LIni.WriteString('Others',  'SourceFile', LabeledEdit4.Text);
      LIni.WriteString('Others',  'PutDir',     LabeledEdit5.Text);
    except
    end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  PUT(転送)するファイルを選択
//  テストなので1つだけとする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Options    := OpenDialog1.Options - [ofAllowMultiSelect];
  OpenDialog1.OptionsEx  := [ofExNoPlacesBar];
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  if OpenDialog1.Execute then begin
    LabeledEdit4.Text := OpenDialog1.FileName;
  end;
end;

//=============================================================================
//  FTPでファイルをアップロードする(ファイルの種別は自動判定)
//
//  LSourceFile  : アップロードするローカル上のファイル名(フルパス)
//  LUpLoadFile  : アップロード後のサーバ上のファイル名(フルパス)
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LServerName    : String;
  LUserID        : String;
  LPassWord      : String;
  LSourceFile    : String;
  LUpLoadFile    : String;
  LResultFlag    : Boolean;
  LhSession      : HINTERNET;
  LhConnect      : HINTERNET;
  LdwFlag        : DWORD;
  LhFile         : HINTERNET;
  LFileData      : TWin32FindData;
  LIsNoDir       : Boolean;
  LPutDir        : String;
begin
  Screen.Cursor := crHourGlass;

  //デリミタがなければ追加
  //最後にデリミタがないと[LPutDir + PUT元ファイル]のファイルになってしまう1
  if LastDelimiter('/', LPutDir) < Length(LabeledEdit5.Text) then begin
    LabeledEdit5.Text := LabeledEdit5.Text + '/';
  end;
  LPutDir := LabeledEdit5.Text;

  LServerName := LabeledEdit1.Text;
  LUserID     := LabeledEdit2.Text;
  LPassWord   := LabeledEdit3.Text;
  LSourceFile := LabeledEdit4.Text;
  LUpLoadFile := LPutDir + ExtractFileName(LSourceFile);

  LResultFlag := False;
  LIsNoDir    := False;


  LhSession := InternetOpen(nil, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
  if Assigned(LhSession) then begin
    //LServerName,LUserID,LPassWordのどれかが不正だと失敗する
    LhConnect := InternetConnect(LhSession,
                                 PChar(LServerName),
                                 INTERNET_DEFAULT_FTP_PORT,
                                 PChar(LUserID),
                                 PChar(LPassWord),
                                 INTERNET_SERVICE_FTP,
                                 0,
                                 0);

    if Assigned(LhConnect) then begin
      //サーバ上のディレクトリの存在を確認
      LhFile := FtpFindFirstFile(LhConnect,
                                 PChar(LPutDir),
                                 LFileData,
                                 INTERNET_FLAG_RELOAD,
                                 0);
      if LhFile = nil then begin
        LIsNoDir := True;
      end else begin
        if IsBinaryFile(LSourceFile) then begin
          LdwFlag := FTP_TRANSFER_TYPE_BINARY;
        end else begin
          LdwFlag := FTP_TRANSFER_TYPE_ASCII;
        end;
          LResultFlag := FtpPutFile(LhConnect,
                                    PChar(LSourceFile),
                                    PChar(LUpLoadFile),
                                    LdwFlag,
                                    0);
        InternetCloseHandle(LhFile);
      end;
    end;
    InternetCloseHandle(LhConnect);
  end;
  InternetCloseHandle(LhSession);
  Screen.Cursor := crDefault;

  if LResultFlag then begin
    MessageDlg('アップロードが終了しました', mtInformation, [mbOK], 0);
  end else begin
    if LIsNoDir then begin
      MessageDlg('ディレクトリが存在しません', mtInformation, [mbOK], 0);
    end else begin
      MessageDlg('アップロードに失敗しました', mtInformation, [mbOK], 0);
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  バイナリかテキストファイルかを自動判定(自動判別)する関数
//  ファイルのMIMEタイプで調べる
//  プレインテキストファイル以外は全てバイナリファイルとする
//
//  usesにUrlMon,が必要
//-----------------------------------------------------------------------------
function TForm1.IsBinaryFile(AFilename: string): Boolean;
const
  MAX_COUNT = 256;
var
  LStream    : TFileStream;
  LMimeType  : PWideChar;
  LBinReader : TBinaryReader;
  LBinArray  : TArray<Byte>;
  LReadSize  : Cardinal;
  LRet       : HRESULT;
begin
  Result := False;

  //ファイルストリームを生成
  LStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
  if LStream.Size > MAX_COUNT then begin
    LReadSize := MAX_COUNT;
  end else begin
    LReadSize := LStream.Size;
  end;

  //TBinaryReaderのインスタンス生成
  LBinReader := TBinaryReader.Create(LStream, TEncoding.Default, False);
  try
    //バイト型配列に格納
    LBinArray := LBinReader.ReadBytes(LReadSize);

    LMimeType := nil;
    LRet := FindMimeFromData(nil, nil, LBinArray, LReadSize, nil, 0, LMimeType, 0);
    if LRet = S_OK then begin
      if not StrUtils.ContainsText(LMimeType, 'text/') then begin
        Result := True;
      end;
    end;
  finally
    FreeAndNil(LBinReader);
    FreeAndNil(LStream);
  end;
end;

end.




13_FTP サーバのファイルを削除


function FtpDeleteFile(hConnect,
                       lpszFileName):

InternetOpen と InternetConnect で FTP サーバへ接続した後,この FtpDeleteFile 関数を使用して指定したファイルを削除します.


hConnect HINTERNEET InternetConnect で取得した FTP ハンドル
lpszFileName PChar 削除するファイルのファイル名(フルパスが望ましい)
戻値 HINTERNET 削除に成功すれば True.失敗したら False


FTP サーバ上のファイルを削除する例です.
入力したサーバー名,アカウント,ハスワードは,FTPInfo.ini というファイルに保存します.


図11
設計時画面

リスト6
FTP サーバのファイルを削除
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName  : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinInet, IniFiles;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabeledEdit4.TextはDELETE(削除)するサーバ上のファイル名
//  ex. 'mrxray.on.coocan.jp/homepage/Delphi/WinInetTest.txt';
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  LIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  LIni := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := LIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := LIni.ReadString('FTPInfo', 'UserID',' ');
     LabeledEdit3.Text := LIni.ReadString('FTPInfo', 'PassWord', '');
     LabeledEdit4.Text := LIni.ReadString('Others',  'DeleteFile', '');
   end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LIni : TInifile;
begin
  LIni := TIniFile.Create(IniFileName);
  try
    try
      LIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      LIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      LIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      LIni.WriteString('Others',  'DeleteFile', LabeledEdit4.Text);
    except
    end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  FTPサーバ上のファイルを削除する
//  LDeleteFile : 削除するサーバ上のファイル(フルパス)
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LhSession   : HINTERNET;
  LhConnect   : HINTERNET;
  LServerName : String;
  LUserID     : String;
  LPassWord   : String;
  LDeleteFile : String;
  LResultFlag : Boolean;
  LhFile      : HINTERNET;
  LFileData   : TWin32FindData;
  LIsNoFile   : Boolean;
begin
  Screen.Cursor := crHourGlass;

  LServerName := LabeledEdit1.Text;
  LUserID     := LabeledEdit2.Text;
  LPassWord   := LabeledEdit3.Text;
  LDeleteFile := LabeledEdit4.Text;

  LResultFlag := False;
  LIsNoFile   := False;

  LhSession := InternetOpen(nil, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);

  if Assigned(LhSession) then begin
    //LServerName,LUserID,LPassWordのどれかが不正だと失敗する
    LhConnect:=InternetConnect(LhSession,
                               PChar(LServerName),
                               INTERNET_DEFAULT_FTP_PORT,
                               PChar(LUserID),
                               PChar(LPassWord),
                               INTERNET_SERVICE_FTP,
                               0,
                               0);
    if Assigned(LhConnect) then begin
      //サーバ上のファイルの存在を確認
      if Assigned(LhConnect) then begin
        LhFile := FtpFindFirstFile(LhConnect,
                                   PChar(LDeleteFile),
                                   LFileData,
                                   INTERNET_FLAG_RELOAD,
                                   0);
        if LhFile = nil then begin
          LIsNoFile := True;
        end else begin
          LResultFlag := FtpDeleteFile(LhConnect, PChar(LDeleteFile));
        end;
      end;
    end;
    InternetCloseHandle(LhConnect);
  end;
  InternetCloseHandle(LhSession);
  Screen.Cursor := crDefault;

  if LResultFlag then begin
    MessageDlg('ファイルを削除しました', mtInformation, [mbOK], 0);
  end else begin
    if LIsNoFile then begin
      MessageDlg('該当ファイルが見つかりませんでした', mtInformation, [mbOK], 0);
    end else begin
      MessageDlg('ファイルの削除に失敗しました', mtInformation, [mbOK], 0);
    end;
  end;
end;

end.




14_FTP サーバのファイル名を変更


function FtpRenameFile(hConnect,
                       lpszExisting,
                       lpszNew):

InternetOpen と InternetConnect で FTP サーバへ接続した後,この FtpRenameFile 関数を使用して指定したファイルの名前を変更します.


hConnect HINTERNET InternetConnect で取得した FTP ハンドル
lpszExisting PChar リネーム対象ファイル名 (フルパスが望ましい)
lpszNew PChar リネーム後のファイル名 (フルパスが望ましい)
リネーム前ファイルのパスと違うパスを指定した場合,ファイルを移動してリネームとなる
戻値 BOOL リネームに成功すれば True.失敗したら False


FTP サーバ上の指定ファイルの名前を変更するサンプルです.
変更後のディレクトリ名が違う場合は,移動して名前変更となります.ただし,移動先のディレクトリがない場合はエラーとなります.
入力したサーバー名,アカウント,ハスワード等は,FTPInfo.ini というファイルに保存します.


図12
設計時画面

リスト7
FTP サーバ上のファイル名を変更
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    LabeledEdit5: TLabeledEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName  : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinInet, IniFiles;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  LIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  LIni := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := LIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := LIni.ReadString('FTPInfo', 'UserID', '');
     LabeledEdit3.Text := LIni.ReadString('FTPInfo', 'PassWord', '');
     LabeledEdit4.Text := LIni.ReadString('Others',  'OldFileName', '');
     LabeledEdit5.Text := LIni.ReadString('Others',  'NewFileName', '');
   end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LIni : TInifile;
begin
  LIni := TIniFile.Create(IniFileName);
  try
    try
      LIni.WriteString('FTPInfo', 'ServerName',  LabeledEdit1.Text);
      LIni.WriteString('FTPInfo', 'UserID',      LabeledEdit2.Text);
      LIni.WriteString('FTPInfo', 'PassWord',    LabeledEdit3.Text);
      LIni.WriteString('Others',  'OldFileName', LabeledEdit4.Text);
      LIni.WriteString('Others',  'NewFileName', LabeledEdit5.Text);
    except
    end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  サーバ上のファイル名を変更
//  ディレクトリを変更すると移動になるので注意
//  その場合移動先のディレクトリの存在のチェックが必要
//
//  LOldFileName  : 変更前のファイルパス名
//  LNewFileName  : 変更後のファイルパス名
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LServerName  : String;
  LUserID      : String;
  LPassWord    : String;
  LOldFileName : String;
  LNewFileName : String;
  LResultFlag  : Boolean;
  LhSession    : HINTERNET;
  LhConnect    : HINTERNET;
  LhFile       : HINTERNET;
  LFileData    : TWin32FindData;
  LIsNoFile    : Boolean;
begin
  Screen.Cursor := crHourGlass;

  LServerName  := LabeledEdit1.Text;
  LUserID      := LabeledEdit2.Text;
  LPassWord    := LabeledEdit3.Text;
  LOldFileName := LabeledEdit4.Text;
  LNewFileName := LabeledEdit5.Text;

  LResultFlag := False;
  LIsNoFile   := False;

  LhSession := InternetOpen(nil, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);

  if Assigned(LhSession) then begin
    //LServerName,LUserID,LPassWordのどれかが不正だと失敗する
    LhConnect := InternetConnect(LhSession,
                                 PChar(LServerName),
                                 INTERNET_DEFAULT_FTP_PORT,
                                 PChar(LUserID),
                                 PChar(LPassWord),
                                 INTERNET_SERVICE_FTP,
                                 0,
                                 0);
    if Assigned(LhConnect) then begin
      LhFile := FtpFindFirstFile(LhConnect,
                                 PChar(LOldFileName),
                                 LFileData,
                                 INTERNET_FLAG_RELOAD,
                                 0);
      if LhFile = nil then begin
        LIsNoFile := True;
      end else begin
        LResultFlag := FtpRenameFile(LhConnect,
                                     PChar(LOldFileName),
                                     PChar(LNewFileName));
        InternetCloseHandle(LhFile);
      end;
    end;
    InternetCloseHandle(LhConnect);
  end;
  InternetCloseHandle(LhSession);
  Screen.Cursor := crDefault;

  if LResultFlag then begin
    MessageDlg('ファイル名を変更しました', mtInformation, [mbOK], 0);
  end else begin
    if LIsNoFile then begin
      MessageDlg('該当ファイルが見つかりませんでした', mtInformation, [mbOK], 0);
    end else begin
      MessageDlg('ファイル名の変更に失敗しました', mtInformation, [mbOK], 0);
    end;
  end;
end;

end.




15_FTP サーバにディレクトリを作成


function FtpCreateDirectory(hConnect,
                            pszDirectory):

FtpCreateDirectory 関数は,指定したディレクトリを作成します.作成する 1 つ上の階層のディレクトリが既に存在している必要があります.階層付きのディレクトリは作成できません.


hConnect HINTERNET InternetConnect で取得した FTP ハンドル
lpszDirectory PChar 作成するディレクトリ名
戻値 BOOL 関数に成功すれば True.失敗したら False
既にあるディレクトリを作成しようとしても失敗


FTP サーバ上にあるディレクトリの下に,ディレクトリを作成する例です.
入力したサーバー名,アカウント,ハスワード等は,FTPInfo.ini というファイルに保存します.


図13
設計時画面

リスト8
FTP サーバ上にディレクトリを作成
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName  : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinInet, IniFiles;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  LIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  LIni := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := LIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := LIni.ReadString('FTPInfo', 'UserID', '');
     LabeledEdit3.Text := LIni.ReadString('FTPInfo', 'PassWord', '');
     LabeledEdit4.Text := LIni.ReadString('Others',  'ADirectory', '');
   end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LIni : TInifile;
begin
  LIni := TIniFile.Create(IniFileName);
  try
    try
      LIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      LIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      LIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      LIni.WriteString('Others',  'ADirectory', LabeledEdit4.Text);
    except
    end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  FTPサーバ上にディレクトリを作成
//  階層を持つディレクトリは作成できない
//  上の階層から順番に作成する必要がある
//
//  LNewDirectory : 作成するディレクトリ名
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LServerName   : String;
  LUserID       : String;
  LPassWord     : String;
  LNewDirectory : String;
  LResultFlag   : Boolean;
  LhSession     : HINTERNET;
  LhConnect     : HINTERNET;
  LhFile        : HINTERNET;
  LFileData     : TWin32FindData;
  LIsDirectory  : Boolean;
begin
  Screen.Cursor := crHourGlass;

  LServerName    := LabeledEdit1.Text;
  LUserID        := LabeledEdit2.Text;
  LPassWord      := LabeledEdit3.Text;
  LNewDirectory  := LabeledEdit4.Text;

  LResultFlag  := False;
  LIsDirectory := False;

  LhSession:=InternetOpen(nil, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);

  if Assigned(LhSession) then begin
    //LServerName,LUserID,LPassWordのどれかが不正だと失敗する
    LhConnect:=InternetConnect(LhSession,
                               PChar(LServerName),
                               INTERNET_DEFAULT_FTP_PORT,
                               PChar(LUserID),
                               PChar(LPassWord),
                               INTERNET_SERVICE_FTP,
                               0,
                               0);
    if Assigned(LhConnect) then begin
      LhFile := FtpFindFirstFile(LhConnect,
                                 PChar(LNewDirectory),
                                 LFileData,
                                 INTERNET_FLAG_RELOAD,
                                 0);
      if LhFile <> nil then begin
        LIsDirectory := True;
      end else begin
        //FtpCreateDirectoryはディレクトリが既に存在していると失敗する
        LResultFlag := FtpCreateDirectory(LhConnect, PChar(LNewDirectory));
      end;
      InternetCloseHandle(LhFile);
    end;
    InternetCloseHandle(LhConnect);
  end;
  InternetCloseHandle(LhSession);
  Screen.Cursor := crDefault;

  if LResultFlag then begin
    MessageDlg('ディレクトリの作成が終了しました', mtInformation, [mbOK], 0);
  end else begin
    if LIsDirectory then begin
      MessageDlg('該当ディレクトリは既に存在します', mtInformation, [mbOK], 0);
    end else begin
      MessageDlg('ディレクトリの作成に失敗しました', mtInformation, [mbOK], 0);
    end;
  end;
end;

end.




16_FTP サーバのディレクトリを削除


function FtpRemoveDirectory(hConnect,
                            lpszDirectory):

FtpRemoveDirectory 関数は,指定したディレクトリを削除します.ディレクトリが空でないと削除に失敗します.
空でないディレクトリを削除するには,あらかじめ,ディレクトリ内のファイルを,サブディレクトリも含めて全て削除しておきます.


hConnect HINTERNET InternetConnect で取得した FTP ハンドル
lpszDirectory PChar 削除するディレクトリ
戻値 BOOL 関数に成功すれば True.失敗したら False


FTP サーバ上のディレクトリを削除する例です.
入力したサーバー名,アカウント,ハスワード等は,FTPInfo.ini というファイルに保存します.


図14
設計時画面

リスト9
FTP サーバ上のディレクトリを削除
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName  : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinInet, IniFiles;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabeledEdit4.Textは削除するディレクトリ名
//  ex. LabeledEdit4.Text := 'mrxray.on.coocan.jp/homepage/AAA';
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  LIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  LIni := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := LIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := LIni.ReadString('FTPInfo', 'UserID', '');
     LabeledEdit3.Text := LIni.ReadString('FTPInfo', 'PassWord', '');
     LabeledEdit4.Text := LIni.ReadString('Others',  'ADirectory', '');
   end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LIni : TInifile;
begin
  LIni := TIniFile.Create(IniFileName);
  try
    try
      LIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      LIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      LIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      LIni.WriteString('Others',  'ADirectory', LabeledEdit4.Text);
    except
    end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  FTPサーバ上にディレクトリを作成
//  空でないディレクトリは削除できない
//
//  LDirectory : 削除するディレクトリ名
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LServerName   : String;
  LUserID       : String;
  LPassWord     : String;
  LDirectory    : String;
  LResultFlag   : Boolean;
  LhSession     : HINTERNET;
  LhConnect     : HINTERNET;
  LhFile        : HINTERNET;
  LFileData     : TWin32FindData;
  LIsNoDir      : Boolean;
begin
  Screen.Cursor := crHourGlass;

  LServerName  := LabeledEdit1.Text;
  LUserID      := LabeledEdit2.Text;
  LPassWord    := LabeledEdit3.Text;
  LDirectory   := LabeledEdit4.Text;

  LResultFlag := False;
  LIsNoDir    := False;

  LhSession := InternetOpen(nil, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);

  if Assigned(LhSession) then begin
    //LServerName,LUserID,LPassWordのどれかが不正だと失敗する
    LhConnect := InternetConnect(LhSession,
                               PChar(LServerName),
                               INTERNET_DEFAULT_FTP_PORT,
                               PChar(LUserID),
                               PChar(LPassWord),
                               INTERNET_SERVICE_FTP,
                               0,
                               0);
    if Assigned(LhConnect) then begin
      LhFile := FtpFindFirstFile(LhConnect,
                                 PChar(LDirectory),
                                 LFileData,
                                 INTERNET_FLAG_RELOAD,
                                 0);
      if LhFile = nil then begin
        LIsNoDir := True;
      end else begin
        //該当するディレクトリが存在しないと失敗
        LResultFlag := FtpRemoveDirectory(LhConnect, PChar(LDirectory));
      end;
      InternetCloseHandle(LhFile);
    end;
    InternetCloseHandle(LhConnect);
  end;
  InternetCloseHandle(LhSession);
  Screen.Cursor := crDefault;

  if LResultFlag then begin
    MessageDlg('ディレクトリを削除しました', mtInformation, [mbOK], 0);
  end else begin
    if LIsNoDir then begin
      MessageDlg('該当ディレクトリが見つかりませんでした', mtInformation, [mbOK], 0);
    end else begin
      MessageDlg('ディレクトリの削除に失敗しました', mtInformation, [mbOK], 0);
    end;
  end;
end;

end.




17_FTP サーバのファイル検索開始


function FtpFindFirstFile(hConnect,
                          lpszSearchFile,
                          lpFileFileData,
                          dwFlags,
                          dwContext):

FtpFindFirstFile 関数は,指定したファイルまたはディレクトリの検索を開始します.


hConnect HINTERNET InternetConnect で取得したFTPハンドル
lpszSearchFile PChar 検索するディレクトリ名またはファイル名.
nil の時はサーバ上のカレントディレクトリの最初のファイルを検索する
var lpFileFileData TWin32FindData 検索結果
dwFlags DWORD 検索の種別を指定するビットマスク値
  • ローカルのキャッシュを無視して常にサーバから取得
    INTERNET_FLAG_RELOAD
  • ローカルおよびケートウェイにキャッシュしない
    INTERNET_FLAG_DONT_CACHE
  • 生のデータを返す
    このフラグがない場合はディレクトリ一覧を HTML で返す
  • INTERNET_FLAG_RAW_DATA
  • SSL や PCT を使用する (HTTP の場合のみ)
    INTERNET_FLAG_SECURE
  • 可能な限りサーバとの接続を再利用する
    INTERNET_FLAG_EXISTING_CONNECT
dwContext DWORD コールバック関数に渡すアプリケーション定義の値
戻値 HINTERNET 検索の続行に使用する列挙ハンドル
失敗したハ場合は nil




18_FTP サーバのファイル検索の続行


function InternetFindNextFile(hFind,
                              lpvFindData):

InternetFindNextFil e関数は,FtpFindFirstFile 関数で開始したファイルの検索を続行し,次のファイルの情報を取得します.


hFind HINTERNET FtpFindFirstFile の戻値
lpvFindData Pointer 検索結果
戻値 BOOL 関数の実行に成功すれば True


FTP サーバ上の,指定ディレクトリ内のファイルを検索してリスト表示する例です.
入力したサーバー名,アカウント,ハスワード等は,FTPInfo.ini というファイルに保存します.



図15
設計時画面

図16
実行結果
  • Edit には接続前に情報を入力しておく (ディレクトリ名も)

リスト10
FTP サーバ上の指定ディレクトリのファイルリスト
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, ImgList, WinInet;

type
  TForm1 = class(TForm)
    ListView1: TListView;
    Panel1: TPanel;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    Button1: TButton;
    StatusBar1: TStatusBar;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName  : String;
    function GetFileList(hNet: HINTERNET; ADir: String): Integer;
    function DisplayFileInfo(FileData: TWin32FindData): Boolean;
    function GetFileExtIcon(FileName: String; Attrib: Cardinal): Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ShellAPI, CommCtrl, IniFiles;

{$R *.dfm}

//=============================================================================
//  ファイル一覧表示用のListView1のカラムの設定
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabeledEdit4.Textはファイルのリストを取得するディレクトリ名
//  ex. LabeledEdit4.Text := 'mrxray.on.coocan.jp/homepage/Halbow';
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  LIni           : TInifile;
  LSHFileInfo    : TSHFileInfo ;
  LImgListHandle : THandle;
begin
  IniFileName := '..\FTPInfo.ini';
  LIni := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := LIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := LIni.ReadString('FTPInfo', 'UserID', '');
     LabeledEdit3.Text := LIni.ReadString('FTPInfo', 'PassWord', '');
     LabeledEdit4.Text := LIni.ReadString('Others',  'SearchDir', '');
   end;
  finally
    FreeAndNil(LIni);
  end;

  ListView1.ViewStyle:=vsReport;
  ListView1.Columns.Add;
  ListView1.Columns[0].Caption   := 'ファイル名';
  ListView1.Columns[0].Width     := 190;
  ListView1.Columns.Add;
  ListView1.Columns[1].Caption   := 'サイズ ';
  ListView1.Columns[1].Width     := 100;
  ListView1.Columns[1].Alignment := taRightJustify;
  ListView1.Columns.Add;
  ListView1.Columns[2].Caption   := ' 更新日時';
  ListView1.Columns[2].Width     := 120;

  //システムのイメージリストのハンドルを取得
  LImgListHandle := SHGetFileInfo('',
                                  0,
                                  LSHFileInfo,
                                  SizeOf(LSHFileInfo),
                                  SHGFI_ICON or
                                  SHGFI_SMALLICON or
                                  SHGFI_SYSICONINDEX);
  ListView_SetImageList(ListView1.Handle, LImgListHandle, LVSIL_SMALL);
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LIni : TInifile;
begin
  LIni := TIniFile.Create(IniFileName);
  try
    try
      LIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      LIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      LIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      LIni.WriteString('Others',  'SearchDir',  LabeledEdit4.Text);
    except
    end;
  finally
    FreeAndNil(LIni);
  end;
end;

//=============================================================================
//  FTPサーバ内の指定ディレクトリ内のファイル一覧
//  ファイルのリスト作成はGetFileListで行う
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LServerName : String;
  LUserID     : String;
  LPassWord   : String;
  LhSession   : HINTERNET;
  LhConnect   : HINTERNET;
  LSearchDir  : String;
  LCount      : Integer;
begin
  Screen.Cursor := crHourGlass;

  LServerName  := LabeledEdit1.Text;
  LUserID      := LabeledEdit2.Text;
  LPassWord    := LabeledEdit3.Text;
  LSearchDir   := LabeledEdit4.Text;

  LCount := 0;
  StatusBar1.SimplePanel := True;
  StatusBar1.SimpleText  := '';
  ListView1.Items.Clear;
  ListView1.Update;

  LhSession := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if Assigned(LhSession) then begin
    //LServerName,LUserID,LPassWordのどれかが不正だと失敗する
    LhConnect := InternetConnect(LhSession,
                                 PChar(LServerName),
                                 INTERNET_DEFAULT_FTP_PORT,
                                 PChar(LUserID),
                                 PChar(LPassWord),
                                 INTERNET_SERVICE_FTP,
                                 0,
                                 0);
    if Assigned(LhConnect) then begin
      //ファイルのリスト作成
      LCount := GetFileList(LhConnect, LSearchDir);
    end;
    InternetCloseHandle(LhConnect);
  end;
  ListView1.Items.EndUpdate;

  InternetCloseHandle(LhSession);
  Screen.Cursor := crDefault;

  if LCount < 0 then begin
    StatusBar1.SimpleText := '該当ディレクトリが見つかりませんでした';
  end else begin
    StatusBar1.SimpleText := ' 項目数 : ' + IntToStr(LCount);
  end;
  StatusBar1.Update;
end;

//-----------------------------------------------------------------------------
//  FTPサーバ内のディレクトリADir内のファイルの一覧を作成
//  FtpFindFirstFileとFtpFindNextFile関数を使用
//  個々のファイルの情報はDisplayFileInfoで実行
//  戻値は表示ファイル数
//-----------------------------------------------------------------------------
function TForm1.GetFileList(hNet: HINTERNET; ADir: String): Integer;
var
  LhFile    : HINTERNET;
  LFileData : TWin32FindData;
begin
  Result := -1;

  LhFile := FtpFindFirstFile(hNet,
                             PChar(ADir),
                             LFileData,
                             INTERNET_FLAG_RELOAD,
                             0);
  if Assigned(LhFile) then begin
    Result := 0;
    while True do begin
      //ListViewのItemにファイル情報を表示
      if DisplayFileInfo(LFileData) then inc(Result);
      if InternetFindNextFile(LhFile, @LFileData) = False then break;

      Application.ProcessMessages;
      Sleep(1);
    end;
  end else begin
    //該当ディレクトリが存在しない場合
  end;
  InternetCloseHandle(LhFile);
end;

//-----------------------------------------------------------------------------
//  ListViewにファイルの情報を表示
//-----------------------------------------------------------------------------
function TForm1.DisplayFileInfo(FileData: TWin32FindData): Boolean;
var
  LFileName : String;
  LSize     : Integer;
  LItem     : TListItem;
  LSysTime  : SYSTEMTIME;
  LDateTime : TDateTime;
begin
  LFileName := FileData.cFileName;
  Result := False;

  if not ((LFileName = '..') or (LFileName = '.')) then begin
    LItem := ListView1.Items.Add;
    //ファイル名
    LItem.Caption := LFileName;

    //ファイルサイズ
    if (FileData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then begin
      LItem.SubItems.Add('');
    end else begin
      LSize := (FileData.nFileSizeLow div 1024) + 1;
      LItem.SubItems.Add(FormatFloat('###,##0 KB', LSize));
    end;

    //ファイルの日時をDelphiのTDateTime型に変換して表示
    FileTimeToSystemTime(FileData.ftLastWriteTime, LSysTime);
    LDateTime:=SystemTimeToDateTime(LSysTime);
    LItem.SubItems.Add(FormatDateTime(' yyyy/mm/dd hh:nn', LDateTime));

    //ファイルの拡張子に応じたアイコンを表示
    LItem.ImageIndex := GetFileExtIcon(LFileName, FileData.dwFileAttributes);
    Result := True;
  end;
end;

//-----------------------------------------------------------------------------
//  ファイルの拡張子に関連付けしたシステムイメージアイコンのインデックスを取得
//  FileNameはファイルのフルパス(パス部分はなくても可)
//  取得するファイルの属性を引数のAttribに与える
//-----------------------------------------------------------------------------
function TForm1.GetFileExtIcon(FileName: String; Attrib: Cardinal): Integer;
var
  LSHFileInfo : TSHFileinfo;
begin
  SHGetFileInfo(PChar('*' + ExtractFileExt(Filename)),
                      Attrib,
                      LSHFileInfo,
                      SizeOf(TSHFileInfo),
                      SHGFI_USEFILEATTRIBUTES or
                      SHGFI_SYSICONINDEX or
                      SHGFI_SMALLICON);
  Result := LSHFileInfo.iIcon;
end;

end.




19_コールバック関数の使用宣言


function InternetSetStatusCallback(hInet,
                                   lpszInternetCallback):

InternetSetStatusCallback 関数は,コールバック関数の使用宣言の定義です.


hInet HINTERNET InternetConnect で取得したハンドル
lpszInternetCallback PFNInternetStatusCallback コールバック関数のポインタ
戻値 PFNInternetStatusCallback 関数の設定に成功すれば、この関数実行直前のコールバック関数のポインタ
失敗したら nil




20_コールバック関数 ( 関数名は任意 )


function InternetStatusCallback(hInet,
                                dwContext,
                                dwIntenetStatus,
                                dwStatusInfomation,
                                dwStatusInfomationLength):

コールバック関数の引数は以下のようになっています.
関数の名前は任意ですが,引数と型と順番はこの表にしたがう必要があります.


hInet HINTERNET コールバックを呼出した WinInet 関数の戻値
dwContext DWORD アプリケーション定義の値
dwIntenetStatus DWORD 状態を現わす以下のいずれかの定数
下記以外は MDN の記事を参照
  • サーバから切断中
    INTERNET_STATUS_CLOSING_CONNECTION
  • サーバへ接続中
    INTERNET_STATUS_CONNECTING_TO_SERVER
  • サーバから切断終了
    INTERNET_STATUS_CONNECTION_CLOSED
  • 実行できない
    INTERNET_STATUS_CTL_RESPONSE_RECEIVED
  • プロクシを検出した
    INTERNET_STATUS_DETECTING_PROXY
  • ハンドルがクローズされた
    INTERNET_STATUS_HANDLE_CLOSING
  • InternetConnectionが新規ハンドルを作成した
    lpvStatusInfomationにINTERNET_ASYNC_RESULT
  • INTERNET_STATUS_HANDLE_CREATED
  • サーバからの中間状態のメッセージを受信
    INTERNET_STATUS_INTERMEDIATE_RESPONSE
  • IPアドレスを正常に取得終了
    INTERNET_STATUS_NAME_RESOLVED
  • 実行不可
    INTERNET_STATUS_PREFETCH
  • サーバからの応答を待機中
    INTERNET_STATUS_RECEIVING_RESPONSE
  • 自動リダイレクトによる要求の転送中
    plvStatusInfomationに新URLをセット
  • INTERNET_STATUS_REDIRECT
  • 非同期操作が終了した
    plvStatusInfomationにINTERNET_ASYNC_RESULT
    INTERNET_STATUS_REQUEST_COMPLETE
  • 要求発行終了
    plvStatusInfomationに送信バイト数(DWORD)
    INTERNET_STATUS_REQUEST_SEND
  • IP アドレスの取得中
    INTERNET_STATUS_RESOLVING_NAME
  • サーバからの応答終了
    plvStatusInfomationに受取バイト数(DWORD)
    INTERNET_STATUS_RESPONSE_RECEIVED
  • 要求発行中
    INTERNET_STATUS_SENDING_REQUEST
  • plvStatusInfomation に関係する値
    INTERNET_STATUS_STATE_CHANGE
dwStatusInfomation DWORD dwInternetStatus がINTERNET_STATUS_STATE_CHANGE の時は以下のいずれかの値
  • 接続されている
    INTERNET_STATE_CONNECTED
  • ネットワークの接続は確率できなかった
    INTERNET_STATE_DISCONNECTED
  • ユーザ要求による切断
    INTERNET_STATE_DISCONNECTED_BY_USER
  • ネットワークが未接続
    INTERNET_STATE_IDLE
  • ネットワーク接続中
    INTERNET_STATE_BUSY
  • ユーザよる切断が必要
    INTERNET_STATUS_USER_INPUT_REQUIRED
dwStatusInfomationLength DWORD 送信または受信したバイト数


次のサンプルは,HTTP サーバからファイルをダウンロードします.コールバック関数を使用して,サーバからの応答を表示します.また,ダウンロードの進行状況をプログレスバーに表示します.

このサンプルはウェブページのファイル名から自動的に保存ファイル名を決定するようにしています.しかし,WinINet では特に指定しない限り自動でリダイレクト処理をします.
そこで,本サンプルでは,このリダイレクトの機能を無効にして,リダイレクトかそうでないのかを判定して,保存ファイル名設定の参考にしています.

ディレクトリ名だけで,ファイル名がない URL アドレスの場合,常にファイル名が取得できるとは限りません.サーバ側のディレクトリインデックス (DirectoryIndex) の機能により,デフォルトドキュメントが設定してある場合は取得できません.その場合は,最後のディレクトリ名に .html という拡張子を付けて保存するようにしています.




図17
設計時画面

図18
実行してダウンロード中

リスト11
コールバック関数を使用しダウンロードの状況を表示
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Panel2: TPanel;
    ProgressBar1: TProgressBar;
    Panel3: TPanel;
    LabeledEdit1: TLabeledEdit;
    Button1: TButton;
    Panel1: TPanel;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    FIsCancel : Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  WinInet, StrUtils, IOUtils;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  コールバック関数
//-----------------------------------------------------------------------------
procedure TestInternetCallback(hInet: HINTERNET; dwcontex, dwInternetStatus: DWORD;
  lpvStatusInformation: Pointer; dwStatusInformationLength: DWORD); stdcall;
begin
  case dwInternetStatus of
    INTERNET_STATUS_RESOLVING_NAME:
      Form1.Memo1.Lines.Add('IPアドレス取得中');
    INTERNET_STATUS_NAME_RESOLVED:
      Form1.Memo1.Lines.Add('IPアドレスの取得終了');
    INTERNET_STATUS_CONNECTING_TO_SERVER:
      Form1.Memo1.Lines.Add('サーバへ接続中');
    INTERNET_STATUS_CONNECTED_TO_SERVER:
      Form1.Memo1.Lines.Add('サーバへ接続完了');
    INTERNET_STATUS_SENDING_REQUEST:
      Form1.Memo1.Lines.Add('要求発行中');
    INTERNET_STATUS_REQUEST_SENT:
      Form1.Memo1.Lines.Add('要求発行終了');
    INTERNET_STATUS_RECEIVING_RESPONSE:
      Form1.Memo1.Lines.Add('サーバの応答待機中');
    INTERNET_STATUS_RESPONSE_RECEIVED:
      Form1.Memo1.Lines.Add('サーバの応答終了');
    INTERNET_STATUS_REDIRECT:
      Form1.Memo1.Lines.Add('自動リダイレクトによる要求の転送中');
    INTERNET_STATUS_CLOSING_CONNECTION:
      Form1.Memo1.Lines.Add('サーバから切断中');
    INTERNET_STATUS_CONNECTION_CLOSED:
      Form1.Memo1.Lines.Add('サーバから切断終了しました');
    INTERNET_STATUS_HANDLE_CREATED:
      Form1.Memo1.Lines.Add('新規ハンドルを作成');
    INTERNET_STATUS_HANDLE_CLOSING:
      Form1.Memo1.Lines.Add('ハンドルをクローズ');
    INTERNET_STATUS_REQUEST_COMPLETE:
      Form1.Memo1.Lines.Add('非同期操作が終了');
  end;
end;

//=============================================================================
//  ダウンロードファイル名をLabelEditに入力
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  LabeledEdit1.Text := 'http://mrxray.on.coocan.jp/Delphi/ZipExe/plSetPrinter.zip';
end;

//=============================================================================
//  HTTPサーバからファイルをダウンロード
//  コールバック関数を使用してダウンロードの進捗状況を表示
//
//  LSourceURL : ダウンロードするファイル名
//  LSaveFile  : ダウンロード後のファイル名
//
//  UnixPathToDosPath関数にはusesにHTTPAppが必要
//  MatchTextの使用にはusesにStrUtilsが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LStream      : TFileStream;
  LSourceURL   : String;
  LSaveFile    : String;
  LResultFlag  : Boolean;
  hSession     : HINTERNET;
  LhService    : HINTERNET;
  LFileSize    : Longint;
  LDLFileSize  : Int64;
  LdwBytesRead : DWORD;
  LReserved    : DWORD;
  LlpvBuffer   : array[0..1023] of Char;
  LDownloadURL : String;
  LIsNoFile    : Boolean;
begin
  Screen.Cursor := crHourGlass;

  LSourceURL := LabeledEdit1.Text;

  LResultFlag  := False;
  LIsNoFile    := False;
  FIsCancel    := False;
  LDownloadURL := '';
  LDLFileSize  := 0;
  Memo1.Lines.Clear;

  hSession := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(hSession) then begin
    //INTERNET_FLAG_NO_AUTO_REDIRECTはリダイレクト回避
    //WinInetはリダイレクトを自動でやってくれる
    //勝手にリダイレクトされてしまうと保存先のファイル名の設定ができない
    //そこで,リダイレクトを回避してステータスコードで判定して処理
    LhService := InternetOpenUrl(hSession,
                                 PChar(LSourceURL),
                                 nil,
                                 0,
                                 INTERNET_FLAG_NO_AUTO_REDIRECT or INTERNET_FLAG_RELOAD,
                                 0);
    if Assigned(LhService) then begin
      //HTTP_QUERY_STATUS_CODEでステータスコードを取得
      FillChar(LlpvBuffer, SizeOf(LlpvBuffer), #0);
      LdwBytesRead := SizeOf(LlpvBuffer);
      LReserved    := 0;
      HttpQueryInfo(LhService,
                    HTTP_QUERY_STATUS_CODE,
                    @LlpvBuffer[0],
                    LdwBytesRead,
                    LReserved);

      if MatchText(LlpvBuffer, ['404', '407']) then begin
        LIsNoFile := True;
      end else
      if not MatchText(LlpvBuffer, ['200','203','301','302','303','307']) then begin
        LIsNoFile := True;
      end;

      //サーバにファイルが存在するなら処理続行
      if not LIsNoFile then begin
        //HTTP_QUERY_LOCATIONを指定してリダイレクト先を取得
        //ステータスコードが301等がリダイレクト
        FillChar(LlpvBuffer, SizeOf(LlpvBuffer), #0);
        LdwBytesRead := SizeOf(LlpvBuffer);
        LReserved    := 0;
        HttpQueryInfo(LhService,
                      HTTP_QUERY_LOCATION,
                      @LlpvBuffer[0],
                      LdwBytesRead,
                      LReserved);
        if String(LlpvBuffer) = '' then begin
          //リダイレクトではない場合(あるいはリダイレクトに失敗)
          LDownloadURL := LSourceURL;
        end else begin
          //リダイレクトされている場合
          LDownloadURL := LlpvBuffer;
        end;

        //保存ファイル名はこのプロジェクトのフォルダでサーバ上と同名
        //ファイル名部分が取得できない場合は最後のディレクトリ名とする
        if TPath.GetFileName(LDownloadURL) = '' then begin
          LSaveFile := ExtractFilePath(ParamStr(0)) +
            TPath.GetFileName(TPath.GetDirectoryName(LDownloadURL)) + '.html';
        end else begin
          LSaveFile := ExtractFilePath(ParamStr(0)) +
            TPath.GetFileName(LDownloadURL);
        end;

        //対象のファイルがサーバに存在することが分かったので
        //今度はリダイレクトを有効にしてInternetOpenUrlを実行
        InternetCloseHandle(LhService);
        //コールバック定義
        InternetSetStatusCallback(hSession, @TestInternetCallback);
        LhService := InternetOpenUrl(hSession,
                                     PChar(LSourceURL),
                                     nil,
                                     0,
                                     INTERNET_FLAG_RELOAD,
                                     Cardinal(@TestInternetCallback));
        //ファイルサイズを取得
        LFileSize    := 0;
        LdwBytesRead := SizeOf(LdwBytesRead);
        LReserved    := 0;
        HttpQueryInfo(LhService,
                      HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER,
                      @LFileSize,
                      LdwBytesRead,
                      LReserved);

        ProgressBar1.Min := 0;
        ProgressBar1.Max := LFileSize;

        try
          //保存するファイルを作成
          //TMemoryStreamに保存,ダウンロード終にディスクに保存する方法も考えられる
          LStream := TFileStream.Create(LSaveFile, fmCreate);
          //Loopにrepeatを用いた例
          try
            LdwBytesRead := SizeOf(LlpvBuffer);
            repeat
              LlpvBuffer := #0;
              if InternetReadFile(LhService,
                                  @LlpvBuffer,
                                  SizeOf(LlpvBuffer),
                                  LdwBytesRead) then begin
                LStream.WriteBuffer(LlpvBuffer, LdwBytesRead);

                LDLFileSize    := LDLFileSize + LdwBytesRead;
                Panel1.Caption := IntToStr(LDLFileSize) + ' バイト完了';
                ProgressBar1.Position := LDLFileSize;
                ProgressBar1.Update;
                Panel1.Update;
                LResultFlag := True;
              end else begin
                LResultFlag := False;
                break;
              end;
              if FIsCancel then break;
              Application.ProcessMessages;
              Sleep(1);
            until LdwBytesRead = 0;
          finally
            FreeAndNil(LStream);
          end;
        except
          //保存ファイルが作成できなかった場合
          //リダイレクト先が取得できなかった場合等
          LResultFlag := False;
        end;
      end;
    end;
    InternetCloseHandle(LhService);
  end;
  InternetCloseHandle(hSession);
  Screen.Cursor := crDefault;

  if FIsCancel then begin
    Panel1.Caption := 'ダウンロードを中止しました';
  end else
  if LResultFlag then begin
    Panel1.Caption := 'ダウンロードが終了しました';
  end else begin
    if LIsNoFile then begin
      Panel1.Caption := '該当するファイルがサーバにありません';
    end else begin
      Panel1.Caption := 'ダウンロードに失敗しました';
    end;
  end;
end;

//=============================================================================
//  キャンセルボタン
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  FIsCancel := True;
end;

end.




21_進行ダイアログの表示 ( ヒント)


InternetSetStatusCallback を使用すると,ダウンロードの進行状況通知を取得するとか,接続状態通知など,要求の進行状況に関する情報を確認できます.ただし,この通知は,転送が完了した割合を示すものではありません.
マイクロソフトのサイトに,次のような記事があります.

≪転送が完了した割合を取得するには,転送ファイルのサイズを確認し,小さいサイズのバッファで InternetReadFile または InternetWriteFile を呼び出す必要があります.これにより,各関数呼び出しの完了時に,転送が完了した割合を計算できます.

たとえば,1000 バイトのファイルをダウンロードするとします.この場合,1000 バイトのバッファを使用して InternetReadFile を 1 回呼び出す代わりに,100 バイトのバッファを使用して InternetReadFile を 10 回呼び出します.これにより,1 回の InternetReadFile 呼び出しが完了するごとに,ダウンロードが 10% ずつ完了していることが分かります.≫






22_非同期でファイルをダウンロード


ここまでのサンプルは全て同期処理です.そのため,ダウンロード中にフォームを移動したりすると処理が中断したりします.これを回避するには,ダウンロードを非同期で行う必要があります.
非同期と言えばスレッドの使用を思いつきますが,下記の [Bin 溜まり] のサイトにスレッドを使用しない非同期操作用のユニットがあります.これをダウンロードしてテストしてみました.

スレッドを使用する方法は,[004_タイマー] のスレッド処理関係のコード,あるいは,下記のリンクの [簡単に http 非同期ファイル取得を行うには] のコードを参考にしてください.



[Bin 溜まり] のウェブページから asyncdelphi.lzh をダウンロードして,コードの一部を変更して実行した結果です.ダウンロードしたファイルが zip ファイルなので,TMemo に PK という文字列が表示されています.この文字列が表示されればダウンロードが終了したことになります.




図19
添付のサンプルの実行結果

リスト12
asyncdelphi.lzh 内の Unit1.pas のコードの以下の部分を編集してテスト
UnixPathToDosPath の使用には uses に HTTPApp が必要
procedure TForm1.OnReceived(Sender: TObject; const Stream: TStream);
var
  LFileStream   : TFileStream;
  LSaveFileName : String;
begin
  Stream.Seek(0, soBeginning);
  Memo1.Lines.LoadFromStream(Stream);

  LSaveFileName := ExtractFileName(UnixPathToDosPath(Edit1.Text));
  LFileStream   := TFileStream.Create(LSaveFileName, fmCreate);
  try
    LFileStream.CopyFrom(Stream, 0);
  finally
    FreeAndNil(LFileStream);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ListBox1.Items.Clear;
  Memo1.Lines.Clear;
  HTTPDown.GetUrl(Edit1.Text);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/Delphi/ZipExe/plSetPrinter.zip';

  HTTPDown := THTTPDownload.Create;




23_WinHTTP - タイプライブラリの取り込み


本ページで扱っている WinInet はクライアント用のアプリ開発として利用する際の関数類です.サーバとしての利用を可能にしたライブラリがマイクロソフトから WinHTTP として提供されています.サーバとしての利用となっていますが,クライアント用としても使用できます.
Delphi XE には WinHTTP の機能は実装されていません.タイプライブラリの取り込でユニットを作成して利用できます.ライブラリとして Microsoft WinHTTP Service を選択します.今回選択したのは,筆者の環境では version 5.1 となっていました.
タイプライブラリの取り込を行うと,WinHttp_TLB.pas というユニットができます.これを uses に追加して利用します.

実装されているインターフェイは,下記の MSDN の記事にあるように,2 つです.




図20
タイプライブラリの取り込み




24_WinHTTP - IWinHttpRequest を使用したダウンロード


IWinHttpRequest インターフェイスを使用した HTTP サーバからファイルをダウンロードする簡単なサンプルです.




図21
実行時画面

リスト13
IWinHttpRequest を使用したファイルのダウンロード
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinHttp_TLB, ActiveX, AxCtrls;

{$R *.dfm}

//=============================================================================
//  テスト用のURLをセット
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/Delphi/zip/003_StopWatch.zip';
end;

//=============================================================================
//  WinHTTPを使用したファイルのダウンロード
//
//  IStreamの使用にはusesにActiveXが必要
//  TOleStreamの使用にはusesにAxCtrlsが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LHttpRequest : IWinHttpRequest;
  LSourceURL   : String;
  LSaveFile    : String;
  LFileStream  : TFileStream;
  LHttpStream  : IStream;
  LOleStream   : TOleStream;
begin
  Screen.Cursor := crHourGlass;

  LSourceURL := Edit1.Text;
  LSaveFile  := ExtractFilePath(Application.ExeName) + '003_StopWatch.zip';

  LHttpRequest := CoWinHttpRequest.Create;
  try
    LHttpRequest.Open('GET', LSourceURL, False);
    LHttpRequest.Send(EmptyParam);
    //上のコードが成功すればLHttpRequest.Statusの値が200になっている

    LHttpStream := IUnknown(LHttpRequest.ResponseStream) as IStream;
    LOleStream  := TOleStream.Create(LHttpStream);
    try
      LFileStream := TFileStream.Create(LSaveFile, fmCreate);
      try
        LFileStream.CopyFrom(LOleStream, 0);
      finally
        FreeAndNil(LFileStream);
      end;
    finally
      FreeAndNil(LOleStream);
    end;
  except
    on E: Exception do
      ShowMessage(E.Message);
  end;
  Screen.Cursor := crDefault;
  LHttpRequest := nil;
end;

end.


タイプライブラリの取り込で,コンポーネントラッパーを生成すると,TWinHttpRequest というコンポーネントが使用可能になります.これを使用すると,実行時に例外が発生します.

原因を追及してもいいのですが,この TWinHttpRequest コンポーネントのメソッド,プロパティの実装コードをみてみると,次のコードのようになっています.つまり,内部では IWinHttpRequest オブジェクトの,同名のメソッドやプロパティを操作しています.したがって,上のサンプルのように,インターフェイスのインスタンスを生成して利用すれば十分と考えられます.



リスト14
TWinHttpRequest コンポーネントの Open メソッドと Send メソッドの実装内容
DefaultInterface は IWinHttpRequest オブジェクト
procedure TWinHttpRequest.Open(const Method: WideString; const Url: WideString);
begin
  DefaultInterface.Open(Method, Url, EmptyParam);
end;

procedure TWinHttpRequest.Send(Body: OleVariant);
begin
  DefaultInterface.Send(Body);
end;