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

　WindowsAPIの「SetBkMode」を使用します。引数１にCanvasオブジェクトのハンドル、引数２に透過モードを指定します。

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;

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

　もっとも、

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

　や、

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

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

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

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

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

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

また、Delphi6以降で「MSWINDOWS」「LINUX」という対Kylix用の条件シンボルが新たに追加されています。

Delphi2009以降で「UNICODE」という ANSI/Unicode を区別する条件シンボルが新たに追加されています。

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

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

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

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,1, 1) = '"' 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[1] in SwitchChars) then
        if IgnoreCase then
          begin
            if (AnsiCompareText(Copy(S, 2, Length(Switch)), Switch) = 0) then
              begin
                Result := True;
                Exit;
              end;
          end
        else
      begin
        if (AnsiCompareStr(Copy(S, 2, Length(Switch)), Switch) = 0) then
          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[1] in SwitchChars) then
        if IgnoreCase then
          begin
            if (AnsiCompareText(Copy(S, 2, Length(Switch)), Switch) = 0) then
              begin
                Result := I;
                Exit;
              end;
          end
        else
      begin
        if (AnsiCompareStr(Copy(S, 2, Length(Switch)), Switch) = 0) then
          begin
            Result := I;
            Exit;
          end;
      end;
    end;
  Result := -1;
end;

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

Windows98を使用しているのにMenuがOffice97ライクにならない場合

　恐らく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,Default:String):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,Default:String):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,Default:String):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..255] of Char;
　Files :Integer;
begin
　if Msg.Message = WM_DROPFILES then
　　begin
　　　DragQueryFile(Msg.wParam, 0, FileNames, Sizeof(FileNames) - 1);
　　　Files := DragQueryFile(Msg.wParam, $FFFFFFFF, nil, 0);
　　　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;

[解説]
・FormCreateにドラッグファイルを受け付けるコントロールをDragAcceptFiles()で列挙しておきます。

・AppMessageで実際にドロップされたコントロールを調べるにはＦindDragTarget()を使用します。
　上の例では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)

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

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

あら、便利ですねぇ。

TStringListのススメ(その2)

　TStringListを２個使うと...

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 0do
　　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 のヘルプ関連プロパティ/メソッドで扱えるようになります <!>

アルファブレンディング機能を利用する(Windows2000)

　拙作「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(0,0,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(ver3.0x)でマトモなワードラップを行う

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

　...つー事でまともに折り返す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 <> nil) then
        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 以前だと、日本語を含むオートコンプリートが正しく働かない事があります。 <!>