frog.raindrop.jp.knowledge

VERSION 5.00
Begin VB.UserControl ctlAsyncEvent 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   HasDC           =   0   'False
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   3600
   ScaleWidth      =   4800
End
Attribute VB_Name = "ctlAsyncEvent"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'-----------------------------------------------------------------------------
'
'   非同期イベント発生コントロール
'
'   ソース名: ctlAsyncEvent.ctl
'   作成日　: 2005.02.22
'
'-----------------------------------------------------------------------------
Option Explicit
Private Const CNST_MODULE_NAME  As String = "ctlAsyncEvent"
''========================================================================
''
''========================================================================
''
'' イベント定義
''
Public Event AsyncEvent(ByVal plngEventId As Long)

''========================================================================
''
''========================================================================
''
'' 型定義
''

Private Type POINTAPI
    x       As Long
    y       As Long
End Type

''========================================================================
''
''========================================================================
''
'' 外部DLLプロシージャ宣言
''

Private Const WM_MBUTTONDOWN                  As Long = &H207   '
Private Const WM_MBUTTONUP                    As Long = &H208   '
Private Const WM_MOUSEMOVE                    As Long = &H200   '
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'******************************************************************
'プロシージャ名   :Raise
'説明             :非同期イベントを発生させる
'引数             :plngEventId          I   イベントの識別番号
'******************************************************************
Public Sub Raise(ByVal plngEventId As Long)
'============= Declare ==============
Dim lngRet      As Long

'============= Initiarize ===========
On Error GoTo ERR_HANDLER_00

'============= Main =================
    
    '' 中ボタンクリックをポストする
    lngRet = PostMessage(UserControl.hWnd, WM_MOUSEMOVE, 0&, plngEventId)
    Call DebugLog(CONT_STATE_NOTE, CNST_MODULE_NAME & ".Raise", "Succeed")

'============= Release ==============
RESUME_00:
    Exit Sub
'============= Error ================
ERR_HANDLER_00:
    Call Err.Raise(Err.Number, CNST_MODULE_NAME & ".Raise ← " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)

End Sub

'------------------------------------------------------------------
'プロシージャ名   :UserControl_MouseMove
'説明             :マウス移動時処理
'引数             :Button               I   押下中のマウスボタン
'                 :Shift                I   シフト状態
'                 :X                    I   クライアント座標:X座標
'                 :Y                    I                   :Y座標
'------------------------------------------------------------------
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
'============= Declare ==============
Dim udtPoint        As POINTAPI
Dim lngOrglParam    As Long
Dim lngRet          As Long

'============= Initiarize ===========
On Error GoTo ERR_HANDLER_00

'============= Main =================
    
    Call DebugLog(CONT_STATE_NOTE, CNST_MODULE_NAME & ".UserControl_MouseMove", "Start")
    
    '' オリジナルの LPARAM を求める
    With UserControl
        udtPoint.x = .ScaleX(x, .ScaleMode, vbPixels)
        udtPoint.y = .ScaleY(y, .ScaleMode, vbPixels)
    End With
    Call CopyMemory(lngOrglParam, udtPoint, Len(lngOrglParam))
        
    '' 非同期イベントを発生させる
    RaiseEvent AsyncEvent(lngOrglParam)
    
    Call DebugLog(CONT_STATE_NOTE, CNST_MODULE_NAME & ".UserControl_MouseMove", "End")
    
'============= Release ==============
RESUME_00:
    Exit Sub
'============= Error ================
ERR_HANDLER_00:
    Call HandleWarn(Err.Number, Err.Source, Err.Description, CNST_MODULE_NAME & ".UserControl_MouseMove")

    Resume RESUME_00
End Sub