ここから本文です

vbsで指定タイトルのウィンドウを検索(部分一致)→結果(有無)で異なる処理(分岐)を...

w3g********さん

2020/7/306:45:00

vbsで指定タイトルのウィンドウを検索(部分一致)→結果(有無)で異なる処理(分岐)をするプログラムをお願いします。

OS「Windows 10 64bit」

例えば、vbsでタイトルの一部に「画像」というウィンドウがあるか検索(部分一致)して、ある場合はそのウィンドウをアクティブかつクリップボードに文字列「True」をコピーして、ない場合はクリップボードに文字列「False」をコピーするプログラムです。

回答よろしくお願いいたします。

閲覧数:
34
回答数:
1
お礼:
50枚

違反報告

ベストアンサーに選ばれた回答

2020/7/519:20:10

このスクリプトは64bit, 32bit 両方で動作するように設計しましたが、別途、フリーソフト SFC mini のインストールが必要です。Vector から入手できます。
https://www.vector.co.jp/download/file/winnt/prog/fh652422.html
開発テスト環境:Windows10 1909 32bit (64bitでの動作は未確認)

' ----- WSH - VBScript --- ( SFC mini required ) -----
Option Explicit

Dim EnumWindows
Declare EnumWindows, "user32", "EnumWindows"

Dim IsWindowVisible
Declare IsWindowVisible, "user32", "IsWindowVisible"

Dim GetWindowText
Declare GetWindowText, "user32", "GetWindowTextA"

Private Sub Declare(objWinAPI, Library, FunctionName)

    Set objWinAPI = WScript.CreateObject("SfcMini.DynaCall")
    objWinAPI.Declare Library, FunctionName

End Sub

Call SelectAction

' ------------------------------------------------

' 取得したウィンドウタイトルと、検索文字を突き合わせます
Private Sub SearchWindow()

    Dim strFindString
    strFindString = InputBox( _
        "検索する文字列を入力してください。" _
        & vbCrLf & vbCrLf & _
        "英字は大文字・小文字を区別します。", _
        "ウィンドウタイトルの検索 - " & WScript.ScriptName)

    If strFindString <> "" Then
        Dim arrTitleString
        arrTitleString = GetWindowTitle

        Dim strFound
        strFound = "False"

        Dim strTitle
        Dim lngFindResult
        For Each strTitle in arrTitleString
            lngFindResult = InStr(strTitle, strFindString)
            If lngFindResult > 0 Then
                strFound = "True"
                Call SetForeFrontWindow(strTitle)
                Call SetClipboardText(strFound)
                Exit For
            End If
        Next

        Dim intQuestionResult
        If strFound = "False" Then
            intQuestionResult = MsgBox( _
                "見つかりませんでした。" & vbCrLf & _
                "検索文字を変えて、もう一度検索しますか?" & _
                vbCrLf & vbCrLf & _
                "英字は大文字・小文字を区別します。", _
                vbYesNo Or vbQuestion Or vbSystemModal, _
                "ウィンドウタイトルの検索結果 - " & WScript.ScriptName)
        End If

        Select Case intQuestionResult
            Case vbYes
                Call SearchWindow
            Case vbNo
                Call SetClipboardText(strFound)
        End Select

    End If

End Sub

' ------------------------------------------------

' ヒットしたウィンドウを最前面表示します
Private Sub SetForeFrontWindow(strTitle)

    Dim objSetForeAPI
    Set objSetForeAPI = WScript.CreateObject("SfcMini.DynaCall")

    With objSetForeAPI
        .LoadLibraries "User32.dll", "Kernel32.dll"

        Dim hWnd
        hWnd = .FindWindowA(vbNullString, strTitle)

        Dim ThreadID
        ThreadID = .GetWindowThreadProcessId(hWnd, 0)

        Dim ThreadHandle
        Const THREAD_QUERY_INFORMATION = &H40
        ThreadHandle = _
            .OpenThread(THREAD_QUERY_INFORMATION, False, ThreadID)

        Dim ProcessID
        ProcessID = .GetProcessIdOfThread(ThreadHandle)

        Call .AllowSetForegroundWindow(ProcessID)
        Call .SetForegroundWindow(hWnd)
    End With

    Set objSetForeAPI = Nothing

End Sub

' ------------------------------------------------

' クリップボードに strFound の内容を複写します
Private Sub SetClipboardText(strFound)

    Dim objClipboardAPI
    Set objClipboardAPI = WScript.CreateObject("SfcMini.DynaCall")

    With objClipboardAPI
        .LoadLibraries "User32.dll", "Kernel32.dll"

        Call .OpenClipboard(0)
        Call .EmptyClipboard

        Dim lngLen
        lngLen = LenB(strFound) + 2

        Dim lngStrPtr
        Const GMEM_MOVEABLE = &H2
        Const GMEM_ZEROINIT = &H40
        lngStrPtr = .GlobalAlloc( _
            GMEM_MOVEABLE Or GMEM_ZEROINIT, lngLen)

        Dim lngLock
        lngLock = .GlobalLock(lngStrPtr)
        Call .lstrcpy(lngLock, strFound & vbNullChar)
        Call .GlobalUnlock(lngStrPtr)

        Const CF_TEXT = &H1
        Call .SetClipboardData(CF_TEXT, lngStrPtr)
        Call .CloseClipboard

    End With

    Set objClipboardAPI = Nothing

End Sub

' ------------------------------------------------

' ウィンドウタイトルを取得して一次元配列で返します
Private Function GetWindowTitle()

    Dim objEnumWindowTitle
    Set objEnumWindowTitle = New EnumWindowsProc

    Call EnumWindows(EnumWindows.CallBack(objEnumWindowTitle, 2), 0)

    Dim strTitleString
    strTitleString = objEnumWindowTitle.strWindowTitle

    Set objEnumWindowTitle = Nothing

    Dim strArrayValue
    strArrayValue = Left(strTitleString, Len(strTitleString) - 1)
    Dim arrWindowTitle
    arrWindowTitle = Split(strArrayValue, "‰")

    GetWindowTitle = arrWindowTitle

End Function

' ------------------------------------------------

' EnumWindows関数のコールバッククラスです
Class EnumWindowsProc

    Dim strWindowText
    Dim strWindowTitle
    Private Sub Class_Initialize()
        strWindowText = ""
        strWindowTitle = ""
    End Sub

    Public Function CallBack(hWnd, lParam)

        If IsWindowVisible(hWnd) = 1 Then
            strWindowText = Space(256)
            If GetWindowText(hWnd, strWindowText, 256) <> 0 then
                strWindowText = _
                    left(strWindowText, InStr(strWindowText, vbNullChar) -1)
                strWindowTitle = _
                    strWindowTitle & strWindowText & "‰"
            End If
        End If
        CallBack = 1

    End Function

End Class

' ------------------------------------------------

' OSアーキテクチャー別で動作を振り分けます
Private Sub SelectAction()

    Dim objArgs
    Set objArgs = WScript.Arguments

    Select Case objArgs.Count
        Case 0
            If GetOSArchitecture = "32 ビット" Then
                Call SearchWindow
            Else
                Call RecursiveCall_in32bitLibrary
            End If
        Case 1
            Call SearchWindow
    End Select

    Set objArgs = Nothing

End Sub

' ------------------------------------------------

' OSアーキテクチャーを取得します
Private Function GetOSArchitecture()

    Dim objWMI
    Dim objLocal
    Dim colOS
    Set objWMI = WScript.CreateObject("WbemScripting.SWbemLocator")
    Set objLocal = objWMI.ConnectServer
    Set colOS = objLocal.ExecQuery("Select * From Win32_OperatingSystem")

    Dim objOS
    For Each objOS In colOS
        GetOSArchitecture = objOS.OSArchitecture
    Next

    Set colOS = Nothing
    Set objLocal = Nothing
    Set objWMI = Nothing

End Function

' --------------- 返信欄に続きます ------------------

' あと一つ Subプロシージャーがありますが、投稿欄の上限文字数に近いので続きは返信欄で行います。

  • 2020/7/519:22:22

    ' -------------- 回答欄からの続き ----------------

    ' 64bitOSなら引数を付加して再起動します
    Private Sub RecursiveCall_in32bitLibrary()

        Dim objShell
        Set objShell = WScript.CreateObject("WScript.Shell")

        Const strWsh32 = "C:\Windows\SysWow64\wscript.exe"
        Dim strScriptPath
        strScriptPath = """" & WScript.ScriptFullName & """"
        Const strArgument = "Win64"

        objShell.Run strWsh32 & " " & strScriptPath & " " & strArgument

        Set objShell = Nothing

    End Sub

    ' -------------------- End ----------------------------


返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2020/7/10 05:21:35

回答ありがとうございました。

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる