Excel VBE Google Search 增益集

by chijanzen on 八月 10th, 2008 | View: 4,224 views

Tags

Comments (0)

索引	F0014
主題	Excel VBE Google Search 增益集
版本	>= 10.0(Office 2002)
說明	本範例會在[程式碼視窗]CommandBars("Code Window")上載入 Google 搜尋工具，共有三個功能。 1.搜尋網站 2.搜尋 Excel 社群討論區 3.搜尋 API 函數使用方法非常簡單，只要選取要搜尋的字串按滑鼠右鍵就能使用該工具
參考

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)
RemoveNewMenuItems
End Sub
　

Private Sub Workbook_Open()
AddNewMenuItems
End Sub
　

Code

Dim CmdDCweb As VBEGOHandler
Dim CmdDCvba As VBEGOHandler
Dim CmdDCtw As VBEGOHandler
Dim CmdAPI As VBEGOHandler
Dim CmdGroup As VBEGOHandler
Dim CmdItem As CommandBarControl
Dim cmdParent As CommandBarControl
Dim Cmd As CommandBarControl
Dim StartLine As Long
Dim EndLine As Long
Dim StartCol As Long
Dim EndCol As Long
　

Sub AddNewMenuItems()
    Dim r As Integer
    RemoveNewMenuItems
    With Application.VBE.CommandBars("Code Window")
        '讓新增的控制項保持在中間位置
        r = VBA.Int(.Controls.Count / 2) + 2
        Set cmdParent = .Controls.Add(Type:=msoControlPopup, _
                Before:=r, Temporary:=True)
    End With
    cmdParent.Caption = "GoogleSearch"
    With cmdParent
        '第一階:Google 搜尋..
        Set CmdItem = .Controls.Add(Type:=msoControlPopup)
        CmdItem.Caption = "Google 搜尋.."
        'Web
        Set Cmd = CmdItem.Controls.Add
        Cmd.Caption = "Google 搜尋:Web"
        ThisWorkbook.Sheets("code").Shapes("google").Copy
        Cmd.PasteFace
        Set CmdDCweb = New VBEGOHandler
        Set CmdDCweb.DCEvtweb = Application.VBE.Events.CommandBarEvents(Cmd)
        'vba.com.tw
        Set Cmd = CmdItem.Controls.Add
        Cmd.Caption = "Google 搜尋:chijanzen.net"
        ThisWorkbook.Sheets("code").Shapes("vba").Copy
        Cmd.PasteFace
        CmdItem.BeginGroup = True
        Set CmdDCvba = New VBEGOHandler
        Set CmdDCvba.DCEvtvba = Application.VBE.Events.CommandBarEvents(Cmd)
        'Taiwan
        Set Cmd = CmdItem.Controls.Add
        Cmd.Caption = "Google 搜尋:Taiwan"
        ThisWorkbook.Sheets("code").Shapes("tw").Copy
        Cmd.PasteFace
        CmdItem.BeginGroup = True
        Set CmdDCtw = New VBEGOHandler
        Set CmdDCtw.DCEvttw = Application.VBE.Events.CommandBarEvents(Cmd)
        '第一階:Excel 社群搜尋
        Set Cmd = .Controls.Add(Type:=msoControlButton)
        Cmd.Caption = "Excel社群搜尋"
        ThisWorkbook.Sheets("code").Shapes("cm").Copy
        Cmd.PasteFace
        Set CmdGroup = New VBEGOHandler
        Set CmdGroup.DLEvtGroup = Application.VBE.Events.CommandBarEvents(Cmd)
    End With
End Sub
　

Sub RemoveNewMenuItems()
    On Error Resume Next
    With Application.VBE.CommandBars("Code Window")
        .Controls("GoogleSearch").Delete
    End With
End Sub
　

Sub vbDHTMLEditText()
    Dim mi As Integer, mk As Integer
    '讀入 Html 語法
    With ThisWorkbook
        For mi = 1 To 205
            HTML = HTML & .Sheets("code").Cells(mi, 1).Text & vbCrLf
        Next mi
        With WebForm.webDHTMLEdit
            .BrowseMode = True: .ScrollBars = False
            .DocumentHTML = HTML
            Do While .Busy: DoEvents: Loop
        End With
    End With
End Sub
　

Sub Evtweb()
    With Application.VBE.ActiveCodePane.CodeModule
        '在 VBE 視窗中取得 SetSelection 內容
        .CodePane.GetSelection StartLine, StartCol, EndLine, EndCol
        '取得第一句字串
        cArray = Split(Mid(.Lines(StartLine, 1), StartCol, _
                EndCol - StartCol), " ")
        On Error Resume Next
        ctxt = cArray(0)
        If Err > 0 Then
            MsgBox "您未正確選取字串"
            Exit Sub
        End If
    End With
    DoEvents
    With WebForm.webDHTMLEdit.dom.all
        .q.Item(0).Value = ctxt
        .sa.Click
    End With
End Sub
　

Sub Evtvba()
    With Application.VBE.ActiveCodePane.CodeModule
        '在 VBE 視窗中取得 SetSelection 內容
        .CodePane.GetSelection StartLine, StartCol, EndLine, EndCol
        '取得第一句字串
        cArray = Split(Mid(.Lines(StartLine, 1), StartCol, _
                EndCol - StartCol), " ")
        ctxt = cArray(0)
        If Err > 0 Then
            MsgBox "您未正確選取字串"
            Exit Sub
        End If
    End With
    DoEvents
    With WebForm.webDHTMLEdit.dom.all
        Set ccc = .q
        .q.Item(0).Value = ctxt
        .sitesearch.Item(1).Checked = True
        .sa.Click
    End With
End Sub
　

Sub Evttw()
    With Application.VBE.ActiveCodePane.CodeModule
        '在 VBE 視窗中取得 SetSelection 內容
        .CodePane.GetSelection StartLine, StartCol, EndLine, EndCol
        '取得第一句字串
        cArray = Split(Mid(.Lines(StartLine, 1), StartCol, _
                EndCol - StartCol), " ")
        ctxt = cArray(0)
        If Err > 0 Then
            MsgBox "您未正確選取字串"
            Exit Sub
        End If
    End With
    DoEvents
    With WebForm.webDHTMLEdit.dom.all
        .q.Item(1).Value = ctxt
        .btnG.Click
    End With
End Sub
　

Sub Evtapi()
    With Application.VBE.ActiveCodePane.CodeModule
        '在 VBE 視窗中取得 SetSelection 內容
        .CodePane.GetSelection StartLine, StartCol, EndLine, EndCol
        '取得第一句字串
        cArray = Split(Mid(.Lines(StartLine, 1), StartCol, _
                EndCol - StartCol), " ")
        ctxt = cArray(0)
        If Err > 0 Then
            MsgBox "您未正確選取字串"
            Exit Sub
        End If
    End With
    DoEvents
    With WebForm.webDHTMLEdit.dom.all
        .sv.Value = ctxt
        .apisa.Click
    End With
End Sub
　

Sub EvtGroup()
    With Application.VBE.ActiveCodePane.CodeModule
        '在 VBE 視窗中取得 SetSelection 內容
        .CodePane.GetSelection StartLine, StartCol, EndLine, EndCol
        '取得第一句字串
        cArray = Split(Mid(.Lines(StartLine, 1), StartCol, _
                EndCol - StartCol), " ")
        On Error Resume Next
        ctxt = cArray(0)
        If Err > 0 Then
            MsgBox "您未正確選取字串"
            Exit Sub
        End If
    End With
    DoEvents
    With WebForm.webDHTMLEdit.dom.all
        .as_q.Value = ctxt
        .sa_q.Click
    End With
End Sub
　

Code

Option Explicit
Public WithEvents DCEvtweb As VBIDE.CommandBarEvents
Public WithEvents DCEvtvba As VBIDE.CommandBarEvents
Public WithEvents DCEvttw As VBIDE.CommandBarEvents
Public WithEvents DLEvtapi As VBIDE.CommandBarEvents
Public WithEvents DLEvtGroup As VBIDE.CommandBarEvents
　

Private Sub EvtHandler_Click(ByVal CommandBarControl As Object, _
                             handled As Boolean, CancelDefault As Boolean)
    On Error Resume Next
    handled = True
    CancelDefault = True
End Sub
　

Private Sub DCEvtweb_Click(ByVal CommandBarControl As Object, _
                           handled As Boolean, CancelDefault As Boolean)
    vbDHTMLEditText
    Evtweb
End Sub
　

Private Sub DCEvtvba_Click(ByVal CommandBarControl As Object, _
                           handled As Boolean, CancelDefault As Boolean)
    vbDHTMLEditText
    Evtvba
End Sub
　

Private Sub DLEvtapi_Click(ByVal CommandBarControl As Object, _
                           handled As Boolean, CancelDefault As Boolean)
    vbDHTMLEditText
    Evtapi
End Sub
　

Private Sub DLEvtGroup_Click(ByVal CommandBarControl As Object, _
                             handled As Boolean, CancelDefault As Boolean)
    vbDHTMLEditText
    EvtGroup
End Sub
　

Private Sub DCEvttw_Click(ByVal CommandBarControl As Object, _
                          handled As Boolean, CancelDefault As Boolean)
    vbDHTMLEditText
    Evttw
End Sub
　