Private Sub Command1_Click()

Me.WindowState = 1
DoEvents
Form2.Show
Call SetWindowPos(Form2.hwnd, HWND_TOPMOST, 0, 0, 0, 0, _
                  SWP_SHOWWINDOW Or SWP_NOSIZE Or SWP_NOMOVE)

End Sub

Private hMemdc  As Long
Private hBmp    As Long
Private hOldBmp As Long

Private StartPo As POINTAPI
Private EndPo   As POINTAPI



Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
' ESCで終了
If KeyCode = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
Dim hDeskdc As Long
Dim w As Long, h As Long

' 画面サイズをピクセルに変換
w = Screen.Width / Screen.TwipsPerPixelX
h = Screen.Height / Screen.TwipsPerPixelY

' デスクットップをコピー
hDeskdc = GetDC(0)
hMemdc = CreateCompatibleDC(0)

hBmp = CreateCompatibleBitmap(hDeskdc, w, h)
hOldBmp = SelectObject(hMemdc, hBmp)

Call BitBlt(hMemdc, 0, 0, w, h, hDeskdc, 0, 0, vbSrcCopy)

Call ReleaseDC(0, hDeskdc)
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

' 範囲選択
If Button = vbLeftButton Then
'   前のを消す
    Call Rectangle(Me.hdc, StartPo.x, StartPo.y, EndPo.x, EndPo.y)
'   新しいのを書く
    Call Rectangle(Me.hdc, StartPo.x, StartPo.y, x, y)
'   新しい座標を取得
    EndPo.x = x
    EndPo.y = y
End If

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
'   カーソルをクロスにする
    MousePointer = vbCrosshair
'   スタート位置を記憶
    StartPo.x = x
    StartPo.y = y
    EndPo = StartPo
End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim Frm As New Form3    ' キャプチャのたびに作る

If Button = vbLeftButton Then
    MousePointer = vbDefault
    EndPo.x = x
    EndPo.y = y

'   フォームの設定
    Load Frm
    With Frm
'       横の淵も含めた幅を計算
        .Width = (Abs(EndPo.x - StartPo.x) * Screen.TwipsPerPixelX) + _
                 (.Width - (.ScaleWidth * Screen.TwipsPerPixelX))
'       タイトルバーも含めた高さを計算
        .Height = (Abs(EndPo.y - StartPo.y) * Screen.TwipsPerPixelY) + _
                  (.Height - (.ScaleHeight * Screen.TwipsPerPixelY))
        
'       マイナス方向へ範囲選択された時の処理
        If StartPo.x > EndPo.x Then
            StartPo.x = EndPo.x
        End If
        If StartPo.y > EndPo.y Then
            StartPo.y = EndPo.y
        End If
'       フォームへコピー
        Call BitBlt(.hdc, 0, 0, .ScaleWidth, .ScaleHeight, hMemdc, StartPo.x, StartPo.y, vbSrcCopy)
        .Show
    End With
    Unload Me
End If

End Sub

Private Sub Form_Paint()
' AutoRedrawは遅いのでしない
Call BitBlt(Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, hMemdc, 0, 0, vbSrcCopy)
End Sub

Private Sub Form_Unload(Cancel As Integer)
' 最前面を解除
Call SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, _
                  SWP_SHOWWINDOW Or SWP_NOSIZE Or SWP_NOMOVE)
' 後処理
Call SelectObject(hMemdc, hOldBmp)
Call DeleteObject(hBmp)
Call DeleteDC(hMemdc)

' 呼び出しフォームを戻す
Form1.WindowState = 0
End Sub