Canvas で文字等を重ねて描画する

 WindowsAPI の SetBkMode() を使用します。第 1 引数に Canvas オブジェクトのハンドル、第 2 引数に透過モードを指定します。

透過モード

OPAQUE 背景はテキスト、ハッチブラシ、またはペンが描画される前に現在の背景色で塗りつぶされます。
TRANSPARENT 背景はそのまま残されます。

 EX.1

SetBkMode(Printer.Canvas.Handle,TRANSPARENT);

 


連続した半角スペースを得る

 ...まさか、

Edit1.Text := '              ';

 なんてやってませんよね?StringOfChar() 関数を使えばいいのです。

function Set_Space(Src:String;Len:Integer;Space:Char):String;
begin
  result := Src + StringOfChar(Space,Len-Length(Src));
end;

function Set_Space2(Src:String;Len:Integer;Space:Char):String;
begin
  result := StringOfChar(Space,Len-Length(Src)) + Src;
end;

 ホラ、この関数を使えば固定長フィールドの前詰スペースや 0 詰なんか簡単。「1・2・3・4...」なんてスペースキー叩いた回数を数えなくても済みますよ(^^;

 もっとも、

Edit1.Text := Format('%.5d',[100]);

 や、

Edit1.Text := FormatFloat('0000000.00',1234.56);

 ってやれば前 0 詰めはできるんですけれど。


異なるバージョンの Delphi でソースを共有する

 条件コンパイルを設定すればバージョンで異なるソースを記述できます。Delphi 3 と Delphi 4 の共存環境では使用頻度が高くなった気がします。

{$ifdef VER120}
 // Delphi4でのソース
{$else}
 // それ以外のソース
{$endif}

 VERnnn の定数は以下のように設定されています。

VER80   Delphi 1
VER90 Delphi 2
VER93 C++Builder 1.0
VER100 Delphi 3
VER110 C++Builder 3
VER120 Delphi 4
VER125 C++Builder 4
VER130 Delphi 5
C++Builder 5
VER140 Delphi 6
C++Builder 6
Kylix / 2 / 3
VER150 Delphi 7
VER160 Delphi 8
IDE Integration Pack for Delphi 8
IDE Integration Pack for C# Builder 1.0
VER170 Delphi 2005
VER180 BDS 2006 (Delphi / C++Builder)
Turbo Delphi / C++
Delphi 2007
C++Builder 2007
VER185 Delphi 2007
C++Builder 2007
VER200 Delphi 2009
C++Builder 2009
VER210 Delphi 2010
C++Builder 2010
VER220 Delphi XE
C++Builder XE
VER230 Delphi XE2
C++Builder XE2
VER240 Delphi XE3
C++Builder XE3
VER250 Delphi XE4
C++Builder XE4
VER260 Delphi XE5
C++Builder XE5
VER265 Appmethod 1.13
VER270 Delphi XE6
C++Builder XE6
Appmethod 1.14
VER280 Delphi XE7
C++Builder XE7
Appmethod 1.15

 他にも定義されているものがあります。

 これらを判断して条件コンパイルに役立てる事ができます。FireMonkey アプリケーションの場合、FMX.Defines.inc がインクルードされるので、IOS 等の条件シンボルを追加で利用する事ができます。

{$IFDEF CONDITIONALEXPRESSIONS}
  {$IF CompilerVersion = 14.0}
    {$DEFINE Delphi6Only}
    {$DEFINE CPPB6Only}
  {$IFEND}
  {$IF CompilerVersion >= 14.0}
    {$DEFINE Delphi6Over}
    {$DEFINE CPPB6Over}
  {$IFEND}
{$ENDIF} 

Delphi 6 以降では {$IFDEF CONDITIONALEXPRESSIONS}{$IF CompilerVersion ~} {$IFEND} または {$IF RTLVersion ~} {$IFEND} が使えるので柔軟な条件分岐が可能です。

See Also:


CreateProcess で実行された時のコマンドライン引数を取得する

 アプリケーションが CreateProcess で実行された場合、ParamStr、ParamCount では引数を正しく取得できません。以下の関数を使えば正しく取得できます。

 ※この現象は Delphi 5 以降では発生しないようです。

function ParamCount2:Integer;
var
  i :Integer;
  Dmy :String;
  Quot_Flg:Boolean;
begin
  Dmy := StrPas(GetCommandLine);
  Dmy := Trim(Dmy);
  Quot_Flg := False;
  if Pos(AnsiUpperCase(ParamStr(0)),AnsiUpperCase(Dmy)) > 0 then
    Result := 0
   else
     Result := 1;
  for i:=1 to Length(Dmy) do
    begin
      if Dmy[i] = '"' then
        Quot_Flg := not Quot_Flg;
      if (Dmy[i] = ' 'and (not(Quot_Flg)) then
        Result := Result + 1;
    end;
end;

function ParamStr2(Index:Integer):String;
var
  i :Integer;
  Dmy :String;
  Quot_Flg :Boolean;
  Param_Pos:Integer;
begin
  Dmy := StrPas(GetCommandLine);
  Dmy := Trim(Dmy);
  Param_Pos := 0;
  if Pos(AnsiUpperCase(ParamStr(0)),AnsiUpperCase(Dmy)) <= 0 then
    Dmy := ParamStr(0) + ' ' + Dmy;
  Quot_Flg := False;
  Result := '';
  for i:=1 to Length(Dmy) do
    begin
      if Param_Pos = Index then
        Result := Result + Dmy[i];
      if Dmy[i] = '"' then
        Quot_Flg := not Quot_Flg;
      if (Dmy[i] = ' 'and (not(Quot_Flg)) then
        Inc(Param_Pos);
    end;
  Result := Trim(Result);
  if Copy(result,11) = '"' then
    Result := Copy(Result,2,Length(Result));
  if Copy(result,Length(result),1) = '"' then
    Result := Copy(Result,1,Length(Result)-1);
end;

function FindCmdLineSwitch2(const Switch: string; SwitchChars: TSysCharSet; IgnoreCase: Boolean): Boolean;
var
  I: Integer;
  S: string;
begin
  for I := 1 to ParamCount2 do
    begin
      S := ParamStr2(I);
      if (SwitchChars = []) or (S[1in SwitchChars) then
        if IgnoreCase then
          begin
            if (AnsiCompareText(Copy(S, 2, Length(Switch)), Switch) = 0then
              begin
                Result := True;
                Exit;
              end;
          end
        else
      begin
        if (AnsiCompareStr(Copy(S, 2, Length(Switch)), Switch) = 0then
          begin
            Result := True;
            Exit;
          end;
      end;
    end;
  Result := False;
end;

少々泥臭い事をしないとマトモにならないようです。一応リプレスしても正しく動作すると思います。

※ついでに、指定したパラメータの位置を返す関数を用意してみました。合わせてお使い下さい。

CmdLineSwitchPos2 関数

CmdLineSwitchPos2関数は,アプリケーションに渡されたSwitchパラメータの位置を返します。

カテゴリ

コマンドラインルーチン

type TSysCharSet = set of Char;

function CmdLineSwitchPos2(const Switch: string; SwitchChars: TSysCharSet; IgnoreCase: Boolean): Boolean;

説明

CmdLineSwitchPos2 関数は,アプリケーションに渡された Switch パラメータの位置を返します。Switch パラメータが存在しない場合は -1 を返します。SwitchChars は有効な引数区切り文字("-","/" など)を識別します。IgnoreCase パラメータは,大文字小文字を区別して検索を実行するか,区別せずに検索を実行するかを制御します。

function CmdLineSwitchPos2(const Switch: string; SwitchChars: TSysCharSet; IgnoreCase: Boolean): Integer;
var
  I: Integer;
  S: string;
begin
  for I := 1 to ParamCount2 do
    begin
      S := ParamStr2(I);
      if (SwitchChars = []) or (S[1in SwitchChars) then
        if IgnoreCase then
          begin
            if (AnsiCompareText(Copy(S, 2, Length(Switch)), Switch) = 0then
              begin
                Result := I;
                Exit;
              end;
          end
        else
      begin
        if (AnsiCompareStr(Copy(S, 2, Length(Switch)), Switch) = 0then
          begin
            Result := I;
            Exit;
          end;
      end;
    end;
  Result := -1;
end;

※FindCmdLineSwitch2() 関数と CmdLineSwitchPos2() 関数は Delphi 標準の FindCmdLineSwitch() 関数と違い、"/D=ATOK8.DIC" 等のパラメータでも "/D" スイッチとして取得できます。


Windows 98 を使用しているのに Menu が Office 97 ライクにならない場合

 恐らく MeinMenu の Images プロパティに ImageList を指定しているのだと思います。設計時にはここを空にしておき、実行時に Images プロパティに ImageList を指定するようにすれば問題は解決します。


Form で Tab / Shift+Tab を取得する。

 form の KeyPreview プロパティを True にしても Tab / Shift+Tab は取得できません。これを取得するには、

 まず Protected 節に以下のコードを記述します。

protected
  procedure CMDialogKey(var msg : TCMDialogKey); message CM_DIALOGKEY;

そして、implementation 以降に以下のコードを記述します。

procedure TForm1.CMDialogKey(var msg : TCMDialogKey);
begin
  msg.Result := 0;
end;

このプロシージャの中で、

case msg.CharCode of
  VK_TAB:
    begin
      // TAB押下時の処理をここに書く  
        msg.Result := 1;
    end;
  else
    inherited;
end;

直接 Tab キーの処理を書いてもいいのですが、これでは Shift+Tab が取得できません。やはりここは Form の KeyDown イベントに、

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_TAB:
      begin
        if (ssShift in Shift) then
          begin
           // SHIFT+TAB押下時の処理をここに書く  
          end
        else
          begin
           // TAB押下時の処理をここに書く  
          end;
      end;
  end;
end;

と、書くのがいいでしょう。


利用可能な Font 名を取得する。

 例ではコンボボックスに利用可能なフォント名を設定しています。

procedure TForm1.FormCreate(Sender: TObject);
var
  i:Integer;
begin
  ComboBox1.Items.Clear;
  for i:=0 to Screen.Fonts.Count -1 do
    begin
      ComboBox1.Items.Add(Screen.Fonts[i]);
    end;
end;

Ini ファイルにアクセスする。

 uses 節に IniFiles を追加しておいてください。

function Get_IniFile(FileName, Section, Value, DefaultString): String;
var
  IniFile :TIniFile;
begin
  IniFile := TIniFile.Create(FileName);
  try
    result := IniFile.ReadString(Section, Value, Default);
  finally
    IniFile.Free;
  end;
end;

procedure Set_IniFile(FileName, Section, Value, Value2:String);
var
  IniFile :TIniFile;
begin
  IniFile := TIniFile.Create(FileName);
  try
    IniFile.WriteString(Section,Value,Value2);
  finally
    IniFile.Free;
  end;
end;

 Ex1.TEST.INI の [OPTION] セクションの ITEM01 の内容を読み込む。

Dmy := Get_IniFile('TEST.INI''OPTION''ITEM01');

 Ex2.TEST.INI の [OPTION] セクションの ITEM01 に "ABC" を書き込む。

Set_IniFile('TEST.INI''OPTION''ITEM01''ABC');

 ※Set_IniFile() では Ini ファイルが存在しない場合、新規作成して書き込みます。
 ※Ini ファイルが 32KB を超える場合には TIniFile ではなく TMemIniFile を使用してください。


レジストリにアクセスする。

 uses 節に Registry を追加しておいてください。

function Get_Registry(Section, Value, DefaultString):String;
var
  RegIniFile:TRegIniFile;
begin
  RegIniFile := TRegIniFile.Create('');
  try
    result := RegIniFile.ReadString(Section, Value,Default);
  finally
    RegIniFile.Free;
  end;
end;

procedure Set_Registry(Section, Value, Value2: String);
var
  RegIniFile:TRegIniFile;
begin
  RegIniFile := TRegIniFile.Create('');
  try
    RegIniFile.WriteString(Section, Value, Value2);
  finally
    RegIniFile.Free;
  end;
end;

procedure Delete_Registry(Section: String);
var
  RegIniFile:TRegIniFile;
begin
  RegIniFile := TRegIniFile.Create('');
  try
    RegIniFile.EraseSection(Section);
  finally
    RegIniFile.Free;
  end;
end;

 手抜きなので、文字列でしかアクセスできません。でも、とりあえず充分でしょ (同様な関数を作って Overload すればいいし)。あと、上の奴はルートが設定されていないのでルートは [HKEY_CURRENT_USER] の "software" になります。Delete_Registry() に Section を設定しないと [HKEY_CURRENT_USER\software] 以下のすべてのレジストリが削除されますので、絶対に空文字列は指定しないで下さい。下のソースはルート変更可能バージョンです。

function Get_Registry(Root: HKEY; Section, Value, DefaultString): String;
var
  RegIniFile:TRegIniFile;
begin
  RegIniFile := TRegIniFile.Create('');
  try
    RegIniFile.RootKey := Root;
    result := RegIniFile.ReadString(Section, Value, Default);
  finally
    RegIniFile.Free;
  end;
end;

procedure Set_Registry(Root: HKEY; Section, Value, Value2: String);
var
  RegIniFile:TRegIniFile;
begin
  RegIniFile := TRegIniFile.Create('');
  try
    RegIniFile.RootKey := Root;
    result := RegIniFile.ReadString(Section, Value, Default);
  finally
    RegIniFile.Free;
  end;
end;

procedure Delete_Registry(Root: HKEY; Section: String);
var
  RegIniFile:TRegIniFile;
begin
  RegIniFile := TRegIniFile.Create('');
  try
    RegIniFile.RootKey := Root;
    RegIniFile.EraseSection(Section);
  finally
    RegIniFile.Free;
  end;
end;

 ※Set_Registry() は存在しない階層を一気に作成します。
 ※Delete_Registry() は指定した階層以下をすべて削除します。


複数のコンポーネントを Explorer からのファイル名ドラッグ&ドロップに対応させる。

 uses 節に ShellAPI を追加しておいてください。

private { Private 宣言 }
  procedure AppMessage(var Msg: TMsg; var Handled: Boolean);

...  

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
var
  FileNames: array [0..255of Char;
  Files: Integer;
begin
  if Msg.Message = WM_DROPFILES then
    begin
      DragQueryFile(Msg.wParam, 0, FileNames, Sizeof(FileNames) - 1);
      Files := DragQueryFile(Msg.wParam, $FFFFFFFFnil0);
      DragQueryFile(Msg.wParam, 0, FileNames, Sizeof(FileNames) - 1);

      if FindDragTarget(Msg.pt, False) is TEdit then
        (FindDragTarget(Msg.pt, False) as TEdit).Text := StrPas(FileNames);

      DragFinish(Msg.wParam);
      Handled:= True;
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage:= AppMessage;
  DragAcceptFiles(EDit1.Handle, True);
  DragAcceptFiles(EDit2.Handle, True);
end;

[解説]

 上の例では TEdit コントロールにドロップされたファイル名をセットしています。

 ※例では単一のファイル名のみを処理しています。
 ※誰も知らないとは思いますが、X680x0 の SX-Window という OS のファイルオープンダイアログは、ファイル名を直接入力かこのドラッグ&ドロップしかありませんでした。ファイルオープンのためのリスト表示コモンダイアログなんて...。今回、懐古趣味で作ってみました。


ファイル名がワイルドカードに一致しているか判定する。

 uses に Masks を追加して下さい。

function MatchesMask(const Filename, Mask: string): Boolean;

 この関数でワイルドカードに一致しているかどうかを判定できます。え? "Masks.pas" なんてない?CD を検索すれば、きっとどこかに...。

 お持ちでない方はM&I 氏が作成された "ワイルドカードマッチコンポーネント" を御使用下さい。

 Delphi5 以降ならば Masks を uses して、

function MatchesMask(Filename, Mask: string): Boolean;
var
  aMask: TMask;
begin
  try
    aMask := Tmask.Create(Mask);
    result := aMask.Matches(FileName);
    aMask.Free;
  except
    result := False;
  end;
end;

 こんな関数を作って使ってみて下さい。


関数のオーバーロード

 "関数のオーバーロード" を行う事で、違う引数を持つ同一名称の関数を作成する事ができます。うまく利用するとコードがすっきり書けます。多用するとソースの見通しが悪くなるのでご注意。 "カンマを含む数値文字列<->数値文字列変換" がサンプルになっています。詳しい事は Delphi の Help を参照して下さい。


TStringList のススメ (その 1)

 ファイルの内容を保持したいとします。さてどうします?まさか、Memo をフォームに ReadOnly で貼ったりしてませんよねぇ?

var
  SL: TStringList;
begin
  SL := TStringList.Create;
  try
    SL.LoadFromFile('TEMP.TXT');
    // 処理
    ...
  finally
    SL.Free;
  end;
end;

 あら、便利ですねぇ。


TStringList のススメ (その 2)

 TStringList を 2 個使うと...

var
  i, l: Integer;
  SL1: TStringList;
  SL2: TStringList;
begin
  SL1 := TStringList.Create;
  SL2 := TStringList.Create;
  try
    SL1.LoadFromFile('TEST.CSV');
    for i:=0 to SL1.Count-1 do
      begin
        SL2.CommaText := SL[i];
        for l:=0 to SL2.Count-1 do
          StringGrid1.Cells[i, l] := SL2[l];
      end;
  finally
    SL2.Free;
    SL1.Free;
  end;
end;

 あーら、CSV がこんなに簡単に処理できました。

<!> 2006 以降では TStrings.Delimiter / TStrings.DelimitedText / TStrings.StrictDelimiter を調べるといい事があるかもしれません。<!>


TStringList のススメ (その 3)

 さらにはこんな使い方もできたりします。

type
  TDataStruct = 
    record
      Code :Integer;
      Name :String;
    end;
  PDataStruct = ^TDataStruct;

function Get_Object(SL: TStringList; Index: Integer):PDataStruct;
begin
  result := PDataStruct(SL.Objects[Index]);
end;

procedure AddData(SL: TStringList; Code: Integer; ShortName, LongName: String);
var
  DS: PDataStruct;
begin
  New(DS);
  DS^.Code := Code;
  DS^.Name := LongName;
  SL.AddObject(ShortName,TObject(DS));
end;

procedure DelData(SL: TStringList; Index: Integer);
begin
  // リソースを解放してから
  Dispose(Get_Object(Index));
  // リストを削除
  SL.Delete(Index);
end;

// 絶対忘れないように。
procedure FormDestroy(Sender: TObject);
var
  i: Integer;
begin
  for i:=SL.Count-1 downto 0 do
    DelData(SL,i);
  SL.Free;
end;

 構造体の各メンバにアクセスするには、

Get_Object(SL, Index).Code := {処理};
Get_Object(SL, Index).Name := {処理};

 リストの追加と削除は

AddData(SL, 1'TEST1''TEST_DATA1');
DelData(SL, Index);

 こんな感じです。ComboBox や ListBox にも応用が可能ですね。

 ※便利だからといって多用は禁物です。TStringList は当然の事ながらデータをメモリ上に保持しますから、あまり多用するとメモリ大喰らいなソフトが出来上がってしまいます(^^;


HTML-Help を呼び出す

 あまり HtmlHelp (*.chm) は使いたくないのですが、そうもいかない場合があります。以下に HtmlHelp をアプリケーションから呼ぶ方法を記します。

 まずグローバル変数として

po: TFarProc;
DLLWnd: THandle;
HtmlHelp: function(hwndCaller: Integer; pszFile: PChar; uCommand: Integer; dwData: Integer): Integer; stdcall;

 を定義します。

 [FormCreate]

po := nil;
DLLWnd := LoadLibrary('hhctrl.ocx');
if DLLWnd > 0 then
  begin
    po := GetProcAddress(DLLWnd, 'HtmlHelpA');
  if po <> nil then
    @HtmlHelp := po;
  end;

 [FormDestroy]

if po <> nil then
  FreeLibrary(DLLWnd);

 これで準備完了です。呼び出すには

if po <> nil then
  HtmlHelp(Handle, PChar(FileName), HH_DISPLAY_INDEX, Integer(PChar(Keyword)));

 とします。FileName には HtmlHelp (*.chm) のファイル名、Keyword には検索するキーワードを設定します。これは WinHelp の "HELP_FINDER" と同じ動作をします。

const
  HH_DISPLAY_TOPIC = $0000;
  HH_HELP_FINDER = $0000;
  HH_DISPLAY_TOC = $0001;
  HH_DISPLAY_INDEX = $0002;
  HH_DISPLAY_SEARCH = $0003;
  HH_SET_WIN_TYPE = $0004;
  HH_GET_WIN_TYPE = $0005;
  HH_GET_WIN_HANDLE = $0006;
  HH_ENUM_INFO_TYPE = $0007;
  HH_SET_INFO_TYPE = $0008;
  HH_SYNC = $0009;
  HH_RESERVED1 = $000A;
  HH_RESERVED2 = $000B;
  HH_RESERVED3 = $000C;
  HH_KEYWORD_LOOKUP = $000D;
  HH_DISPLAY_TEXT_POPUP = $000E;
  HH_HELP_CONTEXT = $000F;
  HH_TP_HELP_CONTEXTMENU = $0010;
  HH_TP_HELP_WM_HELP = $0011;
  HH_CLOSE_ALL = $0012;
  HH_ALINK_LOOKUP = $0013;
  HH_GET_LAST_ERROR = $0014;
  HH_ENUM_CATEGORY = $0015;
  HH_ENUM_CATEGORY_IT = $0016;
  HH_RESET_IT_FILTER = $0017;
  HH_SET_INCLUSIVE_FILTER = $0018;
  HH_SET_EXCLUSIVE_FILTER = $0019;
  HH_INITIALIZE = $001C;
  HH_UNINITIALIZE = $001D;
  HH_PRETRANSLATEMESSAGE = $00fd;
  HH_SET_GLOBAL_PROPERTY = $00fc;

 定数は上記のようになっています。詳しくは MSDNライブラリ"コマンド クイック リファレンス" を参照して下さい。

 <!> Delphi 2005 以降では uses に WinHelpViewer を追加すると *.hlp が、HTMLHelpViewer を追加すると *.chm が TApplication のヘルプ関連プロパティ/メソッドで扱えるようになります <!>


アルファブレンディング機能を利用する (Windows 2000 以降)

 拙作 TEAD で実装されているアルファブレンディング (透過 / 半透明) 機能を実現してみましょう。

 まずグローバル変数として

po: TFarProc;
DLLWnd: THandle;
SetLayeredWindowAttributes: function(hwnd: Integer; crKey: DWORD; bAlpha: Byte; dwFlags: DWORD): Integer; stdcall;

 を定義します。

 [FormCreate]

po := nil;
DLLWnd := LoadLibrary('user32.dll');
if DLLWnd > 0 then
  begin
    po := GetProcAddress(DLLWnd, 'SetLayeredWindowAttributes');
    if po <> nil then
      @SetLayeredWindowAttributes := po;
  end;

 [FormDestroy]

if po <> nil then
  FreeLibrary(DLLWnd);

 これで準備完了です (なんかデジャヴ^^;)。呼び出すには

const
  WS_EX_LAYERED = $80000;
  LWA_COLORKEY = 1;
  LWA_ALPHA = 2;
var
  lEXSTYLE: Integer;
  AlphaValue: Byte;
  KeyColor: TColor;

 とした上で、

if po <> nil then
  begin 
    lEXSTYLE := GetWindowLong(Handle, GWL_EXSTYLE);
    SetWindowLong(Handle, GWL_EXSTYLE, lEXSTYLE + WS_EX_LAYERED);
    SetLayeredWindowAttributes(Handle, ColorToRGB(KeyColor), AlphaValue, LWA_ALPHA);
  end;

 とします。AlphaBlend は 0~255 で、大きくなると不透明になっていきます。また、

SetLayeredWindowAttributes(Handle, ColorToRGB(KeyColor), AlphaValue, LWA_COLORKEY);

 として、KeyColor を指定すると、フォームの KeyColor と同色の部分が透過します。透過した部分をマウスでクリックすると背後にあるアプリケーションへアクセスする事ができます。これを応用すると、今まで困難だった不定形のリージョンを持つアプリケーションを簡単に実現できます。

 結構簡単ですね、解ってしまえば。

 <!> Delphi 6 以降ではフォームのプロパティで同等の機能が実現できます(--メ <!>


Jpeg 画像をリサイズする

 こんなもんですか。

procedure Jpeg_Resize(InFile, OutFile: String; AWidth, AHeight: Integer);
var
  JpegFile: TJpegImage;
  BitmapFile: TBitmap;
begin
  if not FileExists(InFile) then
    Exit;
  JpegFile   := TJpegImage.Create;
  BitmapFile := TBitmap.Create;
  try
    JpegFile.LoadFromFile(InFile);
    if AWidth > 0
      BitmapFile.Width  := AWidth
    else
      BitmapFile.Width  := (-AWidth)  * JpegFile.Width  div 100;
     if AHeight > 0
      BitmapFile.Height := AHeight
    else
      BitmapFile.Height := (-AHeight) * JpegFile.Height div 100;
     BitmapFile.PixelFormat := pf32bit;
    BitmapFile.Canvas.StretchDraw(Rect(00, BitmapFile.Width-1, BitmapFile.Height-1), JpegFile);
    JpegFile.Assign(BitmapFile);
    JpegFile.SaveToFile(OutFile);
  finally
    BitmapFile.Free;
    JpegFile.Free;
  end;
end;

 InFile で指定されたファイルをリサイズして OutFile へ吐き出します。AWidth と AHeight に正の数を渡すとそのピクセル数にリサイズします。負の数を渡すとそのパーセンテージでリサイズします。-50, -50 を渡せば 50% 縮小です。


QuickReport (ver 3.0x) でマトモなワードラップを行う

 QuickReport の QRDBText は Windows 標準と違うワードラップを行う困ったちゃんです。"半角 SP を入れないと折り返しません"...ってそんなのワードラップじゃないやい!!

 ...つー事でまともに折り返す QRDBTextJ を作ってみました。ワードラップを正しく行う事が目的なので、その他のプロパティはあまり作りこんでありません。もう少しマトモに動作させたい場合は各自で修正して下さい。

unit QRDBTextJ;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  QuickRpt, Qrctrls, DB, StdCtrls;

type
  TQRDBTextJ = class(TQRCustomLabel)
  private
    Field : TField;
    FieldNo : integer;
    FieldOK : boolean;
    DataSourceName : string;
    FDataSet : TDataSet;
    FDataField : string;
    FMask : string;
    FQRLabelOnPrintEvent:TQRLabelOnPrintEvent;
    procedure SetDataSet(Value : TDataSet);
    procedure SetDataField(Value : string);
    procedure DoDrawText(var Rect: TRect; Flags: Longint);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure Prepare; override;
    procedure ReadValues(Reader : TReader); virtual;
    procedure Unprepare; override;
    procedure WriteValues(Writer : TWriter); virtual;
    procedure ReadVisible(Reader : TReader); virtual;
    procedure WriteDummy(Writer : TWriter); virtual;
  public
    constructor Create(AOwner : TComponent); override;
    procedure Print(OfsX, OfsY : integer); override;
  published
    property DataSet : TDataSet read FDataSet write SetDataSet;
    property DataField : string read FDataField write SetDataField;
    property Mask : string read FMask write FMask;
    property Alignment;
    property AlignToBand;
    property AutoSize;
    property AutoStretch;
    property BiDiMode;
    property Color;
    property Font;
    property ParentBiDiMode;
    property ParentFont;
    property TransParent;
    property WordWrap;
    property OnPrint: TQRLabelOnPrintEvent read FQRLabelOnPrintEvent write FQRLabelOnPrintEvent;
  end;

procedure Register;

implementation

constructor TQRDBTextJ.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DataSourceName := '';
end;

procedure TQRDBTextJ.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('DataSource', ReadValues, WriteValues, false);
  Filer.DefineProperty('Visible', ReadVisible, WriteDummy, false);
  inherited DefineProperties(Filer);
end;

procedure TQRDBTextJ.SetDataSet(Value: TDataSet);
begin
  FDataSet := Value;
  if Value <> nil then
    Value.FreeNotification(self);
end;

procedure TQRDBTextJ.SetDataField(Value: string);
begin
  FDataField := Value;
  Caption := Value;
end;

procedure TQRDBTextJ.Prepare;
begin
  inherited Prepare;
  if assigned(FDataSet) then
    begin
      Field := FDataSet.FindField(FDataField);
      if (Field <> nilthen
        begin
          FieldNo := Field.Index;
          FieldOK := true;
        end
      else
        begin
          Field := nil;
          FieldOK := false;
        end;
    end
  else
    begin
      Field := nil;
      FieldOK := false;
    end;
end;

procedure TQRDBTextJ.Unprepare;
begin
  Field := nil;
  inherited Unprepare;
  if DataField <> '' then
    SetDataField(DataField)
  else
    SetDataField(Name);
end;

procedure TQRDBTextJ.ReadValues(Reader: TReader);
begin
  DataSourceName := Reader.ReadIdent;
end;

procedure TQRDBTextJ.WriteValues(Writer: TWriter);
begin
end;

procedure TQRDBTextJ.ReadVisible(Reader: TReader);
begin
  Enabled := Reader.ReadBoolean;
end;

procedure TQRDBTextJ.WriteDummy(Writer: TWriter);
begin
end;

procedure TQRDBTextJ.Print(OfsX, OfsY: integer);
const
  Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);
var
  Text: String;
  Rect, CalcRect: TRect;
  DrawStyle: Longint;
begin
  if FieldOK then
    begin
      if FDataSet.DefaultFields then
        Field := FDataSet.Fields[FieldNo];
    end
  else
    Field := nil;
  with ParentReport.QRPrinter do
    begin
      Rect.Left   := XPos(OfsX + Size.Left)+1;
      Rect.Top    := YPos(OfsY + Size.Top )+1;
      Rect.Right  := XPos(OfsX + Size.Left + Size.Width)-1;
      Rect.Bottom := YPos(OfsY + Size.Top  + Size.Height)-1;

      if not Transparent then
        begin
          Canvas.Brush.Color := Self.Color;
          Canvas.Brush.Style := bsSolid;
          Canvas.FillRect(Rect);
        end;
      Canvas.Brush.Style := bsClear;

      Canvas.Pen.Color := Frame.Color;
      Canvas.Pen.Width := Frame.Width;
      Canvas.Pen.Style := Frame.Style;

      Canvas.FillRect(Rect);
      Canvas.MoveTo(Rect.Left ,Rect.Top   );
      if Frame.DrawTop then
        Canvas.LineTo(Rect.Right-1,Rect.Top     )
      else
        Canvas.MoveTo(Rect.Right-1,Rect.Top     );
      if Frame.DrawRight then
        Canvas.LineTo(Rect.Right-1,Rect.Bottom-1)
      else
        Canvas.MoveTo(Rect.Right-1,Rect.Bottom-1);
      if Frame.DrawBottom then
        Canvas.LineTo(Rect.Left   ,Rect.Bottom-1)
      else
        Canvas.MoveTo(Rect.Left   ,Rect.Bottom-1);
      if Frame.DrawLeft then
        Canvas.LineTo(Rect.Left   ,Rect.Top     );

      DrawStyle := DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment];
      if WordWrap then
        DrawStyle := DrawStyle or DT_WORDBREAK;
      DoDrawText(Rect, DrawStyle);
    end;
end;

procedure TQRDBTextJ.DoDrawText(var Rect: TRect; Flags: Longint);
var
  Text: string;
  DC: HDC;
begin
  if Assigned(Field) then
    begin
      if FMask <> '' then
        begin
          case Field.DataType of
            ftSmallint,
            ftInteger,
            ftWord,
            ftFloat,
            ftCurrency,
            ftBCD,
            ftString:
              Text := FormatFloat(FMask, Field.AsCurrency);
            ftDate,
            ftTime,
            ftDateTime:
              Text := FormatDateTime(FMask, Field.AsDateTime);
          else
            Text := Field.AsString;
          end;
        end
      else
        Text := Field.AsString;
    end
  else
    Text := '';
  if Assigned(FQRLabelOnPrintEvent) then
    FQRLabelOnPrintEvent(Self, Text);
  Flags := Flags or DT_NOPREFIX;
  Flags := DrawTextBiDiModeFlags(Flags);
  with ParentReport.QRPrinter do
    begin
      if Enabled then
        begin
          DC := GetDCEx(Canvas.Handle, 0, DCX_PARENTCLIP);
          IntersectClipRect(DC,Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
          try
            DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
          finally
            ReleaseDC(Canvas.Handle, DC);
          end;
        end;
    end;
end;

procedure Register;
begin
  RegisterComponents('QReport', [TQRDBTextJ]);
end;

end.

 # 私は QuickReport のソースコードを持っておりません。...公開してもよかったのかなぁ(^^?

 ※ちゃんと動かない事が多いので参考程度でやめておいた方が無難です。


ComboBox でオートコンプリートを行う

 ブラウザなんかのURLバーのアレです。

private
  { Private 宣言 }
  KeyCD:Word;

...  

procedure TForm1.ComboBox1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  KeyCD := Key;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
var
  OLDSelStart,
  OLDLength,
  Index: Integer;
  ORGText,
  SrcText: String;
begin
  with (Sender as TComboBox) do
    begin
      ORGText     := Text;
      OLDSelStart := SelStart;
      OLDLength   := Length(ORGText);
      Index  := SendMessage(Handle, CB_FINDSTRING, -1, Integer(PChar(ORGText)));
      case KeyCD of
        VK_UP,
        VK_DOWN,
        VK_LEFT,
        VK_RIGHT,
        VK_BACK,
        VK_HOME,
        VK_END,
        VK_INSERT,
        VK_DELETE:;
      else
        if Index >= 0 then
          begin
            ItemIndex := Index;
            SrcText   := Text;
            Text      := ORGText + Copy(SrcText, Length(ORGText) + 1, High(Integer));
            SelStart  := OLDSelStart;
            SelLength := Length(Text) - OLDLength;
          end;
      end;
    end;
end;

 ※履歴を Items に残す仕掛けを作っておく必要があります。

 <!> Delphi 2009 以降では AutoComplete プロパティを True にするだけで実現できます。Delphi 2009 以前だと、日本語を含むオートコンプリートが正しく働かない事があります。 <!>


 BACK