はじめに
VCL Scanner というのは Delphi / C++Builder で作られたアプリをローカルドライブから検出するツールです。意外なツールが Delphi / C++Builder 製だったりして面白い発見があったりしました。製品の一部だけが Delphi 製とかもありましたね。
以前は Borland 社がバイナリを配布していましたが今では配布されていません。
(今、Borland 社って存在しないですしね)
この記事は VCL Scanner を Delphi 10.2 の無償版である Starter Edition でコンパイルしてみようというものです。
VCL Scanner の入手
現在の Delphi / C++Builder の開発元である Embarcadero 社のサイトには、この VCL Scanner のソースコードが公開されています。以下からダウンロードできます。ダウンロードしたらアーカイブを適当な場所に解凍しておきます。
プロジェクトを開く
Delphi 10.2 Starter Edition でプロジェクトを開きます [ファイル(F) | 開く(O)...]。
Oh！タイムスタンプが 2000 年になっていますね。そして開こうとするとエラーが出ます。
これは現在の Delphi には含まれない NetManage 製のインターネットコンポーネントが使われているからです。インターネットコンポーネントが何に使われているのかというと VCL Scanner が検出した Delphi / C++Builder 製コンポーネントの調査結果をメールで Borland に送信する機能のために使われています。
今更 Borland にメールを送信しても仕方がないので [すべて無視] を押してください。
コンパイルが通るようにする
まず、ソースコード中の Char を AnsiChar に置換してください。置換は〔Ctrl〕+〔R〕です。
全置換しましょう。これはこのツールが作られた時のコンパイラである Delphi 5 は ANSI 版のコンパイラであったのに対し、現在のコンパイラは Unicode 版であるからです。Unicode 版コンパイラの Char は WideChar なのです。
以降、コンパイルしながら不具合をつぶします。
先程、NetManage コンポーネントを無視したのでこのエラーが出ます。すべて [はい] を押して宣言を削除します。
今度は Psock でエラーが出たと思います。これも NetManage 絡みなので削除します。Psock, NMsmtp, NMpop3, を削除してください。
{$UNDEF DEBUG}
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, FileCtrl, CheckLst, jpeg, ComCtrls;
次は btnNext4Click() で止まります。メール絡みなので、{} を使いブロックコメントでコメントアウトします。削除しても構いません。
procedure TfrmMain.btnNext4Click(Sender: TObject);
var
Company : String;
CRC : DWORD;
begin
if rbSelf.Checked then begin
if (Pos('@',cbSelf.Text) = 0) or (Pos('.',cbSelf.Text) = 0) or
(Pos('@',cbSelf.Text)+1 >= RPos('.',PChar(cbSelf.Text))) then begin
Application.MessageBox('You have selected to send to yourself for test purposes. Make sure your email address is filled in correctly.','Check email...',0);
Exit;
end;
if cbSMTP.Text = DefaultSMTPServer then begin
Application.MessageBox('You cannot use Borland''s SMTP server to send to yourself. Please use your own server for this purpose.','Check server...',0);
Exit;
end;
end;
{
with Mail, PostMessage do begin
ClearParams := False;
Host := cbSMTP.Text;
UserID := eUserID.Text;
if Host = DefaultSMTPServer then begin
Host := DefaultSMTPAddress;
UserID := DefaultUserID;
end;
Subject := 'VCL Usage Report';
if cbAnonymous.Checked then begin
FromAddress := 'anonymous@borland.com';
FromName := 'Anonymous';
Company := 'Anonymous';
end else begin
FromAddress := cbEmail.Text;
FromName := cbName.Text;
Company := cbCompany.Text;
end;
if rbSelf.Checked then
ToAddress.Text := cbSelf.Text
else
ToAddress.Text := DefaultToAddress;
Body.Text := '[UserData]'#13#10+
'User Number='+IntToStr(SerialNumber)+#13#10+
'Name='+FromName+#13#10+
'Email='+FromAddress+#13#10+
'Company='+Company+#13#10+
#13#10+
reResults.Text;
reFinalResults.Text := 'From: '+FromName+' <'+FromAddress+'>'#13#10+
'To: ';
if rbSelf.Checked then
reFinalResults.Text := reFinalResults.Text+ToAddress.Text
else
reFinalResults.Text := reFinalResults.Text+'Borland'#13#10;
reFinalResults.Text := reFinalResults.Text+
'Subject: '+Subject+#13#10+
#13#10+
Body.Text
end;
}
gbStep5.BringToFront;
gbStep4.Enabled := False;
gbStep5.Enabled := True;
end;
次は btnBack5Click() で止まります。これもメール絡みなので、{} を使いブロックコメントでコメントアウトします。削除しても構いません。
procedure TfrmMain.btnNext5Click(Sender: TObject);
begin
frmStatus := TfrmStatus.Create(nil);
frmStatus.Caption := 'Sending report...';
frmStatus.Label1.Caption := '';
frmStatus.Animate1.Active := True;
frmStatus.Show;
Enabled := False;
try
try
{
with Mail do begin
frmStatus.Label2.Caption := 'Connecting to '+Host+'...';
try
Connect;
except
if Host <> DefaultSMTPAddress then begin
POP.Host := Host;
POP.UserID := UserID;
POP.Connect;
end;
Connect;
end;
frmStatus.Label2.Caption := 'Connected. Sending report...';
SendMail;
frmStatus.Label2.Caption := 'Done. Disconnecting...';
Disconnect;
if POP.Connected then
POP.Disconnect;
end;
}
frmStatus.Close;
frmStatus.Free;
gbFinish.BringToFront;
gbStep5.Enabled := False;
gbFinish.Enabled := True;
except
Application.MessageBox('Something went wrong while sending your report. Go back and try changing the SMTP settings.','Sending mail failed...',0);
frmStatus.Close;
frmStatus.Free;
end;
finally
Enabled := True;
end;
end;
次は ExcludeFile() で止まります。GetFileVersionInfoSize() は Unicode 版 API なのに、PAnsiChar でキャストしているからです。さっき一括置換してしまいましたからね。この関数内の PAnsiChar を PChar に戻します。
function TfrmMain.ExcludeFile(const FileName: String): Boolean;
const
InfoNum = 2;
InfoStr : array [1..InfoNum] of String =
('CompanyName', 'LegalCopyright');
var
n, Len, i : Cardinal;
Buf : PAnsiChar; // <- ここ
Value : PAnsiChar; // <- ここ
begin
Result := False;
n := GetFileVersionInfoSize(PChar(FileName),n); // <- ここ
if n > 0 then begin
Buf := AllocMem(n);
GetFileVersionInfo(PAnsiChar(FileName),0,n,Buf); // <- ここ
for i:=1 to InfoNum do
if VerQueryValue(Buf,PChar('StringFileInfo\040904E4\'+
InfoStr[i]),Pointer(Value),Len) then begin
Result := (Pos('Borland',Value) <> 0) or (Pos('Inprise',Value) <> 0) or (Pos('InterBase',Value) <> 0);
if Result then
Break;
end;
FreeMem(Buf,n);
end;
end;
次は BannerTimerTimer() で止まります。定数 BannerInFront に代入しているからです。素直に変数にすればいいものを...
var
frmMain: TfrmMain;
implementation
{$R *.DFM}
uses
Registry, UrlMon, Status, Debug, ShellAPI, CRC32;
type
TBannerInFront = (bDelphi, bBCB, bLinux);
const
DefaultSMTPServer = 'Borland SMTP Server';
DefaultSMTPAddress = 'smtp.yourcompany.com';
DefaultUserID = 'destinationuserid';
DefaultToAddress = DefaultUserID+'@yourcompany.com';
var
BannerInFront: TBannerInFront; // var にする
BannerInFront を変数にし、BannerInFront の初期値を FormCreate() 内で指定します。
procedure TfrmMain.FormCreate(Sender: TObject);
begin
BannerInFront := bDelphi; // 追加
// Kludge to randomize what banner starts...
Randomize;
case Random(3) of
...
次は POPAuthenticationNeeded() で止まりますが、このイベントハンドラは使われていません。ブロックコメントにしましょう。
{
procedure TfrmMain.POPAuthenticationNeeded(var Handled: Boolean);
begin
POP.UserID := InputBox('Server authentication needed...','POP3 UserID','');
POP.Password := InputBox('Server authentication needed...','POP3 Password','');
Handled := True;
end;
}
定義部もコメントアウトします。
...
procedure btnUncheckSelectedClick(Sender: TObject);
// procedure POPAuthenticationNeeded(var Handled: Boolean); // コメントアウト
procedure btnBack7Click(Sender: TObject);
private
{ Private declarations }
ResList : TStringList;
Excludes : TStringList;
...
コンパイルが通るようになりましたが、メッセージウィンドウにワーニングが出ていますのでこれを潰します。
プロジェクトの依存関係を確認中...
VCLScanner.dproj をビルド中 (Debug, Win32)
brcc32 の "VCLScanner.vrc" コマンド ライン
dcc32 の "VCLScanner.dpr" コマンド ライン
[dcc32 警告] Main.pas(9): W1005 ユニット 'Vcl.FileCtrl' は特定のプラットフォームに固有のものです
[dcc32 ヒント] Main.pas(665): H2164 変数 'Company' が宣言されていますが 'TfrmMain.btnNext4Click' の中では使われていません
[dcc32 ヒント] Main.pas(666): H2164 変数 'CRC' が宣言されていますが 'TfrmMain.btnNext4Click' の中では使われていません
[dcc32 ヒント] Main.pas(1399): H2443 インライン関数 'Point' はユニット 'System.Types' が USES リストで指定されていないため展開されません
[dcc32 ヒント] Main.pas(1404): H2443 インライン関数 'Point' はユニット 'System.Types' が USES リストで指定されていないため展開されません
成功
経過時間: 00:00:06.4
最初のプラットフォームの警告は、Delphi がマルチプラットフォーム対応になってから出るようになったものですね。Windows 固有の機能を使おうとしているのでワーニングが出ます。これは無視しても構わないのですが {$WARN UNIT_PLATFORM OFF} を先頭の方に追加すれば消すことができます。
{$UNDEF DEBUG}
{$WARN UNIT_PLATFORM OFF} // <- 追加
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, FileCtrl, CheckLst, jpeg, ComCtrls;
...
Company と CRC という使われていない変数は btnNext4Click() ですね。さっきコメントアウトした箇所でしか使われていなかったようです。ブロックコメントで止めるか削除しましょう。Company と CRC だけ消すと空の var ブロックが残ってしまうので、こちらも消しておきます。
procedure TfrmMain.btnNext4Click(Sender: TObject);
{
var
Company : String;
CRC : DWORD;
}
begin
if rbSelf.Checked then begin
if (Pos('@',cbSelf.Text) = 0) or (Pos('.',cbSelf.Text) = 0) or
(Pos('@',cbSelf.Text)+1 >= RPos('.',PChar(cbSelf.Text))) then begin
Application.MessageBox('You have selected to send to yourself for test purposes. Make sure your email address is filled in correctly.','Check email...',0);
Exit;
end;
if cbSMTP.Text = DefaultSMTPServer then begin
Application.MessageBox('You cannot use Borland''s SMTP server to send to yourself. Please use your own server for this purpose.','Check server...',0);
Exit;
end;
end;
...
最後の System.Types がどうのこうのも無視して構わないのですが、uses の最後に Types を追加すれば消せます。System.Types を追加しても構いません。古いバージョンとの互換性のために、名前空間を一部省略する事が可能となっています。
{$UNDEF DEBUG}
{$WARN UNIT_PLATFORM OFF}
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, FileCtrl, CheckLst, jpeg, ComCtrls, Types; // <- 追加
これですべてのエラーとワーニングを消すことができました。
ですが、このままだと判定ロジックがうまく動きません。EnumFunc() を以下のように修正します。
function EnumFunc(Instance: THandle; ResType: Integer; ResName: PChar; lParam: LongInt): Boolean; stdcall;
var
Buffer: PAnsiChar;
begin
Buffer := LockResource(LoadResource(Instance,FindResource(Instance,ResName,RT_RCDATA)));
if Pos('TPF0', String(AnsiString(Buffer))) = 1 then
frmMain.ResList.Add(ResName);
Result := True;
end;
これですべての修正が完了しました。
VCL Scanner の使い方
VCL Scanner をコンパイルして実行してみましょう。
[Next] ボタンを押します。
探索したいフォルダを選び [Next] ボタンを押します。下のチェックボックスにチェックを入れればすべての (固定) ドライブをスキャンできます。スキャンが完了し、Delphi / C++Builder 製アプリを検出すると以下のような画面になります。
左下の [More info...] を押すとスキャンから除外したいフォルダやファイルを指定できます。
[Next] ボタンを押すと多分エラーになります。ここから先は労力の割に大した事をやっていません。
Step 3 以降は Borland にメールを送る算段なのです。この先を見たいのならエラーで止まる箇所を片っ端からコメントアウトすればいいと思います。
おわりに
Delphi Professional 以上の製品を購入すると旧製品が入手可能ですので、もっと簡単にコンパイルできると思います。例えば Delphi 2007 なら NetManage の部分を無視するだけでコンパイルできると思います。
旧製品で入手できる最古の Delphi は バージョン 7 なのですが、惜しいことに NetManage がバンドルされているのは Delphi 6 までなんですよね。
それと、この VCL Scanner ですが、名前の通り VCL を検出して Delphi / C++Builder 製かどうかを判定していますが、最近の Delphi には FireMonkey フレームワークがあるため、FireMonkey アプリケーションは検出できないかもしれません。
この記事を書いておいて身も蓋もないのですが、Delphi / C++Builder 製アプリかどうかってバイナリエディタにかければ大体判るんですよね (w
See Also: