[アプリケーションの追加と削除] の情報 (ID:100808)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

一応、報告まで。
K.J.K.さんの書かれたタイプライブラリで
定義されているIShellAppManagerですが
Vistaでは最後のメソッドが無いみたいですので
こちらを削った方が良いようです。

列挙中にエクセルが落ちてたのは
問答無用でCoTaskMemFreeを呼び出していたのが原因でした。
 (ループを抜けるタイミングが、おかしかったのもありますが)
APPINFODATA構造体の中でCoTaskMemFreeで
解放してはいけないメンバが、幾つあるのかまでは調べ切れていません。

「アプリケーションの追加と削除」は、
Vistaではクラシック表示で「プログラムと機能」に
なり、サイズも表示されますが
こちらはどこから取得するのかは分かりませんでした。
どうも、お世話になりました。＜(_ _)＞

Option Explicit
Private Enum APPINFODATAFLAGS
        AIM_DISPLAYNAME = &H1
        AIM_VERSION = &H2
        AIM_PUBLISHER = &H4
        AIM_PRODUCTID = &H8
        AIM_REGISTEREDOWNER = &H10
        AIM_REGISTEREDCOMPANY = &H20
        AIM_LANGUAGE = &H40
        AIM_SUPPORTURL = &H80
        AIM_SUPPORTTELEPHONE = &H100
        AIM_HELPLINK = &H200
        AIM_INSTALLLOCATION = &H400
        AIM_INSTALLSOURCE = &H800
        AIM_INSTALLDATE = &H1000
        AIM_CONTACT = &H4000
        AIM_COMMENTS = &H8000&
        AIM_IMAGE = &H20000
        AIM_READMEURL = &H40000
        AIM_UPDATEINFOURL = &H80000
End Enum
Private Declare Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "Kernel32" _
        (ByVal lpString As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Const S_OK = 0
Const S_FALSE = 1
Const E_NOTIMPL = &H80004001
Const E_INVALIDARG = &H80070057
Private Declare Function IIDFromString Lib "ole32" _
        (lpsz As Any, lpiid As Any) As Long
Private Declare Function CoCreateInstance Lib "ole32" _
        (rclsid As Any, ByVal pUnkOuter As Long, _
        ByVal dwClsContext As Long, riid As Any, _
        ppv As Any) As Long
Const CLSCTX_INPROC_SERVER = 1
Private Const autCCStdCall = 4
Private Declare Function DispCallFunc Lib "oleaut32" _
   (ByVal pvInstance As Long, _
    ByVal oVft As Long, _
    ByVal CallConv As Integer, _
    ByVal vtReturn As Integer, _
    ByVal cActuals As Long, _
    ByRef prgvt As Integer, _
    ByRef prgpvarg As Long, _
    ByRef pvargResult As Variant _
) As Long

Sub test()
 
    Dim lngLength As Long
    Dim Buf As String
    Dim i As Long
    Dim hr As Long
    Dim p As stdole.IUnknown 'ShellAppManager
    Dim pinfo(0 To 19) As Long 'APPINFODATA
    Dim CLSID_ShellAppManager(0 To 3) As Long
    Dim IID_IShellAppManager(0 To 3) As Long
    Dim peia As stdole.IUnknown 'IEnumInstalledApps
    Dim pia As stdole.IUnknown 'IInstalledApp
    Dim S As String
    Dim foo As integer

'Debug.Print "&H" & Hex$(AIM_DISPLAYNAME Or AIM_VERSION Or AIM_PUBLISHER Or AIM_PRODUCTID Or AIM_REGISTEREDOWNER Or AIM_REGISTEREDCOMPANY Or AIM_LANGUAGE Or AIM_SUPPORTURL Or AIM_SUPPORTTELEPHONE Or AIM_HELPLINK Or AIM_INSTALLLOCATION Or AIM_INSTALLSOURCE Or AIM_INSTALLDATE Or AIM_CONTACT Or AIM_COMMENTS Or AIM_IMAGE Or AIM_READMEURL)

IIDFromString ByVal StrPtr("{352EC2B7-8B9A-11D1-B8AE-006008059382}"), _
                  CLSID_ShellAppManager(0)

IIDFromString ByVal StrPtr("{C257690D-85DE-417C-B964-C22B1A6BB5F7}"), _
                  IID_IShellAppManager(0)

hr = CoCreateInstance(CLSID_ShellAppManager(0), 0, CLSCTX_INPROC_SERVER, _
                    IID_IShellAppManager(0), p)
    If hr Then Exit Sub
    
    'ShellAppManager::EnumInstalledApps
    hr = Invoke_(ObjPtr(p), 4, VarPtr(peia))

If hr = S_OK Then
        Do
            'IEnumInstalledApps::Next
            hr = Invoke_(ObjPtr(peia), 3, VarPtr(pia))
            If hr Then Exit Do
            
            pinfo(0) = 80 'cbSize
            pinfo(1) = &H6DFFF 'dwMask

'IShellApp::GetAppInfo
            hr = Invoke_(ObjPtr(pia), 3, VarPtr(pinfo(0)))
 
            If hr = S_OK Then
                For i = 2 To 19
                    lngLength = lstrlenW(pinfo(i))
                    If lngLength Then
                        Buf = String$(lngLength, 0)
                        MoveMemory ByVal StrPtr(Buf), ByVal pinfo(i), lngLength * 2
                        If i = 2 Then CoTaskMemFree pinfo(i) 'pszDisplayName
                        If i = 8 Then CoTaskMemFree pinfo(i) 'pszSupportUrl
                        S = S & Buf & vbCrLf
                    End If
                Next
            S = S & "--------------" & vbCrLf '境界線
            End If
            Set pia = Nothing
        Loop
        foo = FreeFile
        Open ThisWorkbook.Path & "\GetAppInfo.txt" For Output As #foo
        Print #foo, S
        Close #foo
        Set peia = Nothing
    End If
    Set p = Nothing
End Sub

Private Function Invoke_(ByVal lpObject As Long, ByVal VtblOffset As Long, _
                         ParamArray Args() As Variant) As Long
    Dim lngPtArgs() As Long
    Dim intVtArgs() As Integer
    Dim varResult As Variant
    Dim lngArgs As Long
    Dim n As Long
    
    If lpObject = 0 Then
        Exit Function
    End If

lngArgs = UBound(Args) - LBound(Args) + 1
    If lngArgs = 0 Then
        ReDim lngPtArgs(0), intVtArgs(0)
    Else
        ReDim lngPtArgs(lngArgs - 1), intVtArgs(lngArgs - 1)
        For n = 0 To lngArgs - 1
            intVtArgs(n) = VarType(Args(n))
            lngPtArgs(n) = VarPtr(Args(n))
        Next
    End If

n = 0
    n = DispCallFunc(lpObject, VtblOffset * 4, autCCStdCall, _
            vbLong, lngArgs, intVtArgs(0), lngPtArgs(0), varResult)
    If n >= 0 Then
        Invoke_ = CLng(varResult)
    End If
End Function

←解決時は質問者本人がここをチェックしてください。

戻る