Excel網頁瀏覽器

by chijanzen on 九月 30th, 2009 | View: 2,428 views

Tags

No Tags

Comments (1)

索引	G0008
主題	Excel網頁瀏覽器
版本	>= 10.0(Office 2002)
說明	本範例介紹WebBrowser控件的用法。本範例會在功能表新增"我的最愛"功能表項目，當使用者點取"我的最愛"中的項目時會在Excl桌面區域開啟該網頁，並在工具列新增一組"網頁"工具列來操控網頁瀏覽器
參考

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    fname = Application.CommandBars("Favorites").NameLocal
    Application.CommandBars("Worksheet Menu Bar").Controls(fname).Delete
End Sub
　

Private Sub Workbook_Open()
Initialize
End Sub　

Code

Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, _
        ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal _
        lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal HWND As Long, _
        ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal HWND As Long, _
        ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal HWND As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal HWND As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal HWND As Long, lpRect As RECT) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal HWND As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal HWND As Long, _
        ByVal hdc As Long) As Long
Private Const HWND_DESKTOP = 0
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const GWL_STYLE = (-16)
Private Const SW_SHOWMAXIMIZED = 3
Private Const WS_CAPTION As Long = &HC00000
Private Const SW_SHOW As Long = 5
Private Const WS_EX_APPWINDOW = &H40000
Private Type POINTAPI
    X    As Long
    Y    As Long
End Type
Private Type RECT
    Left As Long
    Top  As Long
    Right As Long
    Bottom As Long
End Type
　

Private Sub UserForm_Initialize()
    CreateCmdBar
    Application.DisplayFormulaBar = False
    Application.CommandBars("Standard").Visible = False
End Sub
　

Private Sub UserForm_Activate()
    Dim myRect As RECT
    Dim HWND
    DoEvents
    If Val(Application.Version) < 9 Then
        HWND = FindWindow("ThunderXFrame", Me.Caption)        'XL97
    Else
        HWND = FindWindow("ThunderDFrame", Me.Caption)        'XL2000
    End If
    Classname = "XLMAIN"
    hwndMain = FindWindowEx(0&, 0&, Classname, Application.Caption)        ' window Desk
    Classname = "XLDESK"
    hWndDesk = FindWindowEx(hwndMain, 0&, Classname, vbNullString)        ' acts on Clientbereich ' (XL97).
    Classname = "EXCEL7"
    TargetWindowhWnd = FindWindowEx(hWndDesk, 0&, Classname, vbNullString)        ' window size determine
    Call SetFormStyle(HWND)
    GetWindowRect hWndDesk, myRect
    Dc = GetDC(HWND_DESKTOP)
    WinFont = GetDeviceCaps(Dc, LOGPIXELSX)
    ReleaseDC HWND_DESKTOP, Dc
    ZoomFactor = (ActiveWindow.Zoom - 100) * 0.005
    With FavoritesForm
        .StartUpPosition = 0
        .Top = (myRect.Top * 72 / WinFont) + ZoomFactor
        .Left = (myRect.Left * 72 / WinFont) + ZoomFactor
        .Width = ((myRect.Right - myRect.Left) * 72 / WinFont) + ZoomFactor
        .Height = ((myRect.Bottom - myRect.Top) * 72 / WinFont) + ZoomFactor
        .WebBrowser1.Top = 0
        .WebBrowser1.Left = 0
        .WebBrowser1.Width = .Width - 5
        .WebBrowser1.Height = .Height - 5
    End With
    Do While WebBrowser1.Busy
        DoEvents
    Loop
End Sub
　

Private Sub SetFormStyle(HWND)
    '最大化去標頭去外框
    Dim IStyle As Long
    IStyle = GetWindowLong(HWND, GWL_STYLE)
    IStyle = IStyle And Not WS_CAPTION And Not WS_EX_APPWINDOW
    SetWindowLong HWND, GWL_STYLE, IStyle
    ShowWindow HWND, SW_SHOW
    DrawMenuBar HWND
End Sub
　

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    On Error Resume Next
    Application.CommandBars("fbar").Delete
    Application.Caption = ""
    ActiveWindow.Caption = ActiveWorkbook.Name
    Application.DisplayFormulaBar = True
    Application.CommandBars("Standard").Visible = True
End Sub
　

Private Sub WebBrowser1_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)
    '設定上ㄧ頁/下ㄧ頁是否可用
    If (Command = CSC_NAVIGATEBACK) Then  '上ㄧ頁
        Application.CommandBars("fbar").Controls(2).Enabled = Enable
    End If
    If (Command = CSC_NAVIGATEFORWARD) Then   '下一頁
        Application.CommandBars("fbar").Controls(3).Enabled = Enable
    End If
End Sub
　

Private Sub WebBrowser1_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
    '設定導覽功能表的網址
    Static strFirstWebURL As String
    If Len(strFirstWebURL) = 0 Then
        objComboBox.Text = Me.WebBrowser1.LocationURL
        strFirstWebURL = objComboBox.Text
    End If
    If Not MatchFound Then
        objComboBox.AddItem objComboBox.Text
    End If
    objComboBox.Text = Me.WebBrowser1.LocationURL
End Sub
　

Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)
'預防文字過長
On Error Resume Next
'Excel狀態欄同步
Application.StatusBar = Text
End Sub
　

Private Sub WebBrowser1_TitleChange(ByVal Text As String)
    '設定Excel標題欄文字
    Application.Caption = Text
    ActiveWindow.Caption = ""
End Sub
　

Code

Public objComboBox As CommandBarComboBox
　

Sub CreateCmdBar()
    Dim objBar As CommandBar
    Dim objBtn As CommandBarButton
    On Error Resume Next
    Application.CommandBars("fbar").Delete
    Set objBar = Application.CommandBars.Add("fbar", msoBarTop, False, False)
    objBar.Width = Application.CommandBars(1).Width
    objBar.Visible = True
    Set objBtn = objBar.Controls.Add(Type:=msoControlButton)
    With objBtn
        .Caption = "關閉IE"
        .OnAction = "CloseIE"
        .Style = msoButtonIcon
        .FaceId = 1088
    End With
    Set objBtn = objBar.Controls.Add(Type:=msoControlButton)
    With objBtn
        .Caption = "上ㄧ頁"
        .OnAction = "GoBack"
        .Style = msoButtonIconAndCaption
        .FaceId = 1017
        .Enabled = True
    End With
    Set objBtn = objBar.Controls.Add(Type:=msoControlButton)
    With objBtn
        .Caption = "下ㄧ頁"
        .OnAction = "GoForward"
        .Style = msoButtonIcon
        .FaceId = 1018
        .Enabled = True
    End With
    Set objBtn = objBar.Controls.Add(Type:=msoControlButton)
    With objBtn
        .Caption = "重試"
        .OnAction = "Refresh"
        .Style = msoButtonIcon
        .FaceId = 1020
    End With
    Set objComboBox = objBar.Controls.Add(Type:=msoControlComboBox)
    With objComboBox
        .Style = msoComboNormal
        .Width = 400
        .DropDownLines = 30
        .DropDownWidth = 400
        .OnAction = "ComboBox_Click"
    End With
    Set objBtn = Nothing
End Sub
　

Sub CloseIE()
Unload FavoritesForm
End Sub
　

Sub GoBack()
FavoritesForm.WebBrowser1.GoBack
End Sub
　

Sub GoForward()
FavoritesForm.WebBrowser1.GoForward
End Sub
　

Sub Refresh()
FavoritesForm.WebBrowser1.Refresh
End Sub
　

Sub ComboBox_Click()
FavoritesForm.WebBrowser1.Navigate objComboBox.Text
End Sub
　

Code

Private Sub UserForm_Initialize()
    CreateCmdBar
    Application.DisplayFormulaBar = False
    Application.CommandBars("Standard").Visible = False
End Sub
　