[アプリケーションの追加と削除] の情報
解決[アプリケーションの追加と削除] の情報の取得について、調べています。
こちらでappwiz.cplに参照設定出来ると言う情報を知り、
http://moug.net/faq/viewtopic.php?t=28970
オブジェクトブラウザに表示されている
インターフェース群をGoogle検索して、
MSDNに辿り着き、更に検索してサンプルも見つかりましたが、
http://blogs.msdn.com/oldnewthing/archive/2004/08/31/223271.aspx
IEnumPublishedApps::Next で得られるはずの
IPublishedAppインターフェースが取得されないです。
Vistaだからなのでしょうか？
環境 Vista VBA(Excel 2007)
'shappmgrp 1.0 Type Libraryに参照設定
'C:\Windows\System32\appwiz.cpl
Sub test()
Dim p As ShellAppManager
Dim ppepa As IEnumPublishedApps
Dim pie As IPublishedApp
Dim ppApp As IUnknown 'IPublishedApp
Dim pInfo(0 To 19) As Long 'APPINFODATA
Set p = New ShellAppManager
p.EnumPublishedApps vbNullString, ppepa
ppepa.Next pie '←空のまま
If pie Is Nothing Then Exit Sub
End Sub
>[アプリケーションの追加と削除] の情報の取得
「アプリケーションの追加と削除 WMI」で検索すると
VBScriptで作成されているのが出てきますが、
あえて、茨の道に進もうとするわけですね。
やじゅさん、ありがとうございます。
レジストリからクラスID(IAppPublisher絡み)を読み込んで
インスタンス化しても、やっぱり、
IEnumPublishedApps::Nextで詰まるので
こっち方面はまたいずれ、チャレンジしようと思います。
レジストリ検索で進めて行きます。
ありがとうございました。
IPublishedApp経由で調べる前に、まずIInstalledAppで調べるべきなのでは。
# ちなみに、AppPublisherは使える設定になっていない環境も多々あります。
K.J.K.さん、ありがとうございます。
> IPublishedApp経由で調べる前に、まずIInstalledAppで調べるべきなのでは。
ShellAppManagerのメンバにはEnumInstalledAppsが
あり、EnumInstalledAppsにはNextメソッドがありますが、
IInstalledAppの参照を得られるかと言うと、
こちらも同じようにNGです。
> # ちなみに、AppPublisherは使える設定になっていない環境も多々あります。
IAppPublisher Interface ()
http://msdn.microsoft.com/en-us/library/bb776328(VS.85).aspx
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\AppManagement\
以下のキーにIAppInstaller(?)のクラスIDを
探してみましたがないです。
IAppPublisherにIPublishedAppなので、
IInstalledAppがあるから、IAppInstallerもあるのかと
思いましたがそうでもないようです。
すみません、
K.J.K.さんの回答の意図が私には分かりません。
# IInstalledAppもMSDNには載せられていません。
私の環境(XP Pro SP3)では、
IEnumInstalledApps.Next で有効な値を得ています。
IEnumPublishedApps.Next では有効な値が得られていません。
IEnumInstalledApps は、レジストリキーの
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Management\ARPCache
以下の情報取得に使えます。
また、ここでは "AppPublisher" を、
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Management\Publishers
以下にある複数のクラスとして想定しています。
作りかけでまだ名前の列挙だけですが、IInstalledAppを列挙するサンプル:
http://www.koalanet.ne.jp/~akiya/vbtaste/vbp/AppView.lzh
をとりあえず置いときます。
情報を列挙し、且つアンインストールなどの操作を行えるようにしたものに更新しておきました。
で、 Install と Publish の意味の違いを意識してください。
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
変更した部分
> n = DispCallFunc(lpObject, VtblOffset, autCCStdCall, _
↓
n = DispCallFunc(lpObject, VtblOffset * 4, autCCStdCall, _
度々、すみません。
> IShellApp:: GetAppInfoと進んでも (列挙させないで)
> エクセルが最後は強制終了
> (イミディトウィンドウに書き出されはしますが)。
> 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
End If
Set pia = Nothing
'Wend
Set peia = Nothing
End If
Set p = Nothing
End Sub
だと大丈夫でした(何でだろう)。
# つっこみどころが多過ぎるので、「一部のみ」つっこんでいきます。
> こちらの魔界の仮面弁士さんのコードを
> お借りして、参照設定無しで、行ってますが、
これの元ネタは、私の作った裏サンプルです。
# 基本部分はほとんどパ◯リ? いや、別に訴えたりしないけど。
## というか、そもそも流用されて当然として公開しています。
## オリジナリティを主張するほどのものではないですし。
ちなみに、DispCallFuncを使う元のサンプルは、大人向けを想定しています。
それを利用してうまく行かないことがあったら人に尋ねるような子供に
対しては利用することを考慮しておりません。
# そもそも、他の人に訊くような段階では、利より害のが多いので、裏に設置。
というわけで、素直にタイプライブラリを使ってください。
> E_NOTIMPLを返してくる
E_NOTIMPL が返ってきたら、この先はないと判断して、「他」の方法に
当たるのが、真っ当なCOMの利用法です。
# E_INVALIDARGS などではないのですし。
> Private Type tag_ShellAppCategoryList
> cCategories As Long
> pCategory As tag_ShellAppCategory
> End Type
pCategory As Long にすべきですよね。
> Dim p As stdole.IUnknown 'ShellAppManager
> Dim peia As stdole.IUnknown 'IEnumInstalledApps
> Dim pia As stdole.IUnknown 'IInstalledApp
As IUnknown とするなら、DispCallFunc を使ってはいけません。
使えるケースと使えないケースの区別がつくならば別ですが、
その判断には(コードで記述できるような)一般性がありませんし。
# そういう点でも、タイプライブラリを素直に使うべきかと。
> IIDFromString ByVal "{352EC2B7-8B9A-11D1-B8AE-006008059382}", _
> CLSID_ShellAppManager(0)
Dim abBuffer() As Byte
abBuffer = "{352EC2B7-8B9A-11D1-B8AE-006008059382}" & vbNullChar
Call IIDFromString(abBuffer(0&), CLSID_ShellAppManager(0&))
> End If
> Set pia = Nothing
> 'Wend
> Set peia = Nothing
> End If
> Set p = Nothing
> End Sub
>
> だと大丈夫でした(何でだろう)。
Release し過ぎだから。
# 補足。
> 使えるケースと使えないケースの区別がつくならば別ですが、
> その判断には(コードで記述できるような)一般性がありませんし。
とは言っても、判定式そのものは短いコードで書くことが可能です。
K.J.K.さん、ご回答ありがとうございます。
いろいろ弄ってる内にCoCreateInstanceの宣言が
抜けてました。
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
IIDFromStringの呼び出しも勉強になりました。
> > Private Type tag_ShellAppCategoryList
> > cCategories As Long
> > pCategory As tag_ShellAppCategory
> > End Type
>
> pCategory As Long にすべきですよね。
'ShellAppManager::GetPublishedAppCategories
hr = Invoke_(ObjPtr(p), 5, VarPtr(pCategoryList))
に変更してもE_NOTIMPLなので、
他の項目を列挙するならやっぱり、タイプライブラリですね。
(IEnumInstalledApps::Nextで列挙してる内に
エクセルが落ちてしまうのもありますので)
> > 使えるケースと使えないケースの区別がつくならば別ですが、
> > その判断には(コードで記述できるような)一般性がありませんし。
>
> とは言っても、判定式そのものは短いコードで書くことが可能です。
使えない場面が今の私のレベルでは分かりませんので
以後、勉強します。
> ちなみに、DispCallFuncを使う元のサンプルは、大人向けを想定しています。
> それを利用してうまく行かないことがあったら人に尋ねるような子供に
> 対しては利用することを考慮しておりません。
> # そもそも、他の人に訊くような段階では、利より害のが多いので、裏に設置。
大変、有用なサンプルまで書いて頂きながら
あれこれ、甘えた発言ですみませんでした。＜(_ _)＞
最初の、2008/06/18(水) 09:52:20 でリンクしてた
> http://moug.net/faq/viewtopic.php?t=28970
サイトの質問者さんにも参考になると思うので
そちらのサイトで、
追加スレッドを立てて、リンクを張ってもいいでしょうか？
(そちらでは解決後、追加書き込みは出来ませんので)
# 半年程でそちらでは、過去ログは参照出来なくなります。
> に変更してもE_NOTIMPLなので、
> 他の項目を列挙するならやっぱり、タイプライブラリですね。
意味が繋がりません。
E_NOTIMPL を返す、ということは、
「このメソッドは中身・内容がないよう。」
ということです。だから、どういう呼び出し方をしようが無駄です。
ちなみに、私が提示したサンプルでも、あえてこのメソッドを呼び出して
います。しかし、現時点では効果がないコードです。
規制・保護されているものでない限り、リンクに許可は不要だと考えています。
K.J.K. さん、ご回答ありがとうございます。
> 意味が繋がりません。
> E_NOTIMPL を返す、ということは、
> 「このメソッドは中身・内容がないよう。」
> ということです。だから、どういう呼び出し方をしようが無駄です。
Dim cCategories As Long
Dim pszCategory As Long
Dim idCategory As Long
'ShellAppManager::GetPublishedAppCategories
hr = Invoke_(ObjPtr(p), 5, cCategories, pszCategory, idCategory)
とすればS_OKを返しますが、単独のLong型変数に
何か入って来る訳でもありませんでした。
> 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
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
今更ですが、StrPtr関数を使ってませんでした。
Sub test()
Dim obj As ShellAppManager
Dim piea As EnumInstalledApps
Dim pie As IInstalledApp
Dim refAppinfo As TSHAppDataInfo
ChDrive ThisWorkbook.Path
ChDir ThisWorkbook.Path
Set obj = New ShellAppManager
Set peia = obj.EnumInstalledApps
Do
Set pie = piea.Next
If pie Is Nothing Then
Exit Do
End If
refAppinfo.StructureSize = LenB(refAppinfo)
refAppinfo.Mask = shAppDisplayName
pie.GetAppInfo refAppinfo
Debug.Print SysAllocString(shappinfo.DisplayName)
CoTaskMemFree shappinfo.DisplayName
Set pie = Nothing
Loop
End Sub
ブック(*.xlsm)と同じフォルダにK.J.K. さんの
タイプライブラリをコピーして、参照設定後、
> Set obj = New ShellAppManager
> Set peia = obj.EnumInstalledApps
の時点で、
---
実行時エラー '430':
クラスはオートメーションまたは予測したインターフェースをサポートしていません。
---
になります。
何か簡単な事を見落としているだけだと
思いますので何とかなりそうです。
> 規制・保護されているものでない限り、リンクに許可は不要だと考えています。
向こうの規約にファイルへのリンクを含むリンク先を載せる事を
禁ずる的な文言があるのを忘れてました。
すみませんです＜(_ _)＞
K.J.K. さん、ありがとうございました。
解決とさせて頂きます。
一応、報告まで。
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
解決チェックを付け忘れました。
# 文章やコードをよく読んでください。
とりあえず、文章で書いても理解されないと予測して、サンプルを更新しました。
> Vistaでは最後のメソッドが無いみたいですので
> こちらを削った方が良いようです。
これは、
> 実行時エラー '430':
> クラスはオートメーションまたは予測したインターフェースをサポートしていません。
であり、根本は、
Vista の IID_IShellAppManager: {C257690D-85DE-417C-B964-C22B1A6BB5F7}
XP の IID_IShellAppManager: {352EC2B8-8B9A-11D1-B8AE-006008059382}
となり、名前こそ同じですが実際は別物であることに由来することです。
> APPINFODATA構造体の中でCoTaskMemFreeで
> 解放してはいけないメンバが、幾つあるのかまでは調べ切れていません。
そんな危険な状態でなぜ呼び出せるのでしょうか。
もっとも、サイズとマスクを除き全て解放すべきメンバですが。
コードをよく見直してください。根本的に間違えている部分がありますよ。
で、 DispCallFunc と IUnknown は併用すべきではない、と書いたのに、
そのままでいるのはなぜなのでしょうか。
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
> IUnknownと継承関係の無いCOMは存在しないと
> 思うのですが違うのでしょうか。
例えば、 VB6 で
stdole (Stdole2.tlb) を参照設定して、
Dim oPict As IPictureDisp
Dim oUnk As IUnknown
Set oPict = New StdPicture
Debug.Print ObjPtr(oPict)
Set oUnk = oPict
Debug.Print ObjPtr(oUnk)
というコードを書いた場合、同じ値を出力しますか?
oPict のメソッドを呼び出したい場合に、 ObjPtr(oUnk) を渡すのは
妥当なのでしょうか?
一般的な COM オブジェクトは、1つ「以上」の IUnknown の VTbl を
持っているのですから、 QueryInterface で IID_IUnknown を要求する
"As IUnknonw" で受けるのは妥当とは言えないでしょう。
# ATL で CComQIPtr<IUnknown, &IID_IUnknown> を使わないのと同じ理由。
> 'Nextメソッドが出す(内部的にS_FALSEを返すため)
> '実行時エラーを、すっ飛ばすために入れる。
S_FALSE を返しても、実行時エラーは発生しません。
HRESULT が &H1 〜 &H7FFFFFFF では VB 及び VBA は反応しない仕組みです。
# それゆえに、これらの値を返したいときにはかなり面倒になる。
で、エラーですが、私の提示したサンプルは動くのでしょうか?
Vista 対応部分は推測でしかないので、そこにも問題点があるかもしれません。
# ちなみに、私のサンプルでは、TSV出力をしています。
ただ、熊谷さんのコードには明白な問題点があります。XP からの推測で
修正するならばこんな感じでは。直うちなので適宜修正をしてください。
# でも、これでは、他アプリからは利用しにくいフォーマットのような。
Dim oManager As IShellAppManagerVista
Dim oEnum As IEnumInstalledApps
Dim oApp As IInstalledApp
Dim uInfo As TSHAppDataInfo
Dim uEmpty As TSHAppDataInfo
Dim sData As String
Dim iFile As Integer
Dim sFileName As String
On Error Resume Next
Set oManager = New ShellAppManager
Set oEnum = oManager.EnumInstalledApps()
Do
Set oApp = oEnum.Next()
If oApp Is Nothing Then Exit Do
uInfo = uEmpty
With uInfo
.StructureSize = LenB(uInfo)
.Mask = &H6DFFF
Call oApp.GetAppInfo(uInfo)
If .Mask And shAppDisplayName Then
sData = sData & SysAllocString(.DisplayName) & vbCrLf
Call CoTaskMemFree(.DisplayName)
End If
If .Mask And shAppVersion Then
sData = sData & SysAllocString(.Version) & vbCrLf
Call CoTaskMemFree(.Version)
End If
If .Mask And shAppPublisher Then
sData = sData & SysAllocString(.Publisher) & vbCrLf
Call CoTaskMemFree(.Publisher)
End If
If .Mask And shAppProductID Then
sData = sData & SysAllocString(.ProductID) & vbCrLf
Call CoTaskMemFree(.ProductID)
End If
If .Mask And shAppRegisteredOwner Then
sData = sData & SysAllocString(.RegisteredOwner) & vbCrLf
Call CoTaskMemFree(.RegisteredOwner)
End If
If .Mask And shAppRegisteredCompany Then
sData = sData & SysAllocString(.RegisteredCompany) & vbCrLf
Call CoTaskMemFree(.RegisteredCompany)
End If
If .Mask And shAppLanguage Then
sData = sData & SysAllocString(.Language) & vbCrLf
Call CoTaskMemFree(.Language)
End If
If .Mask And shAppSupportURL Then
sData = sData & SysAllocString(.SupportUrl) & vbCrLf
Call CoTaskMemFree(.SupportUrl)
End If
If .Mask And shAppSupportTelephone Then
sData = sData & SysAllocString(.SupportTelephone) & vbCrLf
Call CoTaskMemFree(.SupportTelephone)
End If
If .Mask And shAppHelpLink Then
sData = sData & SysAllocString(.HelpLink) & vbCrLf
Call CoTaskMemFree(.HelpLink)
End If
If .Mask And shAppInstallLocation Then
sData = sData & SysAllocString(.InstallLocation) & vbCrLf
Call CoTaskMemFree(.InstallLocation)
End If
If .Mask And shAppInstallSource Then
sData = sData & SysAllocString(.InstallSource) & vbCrLf
Call CoTaskMemFree(.InstallSource)
End If
If .Mask And shAppInstallDate Then
sData = sData & SysAllocString(.InstallDate) & vbCrLf
Call CoTaskMemFree(.InstallDate)
End If
If .Mask And shAppContact Then
sData = sData & SysAllocString(.Contact) & vbCrLf
Call CoTaskMemFree(.Contact)
End If
If .Mask And shAppComments Then
sData = sData & SysAllocString(.Comments) & vbCrLf
Call CoTaskMemFree(.Comments)
End If
If .Mask And shAppImage Then
sData = sData & SysAllocString(.Image) & vbCrLf
Call CoTaskMemFree(.Image)
End If
If .Mask And shAppReadMeURL Then
sData = sData & SysAllocString(.ReadmeUrl) & vbCrLf
Call CoTaskMemFree(.ReadmeUrl)
End If
End With
Set oApp = Nothing
sData = sData & "--------------" & vbCrLf '境界線
Loop
Set oEnum = Nothing
Set oManager = Nothing
sFileName = ThisWorkbook.Path
If "\" = Right$(sFileName, 1&) Then
sFileName = sFileName & "GetAppInfo.txt"
Else
sFileName - sFileName & "\GetAppInfo.txt"
End If
iFile = FreeFile
Open sFileName For Output As #iFile
Print #iFile, sData
Close #iFile
Call Err.Clear
On Error GoTo 0
熊谷さんのコーディングを見ると、目先への利益誘導(楽さ)に極めて弱い性格の
ように思えます。全体としての損得勘定を良く考えてコーディングなどを行うべき
でしょう。でないと、このように不毛な問題の発生を繰り返し続けることになります。
K.J.K. さん、ご回答ありがとうございます。
> 例えば、 VB6 で
> stdole (Stdole2.tlb) を参照設定して、
--- 中略 ---
> S_FALSE を返しても、実行時エラーは発生しません。
> HRESULT が &H1 〜 &H7FFFFFFF では VB 及び VBA は反応しない仕組みです。
> # それゆえに、これらの値を返したいときにはかなり面倒になる。
反芻して理解出来る様にして行きます。
> ただ、熊谷さんのコードには明白な問題点があります。XP からの推測で
> 修正するならばこんな感じでは。直うちなので適宜修正をしてください。
> # でも、これでは、他アプリからは利用しにくいフォーマットのような。
バッチリ、動作致しました。
APPINFODATA構造体の初期化が必要なのですね。
K.J.K.さんのコードで取れるのは
確認していたのですが、上で私が載せたコードと
何が異なるのかが理解出来ていませんでした。
> 熊谷さんのコーディングを見ると、目先への利益誘導(楽さ)に極めて弱い性格の
> ように思えます。全体としての損得勘定を良く考えてコーディングなどを行うべき
> でしょう。でないと、このように不毛な問題の発生を繰り返し続けることになります。
ご指摘、ありがとうございます。
出来るだけ改善して行くように心掛けてたいと思います。
> sFileName = ThisWorkbook.Path
> If "\" = Right$(sFileName, 1&) Then
> sFileName = sFileName & "GetAppInfo.txt"
> Else
> sFileName - sFileName & "\GetAppInfo.txt"
> End If
ルートディレクトリも考慮して頂き、ありがとうございます。
(- は = にしました。)
> 「アプリケーションの追加と削除」は、
> Vistaではクラシック表示で「プログラムと機能」に
> なり、サイズも表示されますが
> こちらはどこから取得するのかは分かりませんでした。
今更ですが、IShellApp::GetSlowAppInfoで取れるのですね。
> で、エラーですが、私の提示したサンプルは動くのでしょうか?
> Vista 対応部分は推測でしかないので、そこにも問題点があるかもしれません。
> # ちなみに、私のサンプルでは、TSV出力をしています。
はい、きちんと動作致します。
改めてK.J.K.さんの凄さを実感した今日この頃でした。
週末にも関わらず、また最後までお付き合い頂きまして
本当にありがとうございました。＜(_ _)＞
| ツイート |  |