浏览器

开发平台：
Visual Basic

WebSnap.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cWebSnap"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'---------------------------------------------------------------------------------------
' Module    : cWebSnap
' DateTime  : 2005-8-15 22:34
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Option Explicit
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Implements LEPluginLib.ILEpluginCmd
Private m_Web As SHDocVw.WebBrowser
Private m_Info As LEPluginLib.ILEInfo
Private Function ILEpluginCmd_RunCommand(Optional ByVal lParam As Long = 0&) As Boolean
On Error Resume Next
Dim tShowErrMsg As Boolean
tShowErrMsg = True
If Not m_Web Is Nothing Then
    If Not m_Web.Document Is Nothing Then
        If TypeOf m_Web.Document Is MSHTML.HTMLDocument Then
            tShowErrMsg = False
            Call SaveWebSnap
        End If
    End If
End If
If tShowErrMsg Then
    MsgBox "so error"
End If
End Function
Private Function ILEpluginCmd_SendMessage(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
End Function
Private Sub ILEpluginCmd_SetSite(ByVal pUnkSite As stdole.IUnknown, ByVal vOutPort As LEPluginLib.ILEInfo)
If Not pUnkSite Is Nothing Then
    Set m_Web = pUnkSite
End If
If Not vOutPort Is Nothing Then
    Set m_Info = vOutPort
End If
End Sub
Private Sub ILEpluginCmd_ShowOption()
End Sub
'---------------------------------------------------------------------------------------
' Procedure : SaveWebSnap
' DateTime  : 2005-8-15 22:34
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub SaveWebSnap(Optional vFile$)
On Error Resume Next
Dim tPct As PictureBox
Dim tFrm As frmSnap
Dim tDoc As MSHTML.HTMLDocument
Dim tIV As IViewObject
Dim tRc As RECT, oRc As RECT
Dim tOw&, tOh&, tSw&, tSh&
Dim tHdl&
Dim tHWin&, tStr$
If Len(vFile) = 0 Then
    Dim tSave As cOpenSaveDlg
    Set tSave = New cOpenSaveDlg
    tSave.Filter = "*.bmp|*.bmp"
    tSave.Flags = OFN_OVERWRITEPROMPT
    
    tStr = m_Web.Document.Title
    Call FormatFileName(tStr)
    tSave.FileName = tStr & ".bmp"
    
    tHWin = m_Info.GetMainWindowObj.hwnd
    If tSave.ShowSave(tHWin) Then
        vFile = tSave.FileName
        If LCase$(Right$(vFile, 4)) <> ".bmp" Then
            vFile = vFile & ".bmp"
        End If
    Else
        Exit Sub
    End If
End If
tHdl = GetWebHwnd()
If tHdl <> 0 Then
    Call GetWindowRect(tHdl, oRc)
    
    tOw = oRc.Right - oRc.Left
    tOh = oRc.Bottom - oRc.Top
    
    Set tDoc = m_Web.Document
    Set tIV = tDoc
    
    tDoc.body.Scroll = "no"
    
    tSw = tDoc.body.scrollWidth '+ 4
    tSh = tDoc.body.scrollHeight '+ 4
    
    MoveWindow tHdl, 0, 0, tSw, tSh, 0
    
    tRc.Right = tSw
    tRc.Bottom = tSh
    
    Set tFrm = New frmSnap
    Load tFrm
    Set tPct = tFrm.pctSnap
    
    tPct.Move 0, 0, tSw, tSh
    
    tIV.Draw DVASPECT_CONTENT, 1, ByVal 0, ByVal 0, _
            0&, tPct.hDC, tRc, tRc, ByVal 0, ByVal 0
    
    tDoc.body.Scroll = "yes"
    
    MoveWindow tHdl, 0, 0, tOw, tOh, 1
    SavePicture tPct.Image, vFile
Else
    MsgBox "error"
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetWebHwnd
' DateTime  : 2005-8-15 22:34
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Function GetWebHwnd() As Long
On Error Resume Next
Dim tHdl&
If Not m_Info Is Nothing Then
    tHdl = FindWindowEx(m_Info.GetActiveWindow.hwnd, 0, "Shell Embedding", "")
    If tHdl <> 0 Then
        tHdl = FindWindowEx(tHdl, 0, "Shell DocObject View", "")
        If tHdl <> 0 Then
            GetWebHwnd = tHdl
        End If
    End If
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : FormatFileName
' DateTime  : 2005-8-15 22:50
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub FormatFileName(nFN$)
nFN = Replace(nFN, "", " ")
nFN = Replace(nFN, "/", " ")
nFN = Replace(nFN, "?", " ")
nFN = Replace(nFN, "*", " ")
nFN = Replace(nFN, "|", " ")
nFN = Replace(nFN, ":", " ")
nFN = Replace(nFN, """", " ")
nFN = Replace(nFN, "<", " ")
nFN = Replace(nFN, ">", " ")
End Sub

						