こんにちは。
興味あったのでＶＢＡを簡単に書いてみました。
これは特にダウンロードは不要です。
選択中のテキストをWeb検索するボタンを追加するマクロです。
Normal.dotm に 新規の標準モジュールを追加して、
下記コードを貼り付けて、
Private Sub ポップアップメニュー設定()
を一度だけ実行すれば、右クリックメニューに
"Web検索"ボタンが追加されます。
そのまま、Normal.dotmを上書き保存すれば継続的に利用できます。
Private Sub ポップアップメニュー設定解除()
を実行すれば元の設定に戻すこともできます。
Win7/64 WD2010/64にて動作確認しました。
習作ではありますが、易しく書けているとは思います。
宜しければ、試してみてください。
扱いが解らないようでしたら訊いてください。
' ' Normal.dotm 標準モジュール
' ' / 選択中の文字列をエンコードして 指定のサイトで検索
Private Sub SearchWeb()
Dim sURL As String
sURL = Selection.Text
sURL = Replace(Trim$(sURL), vbCr, "")
If sURL = "" Then Exit Sub
sURL = EncodeUTF8(sURL)
sURL = Application.CommandBars.ActionControl.Parameter & sURL
ThisDocument.FollowHyperlink sURL
End Sub
' ' /// 文字列をURLエンコードして返す（UTF-8）（Office 64bit対応）
Private Function EncodeUTF8(ByVal Source As String) As String
Dim oHtmlFile As Object
Dim oElement As Object
Source = Replace(Source, "\", "\\")
Source = Replace(Source, "'", "\'")
Set oHtmlFile = CreateObject("htmlfile")
Set oElement = oHtmlFile.createElement("span")
oElement.setAttribute "id", "response"
oHtmlFile.appendChild oElement
oHtmlFile.parentWindow.execScript _
"document.getElementById('response').innerText " _
& "= encodeURIComponent('" & Source & "');", "JScript"
EncodeUTF8 = oElement.innerText
End Function
' ' / ポップアップメニューにコントロール追加
Private Sub ポップアップメニュー設定()
On Error GoTo ErrOut_
With Application.CommandBars("Text")
With .Controls.Add(msoControlPopup)
.Caption = "Web検索"
With .Controls.Add(msoControlButton)
.Caption = "Google"
.Parameter = "https://www.google.co.jp/search?q="
.OnAction = "SearchWeb"
End With
With .Controls.Add(msoControlButton)
.Caption = "Weblio"
.Parameter = "http://www.weblio.jp/content/"
.OnAction = "SearchWeb"
End With
End With
End With
Exit Sub
ErrOut_:
MsgBox Err & vbLf & Err.Description _
& "エラーの為、ポップアップメニュー設定できませんでした。"
End Sub
' ' / ポップアップメニューから追加したコントロールを削除
Private Sub ポップアップメニュー設定解除()
Dim oc As CommandBarControl
On Error Resume Next
For Each oc In Application.CommandBars("Text").Controls
Select Case oc.Caption
Case "Web検索", "Google", "Weblio"
oc.Delete
End Select
Next
End Sub
