frmmain.frm

VB网络应用,例如:聊天系统,浏览器程序

'how to disable right click context menu for browser's window.
'
'Requires installed Internet Explorer 3.xx or Internet Explorer 4.xx.
'Works with both versions.
'
'This sample works with All version of VB5.
'--------------------------------------------------------------------------------
'Author   : Serge Baranovsky
'Email    : [e-mail]
'Internet : http://www.geocities.com/SiliconValley/Hills/9086/
'Date     : 16-07-98
'--------------------------------------------------------------------------------

Option Explicit

#Const bCodeForIE4 = True

Public CurrentURL As String
Dim bHTMLClick As Boolean

Dim msWaitForCompleteURL As String
        
Const psVolumeTitle As String = "HTML Viewer"
    
Private Sub Form_Load()
Dim i As Long
    
  Me.Caption = psVolumeTitle
  
  Call SetToolBarFlat(Tools)
  
  HTMLView.Visible = True
  bHTMLClick = False
  
  msWaitForCompleteURL = "(none)"

  Me.Show
      
  HTMLView.SetFocus
  mainHWnd = GetFocus
  Call SetFocusToBrowser(mainHWnd)

  prevMainWndProc = GetWindowLong(mainHWnd, GWL_WNDPROC)
  Call SetWindowLong(mainHWnd, GWL_WNDPROC, AddressOf HTMLWndProc)

Dim URL As String
Dim strURL As String
    
On Error Resume Next
  strURL = Command$()
  If Trim$(strURL) = "" Then strURL = App.Path & "\Blank.htm"
  strURL = "file:///" & strURL
  Dim lTok As Long
  lTok = InStr(strURL, "\")
  While lTok <> 0
    Mid$(strURL, lTok, 1) = "/"
    lTok = InStr(strURL, "\")
  Wend
  URL = strURL
  If (URL <> "") Then
    URL = LCase$(URL)
    If (Right$(URL, 1) <> "/") Then URL = URL & "/"
    
    CurrentURL = URL
    bHTMLClick = False
    HTMLView.Navigate CurrentURL
    HTMLView.Visible = True
    HTMLHide.Visible = False
    
    bHTMLClick = True
  End If
End Sub

Private Sub Form_Resize()
Dim w As Long
Dim h As Long
  
  If Me.WindowState = vbMinimized Then Exit Sub
  
  h = Abs(Me.ScaleHeight - Status.Height - Tools.Height)
  w = Abs(Me.ScaleWidth - 20)
  With HTMLHide
    .Move 10, Tools.Top + Tools.Height, w, h
  End With
  With HTMLView
    .Move 10, Tools.Top + Tools.Height, w, h
  End With
  Me.Refresh
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Call ProcUnBindFromBrowser(mainHWnd)
  Call SetWindowLong(mainHWnd, GWL_WNDPROC, prevMainWndProc)
  End
End Sub

Private Sub HTMLView_BeforeNavigate(ByVal URL As String, ByVal Flags As Long, ByVal TargetFrameName As String, PostData As Variant, ByVal Headers As String, Cancel As Boolean)
On Error GoTo bef_nav_err
  
  ' It is event for IE3
  'Call ProcUnBindFromBrowser(mainHWnd)
  Debug.Print "HTMLView_BeforeNavigate " & URL & " , " & TargetFrameName, bHTMLClick
  If bHTMLClick Then
    bHTMLClick = False
    
    HTMLView.Navigate URL
    Cancel = True
    bHTMLClick = True
  End If
  Exit Sub
    
bef_nav_err:
  MsgBox Err.Description
  Exit Sub
End Sub

Private Sub HTMLHide_Click()

End Sub

Private Sub HTMLView_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
  ' It is event for IE4
  Debug.Print "BeforeNavigate2" & URL
'#If bCodeForIE4 = True Then
  If msWaitForCompleteURL = "(none)" Then
    Call ProcUnBindFromBrowser(mainHWnd)
    msWaitForCompleteURL = LCase$(URL)
  End If
'#End If
End Sub

Private Sub HTMLView_DocumentComplete(ByVal pDisp As Object, URL As Variant)
  Debug.Print "DocumentComplete " & URL
'#If bCodeForIE4 = True Then
  If msWaitForCompleteURL = LCase$(URL) Then
    Call ProcBindToBrowser(mainHWnd)
    msWaitForCompleteURL = "(none)"
  End If
'#End If
End Sub

Private Sub HTMLView_DownloadBegin()
  ProgressShow True
  Debug.Print "HTMLView_DownloadBegin"
'#If bCodeForIE4 = False Then
'  Call ProcUnBindFromBrowser(mainHWnd)
'#End If
End Sub

Private Sub HTMLView_DownloadComplete()
  Debug.Print "DownloadComplete"
  ProgressShow False
'#If bCodeForIE4 = False Then
'  Call ProcBindToBrowser(mainHWnd)
'#End If
End Sub

Private Sub HTMLView_FrameBeforeNavigate(ByVal URL As String, ByVal Flags As Long, ByVal TargetFrameName As String, PostData As Variant, ByVal Headers As String, Cancel As Boolean)
  Debug.Print "HTMLView_FrameBeforeNavigate " & URL & " , " & TargetFrameName
End Sub

Private Sub HTMLView_FrameNavigateComplete(ByVal URL As String)
  Debug.Print "HTMLView_FrameNavigateComplete " & URL
End Sub

Private Sub HTMLView_NavigateComplete(ByVal URL As String)
'  Call ProcBindToBrowser(mainHWnd)
  Debug.Print "HTMLView_NavigateComplete " & URL
End Sub

Private Sub HTMLView_NewWindow(ByVal URL As String, ByVal Flags As Long, ByVal TargetFrameName As String, PostData As Variant, ByVal Headers As String, Processed As Boolean)
  Debug.Print "HTMLView_NewWindow " & URL & " , " & TargetFrameName
End Sub

Private Sub HTMLView_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
  Debug.Print "NavigateComplete2" & URL
End Sub

Private Sub HTMLView_ProgressChange(ByVal ProgressS As Long, ByVal ProgressMax As Long)
On Error Resume Next
  Progress.Max = ProgressMax
  If ProgressS > 0 Then
    Progress.Value = ProgressS
  Else
    Progress.Value = ProgressMax
  End If

'  Debug.Print ProgressS, ProgressMax
End Sub

Private Sub HTMLView_StatusTextChange(ByVal Text As String)
'
  Status.Panels(2).Text = Text
  Status.Refresh
End Sub

Private Sub HTMLView_TitleChange(ByVal Text As String)
'
  Me.Caption = psVolumeTitle & " -> " & Text
End Sub

Private Sub Tools_ButtonClick(ByVal Button As Button)
Dim URL As String
Dim defURL As String
Dim Msg As String
Dim Title As String
Dim cNode As Node
    
  Select Case LCase$(Button.Key)
    Case "url"
      Msg = "Input correct Web URL ..."
      Title = "Open Web URL ..."
      defURL = "http://newvb.126.com"
      URL = InputBox(Msg, Title, defURL)
      
      If (URL <> "") Then
        URL = LCase$(URL)
        'If (Left$(URL, 7) <> "http://") Then URL = "http://" & URL
        If (Right$(URL, 1) <> "/") Then URL = URL & "/"
        
        CurrentURL = URL
        bHTMLClick = False
        
        HTMLView.Navigate CurrentURL
        HTMLView.Visible = True
        HTMLHide.Visible = False
        
        bHTMLClick = True
      End If
      Case "load"
      Dim strURL As String
      strURL = OpenDialog(Me, "HTML files(*.htm;*.html)|*.htm;*.html|All files (*.*)|*.*", "Open HTML file")
      If Trim$(strURL) = "" Then Exit Sub
      strURL = "file:///" & strURL
      Dim lTok As Long
      lTok = InStr(strURL, "\")
      While lTok <> 0
        Mid$(strURL, lTok, 1) = "/"
        lTok = InStr(strURL, "\")
      Wend
      URL = strURL
      If (URL <> "") Then
        URL = LCase$(URL)
        'If (Left$(URL, 7) <> "http://") Then URL = "http://" & URL
        If (Right$(URL, 1) <> "/") Then URL = URL & "/"
        
        CurrentURL = URL
        bHTMLClick = False
        
        HTMLView.Navigate CurrentURL
        HTMLView.Visible = True
        HTMLHide.Visible = False
        
        bHTMLClick = True
      End If
    Case "back"
      On Error Resume Next
      HTMLView.GoBack
      If Err.Number <> 0 Then Beep
    Case "forward"
      On Error Resume Next
      HTMLView.GoForward
      If Err.Number <> 0 Then Beep
    Case "stop"
      On Error Resume Next
      HTMLView.Stop
      If Err.Number <> 0 Then Beep
    Case "refresh"
      On Error Resume Next
      HTMLView.Refresh
      If Err.Number <> 0 Then Beep
  End Select
End Sub

Sub ProgressShow(Visible As Boolean)
  Status.Panels("progress").Visible = Visible
  Progress.Visible = Visible
  If Visible Then Progress.Move Status.Panels("progress").Left + 10, Status.Top + (Status.Height - Progress.Height) \ 2 + 10, Status.Panels("progress").Width - 20
End Sub