拡大鏡（Ⅲ）              <TOP>

虫眼鏡を作成します。 拡大鏡(Ⅰ)と同じですが、拡大・縮小およびスムーズ拡大(？)、終了を右クリックで選択できるようにしてみました。

SystemParametersInfo システム全体に関するパラメータを取得・設定
GetCursorPos マウスカーソル(マウスポインタ)の現在の位置に相当するスクリーン座標を取得
SendMessage メッセージを送る

SetWindowPos ウィンドウの状態を設定
ReleaseCapture マウスキャプチャの解放
GetDesktopWindow デスクトップのウィンドウハンドル取得
StretchBlt 画像の拡大転送
GetDC ウィンドウハンドルからデバイスコンテキストを取得

ReleaseDC デバイスコンテキストを解放

CreatePolygonRgn 多角形のリージョンを作成
CreateEllipticRgn 楕円形のリージョンを作成
CreateRectRgn 長方形のリージョンを作成
CreateRoundRectRgn 角の丸い長方形のリージョンを作成
CombineRgn 既存の二つの領域を結合して新しい領域を作成
SetWindowRgn 指定の領域をウィンドウ領域として設定
SetStretchBltMode 指定されたデバイスコンテキストのビットマップ伸縮モードを設定
AnimateWindow フォームをアニメーション表示
　

メインフォーム（200×200）にピクチュアボックス（200×200）を重ね合わせます。

ルーペは8～12角形を選んでください(例では12角形)。角数が多いと円形に近くなり、少ない場合は枠より円のほうが大きくなります。

ルーペ倍率は初期で２倍に設定しています。カーソルの部分を拡大します。

ルーペの移動は、青いフレーム部分をドラッグ します。

フレーム(青い枠)部を右クリックすると、クリックした位置を左上とする設定ポップアップメニュー(Form2)が表示されます。

拡大縮小

スクロールバーで指定します。拡大縮小率は、その都度表示されます。

拡大縮小範囲

0.8倍 ～ 4倍

通常拡大

StretchBltでの拡大縮小転送です。

スムーズ

SetStretchBltModeを使って綺麗に(?)拡大縮小します。

設定終了

ポップアップメニューを消します。

ルーペの終了

アニメーション終了(あまり効いていません)させています。

　

 

左：元の写真        中：通常拡大        右：スムーズ拡大

    

参考

LOUPE4.LZHをダウンロードするとF-Basicをお持ちでない方でも試用できます。

LOUPE4.lzh

　
'================================================================
'= 虫眼鏡　(リージョン:MainForm12角形)
'=    MainForm、Picture1は同サイズ重ね合わせ
'=    (Loupe4.bas)
'================================================================
#include "Windows.bi"

Type POINTAPI
    x As Long
    y As Long
End Type

Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

' システム全体に関するパラメータを取得・設定
Declare Function Api_SystemParametersInfo& Lib "user32" Alias "SystemParametersInfoA" (ByVal uiAction&, ByVal uiParam&, pvParam As RECT, ByVal fWinIni&)

' マウスカーソル(マウスポインタ)の現在の位置に相当するスクリーン座標を取得
Declare Function Api_GetCursorPos& Lib "user32" Alias "GetCursorPos" (lpPoint As POINTAPI)

' ウィンドウにメッセージを送信。この関数は、指定したウィンドウのウィンドウプロシージャが処理を終了するまで制御を返さない
Declare Function Api_SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hWnd&, ByVal wMsg&, ByVal wParam&, lParam As Any)

' ウィンドウのサイズ、位置、および Z オーダーを設定
Declare Function Api_SetWindowPos& Lib "user32" Alias "SetWindowPos" (ByVal hWnd&, ByVal hWndInsertAfter&, ByVal X&, ByVal Y&, ByVal CX&, ByVal CY&, ByVal uFlags&)

' マウスのキャプチャを解放
Declare Function Api_ReleaseCapture& Lib "user32" Alias "ReleaseCapture" ()

' Windowsのデスクトップウィンドウを識別。返されるポインタは、一時的なポインタ。後で使用するために保存しておくことはできない
Declare Function Api_GetDesktopWindow& Lib "user32" Alias "GetDesktopWindow" ()

' 拡縮をともなうグラフィックデバイス間のイメージを転送
Declare Function Api_StretchBlt& Lib "gdi32" Alias "StretchBlt" (ByVal hDC&, ByVal X&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, ByVal nSrcWidth&, ByVal nSrcHeight&, ByVal dwRop&)

' 指定されたウィンドウのクライアント領域または画面全体を表すディスプレイデバイスコンテキストのハンドルを取得
Declare Function Api_GetDC& Lib "user32" Alias "GetDC" (ByVal hWnd&)

' デバイスコンテキストを解放
Declare Function Api_ReleaseDC& Lib "user32" Alias "ReleaseDC" (ByVal hWnd&, ByVal hDC&)

' 多角形のリージョンを作成
Declare Function Api_CreatePolygonRgn& Lib "gdi32" Alias "CreatePolygonRgn" (lppt As POINTAPI, ByVal nCount&, ByVal nPolyFillMode&)

' 楕円形のリージョンを作成
Declare Function Api_CreateEllipticRgn& Lib "gdi32" Alias "CreateEllipticRgn" (ByVal nLeftRect&, ByVal nTopRect&, ByVal nRightRect&, ByVal nBottomRect&)

' 長方形のリージョンを作成
Declare Function Api_CreateRectRgn& Lib "gdi32" Alias "CreateRectRgn" (ByVal nLeftRect&, ByVal nTopRect&, ByVal nRightRect&, ByVal nBottomRect&)

' 角の丸い長方形のリージョンを作成
Declare Function Api_CreateRoundRectRgn& Lib "gdi32" Alias "CreateRoundRectRgn" (ByVal nLeftRect&, ByVal nTopRect&, ByVal nRightRect&, ByVal nBottomRect&, ByVal nWidthEllipse&, ByVal nHeightEllipse&)

' 既存の二つの領域を結合して新しい領域を作成
Declare Function Api_CombineRgn& Lib "gdi32" Alias "CombineRgn" (ByVal hRgnDest&, ByVal hRgnSrc1&, ByVal hRgnSrc2&, ByVal nCombineMode&)

' 指定の領域をウィンドウ領域として設定
Declare Function Api_SetWindowRgn& Lib "user32" Alias "SetWindowRgn" (ByVal hWnd&, ByVal hRgn&, ByVal bRedraw&)

' 指定されたデバイスコンテキストのビットマップ伸縮モードを設定
Declare Function Api_SetStretchBltMode& Lib "gdi32" Alias "SetStretchBltMode" (ByVal hDC&, ByVal nStretchMode&)

' フォームをアニメーション表示
Declare Function Api_AnimateWindow& Lib "user32" Alias "AnimateWindow" (ByVal hWnd&, ByVal dwTime&, ByVal dwFlags&)

#define COLORONCOLOR 3
#define FORM_HIDE &H80000 Or &h10000    '複合操作
#define HALFTONE 4                      'ハーフトーン
#define HTCAPTION 2                     'タイトルバーをクリックしたことを示す
#define INDING 2                        '全域モード(塗りつぶし)
#define MF_STRING &H0                   '文字列
#define RCCOPY &HCC0020                 '転送元長方形を転送先長方形にそのままコピー
#define TPM_LEFTALIGN &H0               'ショートカットメニューの左端を、xパラメータが指定する座標に合わせる
#define TPM_RETURNCMD &H100             '関数の戻り値として、ユーザーが選択したメニュー項目のIDを返す
#define TPM_RIGHTBUTTON &H2             'マウスの右ボタンでポップアップメニューからの選択が行えるようにする
#define WN_NCLBUTTONDOWN &HA1           '非クライアント領域で左マウスボタンを押す
#define WND_TOPMOST -1                  '
#define SWP_NOACTIVATE &H10             'ウィンドウをアクティブにしない
#define SWP_SHOWWINDOW &H40             'ウィンドウを表示する
#define SPI_GETWORKAREA 48

Var Shared dhDC As Long                 'デスクトップデバイスコンテキスト
Var Shared phDC As Long                 'ピクチャボックスデバイスコンテキスト
Var Shared srcXY As Integer
Var Shared hMenu As Long
Var Shared Flag As Long
Var Shared pa As POINTAPI
Var Shared rc As RECT

'---------- MainForm --------------------------------------------
Var Shared Picture1 As Object
Var Shared Timer1 As Object

Picture1.Attach GetDlgItem("Picture1")
Timer1.Attach GetDlgItem("Timer1")

'---------- Form2 -----------------------------------------------
Var Shared Form2 As Object
Var Shared Text1 As Object
Var Shared HScroll1 As Object
Var Shared Check1 As Object
Var Shared Button1 As Object
Var Shared Button2 As Object

'================================================================
'=
'================================================================
Declare Sub MainForm_Start edecl ()
Sub MainForm_Start()
    Var i As Integer
    Var Corner As Byte                  '角の数
    Var Rad  As Double                  '角度
    Var Rgn1 As Long                    '外枠
    Var Rgn2 As Long                    '円形
    Var Ret  As Long

    'ワークエリア取得
    Ret = Api_SystemParametersInfo(SPI_GETWORKAREA, 0, rc, 0)

    Flag = 0

    '外周(8～12)
    Corner = 12

    'Corner角形の頂点位置
    Var xy(Corner) As POINTAPI

    srcXY = 100

    'デスクトップハンドル取得
    DtphWnd = Api_GetDesktopWindow()

    'PictureBoxデバイスコンテキスト取得
    phDC = Api_GetDC(Picture1.GethWnd)

    'デスクトップデバイスコンテキスト取得
    dhDC = Api_GetDC(DtphWnd)

    'ひとつ分の角度
    Rad = 3.1415926 / (Corner / 2)

    For i = 0 To Corner - 1
        xy(i).x = Sin(Rad * i) * (GetWidth / 2) + (GetWidth / 2)
        xy(i).y = Cos(Rad * i) * (GetHeight / 2) + (GetHeight / 2)
    Next i

    '外枠
    Rgn1 = Api_CreatePolygonRgn(xy(0), Corner, INDING)
    Ret = Api_SetWindowRgn(GethWnd, Rgn1, -1)

    '円形
    Rgn2 = Api_CreateEllipticRgn(10, 10, GetWidth - 9, GetHeight - 9)
    Ret = Api_SetWindowRgn(Picture1.GethWnd, Rgn2, -1)

    Ret = Api_SetWindowPos(GethWnd, WND_TOPMOST, 0, 0, GetWidth, GetHeight, SWP_SHOWWINDOW Or SWP_NOACTIVATE)

    '形状設定後表示
    ShowWindow -1

    Timer1.SetInterval 10
    Timer1.Enable -1
End Sub

'================================================================
'= カーソル位置のデスクトップ画像を拡大して転送
'================================================================
Declare Sub Timer1_Timer edecl ()
Sub Timer1_Timer()
    Var Ret As Long

    Ret = Api_GetCursorPos(pa)

    If Flag = 0 Then
        'そのまま拡大縮小
        Ret = Api_SetStretchBltMode(phDC, COLORONCOLOR)
    Else
        '綺麗に拡大縮小
        Ret = Api_SetStretchBltMode(phDC, HALFTONE)
    End if

    Ret = Api_StretchBlt(phDC, 0, 0, 200, 200, dhDC, pa.x - (srcXY / 2), pa.y - (srcXY / 2), srcXY, srcXY, RCCOPY)
End Sub

'================================================================
'=    
'================================================================
Declare Sub MainForm_MouseDown edecl (Button As Integer, Shift As Integer, x As Single, y As Single)
Sub MainForm_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Var Ret As Long

    Ret = Api_ReleaseCapture()
    Ret = Api_SendMessage(GethWnd, WN_NCLBUTTONDOWN, HTCAPTION, 0)
End Sub

'================================================================
'= 設定フォーム
'================================================================
Declare Sub MainForm_MouseUp edecl (Button As Integer, Shift As Integer, x As Single, y As Single)
Sub MainForm_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Var Flags As Long
    Var Ret As Long

    If Not(CheckObject(Form2)) Then
        Form2.CreateWindow "Form2", -1
        Text1.Attach Form2.GetDlgItem("Text1") : Text1.SetFontSize 14
        HScroll1.Attach Form2.GetDlgItem("HScroll1")
        Check1.Attach Form2.GetDlgItem("Check1") : Check1.SetFontSize 14
        Button1.Attach Form2.GetDlgItem("Button1") : Button1.SetFontSize 14
        Button2.Attach Form2.GetDlgItem("Button2") : Button2.SetFontSize 14

        Form2.SetTopMostWindow -1

        'マウスカーソルの位置を取得
        Ret = Api_GetCursorPos(pa)

        '設定画面(Form2)が、ワークエリア外に位置する場合の処理
　　　　If pa.x + Form2.GetWidth > rc.Right And pa.y + Form2.GetHeight > rc.Bottom Then
            '縦横共にエリア外の場合
            Form2.MoveWindow rc.Right - 200, rc.Bottom - 130

        Else If pa.x + Form2.GetWidth > rc.Right Then
            '横のみエリア外の場合
            Form2.MoveWindow rc.Right - 200, pa.y

        Else If pa.y + Form2.GetHeight > rc.Bottom Then
            '縦のみエリア外の場合
            Form2.MoveWindow pa.x, rc.Bottom - 130

        Else
            'アリア内の場合
            Form2.MoveWindow pa.x, pa.y
        End If

        HScroll1.SetScrollRange 50, 250
        HScroll1.SetScrollStep 10, 10
        HScroll1.SetScrollPos 300 - srcXY
        Text1.SetWindowText "拡大縮小率：" & Format$(200 / srcXY, "#.#")
        Check1.SetCheck Flag
        Flag = Check1.GetCheck
    End If
End Sub

'================================================================
'= スムーズ処理
'================================================================
Declare Sub Check1_on edecl ()
Sub Check1_on()
    Flag = Check1.GetCheck
End Sub

'================================================================
'= 拡大率設定
'================================================================
Declare Sub HScroll1_Change edecl ()
Sub HScroll1_Change()
    srcXY = 300 - HScroll1.GetScrollPos
    Text1.SetWindowText "拡大縮小率：" & Format$(200 / srcXY, "#.#")
End Sub

'================================================================
'= 設定終了
'================================================================
Declare Sub Button1_on edecl ()
Sub Button1_on()
    Form2.DestroyWindow
    Text1.Detach
    HScroll1.Detach
    Check1.Detach
    Button1.Detach
    Button2.Detach
End Sub

'================================================================
'= 拡大鏡の終了
'================================================================
Declare Sub Button2_on edecl ()
Sub Button2_on()
    Form2.DestroyWindow
    Text1.Detach
    HScroll1.Detach
    Check1.Detach
    Button1.Detach
    Button2.Detach

    Ret = Api_ReleaseDC(Picture1.GethWnd, phDC)
    Ret = Api_ReleaseDC(DtphWnd, dhDC)
    Ret = Api_AnimateWindow(GethWnd, 1000, FORM_HIDE)
    End
End Sub

'================================================================
'=
'================================================================
While 1
    WaitEvent
Wend
Stop
End