拡大鏡のようなソフトを作るには？
解決Windowsのアクセサリにある拡大鏡のようなソフトはどのように作ればいいのでしょうか？
具体的には、透明なフォームを作成し、そのフォームに透かして表示された
デスクトップの画面をリアルタイムで拡大・縮小できるというものです。
もしよい方法がありましたらご指導ください。よろしくお願いします。
拡大縮小されたものを表示するフォームをプレビューフォームといい、
拡大縮小する部分を示すフォームをルーペフォームということにします。
デスクトップのデバイスコンテキストが取得できれば、APIのStretchBlt関数を使ってフォームに
拡大縮小描画できます。デスクトップのデバイスコンテキストはAPIのGetDC関数を引数に0を渡して
実行すれば取得できます。
あと、フォームを透かす方法は、いってみればくりぬいたフォームを作成すればいいでしょう。
これは、APIのCreateRectRgn関数またはCreateRectRgnIndirect関数を使用して、
外サイズ（大きい矩形）と内サイズ（小さい矩形）の領域を作成して、外サイズの領域から内サイズ
の領域をひけば、枠の形をした領域が作成されますので、これをフォームに適用すれば、
くりぬいたフォームが作成されます。
あとは、ループ処理で、マウス座標にあわせて、ルーペフォーム（くりぬいたフォーム）を移動させ、
あわせて、ルーペフォームの内サイズ部分をプレビューフォームのサイズにStretchBlt関数を使用して
描画すればOK。
サンプルプログラム
操作方法
プレビューフォームのサイズを変えると、それにあわせて拡大縮小されます。
プレビューフォームをクリックすると終了します。
・フォーム２つ
Form1（ルーペフォーム）
Form2（プレビューフォーム）
・標準モジュール
Module1
を用意します。
・Form1(ルーペフォームの各プロパティを下記のように設定します。
BackColor = お好きな色に
BorderStyle = 0(なし)
あと、サイズは小さめにしておいてください。プログラム中でプレビューフォームを
ルーペフォームの２倍に設定していますので、大きいとプレビューフォームがでかくなっちゃいます。
・Form2(プレビューフォーム)の各プロパティを下記のように設定します。
Caption = "" (空文字)
ControlBox = False
とするとキャプションがないリサイズできるウィンドウとなります。
あとは下記のプログラムをコピペすればOK
'Form2のソース
Option Explicit
Private Sub Form_Click()
'プレビューウィンドウがクリックされたら終了する
End
End Sub
'Module1のソース
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5
Private rc As Long
Private frmLoupe As Form1
Private frmPreview As Form2
Private RectA As RECT
Private RectB As RECT
Private hDeskTopDC As Long
Private Sub main()
Dim hRgnA As Long
Dim hRgnB As Long
'デスクトップのデバイスコンテキストのハンドルを取得
hDeskTopDC = GetDC(0)
'フォームオブジェクトを設定
Set frmLoupe = New Form1
Set frmPreview = New Form2
With frmPreview
.ScaleMode = vbPixels
.AutoRedraw = True
End With
'枠の外サイズを設定
With RectA
.Left = 0
.Top = 0
.Right = frmLoupe.Width \ Screen.TwipsPerPixelX
.Bottom = frmLoupe.Height \ Screen.TwipsPerPixelY
End With
'枠の内サイズを設定
With RectB
.Left = 5
.Top = 5
.Right = RectA.Right - 5
.Bottom = RectA.Bottom - 5
End With
'それぞれ領域を作成
hRgnA = CreateRectRgnIndirect(RectA)
hRgnB = CreateRectRgnIndirect(RectB)
'hRgnAの領域から、hRgnBの領域を引いて枠型領域を作成。作成した領域のハンドルをhRgnAに入れる。
rc = CombineRgn(hRgnA, hRgnA, hRgnB, RGN_DIFF)
'作成した枠型領域をルーペフォームに適用する
rc = SetWindowRgn(frmLoupe.hWnd, hRgnA, True)
'とりあえずデフォルトでは２倍に拡大とするのでプレビューフォームをルーペフォームの２倍に設定
'（厳密に２倍にするためにはフォームのリサイズ枠の幅も計算しなければならないけどね）。
With RectB
frmPreview.Width = (.Right - .Left) * 2 * Screen.TwipsPerPixelX
frmPreview.Height = (.Bottom - .Top) * 2 * Screen.TwipsPerPixelY
End With
'表示
frmLoupe.Show
frmPreview.Show
'拡大実行
Call KakudaiKyou
End Sub
'拡大縮小表示
Private Sub KakudaiKyou()
Dim mPos As POINTAPI
Do
'マウスの現在座標を取得
rc = GetCursorPos(mPos)
'ルーペをマウスに合わせて移動移動
With frmLoupe
frmLoupe.Move mPos.x * Screen.TwipsPerPixelX - .Width / 2, mPos.y * Screen.TwipsPerPixelY - .Height / 2
End With
DoEvents
'プレビューフォームに拡大描画
With RectB
rc = StretchBlt(frmPreview.hDC, 0, 0, frmPreview.ScaleWidth, frmPreview.ScaleHeight, hDeskTopDC, mPos.x - (.Right - .Left) / 2, mPos.y - (.Bottom - .Top) / 2, (.Right - .Left), (.Bottom - .Top), vbSrcCopy)
End With
frmPreview.Refresh
Loop
End Sub
とても丁寧な回答ありがとうございます。
まさかここまで分かりやすく教えていただけるとは思ってもみなかったので、大変驚いています。
説明の通りにやってみたところ無事、拡大鏡を作ることができました。
しかし、できればルーペをマウスに合わせて移動するのではなく、
自分で拡大したい場所までドラッグして移動するようにしたいのですが、
このようなことは可能でしょうか？
簡単に考えて２つの方法が考えられます。
１．枠をドラッグする方法
ルーペフォームをドラッグ中にもプレビュー表示を行うというのでしたら、
ループ処理が必要ですが、ドラッグ中はプレビュー表示を行わない、つまりドラッグ後にプレビュー
表示を行うのでしたら、別にループ処理は必要ありません。
あと、この方法ですと、枠の幅が小さい場合はドラッグ操作がやりにくいという欠点があります。
枠の幅を大きくする（RectB構造体に値を設定している計算式中にある「5」を大きな数字に変更）
すれば、ドラッグ操作は幾分やりやすくなります。
修正方法
計算しやすくするため、Form1のScaleModeを3（ピクセル）にしてください。
そしたら、Form1に下記のソースをコピペします。
Option Explicit
Private mX As Long
Private mY As Long
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
mX = X
mY = Y
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If mX <> 0 And Button = vbLeftButton Then
Me.Move Me.Left + (X - mX) * Screen.TwipsPerPixelX, Me.Top + (Y - mY) * Screen.TwipsPerPixelY
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
mX = 0
mY = 0
End If
DoEvents
Call KakudaiKyou
End Sub
標準モジュールのほうはドラッグ中にプレビューを表示させる場合とさせない場合とで修正
方法が変わってきます。
A.ドラッグ中にもプレビューを表示させる場合
KakudaiKyou関数を下記のように修正します。
'Form1からも呼んでいますので、Public関数に変更します。
Public Sub KakudaiKyou()
Do
DoEvents
With RectB
rc = StretchBlt(frmPreview.hDC, 0, 0, frmPreview.ScaleWidth, frmPreview.ScaleHeight, hDeskTopDC, (frmLoupe.Left \ Screen.TwipsPerPixelX) + 5, (frmLoupe.Top \ Screen.TwipsPerPixelY) + 5, (.Right - .Left), (.Bottom - .Top), vbSrcCopy)
End With
Loop
End Sub
B.ドラッグ中はプレビュー表示を行わない場合
main()関数の一番最後でKakudaiKyou関数を呼んでいましたが、必要ないので消します。
KakudaiKyou関数を下記のように修正します。
'Form1(ルーペフォーム)からも呼んでいますので、Public関数に変更します。
Public Sub KakudaiKyou()
DoEvents
With RectB
rc = StretchBlt(frmPreview.hDC, 0, 0, frmPreview.ScaleWidth, frmPreview.ScaleHeight, hDeskTopDC, (frmLoupe.Left \ Screen.TwipsPerPixelX) + 5, (frmLoupe.Top \ Screen.TwipsPerPixelY) + 5, (.Right - .Left), (.Bottom - .Top), vbSrcCopy)
End With
End Sub
２．ルーペフォームのタイトルバーを表示させ、タイトルバーでドラッグを行う方法
タイトルバーを表示させれば、ドラッグできます。しかし、タイトルバーでのマウスイベントは
拾えません。また、タイトルバーをドラッグしているときは、同一プロセス内において「ドラッグする」という
処理されませんのでドラッグ中でのプレビュー表示ができません。しかし、マウスアップなどの
イベントが拾えないですので、ループ処理（DoEvents付き)で半リアルタイム的にプレビュー表示
を行うことにより対処しています。
まず、Form1(ルーペフォーム)のControlBoxプロパティをTrueにし、BorderStyleを1(固定）にします。
それと、今回は計算しやすくするためにForm1のScaleModeプロパティを1(Twip)のままにします。
１．の方法においてForm1にソースを追加しましたが今回は必要ありません。
また、１．の方法において、main関数で呼んでいたKakudaikyou関数を消しましたが今回は必要ですので残しておきます。
しかし、このままですとルーペフォームのくりぬき部分がタイトルバーにも及んでしまいますので、
タイトルバー部分をくりぬかないように内サイズ(RectB構造体)を変更します。
main関数の
'枠の内サイズを設定
With RectB
.Left = 5
.Top = 5
.Right = RectA.Right - 5
.Bottom = RectA.Bottom - 5
End With
という部分を
'枠の内サイズを設定
With RectB
.Left = 5
.Top = (Form1.Height-Frm1.ScaleHeight) \ Screen.TwipsPerPixelY
.Right = RectA.Right - 5
.Bottom = RectA.Bottom - 5
End With
内サイズの変更に伴いKakudaiKyou関数を下記のように修正します。
Public Sub KakudaiKyou()
Do
DoEvents
With RectB
rc = StretchBlt(frmPreview.hDC, 0, 0, frmPreview.ScaleWidth, frmPreview.ScaleHeight, hDeskTopDC, (frmLoupe.Left \ Screen.TwipsPerPixelX) + 5, (frmLoupe.Top \ Screen.TwipsPerPixelY) + (frmLoupe.Height - frmLoupe.ScaleHeight) \ Screen.TwipsPerPixelY, (.Right - .Left), (.Bottom - .Top), vbSrcCopy)
End With
Loop
End Sub
以上が各方法による修正方法です。枠サイズとプレビューサイズの厳密な調整は行っていませんので、
誤差があるかと思いますが、その辺のところはご自分で調整してください。
frmPreview.Refreshが抜けていたので少し苦戦しましたが、
２のタイトルバーでドラッグを行う方法で作成したところ、
まさに自分の思い描いていた通りのものが出来上がりました。
この度は、とても分かりやすく説明していただき大変勉強になりました。
どうもありがとうございました。
| ツイート |  |