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

名前

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

本文

K.J.K.さん、ご回答ありがとうございます。
また、返信が遅れてすみません。
参照設定して、IInstalledAppで取れることは確認しました。

こちらの魔界の仮面弁士さんのコードを
お借りして、参照設定無しで、行ってますが、
まずCoCreateInstanceでインスタンス化出来てないです。
http://madia.world.coocan.jp/cgi-bin/VBBBS/wwwlng.cgi?print+200310/03100017.txt

仮にインスタンス化出来ても、
ShellAppManager:: GetPublishedAppCategoriesが
E_NOTIMPLを返してくる(構造体の宣言がイマイチなのか)。

ShellAppManager:: EnumInstalledApps、
IEnumInstalledApps:: Next、
IShellApp:: GetAppInfoと進んでも (列挙させないで)
エクセルが最後は強制終了
 (イミディトウィンドウに書き出されはしますが)。

プロシージャを抜ければVBA自身が、
解放する様なコードを使えばこの点は大丈夫なのですが。
 (それでも、列挙させればやっぱり、最後はエクセルが強制終了)
# 解放の入れる場所が違うのかな。

K.J.K.さんの更新前のも、更新後のファイルも拝見しました。
こちらを参考に勉強して行きたいと思います。
ありがとうございました＜(_ _)＞

Option Explicit
Public 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 Type tag_ShellAppCategory
    pszCategory As Long
    idCategory As Long
End Type
Private Type tag_ShellAppCategoryList
    cCategories As Long
    pCategory As tag_ShellAppCategory
End Type
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 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
Const CLSCTX_INPROC_SERVER = 1

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 pCategoryList As tag_ShellAppCategoryList
    Dim peia As stdole.IUnknown 'IEnumInstalledApps
    Dim pia As stdole.IUnknown 'IInstalledApp
    
    IIDFromString ByVal "{352EC2B7-8B9A-11D1-B8AE-006008059382}", _
                  CLSID_ShellAppManager(0)

IIDFromString ByVal "{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::GetPublishedAppCategories
    'hr = Invoke_(objptr(p), 5, VarPtr(pCategoryList))

'ShellAppManager::EnumInstalledApps
    hr = Invoke_(ObjPtr(p), 4, VarPtr(peia))

If hr = S_OK Then
        'While hr = S_OK
            'IEnumInstalledApps::Next
            hr = Invoke_(ObjPtr(peia), 3, VarPtr(pia))

pInfo(0) = 80
            pInfo(1) = &HFFFFDFFF
         
            'IShellApp::GetAppInfo
            hr = Invoke_(ObjPtr(pia), 3, VarPtr(pInfo(0)))
 
            If hr = S_OK Then
                For i = 2 To 19
                    lngLength = lstrlenW(pInfo(i))
                    Buf = String$(lngLength, 0)
                    MoveMemory ByVal StrPtr(Buf), ByVal pInfo(i), lngLength * 2
                    Debug.Print Buf
                    CoTaskMemFree pInfo(i)
                Next
                Debug.Print "----------------"
            End If
            'IUnknown::Release
            Invoke_ ObjPtr(pia), 2
        'Wend
        'IUnknown::Release
        Invoke_ ObjPtr(peia), 2
    End If
    'IUnknown::Release
    Invoke_ ObjPtr(p), 2
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, autCCStdCall, _
            vbLong, lngArgs, intVtArgs(0), lngPtArgs(0), varResult)
    If n >= 0 Then
        Invoke_ = CLng(varResult)
    End If
End Function

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

戻る