wbrworddemo.frm

使用WebBrowser控件作为容器打开Word文档 === === === === === === === 这个源代码演示了使用WebBrowser控件作为容器打开Word文档的操作。需要在工

    
    With mDoc
    
        With .ActiveWindow
            mnuView(VIEW_NORMAL).Checked = (.View.Type = wdNormalView)
            mnuView(VIEW_PAGE).Checked = (.View.Type = wdPageView)
            mnuView(VIEW_HSCROLL).Checked = .DisplayHorizontalScrollBar
            mnuView(VIEW_RULER).Checked = .DisplayRulers
        End With
        
        For Each mnu In mnuViewToolbar  ' Assumes Menu captions match Toolbar names
            mnu.Checked = .CommandBars(mnu.Caption).Visible
        Next
        
    End With

End Sub

Private Sub mnuView_Click(Index As Integer)

    On Error Resume Next
    
    With mDoc.ActiveWindow
    
        Select Case Index
        
            Case VIEW_NORMAL
                .View.Type = wdNormalView
                
            Case VIEW_PAGE
                .View.Type = wdPageView
                
            Case VIEW_HSCROLL
                .DisplayHorizontalScrollBar = Not .DisplayHorizontalScrollBar
                
            Case VIEW_RULER
               .DisplayRulers = Not .DisplayRulers
          
        End Select
    
    End With

End Sub

Private Sub mnuViewToolbar_Click(Index As Integer)

    On Error Resume Next
    
    Dim msoBarPos As Office.MsoBarPosition
    Dim strToolbarName As String
    
    strToolbarName = mnuViewToolbar(Index).Caption
    
    With mDoc.CommandBars(strToolbarName)
    
        .Enabled = True ' ToolBar must be Enabled before it can be made Visible
        .Visible = Not .Visible
        mnuViewToolbar(Index).Checked = .Visible
        
        If .Visible Then
        
            Select Case strToolbarName
            
                Case "绘图"
                    msoBarPos = msoBarBottom
                    
                Case "审阅"
                    msoBarPos = msoBarRight
                    
                Case Else
                    msoBarPos = msoBarTop
            End Select
            
            .Position = msoBarPos
        End If
        
    End With

End Sub

Private Sub mnuToolsMenu_Click()

    On Error Resume Next
    
    With mDoc
    
        mnuTools(TOOLS_SPELL) = Not .SpellingChecked
        
        With .Application.Selection ' restrict to one word only
            mnuTools(TOOLS_THESAURUS) = (.Type = wdSelectionNormal) _
                                    And (.Words.Count = 1)
        End With
        
    End With
    
End Sub

Private Sub mnuTools_Click(Index As Integer)

    On Error Resume Next
    
    Select Case Index
    
        Case TOOLS_SPELL
            mDoc.CheckSpelling
        
        Case TOOLS_THESAURUS
            mDoc.Application.Selection.Range.CheckSynonyms
            
        Case TOOLS_OPTIONS
            mnuOpt(OPT_SHOWALL).Checked = mDoc.ActiveWindow.View.ShowAll
            mnuOpt(OPT_STATUSBAR).Checked = sta.Visible
            
    End Select
    
End Sub

Private Sub mnuOpt_Click(Index As Integer)

    On Error Resume Next

    Dim blnChecked As Boolean
    
    With mnuOpt(Index)
        .Checked = Not .Checked
        blnChecked = .Checked
    End With
    
    Select Case Index
    
        Case OPT_SHOWALL
            mDoc.ActiveWindow.View.ShowAll = blnChecked
           
        Case OPT_STATUSBAR
            sta.Visible = blnChecked
            SetBotUsedArea
            
    End Select
    
End Sub

Private Sub wbr_DocumentComplete(ByVal pDisp As Object, URL As Variant)

    On Error GoTo DocumentComplete_Error
    
    mnuDemoMenu = False '<== Demo
    
    If pDisp Is wbr.Object Then
    
        mnuViewMenu = TypeOf wbr.Document Is Word.Document
        mnuToolsMenu = mnuViewMenu
        
        If mnuViewMenu Then
            Set mDoc = wbr.Document
            mDocURL = URL
            sta.SimpleText = "Done"
            '<== Demo
            mnuDemoMenu = InStr(1, URL, DEMO_DOC, vbTextCompare)
            mnuDemo(DEMO_TITLE) = mnuDemoMenu
            mnuDemo(DEMO_SUBTITLE) = mnuDemoMenu
            mnuDemo(DEMO_DATA) = mnuDemoMenu
            mnuDemo(DEMO_NOTES) = mnuDemoMenu
            mnuDemo(DEMO_ALL) = mnuDemoMenu
            '<== Demo
        Else
            Set mDoc = Nothing
            mDocURL = vbNullString
        End If
        
        mnuFile(FILE_FORMAT).Visible = InStr(1, URL, "about:", vbTextCompare)   '<== Demo
   
   End If
    
DocumentComplete_Exit:
    Exit Sub
    
DocumentComplete_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".DocumentComplete"
    Resume DocumentComplete_Exit
    
End Sub

Private Sub wbr_StatusTextChange(ByVal Text As String)

    sta.SimpleText = Text
    
End Sub

Private Sub FileSaveAsHTML()
'
' This can also be done with the "SaveAs" option.
' Note that ConvHTML.SaveDocAsHTML could be used to convert a
' document to HTML withtout user intervention if parameters
' are provided by some other means.

    On Error GoTo FileSaveAsHTML_Error
    
    Dim FileName As String
    Dim lngPos As Long
    Dim strResult As String
    Dim strMsg As String
    Dim lngStyle As VbMsgBoxStyle
    
    lngPos = InStrRev(mDocURL, "\", , vbTextCompare)
    If lngPos Then
        FileName = Mid$(mDocURL, lngPos + 1)
        FileName = Split(FileName, ".")(0) & ".html"
        FileName = LCase$(FileName)
    End If

    strResult = FileDlgs.GetSaveAsFileName( _
                    FileName, _
                    App.Path, _
                    "HTML Document (*.htm;*.html):*.htm;*.html")
                    
    If Len(strResult) Then
        FileName = ConvHTML.SaveDocAsHTML( _
                    Doc:=mDoc, _
                    NewFileName:=strResult)
        If Len(FileName) Then
            strMsg = mDocURL & vbNewLine & vbNewLine _
                    & vbTab & "saved in HTML format as" & vbNewLine & vbNewLine _
                    & FileName
            lngStyle = vbInformation
        Else
            strMsg = "ERROR: Save operation failed"
            lngStyle = vbExclamation
        End If
        MsgBox strMsg, lngStyle, "Save As HTML"
    End If
    
FileSaveAsHTML_Exit:
    Exit Sub
    
FileSaveAsHTML_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".FileSaveAsHTML"
    Resume FileSaveAsHTML_Exit

End Sub

Private Sub SetBotUsedArea()

    With sta
        .Refresh
        mBotUsedArea = IIf(.Visible, .Height + MARGIN, MARGIN)
    End With
    mVertUsedArea = mTopUsedArea + mBotUsedArea
    Form_Resize
    
End Sub

'<== Demo additions ==================================================

Private Sub mnuDemo_Click(Index As Integer)
'
'   Manipulates DEMO_DOC using pre-defined BookMarks
'

    On Error GoTo mnuDemo_Error

    Dim MenuCaption As String
    
    MenuCaption = "mnuDemo(" & Index & ") - " & mnuDemo(Index).Caption
    sta.SimpleText = MenuCaption
    
    Select Case Index
    
        Case DEMO_TITLE
            mDoc.Bookmarks("BMTitle").Range.InsertAfter ("谢谢光临枕善居(这个是主标题示例)")
            
        Case DEMO_SUBTITLE
           mDoc.Bookmarks("BMSubTitle").Range.InsertAfter ("谢谢光临枕善居(这个是副标题示例)")
           
        Case DEMO_DATA
           InsertData DataFileName:=mFilePath & DEMO_DAT
           
        Case DEMO_NOTES
            With mDoc.Bookmarks("BMNotes").Range
                .InsertAfter _
                    Text:="本站中文名称:" & vbNewLine _
                        & "枕善居VB源码博客" _
                        & "链接地址:" _
                        & vbNewLine & vbNewLine _
                        & "http://www.mndsoft.com" _
                        & "描述:枕善居一个专业发布VB源代码的博客,有问必答，帮助大伙学习的站点。尤其是初学者要去的地方，当然，老鸟也能从那里挖到宝藏:)"
            End With
                    
                    
         Case DEMO_ALL
            AutoSequence    ' = all of the above !!
            
    End Select
    
    mDoc.Application.Selection.GoTo what:=wdGoToBookmark, Name:="BMTop"
    
mnuDemo_Exit:
    mnuDemo(Index) = False
    mnuDemo(DEMO_ALL) = False
    sta.SimpleText = vbNullString
    Exit Sub
    
mnuDemo_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                    Me.Name & "." & MenuCaption
    Resume mnuDemo_Exit

End Sub

Private Sub InsertData(DataFileName As String)
'
' Inserts the contents of file DEMO_DAT
' and formats resultant text as a Word Table
'
    On Error GoTo InsertData_Error
    
    Dim rng As Word.Range
    
    With mDoc.Application.Selection  ' insert data after Bookmark
        .GoTo what:=wdGoToBookmark, Name:="BMData"
        .MoveDown
        Set rng = .Range    ' for repositoning after Insert
        .InsertFile FileName:=DataFileName
    End With
    
    rng.Select
    
    With mDoc.Application.Selection  ' format data as Table
        .MoveDown Unit:=wdLine, Count:=4, Extend:=wdExtend
        .ConvertToTable _
            Separator:=wdSeparateByTabs, _
            AutoFit:=False
        .Tables(1).AutoFormat _
            Format:=wdTableFormatColorful2, _
            AutoFit:=False
    End With
    
InsertData_Exit:
    Exit Sub
    
InsertData_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".InsertData"
    Resume InsertData_Exit

End Sub

Private Sub AutoSequence()

    On Error GoTo AutoSequence_Exit
    
    mnuDemoMenu = False
    mDoc.Application.ScreenUpdating = False
    mnuDemo_Click DEMO_TITLE
    mnuDemo_Click DEMO_SUBTITLE
    mnuDemo_Click DEMO_DATA
    mnuDemo_Click DEMO_NOTES
    
AutoSequence_Exit:
    mDoc.Application.ScreenUpdating = True
    
End Sub

Private Sub FormatTitlePage()   ' Late-binding
'
' This little bit of nonsense demonstrates the manipulation of
' an HTML Document Object contained by a WebBrowser Control.
'
' Recommended method is to set a "Project/References" to
'       "Microsoft HTML Object Library" (mshtml.dll)
' and use strictly-typed objects for early-binding.
' That also makes Tools/Options/Editor/Auto List Members available in the IDE.
'
    On Error GoTo FormatTitlePage_Error
    
    Const strHR = "<HR style=color:cyan;width:300>"
    
    With wbr.Document.body
    
        With .Style
            .backgroundcolor = "#689CD0"
            .Color = "white"
            .fontfamily = "黑体"
            .FontSize = "48pt"
            .TextAlign = "center"
        End With
        
        With .All.idDIV
            .innerHTML = "Automation<BR>Demonstration"  ' multiple-statements
            .insertAdjacentHTML "BeforeBegin", strHR    ' to demonstrate more
            .insertAdjacentHTML "AfterEnd", strHR       ' avaliable functions.
            
            With .Style
                .Color = "yellow"
                .fontfamily = "宋体"
                .FontSize = "32pt"
            End With
            
        End With
        
    End With
    
FormatTitlePage_Exit:
    Exit Sub
    
FormatTitlePage_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".FormatTitlePage"
    Resume FormatTitlePage_Exit
    
End Sub