拡大鏡（Ⅰ）              <TOP>

虫眼鏡を作成します。

SendMessage メッセージを送る

SetWindowPos ウィンドウの状態を設定

ReleaseCapture マウスキャプチャの解放

GetDesktopWindow デスクトップのウィンドウハンドル取得

StretchBlt 画像の拡大転送

GetDC ウィンドウハンドルからhDC取得

ReleaseDC hDCを解放

GetCursorPos マウスカーソル位置の取得

CreatePolygonRgn ポリゴン作成

CreateEllipticRgn 円形・楕円形の領域設定

CreateRectRgn 矩形領域の設定

CreateRoundRectRgn 角を丸めた領域の設定

CombineRgn リージョンを結合し新しいリージョンに設定

SetWindowRgn 指定領域をウィンドウ領域に設定

　

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

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

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

タイトルバーのないフォームの移動のリストと併用して、枠部分をドラッグすると移動できるようにしています。

フォームをワンクリックするたびに20％拡大し、4倍を超えると等倍に戻しています。

フォームをダブルクリックで終了させています。

参考

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

LOUPE.lzh

'================================================================
'= 拡大鏡(虫眼鏡原型：MainForm12角形)
'= MainForm、Picture1は同サイズ重ね合わせ
'=    (loupe.bas)
'================================================================
#include "Windows.bi"

'点を示すタイプ
Type POINTAPI
    x As Long
    y As Long
End Type

' ウィンドウにメッセージを送信。この関数は、指定したウィンドウのウィンドウプロシージャが処理を終了するまで制御を返さない
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_GetCursorPos& Lib "user32" Alias "GetCursorPos" (lpPoint As POINTAPI)

' 多角形のリージョンを作成
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&)

#define COLORONCOLOR 3
#define HTCAPTION 2                     'タイトルバーをクリックしたことを示す
#define WN_NCLBUTTONDOWN &HA1           '非クライアント領域で左マウスボタンを押す
#define RGN_AND 1                       'リージョン同士のAND結合
#define RGN_COPY 5                      'HRGNSRC1のコピーを作成
#define RGN_DIFF 4                      'HRGNSRC1からHRGNSRC2を除いた領域
#define RGN_Or 2                        'リージョン同士のOR結合
#define RGN_XOr 3                       'リージョン同士のXOR結合
#define NULLREGION 1                    'リージョンは空
#define SIMPLEREGION 2                  'リージョンは単一の長方形
#define ERRORAPI 0                      '
#define INDING 2                        '全域モード(塗りつぶし)
#define RCCOPY &HCC0020                 '転送元長方形を転送先長方形にそのままコピー
#define WND_TOPMOST -1                  '
#define SWP_NOACTIVATE &H10             'ウィンドウをアクティブにしない
#define SWP_SHOWWINDOW &H40             'ウィンドウを表示する
#define vbLeftButton 1                  '左ボタンクリック
#define vbRightButton 2                 '右ボタンクリック

Var Shared DtphDC As Long               'デスクトップデバイスコンテキスト
Var Shared PichDC As Long               'ピクチャボックスデバイスコンテキスト
Var Shared srcXY As Integer

Var Shared Picture1 As Object
Var Shared Timer1 As Object

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

'================================================================
'=
'================================================================
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

    Corner = 12                         '外周(8～12)
    Var xy(Corner) As POINTAPI          'Corner角形の頂点位置

    srcXY = 100

    DtphWnd = Api_GetDesktopWindow()    'デスクトップハンドル取得
    PichDC = Api_GetDC(Picture1.GethWnd)'デバイスコンテキスト取得
    DtphDC = 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 xy As POINTAPI
    Var Ret As Long

    Ret = Api_GetCursorPos(xy)
    Ret = Api_SetStretchBltMode(PichDC, COLORONCOLOR)
    Ret = Api_StretchBlt(PichDC, 0, 0, 200, 200, DtphDC, xy.x - (srcXY / 2), xy.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 Picture1_Click edecl ()
Sub Picture1_Click()
    srcXY = srcXY - 20
    If srcXY < 10 Then srcXY = 200
End Sub

'================================================================
'= 終了(ピクチャダブルクリック)
'================================================================
Declare Sub Picture1_DblClick edecl ()
Sub Picture1_DblClick()
    Var Ret As Long

    Ret = Api_ReleaseDC(Picture1.GethWnd, PichDC)
    Ret = Api_ReleaseDC(DtphWnd, DtphDC)
    End
End Sub

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