vbaでHTMLダイアログ

便利だけどあまりｗｅｂに見つからないので。
インターネットでもローカルファイルでも行けます。

Option Explicit

'HRESULT CreateURLMoniker(
'    IMoniker *pMkCtx,
'    LPCWSTR szURL, //ワイド文字
'    IMoniker **ppmk
');
'
'HRESULT ShowHTMLDialog(
'    HWND hwndParent,
'    IMoniker *pMk,
'    VARIANT *pvarArgIn,
'    LPWSTR pchOptions, //ワイド文字
'    VARIANT *pvarArgOut
');


Private Declare Function CreateURLMoniker Lib "urlmon.dll" _
  (ByVal pMkCtx As Long, _
  ByVal szURL As Long, _
  ByRef ppmk As Long) As Long
Private Declare Function ShowHTMLDialog Lib "mshtml.dll" _
  (ByVal hwndParent As Long, _
  ByVal pMk As Long, _
  ByVal pvarArgIn As Long, _
  ByVal pchOptions As Long, _
  ByVal pvarArgOut As Long) As Long
Private Const S_OK = 0
Private Const E_OUTOFMEMORY = &H8007000E
Private Const MK_E_SYNTAX = &H800401E4

'pchOptions
'dialogHeight:sHeight
'dialogLeft:sXPos
'dialogTop:sYPos
'dialogWidth:sWidth
'center:{ yes | no | 1 | 0 | on | off }
'dialogHide:{ yes | no | 1 | 0 | on | off }
'edge:{ sunken | raised }
'resizable:{ yes | no | 1 | 0 | on | off }
'scroll:{ yes | no | 1 | 0 | on | off }
'status:{ yes | no | 1 | 0 | on | off }
'unadorned:{ yes | no | 1 | 0 | on | off }

Sub test()
  Dim moniker As Long
  Dim szURL As String
  Dim ret As Long
  
  Const options = "help:no; status:no; dialogWidth:460px; dialogHeight=320px"
  szURL = "http://www.google.co.jp"
  'szURL = "file://c:/test.htm"
  ret = CreateURLMoniker(0, StrPtr(szURL), moniker)
   
  If ret = S_OK Then
    
    ret = ShowHTMLDialog(0, moniker, 0, StrPtr(options), 0)
    
    If ret = S_OK Then
      MsgBox "成功"
    Else
      MsgBox "失敗"
    End If
  
  End If
   
End Sub

便利！