unit AutoDLDefroseUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DB, ADODB, Buttons, ComCtrls, ExtCtrls, Grids, DBGrids;

type
  TForm1 = class(TForm)
    pnlCaption: TPanel;
    StatusBar1: TStatusBar;
    ADOQuery1: TADOQuery;
    Button1: TSpeedButton;
    Button2: TSpeedButton;
    Button3: TSpeedButton;
    Button999: TSpeedButton;
    DataSource1: TDataSource;
    ADOConnection1: TADOConnection;
    DBGrid1: TDBGrid;
    procedure Button999Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private 宣言 }
    AppDir      : String;
    DLSiteURL         : String;
    DelLZHFileName    : String;
    AddLZHfileName    : String;
    DelCSVFileName    : String;
    AddCSVFileName    : String;
    CSVFileDate       : TDateTime;
    SL                : TStringList;
    function DownloadFile(SourceFile, DestFile: string): Boolean;
    procedure ArchiveLZHFile(SrcFilePath: String);
    function GetFileDateStamp(FilePath: String): TDateTime;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses UrlMon, WinInet, plArchieverLZH;

{$R *.dfm}

//=============================================================================
//  フォーム生成時処理
//
//  ファイル名の命名規則
//  新規追加データ ADD_YYMM.LZH
//  廃止データ     DEL_YYMM.LZH
//  YYMMの部分は更新年月
//  1998年2月2日から1998年1998年3月1日までの新規追加データ    ADD_9803.LZH
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //データベースに接続
  ADOConnection1.Mode           := cmRead;
  ADOConnection1.KeepConnection := False;
  ADOConnection1.Connected      := False;
  ADOConnection1.LoginPrompt    := False;
  ADOQuery1.Connection          := ADOConnection1;

  //DBGri1のカラムの設定
  with DBGrid1 do begin
    Columns[0].FieldName := '郵便番号';
    Columns[1].FieldName := '都道府県名';
    Columns[2].FieldName := '市区町村名';
    Columns[3].FieldName := '町域名';
  end;

  SL:=TStringList.Create;
  //CSVの表示にはschema.iniがあった方がよいので作成して保存
  //shema.iniがないと各項目の表示幅がデフォルトとなる(文字列は255)
  //schema.iniのCol1,Col2,...の順番で途中抜けてはいけない
  //Col1,Col2,Col4,Col5,Col6は今回は使用しないので適当な項目名としている
  //表示するファイル名は実際に表示する直前にセットする
  with SL do begin
    Add('[]');                             //表示するファイル名
    Add('ColNameHeader=False');            //第1行もデータである
    Add('MaxScanRows=0');                  //最後の行まで読込む
    Add('Format=CsvDelimited');            //CSVファイルである
    Add('Col1=AAA Char Width 5');
    Add('Col2=BBB Char Width 5');
    Add('Col3=郵便番号 Char Width 7');
    Add('Col4=CCC Char Width 5');
    Add('Col5=DDD Char Width 5');
    Add('Col6=EEE Char Width 5');
    Add('Col7=都道府県名 Char Width 20');
    Add('Col8=市区町村名 Char Width 50');
    Add('Col9=町域名 Char Width 100');
  end;
  SL.SaveToFile('schema.ini');

  //このプログラムのフォルダに保存して解凍するので予め設定
  AppDir := ExtractFileDir(Application.ExeName);

  //ダウンロードサイト名
  DLSiteURL := 'http://www.post.japanpost.jp/zipcode/dl/kogaki/lzh/';

  //現在の月より一ヶ月前の更新データを取得するものとする
  //実際には更新していない分を順番に取得してデータベース等の更新が必要だろう
  //ダウンロードすべきファイル名を作成
  AddLZHFileName := 'add_' + FormatDateTime('yymm', IncMonth(Now,-1)) + '.lzh';
  DelLZHFileName := 'del_' + FormatDateTime('yymm', IncMonth(Now,-1)) + '.lzh';

  //解凍後のファイル名
  AddCSVFileName := 'ADD_' + FormatDateTime('yymm', IncMonth(Now,-1)) + '.CSV';
  DelCSVFileName := 'DEL_' + FormatDateTime('yymm', IncMonth(Now,-1)) + '.CSV';

  Button2.Enabled := False;
  Button3.Enabled := False;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  FreeAndNil(SL);
  ADOConnection1.Connected := False;

  //ダウンロードしたファイルとCSVファイルは削除(テストなので)
  //実際にはデータベース等に取込む作業終了後に削除すべき
  DeleteFile(AddLZHFileName);
  DeleteFile(DelLZHFileName);
  DeleteFile(AddCSVFileName);
  DeleteFile(DelCSVFileName);
end;

//=============================================================================
//  [閉じる]ボタン
//=============================================================================
procedure TForm1.Button999Click(Sender: TObject);
begin
  Close;
end;

//=============================================================================
//  ダウンロードと解凍作業(自動実行)
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  Flag : Boolean;
begin
  StatusBar1.Panels[0].Text := '';
  StatusBar1.Panels[1].Text := '';

  Screen.Cursor := crSQLWait;

  //ダウンロードと解凍
  //まずAddLHZFileNameのファイルをダウンロードして成功したらDellLZHFileNameを
  //続けてダウンロードする
  Flag := DownloadFile(DLSiteURL + AddLZHfileName,
                       IncludeTrailingPathDelimiter(AppDir) + AddLZHFileName);
  if Flag then begin
    DownloadFile(DLSiteURL + DelLZHFileName,
                 IncludeTrailingPathDelimiter(AppDir) + DelLZHFileName);

    //ダウンロードしたら解凍
    ArchiveLZHFile(IncludeTrailingPathDelimiter(AppDir) + AddLZHFileName);
    ArchiveLZHFile(IncludeTrailingPathDelimiter(AppDir) + DelLZHFileName);
  end;
  Screen.Cursor:=crDefault;

  Button2.Enabled := Flag;
  Button3.Enabled := Flag;
end;

//=============================================================================
//  ファイルをダウンロードする関数
//  SourceFileで指定するファイルがないか，DestFile名が無効の場合はFalseを返す
//  またネットワーク接続不可の場合もFalseを返す
//  usesにUrlMonが必要
//
//  SourceFile : ダウンロードするファイルのURL
//               このサンプルの場合は http://...  .lzh という文字列
//               画像をダウンロードしたい場合は http://...  .gif 等
//               ページのソースならば http://....  .html 等
//  DestFile   : 保存先のフルパス名
//               例えば C:\MyFolder\XXXX.lzh 等　
//=============================================================================
function TForm1.DownloadFile(SourceFile, DestFile: string): Boolean;
begin
  try
  //UrlDownloadToFile関数はIEのキャッシュを優先してDLするので
  //DeleteUrlCacheEntryであらかじめIEキャッシャ内の該当ファイルを削除
  //usesにWinInetが必要
  DeleteUrlCacheEntry(PChar(SourceFile));

  //ダウンロード
  Result := UrlDownloadToFile(nil,
                              PChar(SourceFile),
                              PChar(DestFile),
                              0,
                              nil) = 0;
  except
    Result := False;
  end;
end;

//=============================================================================
//  ファイルの解凍
//  解凍先はこのアプリの起動フォルダ
//  usesにplArchieverLZH(拙作ユニット)が必要
//=============================================================================
procedure TForm1.ArchiveLZHFile(SrcFilePath: String);
var
  ADir : String;
  Arch : TplArchieverLZH;
  AMsg : String;
begin
  //解凍先ディレクトリ
  ADir := ExtractFileDir(Application.ExeName);
  Arch := TplArchieverLZH.Create(Self);
  try
    //解凍
    Arch.UnPackFiles(SrcFilePath, ADir, AMsg);
  finally
    FreeAndNil(Arch);
  end;
end;

//=============================================================================
//  廃止データの確認表示
//  解凍後のCSVファイルをTADOコンポーネントを使用して表示
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  ATableName : String;
  SQLSL      : String;
begin
  StatusBar1.Panels[0].Text := '';
  StatusBar1.Panels[1].Text := '';

  Screen.Cursor := crSQLWait;

  //表示するファイル名をschema.iniにセットして保存
  //本来はファイルの存在を確認すべき
  SL.LoadFromFile('schema.ini');
  SL[0] := '[' + DelCSVFileName + ']';
  SL.SaveToFile('schema.ini');

  with ADOConnection1 do begin
    Connected := False;
    //接続文字列
    ConnectionString := 'DRIVER={Microsoft Text Driver (*.txt; *.csv)};DBQ='+AppDir;
    Connected        := True;
  end;
  //表名(.は#に置換える)
  ATableName := StringReplace(DelCSVFileName, '.', '#', [rfReplaceAll]);
  SQLSL      := 'select * from ' + ATableName;

  //クエリー実行
  with ADOQuery1 do begin
    DisableControls;
    Close;
    SQL.Clear;
    SQL.Add(SQLSL);
    Open;
    First;
    EnableControls;
  end;

  CSVFileDate := GetFileDateStamp(AppDir + '\' + DelCSVFileName);

  StatusBar1.Panels[0].Text := '削除数　' + IntToStr(ADOQuery1.RecordCount);
  StatusBar1.Panels[1].Text := '　' +
               FormatDateTime('yyyy年mm月dd日更新データ(廃止分)', CSVFileDate);

  Screen.Cursor := crDefault;
end;

//=============================================================================
//  新規追加データの確認表示
//  解凍後のCSVファイルをTADOコンポーネントを使用して表示
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  ATableName : String;
  SQLSL      : String;
begin
  StatusBar1.Panels[0].Text := '';
  StatusBar1.Panels[1].Text := '';

  Screen.Cursor := crSQLWait;

  //表示するファイル名をschema.iniにセットして保存
  //本来はファイルの存在を確認すべき
  SL.LoadFromFile('schema.ini');
  SL[0] := '[' + AddCSVFileName+ ']';
  SL.SaveToFile('schema.ini');

  with ADOConnection1 do begin
    Connected := False;
    //接続文字列
    ConnectionString := 'DRIVER={Microsoft Text Driver (*.txt; *.csv)};DBQ='+AppDir;
    Connected        := True;
  end;

  //表名(.は#に置換える)
  ATableName := StringReplace(AddCSVFileName, '.', '#', [rfReplaceAll]);
  SQLSL      := 'select * from ' + ATableName;

  //クエリー実行
  with ADOQuery1 do begin
    DisableControls;
    Close;
    SQL.Clear;
    SQL.Add(SQLSL);
    Open;
    First;
    EnableControls;
  end;

  CSVFileDate := GetFileDateStamp(AppDir + '\' + AddCSVFileName);

  StatusBar1.Panels[0].Text:='追加数　' + IntToStr(ADOQuery1.RecordCount);
  StatusBar1.Panels[1].Text:='　' +
               FormatDateTime('yyyy年mm月dd日更新データ(追加分)', CSVFileDate);

  Screen.Cursor := crDefault;
end;

//=============================================================================
//  FilePathの日付を取得
//=============================================================================
function TForm1.GetFileDateStamp(FilePath: String): TDateTime;
var
  FileHandle : Integer;
begin
  Result := 0;

  if FileExists(Filepath) then begin
    FileHandle := FileOpen(FilePath, fmShareDenyWrite);
    try
      //OSタイムスタンプ値をTDateTime値に変換
      //FileGetDateはファイルハンドルからOSのタイムスタンプを取得する関数
      Result := Trunc(FileDateToDateTime(FileGetDate(FileHandle)));
    finally
       FileClose(FileHandle);
    end;
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
    function DownloadFile(SourceFile, DestFile: string): Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses UrlMon, WinInet, HTTPApp;

{$R *.dfm}

//=============================================================================
//  ファイルのダウンロード
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  SrcFile  : String;
  SaveFile : String;
begin
  //ダウンロードするファイル
  SrcFile  := 'http://mrxray.on.coocan.jp/Delphi/ZipExe/plSetPrinter.zip';
  //保存先はこのアプリのEXEがあるフォルダとする
  SaveFile := ExtractFilePath(Application.ExeName) +
              ExtractFileName(UnixPathToDosPath(SrcFile));

  DownloadFile(SrcFile, SaveFile);
end;

//=============================================================================
//  DownLoadFile関数を用いてサイトのページソースを取得する例
//  サイトのページ(HTML等)もファイルである
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  AURL  : String;
  AFile : String;
begin
  AURL := 'http://mrxray.on.coocan.jp/index.htm';

  //このアプリの起動フォルダに保存
  AFile := ExtractFilePath(Application.ExeName) + 'URLText.Txt';
  if DownloadFile(AURL, AFile) then begin
    Memo1.Lines.LoadFromFile(AFile);
  end;
end;

//=============================================================================
//  DownLoadFile関数を用いてネット上の指定画像を保存する例
//  画像もファイルである
//  筆者のサイトの[Holbow資料館]の画像を保存
//  UnixPathToDosPathにはusesにHTTPAppが必要
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  APath : String;
  AFile : String;
begin
  APath := 'http://mrxray.on.coocan.jp/Halbow/Image/title02.gif';

  //画像の保存先(このアプリの起動フォルダに保存)
  //保存名はtitle02.gif
  //元の名前と同じ名前で保存したい場合の参考コード
  AFile := ExtractFilePath(Application.ExeName) +
           ExtractFileName(UnixPathToDosPath(APath));

  DownloadFile(APath, AFile);
end;

//=============================================================================
//  ファイルをダウンロードする関数
//  SourceFileで指定するファイルがないか，DestFile名が無効の場合はFalseを返す
//  またネットワーク接続不可の場合もFalseを返す
//  usesにUrlMonが必要
//
//  SourceFile : ダウンロードするファイルのURL
//               このサンプルの場合は http://...  .lzh という文字列
//               画像をダウンロードしたい場合は http://...  .gif 等
//               ページのソースならば http://....  .html 等
//  DestFile   : 保存先のフルパス名
//               例えば C:\MyFolder\XXXX.lzh 等　
//=============================================================================
function TForm1.DownloadFile(SourceFile, DestFile: string): Boolean;
begin
  try
    //UrlDownloadToFile関数はIEのキャッシュを優先してDLするので
    //DeleteUrlCacheEntryであらかじめIEキャッシャ内の該当ファイルを削除
    //usesにWinInetが必要
    DeleteUrlCacheEntry(PChar(SourceFile));

    //ダウンロード
    Result := UrlDownloadToFile(nil,
                                PChar(SourceFile),
                                PChar(DestFile),
                                0,
                                nil) = 0;
  except
    Result := False;
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdHTTP;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Memo1: TMemo;
    IdHTTP1: TIdHTTP;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
    function DownloadFile(SourceFile, DestFile: string): Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses HTTPApp;

{$R *.dfm}

//=============================================================================
//  ファイルのダウンロード
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  SrcFile  : String;
  SaveFile : String;
begin
  //ダウンロードするファイル
  SrcFile  := 'http://mrxray.on.coocan.jp/Delphi/ZipExe/plSetPrinter.zip';
  //保存先はこのアプリのEXEがあるフォルダとする
  SaveFile := ExtractFilePath(Application.ExeName) +
              ExtractFileName(UnixPathToDosPath(SrcFile));

  DownloadFile(SrcFile, SaveFile);
end;

//=============================================================================
//  DownLoadFile関数を用いてサイトのページソースを取得する例
//  サイトのページ(HTML等)もファイルである
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  AURL  : String;
  AFile : String;
begin
  AURL := 'http://mrxray.on.coocan.jp/index.htm';

  //このアプリの起動フォルダに保存
  AFile := ExtractFilePath(Application.ExeName) + 'URLText.Txt';
  if DownloadFile(AURL, AFile) then begin
    Memo1.Lines.LoadFromFile(AFile);
  end;
end;

//=============================================================================
//  DownLoadFile関数を用いてネット上の指定画像を保存する例
//  画像もファイルである
//  筆者のサイトの[Holbow資料館]の画像を保存
//  UnixPathToDosPathにはusesにHTTPAppが必要
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  APath : String;
  AFile : String;
begin
  APath := 'http://mrxray.on.coocan.jp/Halbow/Image/title02.gif';

  //画像の保存先(このアプリの起動フォルダに保存)
  //保存名はtitle02.gif
  //元の名前と同じ名前で保存したい場合の参考コード
  AFile := ExtractFilePath(Application.ExeName) +
           ExtractFileName(UnixPathToDosPath(APath));

  DownloadFile(APath, AFile);
end;

//=============================================================================
//  インターネット上のファイルをダウンロード
//  [Indy Clients]タブのTIdHTTPコンポーネントを使用する例
//
//  ファイルに保存しない場合はTFileStreamではなくTMemoryStreamを使用すると良
//=============================================================================
function TForm1.DownloadFile(SourceFile, DestFile: string): Boolean;
var
  FS : TFileStream;
begin
  Result := True;
  //上書き保存(なければ新規作成)
  FS := TFileStream.Create(DestFile, fmCreate);
  try
   try
     IdHTTP1.Get(SourceFile,FS);
   except
     Result := False;
   end;
  finally
   FS.Free;
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
    function DownloadFile(SourceFile, DestFile: string): Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses WinInet, HTTPApp;

{$R *.dfm}

//=============================================================================
//  ファイルのダウンロード
//
//  このサンプルでは，ダウンロードが終了しなくてもButtonが使用可能となってしま
//  い，ダウンロード中にクリックするとエラーとなる
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  SrcFile  : String;
  SaveFile : String;
begin
  //ダウンロードするファイル
  SrcFile  := 'http://mrxray.on.coocan.jp/Delphi/ZipExe/plSetPrinter.zip';
  SaveFile := ExtractFilePath(Application.ExeName) +
              ExtractFileName(UnixPathToDosPath(SrcFile));

  DownloadFile(SrcFile, SaveFile);
end;

//=============================================================================
//  DownLoadFile関数を用いてサイトのページソースを取得する例
//  サイトのページ(HTML等)もファイルである
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  AURL  : String;
  AFile : String;
begin
  AURL := 'http://mrxray.on.coocan.jp/index.htm';

  //このアプリの起動フォルダに保存
  AFile := ExtractFilePath(Application.ExeName) + 'URLText.Txt';
  if DownloadFile(AURL, AFile) then begin
    Memo1.Lines.LoadFromFile(AFile);
  end;
end;

//=============================================================================
//  DownLoadFile関数を用いてネット上の指定画像を保存する例
//  画像もファイルである
//  筆者のサイトの[Holbow資料館]の画像を保存
//  UnixPathToDosPathにはusesにHTTPAppが必要
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  APath : String;
  AFile : String;
begin
  APath := 'http://mrxray.on.coocan.jp/Halbow/Image/title02.gif';

  //画像の保存先(このアプリの起動フォルダに保存)
  //保存名はtitle02.gif
  //元の名前と同じ名前で保存したい場合の参考コード
  AFile := ExtractFilePath(Application.ExeName) +
           ExtractFileName(UnixPathToDosPath(APath));

  DownloadFile(APath, AFile);
end;

//=============================================================================
//  インターネット上のファイルをダウンロード
//  WinInetを使用する例(usesにWinInetが必要)
//
//  ファイルに保存しない場合はTFileStreamではなくTMemoryStreamを使用すると良
//=============================================================================
function TForm1.DownloadFile(SourceFile, DestFile: string): Boolean;
var
  FS          : TFileStream;
  hSession    : HINTERNET;
  hService    : HINTERNET;
  dwBytesRead : DWORD;
  dwFlag      : DWORD;
  lpBuffer    : array[0..MAX_PATH-1] of Char;
begin
  Result   := True;
  hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if Assigned(hSession) then begin
    //dwFlagを0にするとIEのキャッシュからダウンロードする(できる)
    dwFlag   := INTERNET_FLAG_RELOAD;
    hService := InternetOpenUrl(hSession, PChar(SourceFile), nil, 0, dwFlag, 0);
    if Assigned(hService ) then begin
      //上書き保存(なければ新規作成)
      FS := TFileStream.Create(DestFile, fmCreate);
      try
        dwBytesRead := 1024;
        while True do begin
          lpBuffer := #0;
          if InternetReadFile(hService,
                              @lpBuffer,
                              SizeOf(lpBuffer),
                              dwBytesRead) then begin
            //これがないと動作中にFormの移動などが不可となる
            //Sleep(0)の0は適当0～10程度でいいようだ
            Application.ProcessMessages;
            Sleep(0);
            if dwBytesRead = 0 then break;
            FS.WriteBuffer(lpBuffer, dwBytesRead);
          end else begin
            Result := False;
            break;
          end;
        end;
      finally
        FreeAndNil(FS);
      end;
    end;
    InternetCloseHandle(hService);
  end else begin
    Result := False;
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, UrlMon, ActiveX, StdCtrls, Gauges, WinInet;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Gauge1: TGauge;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    function DownloadFile( Source, Dest: String): Boolean;
  public
    { Public 宣言 }
  end;

type
  //---------------------------------------------------------------------------
  //  UrlDownloadToFileのコールバッククラス
  //  ネット上のhttp://www.delphipraxis.net/topic75,0,asc,0.htmlを利用
  //  TObject,IUnknown,IBindStatusCallbackを以下に変更
  //  QueryInterfaceを削除(TInterfacedObjectにある)
  //  _AddRefと_Releaseは参照カウンタの制御に必要なので実装
  //---------------------------------------------------------------------------
  cDownloadStatusCallback = class(TInterfacedObject, IBindStatusCallback)
  private
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo):
      HResult; stdcall;
    function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc:
      PFormatEtc; stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
  end;

var
  Form1: TForm1;
  usercancel: Boolean = False;

implementation

uses HTTPApp;

{$R *.dfm}

//=============================================================================
//  ダウンロード開始
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  Source : String;
  Dest   : String;
begin
  Source := 'http://mrxray.on.coocan.jp/Delphi/ZipExe/plSetPrinter.zip';
  Dest   := ExtractFilePath(Application.ExeName) +
            ExtractFileName(UnixPathToDosPath(Source));

  usercancel := False;

  DownloadFile(Source, Dest);
end;

//=============================================================================
//  [Abort]つまりキャンセルボタン
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  usercancel := True;
end;

//=============================================================================
//  ファイルをダウンロードする関数
//  SourceFileで指定するファイルがないか，DestFile名が無効の場合はFalseを返す
//  またネットワーク接続不可の場合もFalseを返す
//  usesにUrlMonが必要
//
//  SourceFile : ダウンロードするファイルのURL
//               このサンプルの場合は http://...  .zip という文字列
//               画像をダウンロードしたい場合は http://...  .gif 等
//               ページのソースならば http://....  .html 等
//  DestFile   : 保存先のフルパス名
//               例えば C:\MyFolder\XXXX.zip 等　
//=============================================================================
function TForm1.DownloadFile(Source, Dest: String): Boolean;
var
  cDownStatus : cDownloadStatusCallback;
begin
  //コールバック用クラスの生成
  cDownStatus := cDownloadStatusCallBack.Create;
  try
    try
      //UrlDownloadToFile関数はIEのキャッシュを優先してDLする
      //GetBindInfoで設定読出しが可能なようだが，コールバック内で設定する必要が
      //あるので，DeleteUrlCacheEntryであらかじめIEキャッシャ内の該当ファイルを
      //削除してしまった方が簡単
      DeleteUrlCacheEntry(PChar(Source));
      Result := UrlDownloadToFile(nil,
                                  PChar(Source),
                                  PChar(Dest),
                                  0,
                                  CDownStatus) = 0;
    except
      Result:= False;
    end;
  finally;
    cDownStatus.Free;
  end;
end;

{ cDownloadStatusCallback }

//-----------------------------------------------------------------------------
function cDownloadStatusCallback._AddRef: Integer;
begin
  Result := 0;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback._Release: Integer;
begin
  Result := 0;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback.OnStartBinding(dwReserved: DWORD;
  pib: IBinding): HResult;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback.GetPriority(out nPriority): HResult;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback.OnLowResource(reserved: DWORD): HResult;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback.OnStopBinding(hresult: HResult;
  szError: LPCWSTR): HResult;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback.OnDataAvailable(grfBSCF, dwSize: DWORD;
  formatetc: PFormatEtc; stgmed: PStgMedium): HResult;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback.OnObjectAvailable(const iid: TGUID;
  punk: IInterface): HResult;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
function cDownloadStatusCallback.OnProgress(ulProgress, ulProgressMax,
  ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult;
begin
  case ulStatusCode of
    BINDSTATUS_BEGINDOWNLOADDATA:
    begin
      Form1.Gauge1.Progress := 0;
      //ダウンロード開始;
      if (UserCancel) then
      begin
        Result := E_ABORT;
        exit;
      end;
    end;
    BINDSTATUS_DOWNLOADINGDATA:
    begin
      Form1.Gauge1.Progress := MulDiv(ulProgress, 100, ulProgressMax);
      //ダウンロード中
      if (UserCancel) then
      begin
        Result := E_ABORT;
        exit;
      end;
    end;
    BINDSTATUS_ENDDOWNLOADDATA:
    begin
    //ダウンロード終了
    end;
  end;
  Application.ProcessMessages;

  Result := S_OK;
end;

end.

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

uses ExtActns, HTTPApp;

{$R *.dfm}

//=============================================================================
//  TDownLoadURLを使用したファイルのダウンロード
//  TDownLoadURLはTActionListで指定可能なアクションクラス
//
//  TDownLoadURLの使用にはusesにExtActnsが必要
//  UnixPathToDosPathの使用にはusesにHTTPAppが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ActClass : TDownLoadURL;
  URL      : String;
  SavePath : String;
begin
  ActClass := TDownLoadURL.Create(Self);
  try
    //ダウンロードするファイルとその保存ファイル名
    URL      := 'http://mrxray.on.coocan.jp/Delphi/plSamples/Images/AutoDL_03.gif';
    SavePath := ExtractFileName(UnixPathToDosPath(URL));
    SavePath := ExtractFilePath(Application.ExeName) + SavePath;

    //プロパティをセット
    ActClass.URL      := URL;
    ActClass.Filename := SavePath;

    //実行
    //ActClass.ExecuteTarget(Self);でもOK
    ActClass.Execute;
  finally
    FreeAndNil(ActClass);
  end;
end;

end.