エクスプローラからのファイルのドラッグアンドドロップを受け入れる

エクスプローラからファイルをドラッグアンドドロップで受け入れるにはDragAcceptFilesで受け入れを許可し、WM_DROPFILESメッセージで通知を受け付け、DragQueryFileでドロップされた各ファイルを受け取ります。ドロップ先がフォームであれば普通にメッセージハンドラを記述すればよいのですが、特定の(TWinControlから派生した)コントロールで受け入れるためにはウィンドウプロシージャを置き換える必要があり、ちょっとハードルが高くなってしまいます。

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;
  public
  end;

procedure TForm1.FormCreate(Sender: TObject);
begin

  { Enable to accept drop files }
  DragAcceptFiles(Handle,True);

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin

  { Disable to accept drop files }
  DragAcceptFiles(Handle,False);

end;

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
  Index: Integer;
  Count: Integer;
  Size: Integer;
  Filename: String;
begin

  try
    { Get dropped filename }
    Count := DragQueryFile(Msg.Drop,DWORD(-1),nil,0);

    for Index := 0 to Count - 1 do
    begin
      { Get filename length }
      Size := DragQueryFile(Msg.Drop,Index,nil,0) + 1;

      { Get filename }
      SetLength(Filename,Size);
      Size := DragQueryFile(Msg.Drop,Index,PChar(Filename),Size);
      SetLength(Filename,Size);

      ListBox1.Items.Add(Filename)
    end;

  finally
    { Finish }
    DragFinish(Msg.Drop);
  end;

end;

Object Pascal

2010/08/04追記: Windows Vista/7ではUIPI(User Interface Privilege Isolation、ユーザインタフェース特権分離)により、下位IL(Integrity Level)のプロセスから上位ILのプロセスに対して通信(メッセージを含む)を行うことができなくなっています。WindowsのExplorer(explorer.exe)は中IL(medium integrity level)で起動されていますから、高IL(high integrity level)で実行しているプログラムに対してファイルをドラッグアンドドロップすることはできない、ということになります。特にIDEを管理者権限で実行している場合、デバッグプロセスも管理者権限(=高IL)で実行されるため注意が必要です。詳しくはWindows Integrity Mechanism Designを参照してください。元ねたは公式フォーラムのエクスプローラからのドラッグ＆ドロップスレッドの高橋さんの回答と、そこにリンクされているMicrosoftのVisual Studioフォーラムの管理者として起動したVS2005でデバッグするとWM_DROPFILESが発生しないスレッド。

ファイル名を長い形式に変換(GetLongPathName版)

Win32APIのGetLongPathNameを使用して8.3形式の短いファイル名(Short File Name)の混じったフルパス名を全て長いファイル名(Long File Name)に変換する方法です。Windows 2000以降でのみ動作します。

uses
  Windows, SysUtils;

type
  TGetLongPathNameFunc = function(lpszShortPath: PChar;
                                  lpszLongPath: PChar;
                                  cchBuffer: DWORD): DWORD; stdcall;

function ToLongFilename(const Filename: String): String;
var
  Size: Integer;
  GetLongPathName: TGetLongPathNameFunc;
begin

  Result := Filename;

  if (Win32Platform = VER_PLATFORM_WIN32_NT) and
     (Win32MajorVersion >= 5) then  // Windows 2000 or later
  begin
    @GetLongPathName := GetProcAddress(GetModuleHandle('Kernel32.dll'),
{$IFDEF Unicode}
                                       'GetLongPathNameW');
{$ELSE}
                                       'GetLongPathNameA');
{$ENDIF}
    if Assigned(GetLongPathName) = True then
    begin
      { Calculate buffer size }
      Size := GetLongPathName(PChar(Filename),nil,0);
      if Size = 0 then
      begin
        Exit;
      end;

      { Convert to long name }
      SetLength(Result,Size);
      Size := GetLongPathName(PChar(Filename),PChar(Result),Size);
      SetLength(Result,Size);
    end;
  end;

end;

Object Pascal

この例でもGetShortPathNameを使用する場合と同様に、対象となるファイルが存在しないと最初のGetLongPathName呼び出しで0が返ってきて変換不能になってしまうため、注意が必要です。

2018/11/08追記: TGetLongPathNameFuncの宣言で引数名が入れ替わっていたものを修正。ご指摘ありがとうございます。

ファイル名を短い形式に変換

長いファイル名(Long File Name)の混じったフルパス名を全て8.3形式の短いファイル名(Short File Name)に変換する(あまりあり得ない状況だとは思いますけど)にはGetShortPathNameを使用します。

uses
  Windows;

function ToShortFilename(const Filename: String): String;
var
  Size: Integer;
begin

  { Calculate buffer size }
  Size := GetShortPathName(PChar(Filename),nil,0);
  if Size = 0 then
  begin
    Result := Filename;
    Exit;
  end;

  { Convert to short name }
  SetLength(Result,Size);
  Size := GetShortPathName(PChar(Filename),PChar(Result),Size);
  SetLength(Result,Size);

end;

Object Pascal

ただし対象となるファイルが存在しないと最初のGetShortPathName呼び出しで0が返ってきて変換不能になってしまうため、注意が必要です(この例では渡されたパス名をそのまま返すようにしています)。

FastMM4.84リリース

Delphi/C++Builder用のメモリマネージャFastMMが4.84に更新されています。Team Japan » C++Builder with FastMM 4.84からの情報。
何が変更されたのかの確認はこれから。

ファイル名を長い形式に変換

8.3形式の短いファイル名(Short File Name)の混じったフルパス名を全て長いファイル名(Long File Name)に変換するには、それぞれのディレクトリ/ファイル名を、FindFirstFileで得られるTWin32FindData(WIN32_FIND_DATA)構造体のcFileNameに格納されている長い名前で置き換えていきます。

uses
  Windows, SysUtils;

function ToLongFilename(const Filename: String): String;
var
  Path: String;
  BaseName: String;
  H: THandle;
  FD: TWin32FindData;
begin

  { Separate to path and base name }
  Path := ExtractFileDir(Filename);
  if Path = Filename then
  begin
    Result := Filename;
    Exit;
  end;
  BaseName := ExtractFileName(Filename);

  { Convert (recursive) }
  Path := ToLongFilename(Path);

  { Search using FindFirstFile/FindClose }
  Result := IncludeTrailingPathDelimiter(Path) + BaseName;
  H := Windows.FindFirstFile(PChar(Result),FD);
  if H = INVALID_HANDLE_VALUE then
  begin
    Exit;
  end;
  Windows.FindClose(H);

  Result := IncludeTrailingPathDelimiter(Path) + FD.cFileName;

end;

Object Pascal

SFNに変換するGetShortPathNameのようにGetLongPathNameを使えばいいのかと思いきや、これではWindows NT 4.0が対象外になってしまいます。ターゲットをWindows 2000以降に限定するならいいのですけど。

仮想リストビュー

ListViewはWindowsのコモンコントロールですが、表示件数が100件を超えるあたりから処理がどんどん重くなっていき、10000件あたりになるとクリアするだけでも数秒掛かるようになってしまいます。そこで表示件数が多くなることが想定される場合は仮想リストビューを使用します。といってもListItemを追加、変更、削除する代わりにOwnerDataをTrueにした状態でCountを変更するかInvalidateで表示を無効化し、OnDataイベントで渡されたListItemのCaptionおよびSubItemsを設定するだけです。

procedure TForm1.ListView1Data(Sender: TObject; Item: TListItem);
begin

  try
    Item.Caption := 'Line ' + IntToStr(Item.Index);
    Item.SubItems.Clear;
    Item.SubItems.Add('2nd column');
    Item.SubItems.Add('3rd column');

  except
    { Ignore exceptions }
  end;

end;

Object Pascal

ただし仮想リストビューにした場合はListView_SetColumnWidthでLVSCW_AUTOSIZEやLVSCW_AUTOSIZE_USEHEADERを指定することはできません。

ListViewのカラムの幅を調整する

ListViewのカラムの幅をそのカラム内の文字列の最も長いものにあわせるにはListView_SetColumnWidthでカラム幅としてLVSCW_AUTOSIZEを指定します。

begin

  ListView_SetColumnWidth(ListView1.Handle,0,LVSCW_AUTOSIZE);

end;

Object Pascal

第2パラメータはカラムのインデックスです。
またカラムヘッダの文字列も含めて幅を合わせるときはLVSCW_AUTOSIZE_USEHEADERを指定します。

begin

  ListView_SetColumnWidth(ListView1.Handle,0,LVSCW_AUTOSIZE_USEHEADER);

end;

Object Pascal

なお仮想リストビューではうまくいきません。

StringBuilder

Delphi 2009で追加されるTStringBuilderは
Building strings with TStringBuilder
こんなものらしいです。CLRからDelphi.NET経由で今回導入となったようですが、う～ん？
C++のostreamに<<で出力していくようなイメージなんでしょうか。

第10回エンバカデロ・デベロッパーキャンプ

第10回エンバカデロ・デベロッパーキャンプは2008年09月09日(大阪は11日)開催だそうです。今回のスコッツバレーからの来日はNick Hodgesさん(Delphi Product Manager)。それにしてもアグレッシブな企画ですね。出演者(参加者じゃなくて)は集まるのかいな？

リストビューコントロールのReport形式で行毎に背景色を変える

リストビューコントロール(TListView)のReport形式で行毎に背景色を変えるにはOnCustomDrawItemイベントでSender.Canvas.Brush.Colorを変更します。

procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
                                         Item: TListItem; 
                                         State: TCustomDrawState; 
                                         var DefaultDraw: Boolean);
begin

  if (Item.Index mod 2) = 0 then
  begin
    Sender.Canvas.Brush.Color := $FFE0FF;
  end
  else
  begin
    Sender.Canvas.Brush.Color := $FFFFE0;
  end;

end;

Object Pascal

Canvasの属性だけを変更して実際の描画はDefaultDraw = TrueのままでTListViewに任せるのがポイントです。
同じように文字の色やスタイルなどの属性を変えるにはSender.Canvas.Font.ColorやSender.Canvas.Font.Styleを変更します。

procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
                                         Item: TListItem;
                                         State: TCustomDrawState;
                                         var DefaultDraw: Boolean);
begin

  if cdsSelected in State then
  begin
    Sender.Canvas.Font.Style := Sender.Canvas.Font.Style + [fsBold];
  end;

end;

Object Pascal

Delphi 2009のジェネリクスと匿名メソッド

Delphiの新機能のうちジェネリクス(Generics)と匿名メソッド(Anonymous methods)は
Sip from the Firehose : Tiburon - new language features for Delphi 2009
こんな感じになります。

Windowsをログオフ/リブート/シャットダウンする

Windowsをログオフ/リブート/シャットダウンするにはExitWindowsExを呼び出すのですが、NT系のOSではそれなりの特権をOpenProcessToken/LookupPrivilegeValue/AdjustTokenPrivilegesで取得しておく必要があります。

uses
  Windows, Forms, SysUtils;

{$WARN SYMBOL_PLATFORM OFF}
procedure ShutdownWindows(Flags: DWORD);
var
  TokenHandle: THandle;
  ReturnLength: DWord;
  NewTKP: TTokenPrivileges;
begin

  { Set shutdown privilege }
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    { Get current process token }
    Win32Check(OpenProcessToken(GetCurrentProcess,
                                TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
                                TokenHandle));

    { Get privilege }
    Win32Check(LookupPrivilegeValue(nil,'SeShutdownPrivilege',
                                  NewTKP.Privileges[0].Luid));

    { New privilege }
    NewTKP.PrivilegeCount := 1;
    NewTKP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

    { Get privilege for setting date and time }
    ReturnLength := 0;
    Win32Check(AdjustTokenPrivileges(TokenHandle,False,NewTKP,0,nil,ReturnLength));
    if GetLastError <> ERROR_SUCCESS then
    begin
      RaiseLastOSError;
    end;
  end;

  { ExitWindowsEx }
  Win32Check(ExitWindowsEx(Flags,0));

  { Terminate application }
  Application.Terminate;

end;
{$IFDEF VER200}  // Delphi 2009 or later
{$WARN SYMBOL_PLATFORM DEFAULT}
{$ELSE}
{$WARN SYMBOL_PLATFORM ON}  
{$ENDIF}

const
  CForceIfHung: array [Boolean] of DWORD = (0,EWX_FORCEIFHUNG);

procedure LogOff(ForceIfHung: Boolean);
begin

  ShutdownWindows(EWX_LOGOFF or CForceIfHung[ForceIfHung]);

end;

procedure PowerOff(ForceIfHung: Boolean);
begin

  ShutdownWindows(EWX_POWEROFF or CForceIfHung[ForceIfHung]);

end;

procedure Reboot(ForceIfHung: Boolean);
begin

  ShutdownWindows(EWX_REBOOT or CForceIfHung[ForceIfHung]);

end;

procedure Shutdown(ForceIfHung: Boolean);
begin

  ShutdownWindows(EWX_SHUTDOWN or CForceIfHung[ForceIfHung]);

end;

Object Pascal

Blogger Syntax Highlighter

コード部分をBlogger Syntax Highlighterで見やすくしてみました。

全角→半角変換

文字列中の全角文字を(可能な範囲で)半角に変換するのにもLCMapStringを使用します。ちなみにLCMapStringのA版はバイト数で、W版は文字数で長さを扱うので注意が必要です。

uses
  Windows;

function ZenkakuToHankaku(const Str: String): String;
{$IFNDEF UNICODE}
const
  TestStr: String = '亜';
{$ENDIF}
var
  Size: Integer;
  Flags: DWORD;
{$IFNDEF UNICODE}
  Multiplier: Integer;
{$ENDIF}
begin

  Flags := LCMAP_HALFWIDTH;
{$IFNDEF UNICODE}
  Multiplier := 1;
{$ENDIF}

  { Calculate destination size }
{$IFNDEF UNICODE}
  if LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,
                 PChar(TestStr),Length(TestStr),nil,0) = 1 then
  begin
    Multiplier := 2;
  end;
{$ENDIF}
  Size := LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,
                      PChar(Str),Length(Str),nil,0);
{$IFNDEF UNICODE}
  Size := Size * Multiplier;
{$ENDIF}

  { Convert }
  SetLength(Result,Size);
  Size := LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,
                      PChar(Str),Length(Str),PChar(Result),Size);
  if Size <= 0 then
  begin
    Result := Str;
    Exit;
  end;
  SetLength(Result,Size);

end;

Object Pascal

2011/05/19追記: Windows 7の互換モードにおけるLCMapStringの不具合を回避するため、ANSI版の動作を修正しました。オリジナルのコードはこちら。

uses
  Windows;

function ZenkakuToHankaku(const Str: String): String;
var
  Size: Integer;
  Flags: DWORD;
begin

  Flags := LCMAP_HALFWIDTH;

  { Calculate destination size }
  Size := LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,PChar(Str),Length(Str),nil,0);

  { Convert }
  SetLength(Result,Size);
  Size := LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,
                      PChar(Str),Length(Str),PChar(Result),Size);
  if Size <= 0 then
  begin
    Result := Str;
    Exit;
  end;
  SetLength(Result,Size);

end;

Object Pascal

半角→全角変換

LCMapStringを使用して文字列中の英数字を全角英数字に、いわゆる半角カタカナおよびひらがなを全角カタカナに、それぞれ変換します。第2パラメータを変更することで変換の動作を変更することもできます。

uses
  Windows;

function KanaToZenkaku(const Str: String): String;
{$IFNDEF UNICODE}
const
  TestStr: String = 'A';
{$ENDIF}
var
  Size: Integer;
  Flags: DWORD;
{$IFNDEF UNICODE}
  Multiplier: Integer;
{$ENDIF}
begin

  Flags := LCMAP_FULLWIDTH or LCMAP_KATAKANA;
{$IFNDEF UNICODE}
  Multiplier := 1;
{$ENDIF}

  { Calculate destination size }
{$IFNDEF UNICODE}
  if LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,
                 PChar(TestStr),Length(TestStr),nil,0) = 1 then
  begin
    Multiplier := 2;
  end;
{$ENDIF}
  Size := LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,
                      PChar(Str),Length(Str),nil,0);
{$IFNDEF UNICODE}
  Size := Size * Multiplier;
{$ENDIF}

  { Convert }
  SetLength(Result,Size);
  Size := LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,
                      PChar(Str),Length(Str),PChar(Result),Size);
  if Size <= 0 then
  begin
    Result := Str;
    Exit;
  end;
  SetLength(Result,Size);

end;

Object Pascal

2011/05/19追記: Windows 7の互換モードにおけるLCMapStringの不具合を回避するため、ANSI版の動作を修正しました。オリジナルのコードはこちら。

uses
  Windows;

function KanaToZenkaku(const Str: String): String;
var
  Size: Integer;
  Flags: DWORD;
begin

  Flags := LCMAP_FULLWIDTH or LCMAP_KATAKANA;

  { Calculate destination size }
  Size := LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,PChar(Str),Length(Str),nil,0);

  { Convert }
  SetLength(Result,Size);
  Size := LCMapString(LOCALE_SYSTEM_DEFAULT,Flags,
                      PChar(Str),Length(Str),PChar(Result),Size);
  if Size <= 0 then
  begin
    Result := Str;
    Exit;
  end;
  SetLength(Result,Size);

end;

Object Pascal

リモートPCの共有パスに接続する

Microsoftファイル共有でリモートPCの共有パスに接続するときはWNetAddConnection2を、接続を解除するときはWNetCancelConnection2を使用します。

uses
  Windows;

procedure DoLogOn(var RemotePath: String; const UserName: String;
                  const Password: String);
var
  NR: TNetResource;
  Win32Result: Integer;
begin

  { Check local path }
  if (RemotePath = '') or (Copy(RemotePath,1,2) <> '\\') then
  begin
    Exit;
  end;

  RemotePath := ExcludeTrailingPathDelimiter(RemotePath);

  with NR do
  begin
    dwType := RESOURCETYPE_ANY;
    lpLocalName := nil;
    lpRemoteName := PChar(RemotePath);
    lpProvider := nil;
  end;

  Win32Result := WNetAddConnection2(NR,PChar(Password),
                                    PChar(UserName),0);
  if Win32Result <> NO_ERROR then
  begin
    RaiseLastOSError(Win32Result);
  end;

end;

procedure DoLogOff(const RemotePath: String);
var
  Pathname: String;
  Win32Result: Integer;
begin

  { Check local path }
  if (RemotePath = '') or (Copy(RemotePath,1,2) <> '\\') then
  begin
    Exit;
  end;

  Win32Result := WNetCancelConnection2(PChar(Pathname),0,False);
  if Win32Result <> NO_ERROR then
  begin
    RaiseLastOSError(Win32Result);
  end;

end;

Object Pascal

年齢の計算

任意の日付における生物学的(?)年齢を計算する方法。日本の法律では誕生日の前日の満了を以って年齢が加算される(明治三十五年法律第五十号(年齢計算ニ関スル法律)、民法(明治二十九年四月二十七日法律第八十九号)第百四十三条および年齢のとなえ方に関する法律(昭和二十四年五月二十四日法律第九十六号))ため、法的年齢を要求される場合は注意が必要です。

uses
  Windows, SysUtils;

function GetAge(ABirthday: TDateTime; ABase: TDateTime;
                var AYear: Integer; var AMonth: Integer;
                var ADate: Integer; var AWeek: Integer): Integer;
var
  DT: TDateTime;
  ST1: TSystemTime;
  ST2: TSystemTime;
  ST3: TSystemTime;
begin

  { Decode }
  DecodeDate(ABirthday,ST1.wYear,ST1.wMonth,ST1.wDay);
  DecodeDate(ABase,ST2.wYear,ST2.wMonth,ST2.wDay);

  AYear  := ST2.wYear  - ST1.wYear;
  AMonth := ST2.wMonth - ST1.wMonth;
  ADate  := ST2.wDay   - ST1.wDay;

  if (ST1.wMonth > ST2.wMonth) or
     ((ST1.wMonth = ST2.wMonth) and (ST1.wDay > ST2.wDay)) then
  begin
    AYear  := AYear  -  1;
    AMonth := AMonth + 12;
  end;

  { Regulate date }
  if ADate < 0 then
  begin
    AMonth := AMonth - 1;

    ST3.wYear  := ST1.wYear  + AYear;
    ST3.wMonth := ST1.wMonth + AMonth;
    ST3.wDay   := ST1.wDay;
    if ST3.wMonth > 12 then
    begin
      ST3.wYear  := ST3.wYear  +  1;
      ST3.wMonth := ST3.wMonth - 12;
    end;

    DT := ABase;
{$IFDEF CONDITIONALEXPRESSIONS}
    { Delphi 6 or later }
    while TryEncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay,DT) = False do
    begin
      ST3.wDay := ST3.wDay - 1;
    end;
{$ELSE}
    { Delphi 5 or before }
    repeat
      try
        DT := EncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay);

      except
        ST3.wDay := ST3.wDay - 1;
        Continue;
      end;

      Break;
    until False;
{$ENDIF}

    ADate := Trunc(ABase - DT);
  end;

  { Calc weeks }
  DT := ABase;
  ST3.wYear  := ST1.wYear + AYear;
  ST3.wMonth := ST1.wMonth;
  ST3.wDay   := ST1.wDay;
{$IFDEF CONDITIONALEXPRESSIONS}
  { Delphi 6 or later }
  while TryEncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay,DT) = False do
  begin
    ST3.wDay := ST3.wDay - 1;
  end;
{$ELSE}
  { Delphi 5 or before }
  repeat
    try
      DT := EncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay);

    except
      ST3.wDay := ST3.wDay - 1;
      Continue;
    end;

    Break;
  until False;
{$ENDIF}

  AWeek := Trunc(ABase - DT) div 7;

  Result := AYear;

end;

Object Pascal

ABirthdayに誕生日、ABaseに基準日を渡すとAYear/AMonth/ADateに経過年/月/日数が、AYear/AWeekに経過年/週数が格納されます。

2010/12/16追記: 経過日数、経過週数の補正処理の部分で、Delphi 6以降({$IFDEF CONDITIONALEXPRESSIONS}で判別)ではEncodeDateの呼び出しとそこからの例外の送出ではなくTryEncodeDateとその戻値を使用するように変更しました。オリジナルのコードは以下に置いておきます。

uses
  Windows, SysUtils;

function GetAge(ABirthday: TDateTime; ABase: TDateTime;
                var AYear: Integer; var AMonth: Integer;
                var ADate: Integer; var AWeek: Integer): Integer;
var
  DT: TDateTime;
  ST1: TSystemTime;
  ST2: TSystemTime;
  ST3: TSystemTime;
begin

  { Decode }
  DecodeDate(ABirthday,ST1.wYear,ST1.wMonth,ST1.wDay);
  DecodeDate(ABase,ST2.wYear,ST2.wMonth,ST2.wDay);

  AYear  := ST2.wYear  - ST1.wYear;
  AMonth := ST2.wMonth - ST1.wMonth;
  ADate  := ST2.wDay   - ST1.wDay;

  if (ST1.wMonth > ST2.wMonth) or
     ((ST1.wMonth = ST2.wMonth) and (ST1.wDay > ST2.wDay)) then
  begin
    AYear  := AYear  -  1;
    AMonth := AMonth + 12;
  end;

  { Regulate date }
  if ADate < 0 then
  begin
    AMonth := AMonth - 1;

    ST3.wYear  := ST1.wYear  + AYear;
    ST3.wMonth := ST1.wMonth + AMonth;
    ST3.wDay   := ST1.wDay;
    if ST3.wMonth > 12 then
    begin
      ST3.wYear  := ST3.wYear  +  1;
      ST3.wMonth := ST3.wMonth - 12;
    end;

    DT := ABase;
    repeat
      try
        DT := EncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay);

      except
        ST3.wDay := ST3.wDay - 1;
        Continue;
      end;

      Break;
    until False;

    ADate := Trunc(ABase - DT);
  end;

  { Calc weeks }
  DT := ABase;
  ST3.wYear  := ST1.wYear + AYear;
  ST3.wMonth := ST1.wMonth;
  ST3.wDay   := ST1.wDay;
  repeat
    try
      DT := EncodeDate(ST3.wYear,ST3.wMonth,ST3.wDay);

    except
      ST3.wDay := ST3.wDay - 1;
      Continue;
    end;

    Break;
  until False;
  AWeek := Trunc(ABase - DT) div 7;

  Result := AYear;

end;

Object Pascal

ファイルをWindowsの関連付けに従って開く

プログラムの動作状況をログファイルに記録する、というのはよくある話ですが、これをWindowsの関連付けに従って開く(たとえば.LOGファイルをメモ帳やテキストエディタで開く)にはShellExecuteを使用します。

uses
  Windows, Forms, ShellAPI;

procedure OpenFileWithAssociation(const Filename: String);
begin

  ShellExecute(Application.Handle,nil,PChar(Filename),nil,nil,SW_SHOWDEFAULT);

end;

Object Pascal

ログファイルのたぐいも従来は実行ファイルと同じ場所に書き込みね、なんてやっていましたが、Windows XP/VistaではCSIDL_LOCAL_APPDATAの下に配置するのが望ましいってことになり、これをテキストエディタで開こうにもものすごく深いパスにあるわけで、こういう機能をプログラム側で用意しておくと自分が楽ですよね。

UACエレベーションを要求してプログラムを実行

コントロールパネルの"日付と時刻"のようにWindows VistaのUACの対象となるプログラムを起動するにはShellExecuteでverbにrunasを指定します。ただしWindows 2000/XPではrunasを指定できないので代わりにデフォルトを示すNULLを指定します。

uses
  Windows, SysUtils, ShellAPI;

function ExecChildProcessAsAdmin(const CommandLine: String;
                                 const Parameters: String): Boolean;
const
  CRunAs: String = 'runas';
var
  POperation: PChar;
begin

  if Win32MajorVersion >= 6 then
  begin
    POperation := PChar(CRunAs);
  end
  else
  begin
    POperation := nil;
  end;

Result := (ShellExecute(0,POperation,PChar(CommandLine),PChar(Parameters),
                        nil,SW_SHOWNORMAL) > 32);

end;

Object Pascal

これでWindows Vistaでは画面がブラックアウトして確認のダイアログが表示されます。
ちなみにUACエレベーションを要求するrunasというverbは未だにundocumentedみたいです。

2008/11/17追記: ユーザが権限の昇格を拒否した場合、ShellExecuteはFALSE(0)を返し、GetLastErrorの値はERROR_CANCELLED(1223)となります。元ねたはAdvanced Windows 第5版 上 p.144

Delphi/C++Builder 2009

いよいよDelphi/C++Builder 2009(Tiburon)の発売(2008年9月？)に向かって情報開示が始まりました。新機能として公開されているのは現時点では

• Unicodeフルサポート
• ジェネリクス(パラメタライズドタイプ)
• 匿名メソッド
• 新しいコンポーネント

といったところでしょうか。今回もDelphi/C++Builderは先行するようで、RAD Studioは2008年4Qそれ以降になる見込みです。

2008/07/28追記: RAD Studioの時期(2008年4Q)の根拠はどっかの(CodeGear関係者の)blogだったと思うのですが、ちょっと見つからないので一時的に表現を修正させていただきます。

2011/05/04追記: dn.codegear.comのリンクをedn.embarcadero.comのものに差し替え。

ショートカットをプログラムから作成する

プログラムから実行ファイルへのショートカットを作成するにはCOMオブジェクトのシェルリンク機能をIShellLinkとIPersistFileを使用して呼び出します。

uses
  SysUtils, ShlObj, ActiveX, ComObj;

function CreateShortCut(const Location: String;
                        const ShortcutName: String;
                        const FullPathname: String;
                        const Params: String;
                        const WorkingDir: String;
                        const Description: String): Boolean;
var
  Unknown: IUnknown;
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
{$IFDEF Unicode}
  FileName: String;
{$ELSE}
  FileName: WideString;
{$ENDIF}
begin

  { Create shell link object }
  Unknown := CreateComObject(CLSID_ShellLink);

  { Get IShellLink/IPersistent inferface }
  ShellLink   := Unknown as IShellLink;
  PersistFile := Unknown as IPersistFile;

  { Set path to shell link }
  ShellLink.SetPath(PChar(FullPathname));

  { Set arguments to shell link }
  ShellLink.SetArguments(PChar(Params));

  { Set description string }
  ShellLink.SetDescription(PChar(Description));

  { Set working directory }
  ShellLink.SetWorkingDirectory(PChar(WorkingDir));

  { Set location (path and index) of the icon }
  ShellLink.SetIconLocation(PChar(FullPathname),0);

  { Save to file }
  FileName := IncludeTrailingPathDelimiter(Location) +
              ShortcutName + '.LNK';
{$IFDEF Unicode}
  Result := Succeeded(PersistFile.Save(PChar(FileName),True));
{$ELSE}
  Result := Succeeded(PersistFile.Save(PWChar(FileName),True));
{$ENDIF}

end;

Object Pascal

元ねたは現Embarcadero Technologies社員でローカライズ担当の新井さんのDelphiの神託 DelphiによるCOMの徹底活用 シェルプログラミング入門(新井 正広著/ソフトバンク/ISBN4-7973-0782-X)。出版当時新井さんはまだ学生さんだった気がします。

2008/07/30追記: Windowsが管理している場所(スタートメニューなど)にショートカットを作成したときは

  SendMessage(HWND_BROADCAST,WM_SETTINGCHANGE,0,0);

Object Pascal

を行わないと次回起動時まで表示に反映されない、という点に注意してください。

接続されていないデバイスの情報を表示させる

接続されていないデバイスのドライバを削除したい場合など、現在接続されていないものも含めて全てのデバイスをデバイスマネージャに表示させるには、コマンドプロンプト(UAC有効の場合は管理者として実行)から

set devmgr_show_nonpresent_devices=1
cd %SystemRoot%\System32
start devmgmt.msc

Textfile

として、表示されたデバイスマネージャの表示メニューから"非表示のデバイスの表示"を選択します。
Windows XPやWindows Vistaではデバイスは追加できても削除できないようなので、そのような場合にはこの方法が有効です。以下に参考リンクを。

KB241257 Windows 2000 に現在存在しないデバイスがデバイス マネージャに表示されない
KB315539 Windows XP ベースのコンピュータに接続されていないデバイスがデバイス マネージャに表示されない
接続されていないデバイスの情報を表示させる － ＠IT

IP(v4)アドレスの正規形表現への変換

入力されたIP(v4)アドレスを正規形の表現に変換する方法はいくらでもありそうですが、手抜きでWinSockのinet_addrとinet_ntoaを使用して文字列→IPアドレス→文字列とするやり方を。

function CanonicalizeIPAddress(const AIPAddress: String): String;
var
  P: PAnsiChar;
  IPAddr: in_addr;
{$IFDEF UNICODE}
  AnsiIPAddress: AnsiString;
{$ENDIF}
begin

{$IFDEF UNICODE}
{$WARN EXPLICIT_STRING_CAST_LOSS OFF}  // W1060
  AnsiIPAddress := AnsiString(AIPAddress);
{$WARN EXPLICIT_STRING_CAST_LOSS DEFAULT}
  IPAddr.S_addr := inet_addr(PAnsiChar(AnsiIPAddress));
{$ELSE}
  IPAddr.S_addr := inet_addr(PAnsiChar(AIPAddress));
{$ENDIF}

  if IPAddr.S_addr = u_long(INADDR_NONE) then
  begin
    raise EConvertError.CreateFmt('Bad IP address: %s',[AIPAddress]);
  end;

  P := inet_ntoa(IPAddr);
{$IFDEF UNICODE}
  SetString(AnsiIPAddress,P,StrLen(P));
  Result := String(AnsiIPAddress);
{$ELSE}
  SetString(Result,P,StrLen(P));
{$ENDIF}

end;

Object Pascal

入力がIPアドレスとして不適切(INADDR_NONE)だと例外が発生しますが、かといって全部が全部エラーになるわけではない(暗黙に0が埋められる場合とか)ところは要注意かな。

2008/08/25追記: コードサンプルをUnicode Readyなものに更新しました。

特殊フォルダのパス名の取得

Windowsの特殊フォルダのCSIDLからパス名を取得するにはSHGetFolderPathを使用します。

uses
  Windows, SHFolder;

function GetSpecialFolder(csidl: Integer): String;
var
  Buffer: array [0..MAX_PATH] of Char;
begin

  Result := '';
  if Succeeded(SHGetFolderPath(0,csidl,0,0,Buffer)) = True then
  begin
    Result := Buffer;
  end;

end;

Object Pascal

ただし全てのCSIDL_...が有効なパスを返すとは限らない(SHGetFolderPathでパスが取得できないCSIDLもあり、また環境にも依存する)ので注意が必要。

2008/07/17追記: SHGetFolderPathの第4パラメータは正確には
SHGFP_TYPE_CURRENT(0): 実際のパス
SHGFP_TYPE_DEFAULT(1): デフォルトのパス
のどちらかを指定します。SHGFP_TYPE_CURRENTを指定するとユーザによって特殊フォルダのパス名が変更されていた場合でもこれを反映したものを返します。SHGFP_TYPE_DEFAULTを指定するとシステム本来の(デフォルトの)パスを返します。

Adobe Readerで指定したファイルの指定したページを開く

2017/03/07追記: Adobe Acrobat/Reader X以降でDDEのサービス名が変更になったことに対応したアーティクルを作成しましたので、そちらをご覧ください。
Adobe Reader(X以降)で指定したファイルの指定したページを開く

PDFファイルの任意のページをプログラムから開くときは、Adobe Readerのパスをレジストリから取得し、DDEでキックしてからDocOpenでPDFを開きDocGotoで所定のページに移動する、というマクロを実行します。

uses
{$IFDEF Unicode}
  AnsiStrings,
{$ENDIF}
  Windows, SysUtils, DdeMan, Registry;

function GetAdobeReader: String;
begin

  with TRegistry.Create do
  begin
    try
      RootKey := HKEY_CLASSES_ROOT;
      OpenKeyReadOnly('Software\Adobe\Acrobat\Exe');
      try
        Result := ReadString('');

      finally
        CloseKey;
      end;

    finally
      Free;
    end;
  end;

end;


procedure OpenPDF(const Filename: String; Page: Integer);
const
  CDdeCommand: AnsiString = '[DocOpen("%s")][DocGoTo(NULL,%d)]';
var
  Macro: AnsiString;
begin

  Macro := Format(CDdeCommand,[Filename,Page - 1]);

  with TDdeClientConv.Create(nil) do
  begin
    try
      ConnectMode := ddeManual;
      ServiceApplication := ChangeFileExt(GetAdobeReader,'');
      SetLink('Acroview','Control');
      if OpenLink = True then
      begin
        ExecuteMacro(PAnsiChar(Macro),False);
        CloseLink;
      end;

    finally
      Free;
    end;
  end;

end;

Object Pascal

Adobe Readerの所在は"HKEY_CLASSES_ROOT\Software\Adobe\Acrobat\Exe"から取得する(これが一番確実)、Adobe ReaderはDDEで呼び出してマクロ実行でファイルを開きページを移動する、DelphiのTDdeClientConvには不具合があるので使用する都度生成しないと正常に動作しない、といったところが注意点ですかね。

2008/08/16追記: AnsiString版のFormatを使用するようにコードを修正しました。

2009/03/17再追記: Adobe Acrobat/ReaderのDDEコマンドなどを定義した"Interapplication Communication API Reference"(アプリケーション間通信APIリファレンス)がAdobeのサイトにあります(英語ですが)。
Adobe Acrobat 7.0.5 Acrobat Interapplication Communication Reference
Adobe Acrobat SDK Version 8.0 Interapplication Communication API Reference

2017/03/05追記: おかぽんさんからAcrobat X以降では仕様の変更があったという情報をコメントでいただきました。調査してわかったことがありましたら追記します。(Bloggerはコメントが見づらいのでここに追記しておきます。おかぽんさん、情報ありがとうございました。)

ファイルサイズの取得

フルパス名からファイルのサイズを取得する方法は色々考えられますが、直球なのはFindFirstFileでFindDataのnFileSizeLowとnFileSizeHighから計算する方法でしょうか。

uses
  Windows;

function GetFileSize(const Filename: String; var FileSize: Int64): Boolean;
var
  Handle: THandle;
  FindData: TWin32FindData;
begin

  FileSize := 0;
  Handle := Windows.FindFirstFile(PChar(Filename),FindData);
  if Handle <> INVALID_HANDLE_VALUE then
  begin
    Windows.FindClose(Handle);
    FileSize := FindData.nFileSizeLow or Int64(FindData.nFileSizeHigh) shl 32;
    Result := True;
    Exit;
  end;
  Result := False;

end;

Object Pascal

戻値がTrueならばFileSizeに取得したファイルサイズが格納されています。

2008/12/16追記: KB961110の問題を回避するためにWin32APIのGetFileSizeExを使用する方法をファイルサイズを取得する(2)に示しました。

プリンタの用紙のサイズおよび方向を変更

プリンタの用紙のサイズおよび方向を変更するときはGetPrinter/SetPrinterを使用します。

uses
  Printers;

var
  Device: array [0..127] of Char;
  Driver: array [0..127] of Char;
  Port: array [0..127] of Char;
  DeviceMode: THandle;
  pDevMode: ^TDevMode;
begin

  { Lock }
  Printer.GetPrinter(Device,Driver,Port,DeviceMode);
  pDevMode := GlobalLock(DeviceMode);
  try
    { Set paper orientation }
    pDevMode^.dmOrientation := DMORIENT_PORTRAIT;  // 用紙は縦

    { Set paper size }
    pDevMode^.dmPaperSize := DMPAPER_A4;  // 用紙はA4

  finally
    { Unlock }
    GlobalUnlock(DeviceMode);
  end;

  Printer.SetPrinter(Device,Driver,Port,DeviceMode);

end;

Object Pascal

元ねたはDelphi Graphic Secrets Know-how & Libraries(中村 拓男著/ソフトバンクパブリッシング/ISBN4-7973-1922-4)。

シリアルポートの列挙

PC上で使用できるシリアルポートはレジストリの"HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM"上の"COM"で始まるエントリを列挙すればよい。ただしこのエントリはOpenKeyReadOnlyで開かないとユーザ権限によってはエラーになるので要注意。

uses
  Windows, SysUtils, Classes, Registry;

function EnumSerialComm(const S: TStrings): Integer;
var
  Index: Integer;
  PortNo: Integer;
  Str: String;
  Names: TStringList;
begin

  Result := 0;

  S.Clear;

  { Create temporary string list object }
  Names := TStringList.Create;
  try
    { Create and open registry key }
    with TRegistry.Create do
    begin
      try
        RootKey := HKEY_LOCAL_MACHINE;
        OpenKeyReadOnly('\HARDWARE\DEVICEMAP\SERIALCOMM');
        try
          { Get names }
          GetValueNames(Names);

          { Read key values }
          for Index := 0 to Names.Count - 1 do
          begin
            if GetDataType(Names.Strings[Index]) = rdString then
            begin
              Str := ReadString(Names.Strings[Index]);
              if CompareText(Copy(Str,1,3),'COM') = 0 then
              begin
                PortNo := StrToIntDef(Copy(Str,4,Length(Str)),-1);
                if PortNo > 0 then
                begin
                  S.AddObject(Str,Pointer(PortNo));
                  if Result < PortNo then
                  begin
                    Result := PortNo;
                  end;
                end;
              end;
            end;
          end;

        finally
          { Close registry key }
          CloseKey;
        end;

      finally
        Free;
      end;
    end;

  finally
    { Release local objects }
    Names.Free;
  end;

end;

Object Pascal

取り込んだシリアルポートはソートされていない(レジストリのエントリ順)なので、必要に応じてソートしてから使用しましょう。

TColor型と色名(文字列)の相互変換

TColor型と色名の文字列の相互変換にはGraphicsネームスペースのStringToColor/ColorToStringを使用します。

uses
  Graphics;

var
  Color: TColor;
begin

  Color := StringToColor('clRed');  // Color <- clRed

end;

var
  ColorName: String;
begin

  ColorName := ColorToString(clBlue);  // ColorName <- 'clBlue'

end;

Object Pascal

TColorは列挙型ではないのでGetEnumName/GetEnumValueではうまくいかない。

列挙型と列挙子名(文字列)の相互変換

列挙型と列挙子名の文字列の相互変換にはTypInfoネームスペースのGetEnumName/GetEnumValueを使用します。

uses
  TypInfo, SysConst;

var
  Alignment: TAlignment;
  Value: Integer;
  P: PTypeInfo;
begin

  P := TypeInfo(TAlignment);
  Value := GetEnumValue(P,'taLeftJustify');
  with GetTypeData(P)^ do
  begin
    if (Value < MinValue) or (Value > MaxValue) then
    begin
      raise ERangeError.CreateRes(@SRangeError);
    end;

    Alignment := TAlignment(Value);  // Alignment <- taLeftJustify
  end;

end;

var
  AlignmentName: String;
begin

  AlignmentName := GetEnumName(TypeInfo(TAlignment),
                               Ord(taRightJustify));  // AlignmentName <- 'taRightJustify'

end;

Object Pascal

2008/08/16追記: 該当する列挙子名が存在しないとGetEnumValueが-1を返す問題の対策を追加しました。

2012/05/08追記: 列挙型と列挙子名(文字列)の相互変換(ジェネリックス版)もどうぞ(Delphi 2009以降)。

Windows Vista上で管理者権限を要求するアプリケーションを作成する

Delphi 2007でWindows Vista/Server 2008上で管理者権限を要求するアプリケーションを作成するには:

1.まず普通にアプリケーションを作成する。このときプロジェクトオプションでランタイムテーマを一旦有効にしておく。
2.実行プログラムをリソースエディタ(今回はXN Resource Editorを使用)で開き、左側のツリーペインで"XP Theme Manifest"→"1"→"日本語"でマニフェスト部分を表示させて全て選択してCtrl-Cでコピーし、UTF-8を扱えるエディタに貼り付ける。
3.level="asInvoker"の"asInvoker"を"requireAdministrator"に書き換えてファイルを拡張子.manifest、文字コードUTF-8で保存する。
4.マニフェストをリンクするための.rcファイルを作成する。内容は

1 24 "<manifestfilename>.manifest"

Textfile

の1行だけ(<manifestfilename>には3.でマニフェストを保存したときのファイル名を入れる)。
5.プロジェクトオプションでランタイムテーマを無効に設定する。
6.プロジェクトマネージャで実行ファイルを右クリック→"追加"で4.の.rcファイルを指定する。これでDelphi2007ではプロジェクトソースの最初のところに

{$R 'XYZ.res' 'XYZ.rc'}

Object Pascal

という1行が挿入される。
8.プログラムをコンパイルしなおす。これで改変したマニフェストがリンクされた実行ファイルができているはず。リソースエディタで"XP Theme Manifest"の内容がlevel="requireAdministrator"となっていることを確認。

このプログラムをWindows Vista上で実行すると例のUACのダイアログが表示され、実行を許可するとプログラムが管理者権限で動作するはずです。

元ねたは第4回デベロッパーキャンプの【G4】テクノロジープレビュー「Delphi 2007 for Win32によるWindows Vista対応」から。

Windows XP以降のウィンドウゴースト機能を回避

Windows XP以降ではUIを持ったアプリケーションが5秒以上メッセージループを回さないとウィンドウゴースト機能(window ghosting feature)が働いて、そのアプリケーションのトップレベルウィンドウと同じ位置、サイズ、キャプションを持ったゴーストウィンドウが生成されます。
まぁそれはそれでいいのですが、アプリケーションがこの状態から復帰したときに、(1)Zオーダが狂ってしまい、直後の最前面ウィンドウ表示が最背面に回されてしまう、(2)Windows Vistaのタスクバーにゴーストウィンドウが残ってしまう、という微妙な(状況によっては厄介な)問題があります。
そこでウィンドウゴースト機能を停止してしまえ、ということでDisableProcessWindowsGhostingのサンプルコードです。

uses
  Windows, SysUtils;

procedure DisableProcessWindowsGhosting;
var
  PDisableProcessWindowsGhosting: procedure; stdcall;
begin

  if (Win32Platform = VER_PLATFORM_WIN32_NT) and
     (((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) or  // Windows XP
      (Win32MajorVersion >= 6)) then                             // Windows Vista or later
  begin
    @PDisableProcessWindowsGhosting := GetProcAddress(GetModuleHandle('user32.dll'),
                                                      'DisableProcessWindowsGhosting');
    if Assigned(PDisableProcessWindowsGhosting) = True then
    begin
      PDisableProcessWindowsGhosting;
    end;
  end;

end;

Object Pascal

元ねたはCodeGearのQC3730から。

2011/05/04追記: QC3730のリンクをqc.embarcadero.comのものに差し替え。

Microsoft Monthly Update 2008/07

今日はMicrosoftのセキュリティアップデートの日です。
MS08-037
MS08-038
MS08-039
MS08-040

はじめに

Embarcadero TechnologiesのRADツール、CodeGear Delphi (RAD Studio)に関する主に自分用のメモ書きです。