|
枠のないフォームのリサイズと移動
まずマウスの位置を検出
function GetMyMouseStatus(P: TPoint; R: TRect): integer;
// 0内 1左 2右 3上 4左上 5右上 6下 7左下 8右下(ちゃんと理由がある)
//┌─┬─┬─┐
//│ 4│ 3│ 5│
//├─┼─┼─┤
//│ 1│ 0│ 2│
//├─┼─┼─┤
//│ 7│ 6│ 8│
//└─┴─┴─┘
const
mg: integer = 8; // センスマージン
begin
{内側なら 0} Result := 0;
{左端なら+1} if (P.X < R.Left + mg) then Result := Result + 1;
{右端なら+2} if (R.Right - mg < P.X) then Result := Result + 2;
{上端なら+3} if (P.Y < R.Top + mg) then Result := Result + 3;
{下端なら+6} if (R.Bottom - mg < P.Y) then Result := Result + 6;
end;
マウスカーソルを設定
function SetMyResizeCursor(MouseStatus: integer): TCursor;
begin
case MouseStatus of {West,East,North,South}
1,2: Result := crSizeWE; {⇔}
3,6: Result := crSizeNS; {|}
4,8: Result := crSizeNWSE; {\}
5,7: Result := crSizeNESW; {/}
else
Result := crDefault;
end;
end;
マウス通過時の対応
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
var
P: TPoint; // マウスカーソルの位置
MyMouseStatus: integer; // 0..8
begin
GetCursorPos(P); // スクリーン系座標
MyMouseStatus := GetMyMouseStatus(P, BoundsRect);
Cursor := SetMyResizeCursor(MyMouseStatus);
// マウスの左ボタンを押されていなければ終わり
if not (ssLeft in Shift) then exit;
//
ReleaseCapture;
if MyMouseStatus = 0 then begin
// フォームをドラッグする
SendMessage(Handle, WM_SYSCOMMAND, SC_MOVE or HTCAPTION, MakeLong(X,Y));
end else begin
// フォームをリサイズする
SendMessage(Handle, WM_SYSCOMMAND, SC_SIZE or MyMouseStatus, MakeLong(X,Y));
end;
end;
バージョン情報をグラデーション表示
ダイアログのOnPaintで描画
procedure TForm1.MyDlgPaint(Sender :TObject);
// uses GraphUtil // usesに追加必要
// { Private 宣言 }
// procedure MyDlgPaint(Sender :TObject); // Privateに追加必要
// { OnFormCreate }
// Randomize; // FormCreateに追加必要
var
sc1: TColor; // StartColor
ec1: TColor; // EndColor
gd1: TGradientDirection;
begin
with TForm(Sender) do begin
sc1 := clWhite; // $FFFFFF
ec1 := Random(sc1); // $000000..sc1
if odd(ec1) then
gd1 := gdHorizontal {→}
else
gd1 := gdVertical; {↓}
GradientFillCanvas(Canvas,sc1,ec1,ClientRect,gd1);
end;
end;
グラデーションでバージョン表示
procedure TForm1.About1Click(Sender: TObject);
// グラデーションでバージョン表示
var
MyDlg1 : TForm; // ダイアログも実体はフォーム
Msg1 : string;
begin
Msg1 := Application.Title + sLineBreak + Application.ExeName;
MyDlg1 := CreateMessageDialog(Msg1,mtInformation,[mbOK]);
with MyDlg1 do try
Caption := 'バージョン情報';
BorderIcons := [];
Timage (Components[0]).Picture.Icon := Application.Icon;
TLabel (Components[1]).Transparent := true;
TLabel (Components[1]).AutoSize := true;
TButton(Components[2]).Caption := 'おぅいぇ';
TButton(Components[2]).Cursor := crHandPoint;
Position := poScreenCenter;
OnPaint := MyDlgPaint; // イベントハンドラを追加
ShowModal;
finally
Free;
end;
end;
色分解と再合成
var
Color1, Color2 : Tcolor;
Red1, Green1, Blue1 : integer; // $00..$FF
Red2, Green2, Blue2 : integer; // $00..$FF
RGBに分解
Red1 := GetRValue(ColorToRGB(Color1)); // Windows API
Green1 := GetGValue(ColorToRGB(Color1)); // Windows API
Blue1 := GetBValue(ColorToRGB(Color1)); // Windows API
// 延々と割り算して引き算していたのは知らなかっただけ
RGBから再合成
Color2 := RGB(Red2,Green2,Blue2); // Windows API
// 次々に掛け算して足し算していたのも知らなかったから
フォームの色をランダムに
Form1.Color := Random(clWhite); // clWhite = $FFFFFF
// FormCreateでRandomizeしておく
プログレスバーの色を変える
SendMessage(ProgressBar1.Handle,PBM_SETBARCOLOR,0,Color2); // バー表示の色 Windows API
ProgressBar1.Brush.Color := Color1; // バー背景の色
ちょっとした小技
拡張子以外の部分も変名
SaveFileName1 := 'HelloWorld.exe';
SaveFileName2 := ChangeFileExt(SaveFileName1,'Link.html');
// → SaveFileName2 = 'HelloWorldLink.html'
他のアプリを最小化、デスクトップを表示
procedure TForm1.MinimizeOthers;
// 他のアプリを最小化(戻らない)
begin
// [Windows]キーを押す
Keybd_event(VK_LWIN, 0, 0, 0);
// [M]キーを押す
Keybd_event(Byte('M'), 0, 0, 0);
// [M]キーを離す
Keybd_event(Byte('M'), 0, KEYEVENTF_KEYUP, 0);
// [Windows]キーを離す
Keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);
end;
procedure TForm1.ShowDeskTop;
// デスクトップを表示(再呼び出しで戻る)
begin
// [Windows]キーを押す
Keybd_event(VK_LWIN, 0, 0, 0);
// [D]キーを押す
Keybd_event(Byte('D'), 0, 0, 0);
// [D]キーを離す
Keybd_event(Byte('D'), 0, KEYEVENTF_KEYUP, 0);
// [Windows]キーを離す
Keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);
end;
フォント名を指定してプロポーショナルフォントかどうかを判定
function IsProportionalFont(AFontName: string): boolean;
var
TM1: TTextMetric;
begin
Result := false;
with TCanvas.Create do try
Handle := CreateCompatibleDC(0);
Font.Name := AFontName;
GetTextMetrics(Handle,TM1) ;
if (TM1.tmPitchAndFamily and TMPF_FIXED_PITCH) = TMPF_FIXED_PITCH then
Result := true;
DeleteDC(Handle);
finally
free;
end;
end;
ツリービューの横スクロール位置を保存して復元
var
si : SCROLLINFO; // スクロール情報構造体
ScrollPosX : integer; // 横スクロール桁位置
// 保存
GetScrollInfo(TreeView1.Handle, SB_HORZ, si); // 状況取得
WriteInteger('OPTION', 'ScrollPosX', si.nPos); // 保存
// 復元
ScrollPosX := ReadInteger('OPTION','ScrollPosX',0); // 読出し
ZeroMemory(@si, SizeOf(SCROLLINFO)); // 初期化
si.cbSize := SizeOf(SCROLLINFO);
si.fMask := SIF_POS;
si.nPos := ScrollPosX;
SetScrollInfo(TreeView1.Handle, SB_HORZ, si, true); // 反映
URLから純ファイル名(最下層名)を得る
if RightStr(Url1,1) = '/' then Url1 := LeftStr(Url1,Length(Url1)-1);
FileName1 := ExtractFileName(StringReplace(Url1,'/','\',[rfReplaceAll]));
重複しない文字列行だけを追加する
if (Memo1.Lines.IndexOf(Str1) = -1) and (Memo2.Lines.IndexOf(Str1) = -1) then
// 既出とも新作とも重複しなければ
begin
Memo2.Lines.Add(Str1); // 新作として追加する
end;
リストボックスから右クリックで選択してメニューも表示する
procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X,Y: Integer);
var
Yi : integer; // Y方向のインデクス
begin
if not ( ssRight in Shift ) then exit; // 右ボタンが押されていなければ終わり
//
Yi := Y div ListBox1.ItemHeight + ListBox1.TopIndex; // 押されたのは何行めか
if Yi >= ListBox1.Items.Count then exit; // 既存行の外なら終わり
//
ListBox1.ItemIndex := Yi; // 行を決めて
Form1.ListBox1Click(self); // 左クリックしたことにして(ここで行選択される)
PopupMenu1.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y); // その座標にポップアップ表示
end;
一行入力Editの隠し味
数字とBackSpaceしか入力できないようにする
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9',Char(VK_BACK)]) then Key := #0;
end;
入力キャレット(縦棒)を右端に表示する
// Edit1.SelStart := Length(Edit1.Text);
// ↓ 結果は同じ
Edit1.SelStart := MaxInt;
Edit内でエンターキーを有効にする
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if key = Char(VK_RETURN) then
begin
key := #0; // 副作用防止
Form1.Button1Click(self); // Enterでさせたいことを記述
end;
end;
起動と終了 (INIファイル型)
uses
Inifiles;
var
IsCloseQuery : boolean;
IsSaveStatus : boolean;
const
VersionConst : string = 'V1.0';
inifileを読んで起動
procedure TForm1.FormCreate(Sender: TObject);
var
IniFileName : string;
begin
IniFileName := ChangeFileExt(Application.ExeName,'.ini');
with TIniFile.Create(IniFileName) do
try
// 位置
Top := ReadInteger('POSITION','Top' , (Screen.Height - Height) div 2);
Left := ReadInteger('POSITION','Left', (Screen.Width - Width ) div 2);
Height:= ReadInteger('POSITION','Height', Height);
Width := ReadInteger('POSITION','Width', Width);
// オプション
Mode1 := ReadBool ('OPTION','Mode1',False);
Name1 := ReadString ('OPTION','Name1','');
Data1 := ReadInteger('OPTION','Data1',0);
IsCloseQuery := ReadBool('OPTION','CloseQuery',false);
IsSaveStatus := ReadBool('OPTION','SaveStatus',false);
finally
free;
end;
end;
inifileに書いて終了
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var
IniFileName: string;
begin
if IsCloseQuery then
begin
if Application.MessageBox('終了してもよいですか?' ,
PChar(Application.Title), MB_YesNo + MB_IconQuestion) = IdNo then
begin
CanClose := False; // Noなら終了をキャンセルして終わり
exit;
end;
end;
// Ini書き込み
IniFileName := ChangeFileExt(Application.ExeName,'.ini');
with TIniFile.Create(IniFileName) do
try
// 概要
WriteString('PROGRAM','Name',ExtractFileName(Application.ExeName));
WriteString('PROGRAM','Path',ExtractFilePath(Application.ExeName));
WriteString('PROGRAM','Version',VersionConst);
// 位置
EraseSection('POSITION');
EraseSection('OPTION');
if IsSaveStatus then
begin
WriteInteger('POSITION','Top',Top);
WriteInteger('POSITION','Left',Left);
WriteInteger('POSITION','Height',Height);
WriteInteger('POSITION','Width',Width);
// オプション
WriteBool ('OPTION','Mode1',Mode1);
WriteString ('OPTION','Name1',Name1);
WriteInteger('OPTION','Data1',Data1);
WriteBool('OPTION','CloseQuery',IsCloseQuery);
WriteBool('OPTION','SaveStatus',IsSaveStatus);
end;
finally
Free;
end;
end;
ショートカットを作成する
uses
ShlObj, ActiveX, ComObj, Registry;
デスクトップに登録する
procedure TForm1.DeskTop1Click(Sender: TObject);
const
MyRegFile : string = 'Software\Microsoft\Windows\CurrentVersion\Explorer';
MyMessage : string = 'デスクトップに登録しますか?';
MyFolders : string = 'Desktop';
// -------------------------------------------------------------------------
// ↓ここから下は共通
var
MyObject : IUnknown;
MySLink : IShellLink; // ShlObj
MyPFile : IPersistFile; // ActiveX
Directory : String;
WFileName : WideString;
begin
if Application.MessageBox(PChar(MyMessage),'確認',
MB_YesNo + MB_IconQuestion) = IdNo then exit; // Noなら何もしないで終わり
// Yesなら
MyObject := CreateComObject(CLSID_ShellLink); // ComObj
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
MySLink.SetPath(PChar(Application.ExeName));
//
with TRegIniFile.Create(MyRegFile) do // Registry
try
Directory := ReadString('Shell Folders',MyFolders,'') + '\';
WFileName := Directory + Application.Title + '.Lnk';
MyPFile.Save(PWChar(WFileName),False);
ShowMessage(WFileName + ' に登録しました。'); // OKを押して終わり
finally
Free;
end;
end;
スタートアップに登録する
procedure TForm1.StartUp1Click(Sender: TObject);
const
MyRegFile : string = 'Software\Microsoft\Windows\CurrentVersion\Explorer';
MyMessage : string = 'スタートアップに登録しますか?';
MyFolders : string = 'Startup';
// -------------------------------------------------------------------------
{以下同文}
スタートメニューに登録する
procedure TForm1.StartMenu1Click(Sender: TObject);
const
MyRegFile : string = 'Software\Microsoft\Windows\CurrentVersion\Explorer';
MyMessage : string = 'スタートメニューのプログラムに登録しますか?';
MyFolders : string = 'Programs';
// -------------------------------------------------------------------------
{以下同文}
ヘルプを表示する
procedure TForm1.Help2Click(Sender: TObject);
var
HelpFileName: string;
begin
HelpFileName := ChangeFileExt(Application.ExeName,'.hlp');
ShellExecute(handle,'open',PChar(HelpFileName),nil,nil,SW_SHOWNORMAL); // Windows API
end;
バージョンを表示する
const
VersionConst : string = 'V1.0'; // バージョン定数
procedure TForm1.About1Click(Sender: TObject);
var
Text1,Text2,Text3 : string;
begin
Text1 := '『'+Application.Title+'』のバージョン情報'; // タイトルバー用
Text2 := 'Windows版『' + Application.Title + '』' + VersionConst; // 1行め
Text3 := 'application built by 沌珍館企画 (C)2006'; // 2行め
ShellAbout(Handle,Pchar(Text1+'#'+Text2),Pchar(Text3),Application.Icon.Handle); // Windows API
end;
ホームページを表示する
procedure TForm1.Site1Click(Sender: TObject);
const
SiteURL : string = 'http://hp.vector.co.jp/authors/VA012191/';
begin
ShellExecute(handle,'open',PChar(SiteURL),nil,nil,SW_SHOWNORMAL); // Windows API
end;
テキストエリアの内容をメールソフトに渡す
procedure TForm1.Mail1Click(Sender: TObject);
var
MailString: string;
i: integer;
begin
MailString := '?subject=【メール送信サンプル】&body=';
for i := 0 to Memo1.Lines.Count - 1 do
begin
MailString := MailString + Memo1.Lines[i]+'%0D%0A';
if length(MailString) > 2048 then break;
end;
ShellExecute(Application.Handle,'open',PChar(MailString),nil,nil,SW_SHOWNORMAL); // Windows API
end;
日付関連の振分け変換
西暦から干支を計算
function YearToEto(year: integer): String;
begin
case (( year + 8) mod 12 ) of
0: result := '子・ね';
1: result := '丑・うし';
2: result := '寅・とら';
3: result := '卯・う';
4: result := '辰・たつ';
5: result := '巳・み';
6: result := '午・うま';
7: result := '未・ひつじ';
8: result := '申・さる';
9: result := '酉・とり';
10: result := '戌・いぬ';
11: result := '亥・い';
end;
end;
月日から星座を計算
function DateToSeiza(Date1:TDateTime): string;
begin
case StrToInt(FormatDateTime('mmdd',Date1)) of
101.. 119: result := '山羊(やぎ)'; // Capricorn
120.. 218: result := '水瓶(みずがめ)'; // Aquarius
219.. 320: result := '魚(うお)'; // Pisces
321.. 419: result := '牡羊(おひつじ)'; // Aries
420.. 520: result := '牡牛(おうし)'; // Taurus
521.. 621: result := '双子(ふたご)'; // Gemini
622.. 722: result := '蟹(かに)'; // Cancer
723.. 821: result := '獅子(しし)'; // Leo
822.. 922: result := '乙女(おとめ)'; // Virgo
923..1023: result := '天秤(てんびん)'; // Libra
1024..1122: result := '蠍(さそり)'; // Scorpio
1123..1221: result := '射手(いて)'; // Sagittarius
1222..1231: result := '山羊(やぎ)'; // Capricorn
else
result := FormatDateTime('mm/dd',Date1);
end;
result := result+'座';
end;
コンパイルエラー事例
while文 / with文
begin
while MyGuitar.GentlyWeeps do begin
I.DontKnow(WHY, Nobody.Told(You), HowToUnfold(YourLove));
I.DontKnow(HOW, Someone.Controlled(You));
They.BoughtAndSold(You);
with EveryMistake do try
We.Must(SURELY, beLearning);
finally
still MyGuitar.GentlyWeeps;
end;
end;
end;
|