「OLELIB.TLB」セキュリティについて (ID:103454)

名前

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

本文

> 「エントリIUnknown_QueryServiceがDLLファイルShiwapi内に
> 見つかりません」となり、稼働確認に至っていません。

http://msdn.microsoft.com/en-us/library/windows/desktop/bb759858(v=vs.85).aspx
MSDNの最後の部分にも書いてありますが、

> .... this function must be called directly from Shlwapi.dll 
> using ordinal 176.

Ordinal番号を付けて呼び出してください。OSのバージョンの問題ですので。

以下は、簡単な確認コードです。
# VB6の環境を取り出すのが面倒だったので、Office VBAで制作。

'（標準モジュール）
Declare Function GetClassNameW& Lib "User32" _
    (ByVal hWnd&, _
     lpClassName%, _
     ByVal nMaxCount&)
Declare Function EnumWindows& Lib "User32" _
    (ByVal lpEnumFunc&, _
     ByVal lParam&)
Declare Function EnumChildWindows& Lib "User32" _
    (ByVal hwndParent&, _
     ByVal lpEnumFunc&, _
     ByVal lParam&)
Declare Function RegisterWindowMessageW& Lib "User32" _
    (ByVal lpString&)
Declare Function SendMessageW& Lib "User32" _
    (ByVal hWnd&, _
     ByVal uMsg&, _
     ByVal wParam&, _
     ByVal lParam&)
Declare Function ObjectFromLresult& Lib "Oleacc" _
    (ByVal lResult&, _
     ByVal riid&, _
     ByVal wParam&, _
     ppvObject As Any)
Declare Function IIDFromString& Lib "Ole32" _
    (ByVal lpsz&, _
     ByVal lpiid&)
Declare Function SysAllocString& Lib "Oleaut32" _
    (ByRef psz%)
Declare Function IUnknown_QueryService& Lib "Shlwapi" Alias "#176" _
    (ByVal pUnk As Any, _
     ByVal guidService&, _
     ByVal riid&, _
     ppvOut As Any)
Declare Sub RtlMoveMemory Lib "Kernel32" _
    (pDesc As Any, _
     pSrc As Any, _
     Optional ByVal cbLen& = 4)
     
Private pFn&

Public Sub Main()
    pFn = VBA.CLng(AddressOf EnumProc)
    EnumWindows pFn, 0
End Sub

Private Function EnumProc&(ByVal hWnd&, ByVal lParam&)
    Dim ii%(50), sClass$
    
    EnumProc = 1
    GetClassNameW hWnd, ii(0), 50
    RtlMoveMemory ByVal VarPtr(sClass), SysAllocString(ii(0))
    
    If sClass = "IEFrame" Then
        EnumChildWindows hWnd, pFn, hWnd
    End If
    
    If lParam = 0 Then Exit Function
    If sClass = "Internet Explorer_Server" Then
        TestProc hWnd
    End If
    
End Function

Private Sub TestProc(ByVal hWnd As Long)
    Dim hr&
    Dim iid&(3), pp&, ll&
    Dim pHtmlDoc As IUnknown  ' IHTMLDocument2
    Dim obj As Object         ' IDispatch
    Static WM_GetHTML&
    
    pp = VarPtr(iid(0))
    
    If WM_GetHTML = 0 Then
        WM_GetHTML = RegisterWindowMessageW(StrPtr("WM_HTML_GETOBJECT"))
    End If
    ll = SendMessageW(hWnd, WM_GetHTML, 0, 0)
    
    ' IID_IHTMLDocument2
    IIDFromString StrPtr("{332C4425-26CB-11D0-B483-00C04FD90119}"), pp
    hr = ObjectFromLresult(ll, pp, 0, pHtmlDoc)
    
    ' IID_IWebBrowserApp
    IIDFromString StrPtr("{0002DF05-0000-0000-C000-000000000046}"), pp
    hr = IUnknown_QueryService(pHtmlDoc, pp, pp, obj)

Debug.Print Time, obj.LocationURL

End Sub

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

戻る