☆デスクトップに定規を・・・。

細かいマトリックス表をDocuworksで編集していると、行や列がわからなくなるので わざわざ三角スケールを画面に当てて作業している人がいました。 液晶画面が傷つきそうなので、次のようなものを作ってみました。 (定規と書いていますが、測定するためのものではないです)

Docu

(この画像では、2つ起動させ、それぞれを縦と横に設定して使っています。)

次の通り仕組みは簡単です。ポイントとしては、キャプションのないフォームを移動させる 処理かな。
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, ExtCtrls, StdCtrls, Menus;

type
  TForm1 = class(TForm)
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    procedure N1Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    procedure WMNCHitTest(var Msg : TWMNchitTest); Message WM_NCHITTEST;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  DefaultSize = 25;

procedure TForm1.FormCreate(Sender: TObject);
begin
  BorderStyle := bsNone;
  AlphaBlend := True;
  AlphaBlendValue := 200;
  Color := clBlack;
  N2Click(Self);
end;

procedure TForm1.N1Click(Sender: TObject);
begin
  Close;
end;

// 横
procedure TForm1.N2Click(Sender: TObject);
var
  ARect: TRect;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, @ARect, 0);
  Height := DefaultSize;
  Width := Screen.Width * 3;
  Left := -Screen.Width;
  Top := ARect.Bottom-(ARect.Top+DefaultSize);
end;

// 縦
procedure TForm1.N3Click(Sender: TObject);
var
  ARect: TRect;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, @ARect, 0);
  Width := DefaultSize;
  Height := Screen.Height * 3;
  Top := -Screen.Height;
  Left := ARect.Right-DefaultSize;
end;

// 隅へ移動
procedure TForm1.N4Click(Sender: TObject);
var
 ARect: TRect;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, @ARect, 0);
  Width := DefaultSize;
  Height := DefaultSize;
  Top := ARect.Bottom-(ARect.Top+DefaultSize);
  Left := ARect.Right-DefaultSize;
end;

procedure TForm1.WMNCHitTest(var Msg: TWMNchitTest);
const
  Offset = 3;
var
  P: TPoint;
begin
  P := ScreenToClient(Point(Msg.XPos, Msg.YPos));

  if (P.X > Width-Offset) and (P.Y > Height-Offset) then
    Msg.Result := HTBOTTOMRIGHT
  else if (P.X > Width-Offset) and (P.Y < Offset) then
    Msg.Result := HTTOPRIGHT
  else if (P.X < Offset) and (P.Y > Height-Offset) then
    Msg.Result := HTBOTTOMLEFT
  else if (P.X < Offset) and (P.Y < Offset) then
    Msg.Result := HTTOPLEFT
  else if (P.X < Offset) then
    Msg.Result := HTLEFT
  else if (P.X > Width-Offset) then
    Msg.Result := HTRIGHT
  else if (P.Y < Offset) then
    Msg.Result := HTTOP
  else if (P.Y > Height-Offset) then
    Msg.Result := HTBOTTOM
  else if (GetAsyncKeyState(VK_LBUTTON) < 0) then
    Msg.Result := HTCAPTION
  else
    Msg.Result := HTCLIENT;
end;

end.

|

☆FormのOnMouseWheelDown(Up)

CAD Viewerを作っていて、FormのOnMouseWheelDown(Up)で問題が発生しました。 CADではコードがややこしいので、下記のような簡単なもので考えてみることにします。 問題点としては、PaintBoxに描画したものをマウスホイールにより拡大縮小する 仕様なのですが、この動作によりListBoxがスクロールしてしまうことです。

Cad


問題のあるコード
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    PaintBox1: TPaintBox;
    procedure PaintBox1Paint(Sender: TObject);
    procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure FormCreate(Sender: TObject);
  private
    P: Integer;
    procedure DrawData;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  P := 0;
  Form1.OnResize := PaintBox1Paint;
  for I := 0 to 99  do
    ListBox1.Items.Add(IntToStr(I));
end;

procedure TForm1.DrawData;
var
  Rect: TRect;
begin
  // Clear
  Rect.Top := PaintBox1.Top;
  Rect.Left := PaintBox1.Left;
  Rect.Bottom := PaintBox1.Height;
  Rect.Right := PaintBox1.Width;
  // Rectangle
  PaintBox1.Canvas.FillRect(Rect);
  Rect.Top := (PaintBox1.Top + P);
  Rect.Left := PaintBox1.Left + P;
  Rect.Bottom := PaintBox1.Height - P;
  Rect.Right := PaintBox1.Width - P;
  PaintBox1.Canvas.Rectangle(Rect);
end;

procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  Dec(P,5);
  DrawData;
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  Inc(P,5);
  DrawData;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  DrawData;
end;

end.


対策後のコード
MouseWheelDown(Up)をそれぞれ下記のようにしました。
procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
var
  Pt: TPoint;
begin
  GetCursorPos(Pt);
  Pt := ScreenToClient(Pt);
  if ((Pt.X > 0) and (Pt.X < PaintBox1.Width)) and
     ((Pt.Y > 0) and (Pt.Y < PaintBox1.Height)) then
  begin
    Handled := True;
    Dec(P,5);
    DrawData;
  end;
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
var
  Pt: TPoint;
begin
  GetCursorPos(Pt);
  Pt := ScreenToClient(Pt);
  if ((Pt.X > 0) and (Pt.X < PaintBox1.Width)) and
     ((Pt.Y > 0) and (Pt.Y < PaintBox1.Height)) then
  begin
    Handled := True;
    Inc(P,5);
    DrawData;
  end;
end;

これによりPaintBox1上にマウスがある場合のみPaintBox1にマウスホイールが働きます。 ListBox1をスクロールするには、ListBox1上にマウスを移動させます。

|

☆リターンキーで移動させる。

なんだっけ?なんだっけ?となかなか思い出せず、過去のプログラムを 調べて、ようやく見つけた出した SelectNext!超、超、超いまさらですが、書いておきますね。

Form1のKeyPreviewをTrueにする必要があります。
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  //リターンキーで移動させる
  if Key = #13 then
  begin
    SelectNext(ActiveControl, True, True);
    Key := #0;
  end;
end;

|

☆多数のEditのテキストを削除する。

TFormは、TComponentから派生されていますので、 ComponentsプロパティやComponentCountプロパティを使えば、 フォーム上のコンポーネントの単純な処理が可能になります。
ここでは、Editのテキストを空白にする処理を行ってみました。

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  // Editの初期化
  for I := 0 to Self.ComponentCount - 1 do
    if Self.Components[I] is TEdit then
      (Self.Components[I] as TEdit).Text := '';
end;

|

☆入力間違いを知らせる一つの方法

Yahoo!ウィジェットか何かで、ID、パスワードが違うとフォームが細かく左右に動く・・・まるで「いやいや」(関西人としては、「ちゃうちゃう」かな)してるようなものを見たことがあるので、Delphiで試してみました。

フォームにボタンを貼り付けて、試してみて下さい。
procedure TForm1.Button1Click(Sender: TObject);
const
  Wait = 50;
var
  I, J: Integer;
begin
  J := -30;
  for I := 0 to 3 do
  begin
    case I of
      0: Left := Left - 15;
      1..3: begin
              J := J * (-1);
              Left := Left + J;
            end;
    end;
    Sleep(Wait);
    Application.ProcessMessages;
  end;
  Left := Left-15;
end;

|

その他のカテゴリー

ADO | ADT | API | ArrayList | ASP.NET | BDE | BDP.NET | BdpConnection | Borland Developer Studio 2006 | CAPICOM | class | ClipBoard | CodeEditor | Convert.ToString | Custom component | DBExpress | Delphi 2005 | Delphi 2006 | Delphi 2007 | Delphi XE2 | Delphi7 | Delphi8 | Device Driver | Dialog | Docking | DocuWorks | Docuworks SDK | Drag&Drop | Evernote | EXCEL | Firebird | FireMonkey | Game | General | Generics | Google Earth COM API | Google Maps | Google SketchUp | Graphic | IDE | Imm | Indy | InstallAware Express6 | InterBase Admin | JWW | Microsoft SQL Server | MyBase | OnMouseDown | Oracle XE | Paradox | PreviewHandler | PrintDialog | PrintPreviewDialog | PropertyGrid | PSDファイル | Ribbon Controls | RichTextBox | Servers | SubClass | TAction | TActionList | TAnimate | TButton | TCategoryButtons | TClientDataSet | TComboBox | TComboBoxEx | TCustomEdit | TDBGrid | TDockTabSet | TDrawGrid | TEdit | TExcelApplication | TFont | TForm | third party | TImage | TLabel | TList | TListBox | TListView | TMemo | TOpenDialog | TOutlookApplication | TPageControl | TPanel | TRichEdit | TShellResources | TStringGrid | TTabControl | TToolBar | TToolButton | TTreeView | TWebBrowser | Update | VCL Styles | WinInet | XE2 | XPman | オープン配列パラメータ | グループ化 | トランスレーションマネージャー | ファイル処理 | ファイル名処理 | 動的配列 | 投票 | 文字列処理 | 日本語入力 | 暗号 | | 音声合成利用