Canvas で文字等を重ねて描画する
WindowsAPI の SetBkMode() を使用します。第 1 引数に Canvas オブジェクトのハンドル、第 2 引数に透過モードを指定します。
透過モード
背景はテキスト、ハッチブラシ、またはペンが描画される前に現在の背景色で塗りつぶされます。
背景はそのまま残されます。
EX.1
SetBkMode(Printer.Canvas.Handle,TRANSPARENT);
連続した半角スペースを得る
...まさか、
なんてやってませんよね？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 詰なんか簡単。「１・２・３・４...」なんてスペースキー叩いた回数を数えなくても済みますよ(^^;
もっとも、
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
VER140
Delphi 6
VER150
Delphi 7
VER160
Delphi 8IDE Integration Pack for Delphi 8 IDE Integration Pack for C# Builder 1.0
VER170
Delphi 2005
VER180
BDS 2006 (Delphi / C++Builder)
VER185
Delphi 2007
VER200
Delphi 2009
VER210
Delphi 2010
VER220
Delphi XE
VER230
Delphi XE2
VER240
Delphi XE3
VER250
Delphi XE4
VER260
Delphi XE5
VER265
Appmethod 1.13
VER270
Delphi XE6
VER280
Delphi XE7
他にも定義されているものがあります。
CONSOLE
コンソールアプリケーションであるかどうかを判断します。
MSWINDOWS
ターゲットプラットフォームが Windows であるかを判断します。
WIN32
ターゲットプラットフォームが 32bit Windows 用ネイティブアプリケーションであるかを判断します。
WIN64
ターゲットプラットフォームが 64bit Windows 用ネイティブアプリケーションであるかを判断します。(XE2 で追加)
LINUX
ターゲットプラットフォームが Linux であるかを判断します。Kylix / CLX 用。
POSIX
ターゲットプラットフォームが POSIX 準拠 OS であるかを判断します。Linux や MacOSX 用であるかを判断できます。
POSIX32
ターゲットプラットフォームが 32bit の POSIX 準拠 OS であるかを判断します。Linux や MacOSX であるかを判断できます。
MACOS
ターゲットプラットフォームが Mac OSX であるかを判断します。(XE2 で追加)
MACOS32
ターゲットプラットフォームが 32bit Mac OSX であるかを判断します。(XE2 で追加)
IOS
ターゲットプラットフォームが iOS であるかを判断します。(XE4 で追加)
Android
ターゲットプラットフォームが Android であるかを判断します。(XE5 で追加)
CPU386
x86 アーキテクチャ用かどうかを判断します。
CPUX86
x86 アーキテクチャ用かどうかを判断します。X86ASM も同時に定義されます。(XE2 で追加)
CPUX64
x64 アーキテクチャ用かどうかを判断します。X64ASM / PUREPASCAL も同時に定義されます。(XE2 で追加)
UNICODE
Unicode アプリケーションであるかどうかを判断します。(2009 で追加)
ASSEMBLER
インラインアセンブラが使えるかどうかを判断します。
X86ASM
x86 用のアセンブラを記述できるかどうかを判断します。
X64ASM
x64 用のアセンブラを記述できるかどうかを判断します。
PUREPASCAL
アセンブラが利用できない場合の条件定義です。
これらを判断して条件コンパイルに役立てる事ができます。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,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" スイッチとして取得できます。
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, 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 ファイルが存在しない場合、新規作成して書き込みます。
レジストリにアクセスする。
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() は存在しない階層を一気に作成します。
複数のコンポーネントを 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 で実際にドロップされたコントロールを調べるには FindDragTarget() を使用します。
上の例では TEdit コントロールにドロップされたファイル名をセットしています。
※例では単一のファイル名のみを処理しています。
ファイル名がワイルドカードに一致しているか判定する。
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(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 (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 <> 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 以前だと、日本語を含むオートコンプリートが正しく働かない事があります。 <!>
