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

名前

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

本文

K.J.K. さん、ご回答ありがとうございます。

> であり、根本は、
> Vista の IID_IShellAppManager: {C257690D-85DE-417C-B964-C22B1A6BB5F7}
> XP の IID_IShellAppManager: {352EC2B8-8B9A-11D1-B8AE-006008059382}
> となり、名前こそ同じですが実際は別物であることに由来することです。

これは気付きませんでした。

> そんな危険な状態でなぜ呼び出せるのでしょうか。
> もっとも、サイズとマスクを除き全て解放すべきメンバですが。
> コードをよく見直してください。根本的に間違えている部分がありますよ。

K.J.K.さんの書いて頂いたタイプライブラリを
参照設定後、試しましたがどうしてもエクセルが落ちます。
何を見落としているのか結局、分かりませんでした。

> で、 DispCallFunc と IUnknown は併用すべきではない、と書いたのに、
> そのままでいるのはなぜなのでしょうか。

IUnknownと継承関係の無いCOMは存在しないと
思うのですが違うのでしょうか。

Option Explicit
'K.J.K.'s Type Library for Registered Applications.
'C:\Windows\system32\KTLApps.tlb
Sub test()

Dim piea As IEnumInstalledApps
    Dim pie As IInstalledApp
    Dim refAppinfo As TSHAppDataInfo
    Dim unk As IUnknown
    Dim obj As IShellAppManagerVista
    Dim S As String
    Dim foo As Integer
    Set unk = New ShellAppManager
    Set obj = unk
    Set piea = obj.EnumInstalledApps()

On Error Resume Next
    'Nextメソッドが出す(内部的にS_FALSEを返すため)
    '実行時エラーを、すっ飛ばすために入れる。

Do
        Set pie = piea.Next()
        If pie Is Nothing Then Exit Do
        Call pie.GetAppInfo(refAppinfo)

With refAppinfo
            .StructureSize = LenB(refAppinfo)
            .Mask = &H6DFFF
            
            If .Mask And shAppDisplayName Then
                S = S & SysAllocString(.DisplayName) & vbCrLf
                Call CoTaskMemFree(.DisplayName)
            End If

If .Mask And shAppVersion Then
                S = S & SysAllocString(.Version) & vbCrLf
                Call CoTaskMemFree(.Version)
            End If

If .Mask And shAppPublisher Then
                S = S & SysAllocString(.Publisher) & vbCrLf
                Call CoTaskMemFree(.Publisher)
            End If

If .Mask And shAppProductID Then
                S = S & SysAllocString(.ProductID) & vbCrLf
                Call CoTaskMemFree(.ProductID)
            End If

If .Mask And shAppRegisteredOwner Then
                S = S & SysAllocString(.RegisteredOwner) & vbCrLf
                Call CoTaskMemFree(.RegisteredOwner)
            End If

If .Mask And shAppRegisteredCompany Then
                S = S & SysAllocString(.RegisteredCompany) & vbCrLf
                Call CoTaskMemFree(.RegisteredCompany)
            End If

If .Mask And shAppLanguage Then
                S = S & SysAllocString(.Language) & vbCrLf
                Call CoTaskMemFree(.Language)
            End If

If .Mask And shAppSupportURL Then
                S = S & SysAllocString(.SupportUrl) & vbCrLf
                Call CoTaskMemFree(.SupportUrl)
            End If

If .Mask And shAppSupportTelephone Then
                S = S & SysAllocString(.SupportTelephone) & vbCrLf
                Call CoTaskMemFree(.SupportTelephone)
            End If

If .Mask And shAppHelpLink Then
                S = S & SysAllocString(.HelpLink) & vbCrLf
                Call CoTaskMemFree(.HelpLink)
            End If

If .Mask And shAppInstallLocation Then
                S = S & SysAllocString(.InstallLocation) & vbCrLf
                Call CoTaskMemFree(.InstallLocation)
            End If

If .Mask And shAppInstallSource Then
                S = S & SysAllocString(.InstallSource) & vbCrLf
                Call CoTaskMemFree(.InstallSource)
            End If

If .Mask And shAppInstallDate Then
                S = S & SysAllocString(.InstallDate) & vbCrLf
                Call CoTaskMemFree(.InstallDate)
            End If

If .Mask And shAppContact Then
                S = S & SysAllocString(.Contact) & vbCrLf
                Call CoTaskMemFree(.Contact)
            End If

If .Mask And shAppComments Then
                S = S & SysAllocString(.Comments) & vbCrLf
                Call CoTaskMemFree(.Comments)
            End If
            
            If .Mask And shAppImage Then
                S = S & SysAllocString(.Image) & vbCrLf
                Call CoTaskMemFree(.Image)
            End If

If .Mask And shAppReadMeURL Then
                S = S & SysAllocString(.ReadmeUrl) & vbCrLf
                Call CoTaskMemFree(.ReadmeUrl)
            End If
        End With
        Set pie = Nothing
        S = S & "--------------" & vbCrLf '境界線
    Loop
    foo = FreeFile
    Open ThisWorkbook.Path & "\GetAppInfo.txt" For Output As #foo
    Print #foo, S
    Close #foo
    Set piea = Nothing
    Set obj = Nothing
    Set unk = Nothing

Call Err.Clear
    On Error GoTo 0
End Sub

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

戻る