用户登录  |  用户注册
首 页源码下载网络学院最新源码源码排行屏蔽广告
当前位置:新兴网络 > 源码下载 > VB源码 > 控件组件 > VB vbMHWB v1.2.1.6浏览器控件源码_VB WebBrowser加强版控件 > frmPopup.frm
loading...复制代码
VERSION 5.00
Object = "{33658027-1004-4E1E-8D35-C9146DF87919}#1.0#0"; "vbMHWB.dll"
Begin VB.Form frmPopup 
   Caption         =   "Form1"
   ClientHeight    =   6645
   ClientLeft      =   2430
   ClientTop       =   2715
   ClientWidth     =   8550
   LinkTopic       =   "Form1"
   ScaleHeight     =   6645
   ScaleWidth      =   8550
   Begin VBMHWBLibCtl.vbWB vbWB1 
      Height          =   6615
      Left            =   0
      OleObjectBlob   =   "frmPopup.frx":0000
      TabIndex        =   0
      Top             =   0
      Width           =   8535
   End
End
Attribute VB_Name = "frmPopup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public hPopupCurWB As Integer

Private Sub Form_Load()

    On Error GoTo Form_Load_Error
    Dim glWBDownloadFlags As Long
    'default UI flags: DOCHOSTUIFLAG_NO3DBORDER or DOCHOSTUIFLAG_FLAT_SCROLLBAR
    vbWB1.DocumentHostUiFlags = WBDOCHOSTUIFLAG_NO3DBORDER Or _
                                WBDOCHOSTUIFLAG_FLAT_SCROLLBAR Or _
                                WBDOCHOSTUIFLAG_THEME
    
    'Default DLCTL flags
    glWBDownloadFlags = WBDOCDOWNLOADCTLFLAG_DLIMAGES Or _
                        WBDOCDOWNLOADCTLFLAG_BGSOUNDS Or _
                        WBDOCDOWNLOADCTLFLAG_VIDEOS
    vbWB1.DocumentDownloadControlFlags = glWBDownloadFlags
    
    'Context menu action
    'Default, display none
    vbWB1.ContextMenuAction = WBCONTEXTMENUACTION_RAISE_ONCONTEXTMENU_EVENT
    
    vbWB1.StartupURL = "about:blank"
    vbWB1.AddBrowser hPopupCurWB

    vbWB1.RegisterAsBrowser(hPopupCurWB) = True
    vbWB1.RegisterAsDropTarget(hPopupCurWB) = True

    Exit Sub
Form_Load_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Form_Load of Form frmPopup"
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    On Error GoTo Form_QueryUnload_Error

    If UnloadMode = vbFormControlMenu Then
        Cancel = True
        vbWB1.Stop hPopupCurWB
        Me.Hide
        Exit Sub
    End If

    Exit Sub
Form_QueryUnload_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Form_QueryUnload of Form frmPopup"
End Sub

Private Sub vbWB1_NavigateError(ByVal wbUID As Integer, ByVal pDisp As Object, URL As Variant, TargetFrameName As Variant, StatusCode As Variant, Cancel As Boolean)

    On Error GoTo vbWB1_NavigateError_Error

    Dim lStat As Long
    
    lStat = CLng(StatusCode)
    'Here we get nav errors for file download with status code 200(OK)
    If lStat = enumInetNav.HTTP_STATUS_CONTINUE Or _
        lStat = enumInetNav.HTTP_STATUS_ACCEPTED Or _
        lStat = enumInetNav.HTTP_STATUS_OK Or _
        lStat = enumInetNav.HTTP_STATUS_REDIRECT Or _
        lStat = enumInetNav.HTTP_STATUS_REQUEST_TIMEOUT Then Exit Sub 'Let wb show a timeout page

    frmMain.AddToLog ">>>Popup_vbWB1_NavigateError>>> " & CStr(URL) & vbCrLf & ">>>StatusCode>>> " & TranslateStatusCode(lStat)
    Cancel = False

    Exit Sub
vbWB1_NavigateError_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_NavigateError of Form frmPopup"
End Sub

Private Sub vbWB1_OnHTTPSecurityProblem(ByVal wbUID As Integer, ByVal lProblem As Long, Cancel As Boolean)

    On Error GoTo vbWB1_OnHTTPSecurityProblem_Error

    If MsgBox("Popup_Security Problem:" & vbCrLf & TranslateStatusCode(lProblem) & vbCrLf & "Proceed?", vbYesNo + vbCritical) = vbYes Then
        Cancel = False
    End If

    Exit Sub
vbWB1_OnHTTPSecurityProblem_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnHTTPSecurityProblem of Form frmPopup"
End Sub

Private Sub vbWB1_OnShowScriptError(ByVal wbUID As Integer, vErrorLine As Variant, vErrorCharacter As Variant, vErrorCode As Variant, vErrorMsg As Variant, vErrorURL As Variant, bStopRunningScript As Boolean)

    On Error GoTo vbWB1_OnShowScriptError_Error

    bStopRunningScript = False

    Exit Sub
vbWB1_OnShowScriptError_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnShowScriptError of Form frmPopup"
End Sub

Private Sub vbWB1_TitleChange(ByVal wbUID As Integer, ByVal Text As String)

    On Error GoTo vbWB1_TitleChange_Error

    Me.Caption = Text

    Exit Sub
vbWB1_TitleChange_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_TitleChange of Form frmPopup"
End Sub

Private Sub vbWB1_WBEvaluateNewWindow(ByVal wbUID As Integer, ByVal sURL As String, ByVal sName As String, ByVal sURLContext As String, ByVal sFeatures As String, ByVal bReplace As Boolean, ByVal lFlags As Long, ByVal lUserActionTime As Long, lPopUpAction As Long)

    On Error GoTo vbWB1_WBEvaluateNewWindow_Error

    frmMain.AddToLog "Popup_WBEvaluateNewWindow>> " & sURL

    Exit Sub
vbWB1_WBEvaluateNewWindow_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_WBEvaluateNewWindow of Form frmPopup"
End Sub

Private Sub vbWB1_WindowClosing(ByVal wbUID As Integer, ByVal IsChildWindow As Boolean, Cancel As Boolean)

    On Error GoTo vbWB1_WindowClosing_Error

    Cancel = True

    Exit Sub
vbWB1_WindowClosing_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_WindowClosing of Form frmPopup"
End Sub