セルの値をGoogleで検索する - SO NOTE そうのて (；^ω^)

セルの値をGoogleで検索するアドイン、その名もCellgle(；^ω^)
まぁ、こんな事しなくても、いまや大抵のブラウザにはGoogleやYahooの検索ボックスやツールバーがついてるでしょうから、そこへセルの値をコピペすりゃ済む訳ですが、なんとなく作ってみました。

ソース

'ThisWorkbookモジュール
Option Explicit
Private Const cnsMenuName As String = "Cellgle"

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    On Error Resume Next
    Application.CommandBars("Cell").Controls(cnsMenuName).Delete
    On Error GoTo 0
    
End Sub

Private Sub Workbook_Open()

    Const cnsFaceID   As Long = 82                               'アイコンのFaceID
    Const cnsTipText  As String = "セルの値をGoogleで検索します" 'ツールチップテキスト
    
    Dim cbCells       As CommandBar
    Dim cbNewMenu     As CommandBarButton
    
    Set cbCells = Application.CommandBars("Cell")

    '新規作成するメニューを予め削除しておく
    On Error Resume Next
    cbCells.Controls(cnsMenuName).Delete
    On Error GoTo 0
    
    Set cbNewMenu = cbCells.Controls.Add(Type:=msoControlButton)
    
    With cbNewMenu
        .TooltipText = cnsTipText
        .FaceId = cnsFaceID
        .Caption = cnsMenuName
        .OnAction = cnsMenuName
    End With

End Sub

'標準モジュール
Option Explicit
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Sub Cellgle()

    Const cnsGoogleURL As String = "http://www.google.co.jp/search?hl=ja&oe=utf8&q="
    
    Dim r    As Range
    Dim kw   As String
    Dim sc   As Object
    Dim sURL As String
    Dim lRet As Long
    
    'Cellsのコンテキストメニューに追加してるので
    'セル以外が選択されている事は有り得ないけど…
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    kw = ""
    Set sc = CreateObject("ScriptControl")
    With sc
        .Language = "JScript"
        For Each r In Selection
            '検索キーワードをurlエンコード
            kw = kw & .CodeObject.encodeURIComponent(r.Text) & "+"
        Next r
    End With
    Set r = Nothing
    Set sc = Nothing
    kw = Left(kw, Len(kw) - 1) 'お尻の+は削る
    
    '何も入力されてない時は終了
    If LenB(kw) = 0 Then Exit Sub
    
    sURL = cnsGoogleURL & kw
    'APIのShellExecuteでurlショートカットに関連付けられたブラウザで起動する
    ShellExecute vbNull, "Open", sURL, vbNullString, vbNullString, 1

End Sub

urlをYahooに変えれば、Yahoo用にもすぐカスタマイズ可能です。

検索結果を関連付けられているブラウザで表示させるのに少し手間取った

単純にShell関数にurl渡せばうまくいくかと思ったんですが、そんな簡単にはいきませんでした。で、いつもの如くGoogle先生に教えてもらったところ、関連付けられたアプリケーションで起動させるにはAPI関数のShellExecuteってのを使わないといけないってのがわかった。ふむふむ。あと、引数の意味が良く理解出来てないので、そこはまた調べてみる事にします。

使い方

今までのパターンと同じ。このアドインを入れるとセルの右クリックで表示されるコンテキストメニューに

なのが追加されるので、検索したい値が入力されてるセル上で右クリックして、このメニューを選択してやればok。

な感じで、いつも使ってるブラウザで検索結果が表示されます。あと、複数セル選択状態でコイツを動かすと、各セルの値で複数キーワード検索します。

よければ

ここからどうぞ。