拡大鏡のようなソフトを作るには？ (ID:81353)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

拡大縮小されたものを表示するフォームをプレビューフォームといい、
拡大縮小する部分を示すフォームをルーペフォームということにします。

デスクトップのデバイスコンテキストが取得できれば、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

←解決時は質問者本人がここをチェックしてください。

戻る