Option Explicit

Const LICENSE_KEY = "xxxxxxxx-xxxxxxxx-xxxxxxxx-xxxxxxxx"

Const TITLE = "ポイント位置の文字列取得"

'----------------------------------------------
Const PAUSE_KEY = VK_SHIFT
Const PAUSE_KEY_NAME = "SHIFT"
'----------------------------------------------

Dim LoopSw As Boolean   '実行中
Dim Getting As Boolean  '取得中

'ウィンドウ状態
Private Type ORG_VALUE
    caption As String       'キャプション
    windowstate As Integer  '
    width As Integer        'ウィンドウ幅
    height As Integer       '　　　　　高さ
End Type
Dim OrgValue As ORG_VALUE
 
Private Sub cmdGo_Click()
     
    Dim p As POINTAPI
    Dim X As Long, Y As Long      '現在のポインタ位置
    Dim x_o As Long, y_o As Long  '前回のポインタ位置
    Dim hwnd As Long        'ウィンドウハンドル
    Dim Got As Boolean      '取得済み
    Dim rc As Long
    
    On Error GoTo MyErr

    Call DispTop(Application.hwnd)  '最前面
  
    If LoopSw Then          '実行中→中止
        LoopSw = False
    Else
        
        Call Init '初期化
        
        '----------------------------------------------------
        'ライセンスキーを登録
        '---------------------------
        rc = RegistKey(LICENSE_KEY)
        '----------------------------------------------------

     
        LoopSw = True
        Getting = True

        GetAsyncKeyState (PAUSE_KEY)    '空読み
         
        Do While LoopSw

            If Getting Then '取得中
            
                GetCursorPos p
                X = p.X: Y = p.Y
                 
                hwnd = WindowFromPoint(X, Y)
                lblMousePos = X & "," & Y
                lblhWnd = hwnd
                lblClassName = MyGetClassName(hwnd)
                '
                ' 取得条件
                ' 　マウスが停止していること
                ' 　取得済みではないこと、自ウィンドウ以外であること
                '
                If (X <> x_o) Or (Y <> y_o) Then    '移動中
                    Got = False                     '未取得に設定
                ElseIf (Got = False) And (GetTopParent(hwnd) <> Application.hwnd) Then  '未取得＆自以外のウィンドウ
                    DoEvents
         
                    txtText.Text = MyGetText(X, Y)
                    txtFullText.Text = MyGetFullText(X, Y)
    
                    Dim l As Long, t As Long, w As Long, h As Long
                    Dim Role As Long, ObjType As String, Dt As String
                    Dim lpRec As ACC_RECT
                     
                    rc = GetAccLocation(X, Y, lpRec)
         
                    Role = Val(GetAccNum(X, Y, GS_ACC_NUM_ROLE))
                    Select Case GetObjType(X, Y)
                        Case 1: ObjType = "Simple Element"
                        Case 2: ObjType = "Real Object"
                        Case 3: ObjType = "Container"
                    End Select
     
                    Dt = ""
                    Dt = Dt & "Name        : " & MyGetAccInfo(X, Y, GS_ACC_INFO_NAME) & vbCrLf
                    Dt = Dt & "Value       : " & MyGetAccInfo(X, Y, GS_ACC_INFO_VALUE) & vbCrLf
                    Dt = Dt & "Role        : " & Role & ":" & MyGetAccRoleText(Role) & vbCrLf
                    Dt = Dt & "State       : " & "x" & Hex(Val(GetAccNum(X, Y, GS_ACC_NUM_STATE))) & vbCrLf
                    Dt = Dt & "Location    : " & lpRec.pxLeft & "," & lpRec.pxTop & "," & _
                                                 lpRec.pxRight & "," & lpRec.pxBottom & vbCrLf
                    Dt = Dt & "DefAction   : " & MyGetAccInfo(X, Y, GS_ACC_INFO_DEFAULTACTION) & vbCrLf
                    Dt = Dt & "ChildCount  : " & GetAccNum(X, Y, GS_ACC_NUM_CHILDCOUNT) & vbCrLf
                    Dt = Dt & "Description : " & MyGetAccInfo(X, Y, GS_ACC_INFO_DESCRIPTION) & vbCrLf
                    Dt = Dt & "Object Type : " & ObjType & vbCrLf
                    Dt = Dt & "ID          : " & GetAccNum(X, Y, GS_ACC_NUM_ID) & vbCrLf
                     
                    txtAccInfo.Text = Dt
                     
                    txtStatusText = MyGetStatusText(X, Y)
         
                    Got = True  '取得済み
         
                End If
                x_o = X: y_o = Y
            
            End If
             
            If GetAsyncKeyState(PAUSE_KEY) <> 0 Then
                Getting = Not Getting   'フラグ反転
                If Getting Then
                    Application.caption = PAUSE_KEY_NAME & "キー：停止"
                Else
                    Application.caption = "停止中 " & PAUSE_KEY_NAME & "キー：再開"      'タイトル
                End If
                DoEvents
                Sleep 1000 '押しっぱなし対処
            End If
            Sleep 30
            DoEvents
        Loop
        
    End If
     
    GoTo MyEnd
 
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:

    Call DispUntop(Application.hwnd)  '最前面解除
    
    Call Default '処理終了
        
    On Error GoTo 0
     
End Sub
 

Private Sub Init()
'
' 開始時の処理
'
    Const HOSEI_HEIGHT = 40     '高さ補正
    Dim BookPath As String      'ブックのパス

    BookPath = ThisWorkbook.Path    'ブックのパス
    ChDrive left(BookPath, 1)       'ドライブ変更
    ChDir BookPath                  'ディレクトリ変更
    
    With Application
        
        '現在値退避
        OrgValue.caption = .caption         'キャプション
        OrgValue.windowstate = .windowstate 'ウィンドウ状態
        If .windowstate = xlNormal Then     '通常サイズ？
            OrgValue.width = .width         ' ウィンドウ幅高記憶
            OrgValue.height = .height
        End If
 
        .caption = PAUSE_KEY_NAME & "キー：停止"      'タイトル
        .windowstate = xlNormal         '通常サイズ
        .height = txtStatusText.top + txtStatusText.height + HOSEI_HEIGHT   '　　　　　高さ
        .width = txtText.width                                              'ウィンドウ幅

        .DisplayFormulaBar = False      '数式バー
        .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"    'リボン非表示
        
    End With
    
    With ActiveWindow

        .DisplayHeadings = False            '行列見出し
        .DisplayWorkbookTabs = False        'シート見出し
        .DisplayVerticalScrollBar = False   '垂直スクロールバー
        .DisplayHorizontalScrollBar = False '水平スクロールバー

    End With

    cmdGo.caption = "終了"

    lblMousePos = "": lblhWnd = "": lblClassName = ""
    txtText = "": txtFullText = "": txtAccInfo = "": txtStatusText = ""
    
    MsgBox PAUSE_KEY_NAME & " キーで一時停止／再開" & vbNewLine & vbNewLine & "「終了」ボタンクリックでシートに戻ります。", vbOKOnly, "GetTextDLL"

End Sub
 
Public Sub Default()
'
' 終了時の処理
'
    With Application

        '元の値復元
        If OrgValue.caption <> "" Then
            .caption = OrgValue.caption
            .windowstate = OrgValue.windowstate
            If .windowstate = xlNormal Then
                .width = OrgValue.width
                .height = OrgValue.height
            End If
        End If
        
        .DisplayFormulaBar = True   '数式バー
        .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",true)" 'リボン表示
 
    End With
    
    With ActiveWindow

        .DisplayHeadings = True     '行列見出し
        .DisplayWorkbookTabs = True

        .DisplayVerticalScrollBar = True
        .DisplayHorizontalScrollBar = True
        
    End With
    
    cmdGo.caption = "開始"
    
End Sub