Option Explicit
'Autocomplete TextBox
Private Const SHACF_AUTOAPPEND_FORCE_OFF = &H80000000
Private Const SHACF_AUTOAPPEND_FORCE_ON = &H40000000
Private Const SHACF_AUTOSUGGEST_FORCE_OFF = &H20000000
Private Const SHACF_AUTOSUGGEST_FORCE_ON = &H10000000
Private Const SHACF_DEFAULT = &H0
Private Const SHACF_FILESYSTEM = &H1
Private Const SHACF_URLHISTORY = &H2
Private Const SHACF_URLMRU = &H4
Private Const SHACF_USETAB = &H8
Private Const SHACF_URLALL = (SHACF_URLHISTORY Or SHACF_URLMRU)
Private Declare Sub SHAutoComplete Lib "shlwapi.dll" (ByVal hwndEdit As Long, ByVal dwFlags As Long)

'ProgressBar dans la StatusBar
Private Declare Function SetParent Lib "user32" _
        (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
        
Dim X As Integer, Y As Integer
Dim myURL As String
Dim myCol As New Collection
Dim bGoBack As Boolean, bGoForward As Boolean
Dim sParamCommand As String, sParam() As String, sExecute As String
Dim lParam As Long, l As Long

Private Sub Form_Load()
    On Error Resume Next
    
    SHAutoComplete txtAddress.hWnd, SHACF_DEFAULT
    
    sParamCommand = Command
    sParam() = Split(sParamCommand, " ")
    lParam = UBound(sParam)
    For l = 0 To lParam
        sExecute = sParam(l)
    Next

    'Passage de paramètre
    If sExecute <> "" Then
        Select Case sExecute
            Case "1"
                'Carte du Mans
                Me.Caption = "Plan du Mans"
                sSite = _
                    "http://www.viamichelin.fr/viamichelin/fra/dyn/controller/" & _
                    "Cartes?strCountry=1424&strAddress=&strMerged=72000&x=35&y=12&ie=UTF-8"
            Case "2"
                'Carte de la Sarthe
                Me.Caption = "Carte de la Sarthe"
                sSite = _
                    "http://maps.google.fr/maps?q=carte+de+la+sarthe&oe=utf-8&rls=" & _
                    "org.mozilla:fr:official&client=firefox-a&um=1&ie=UTF-8&split=0&gl=fr&ei=" & _
                    "TC6hSbaQLMLM-Aa885S4Dg&sa=X&oi=geocode_result&resnum=1&ct=title"
            Case "3"
                Me.Caption = "Communes de la Sarthe"
                sSite = "http://fr.wikipedia.org/wiki/Communes_de_la_Sarthe"
        End Select
        'Charger la page
        WB1.Navigate (sSite)
        txtAddress.Text = sSite
    Else
        'Charger la page
        WB1.Navigate "www.google.fr"
        txtAddress.Text = "www.google.fr"
    End If
  
    'Setparent
    SetParent PB1.hWnd, SB1.hWnd
         
    'Barre de progression
    With PB1
        .Top = 55
        .Left = SB1.Panels(1).Width + 60
        .Width = SB1.Panels(2).Width - 50
        .Height = SB1.Height - 90
    End With
    
    Me.Show
    txtAddress.SetFocus
End Sub

Private Sub Form_Resize()
    On Error Resume Next

    With Me
        .WB1.Height = .Height - 2800
        .WB1.Width = .Width - 100
    End With
    SB1.Panels(1).Width = Me.Width - 4250
    fraURL.Width = Me.Width - 120
    PB1.Left = SB1.Panels(1).Width + 60
    txtAddress.Width = Me.Width - 2220
    cmdGo.Left = txtAddress.Width + 1185
End Sub

Private Sub WB1_TitleChange(ByVal Text As String)
    If sExecute = "" Then frmLeMans.Caption = "Claude Cabon - Web Browser - " & Text
End Sub

Private Sub WB1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
    On Error Resume Next
   
    With PB1
        .Max = ProgressMax
        .Value = Progress
    End With
End Sub

Private Sub WB1_StatusTextChange(ByVal Text As String)
    'StatusBar
    SB1.Panels.Item(1).Text = Text
End Sub

Private Sub cmdGo_Click()
    'Pévenir une erreur non désirée
    With WB1
        .Silent = True
        .Navigate (txtAddress.Text)
    End With
End Sub

Private Sub cmdGo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Set ToolTip
    cmdGo.ToolTipText = "Aller à " & "'' " & txtAddress.Text & " ''"
End Sub

Private Sub txtAddress_GotFocus()
    With txtAddress
        .SelStart = Len(.Text)
        .SetFocus
    End With
End Sub

'Private Sub txtAddress_Click()
'    txtAddress.SelStart = Len(txtAddress.Text)
'    txtAddress.SetFocus
'End Sub

Private Sub TB1_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    
    Select Case Button.Index
        Case 1
            X = X + 1
            Y = Y - 1
            TB1.Buttons(2).ButtonMenus.Add , , myCol.Item(X - 1)
            TB1.Buttons(1).ButtonMenus.Remove (X - 1)
            bGoBack = True
            WB1.GoBack
            bGoBack = False
        Case 2
            X = X - 1
            Y = Y + 1
            TB1.Buttons(1).ButtonMenus.Add , , myCol.Item(Y - 1)
            TB1.Buttons(2).ButtonMenus.Remove (Y - 1)
            bGoForward = True
            WB1.GoForward
            bGoForward = False
        Case 3
            WB1.Stop
        Case 4
            WB1.Refresh
        Case 5
            WB1.Navigate "www.google.fr"
    End Select
End Sub

Private Sub WB1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, _
    TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
    'Possibilité d'ajouter des filtres. Exemple, pour interdire "YouTube"
    If InStr(1, URL, ".avi") > 0 Or InStr(1, URL, ".wmv") > 0 Or InStr(1, URL, "youtube") Then
        MsgBox "Vous ne pouvez pas accéder à cette page"
        Cancel = True
    End If
End Sub

Private Sub WB1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    On Error Resume Next
    
    If (pDisp Is WB1.Application) Then
        Dim HTML As HTMLDocument        'Notifier les changements ici

        'Définir le document comme une objet HTML
        Set HTML = WB1.Document
    End If
    
    'Ajouter depuis la collection
    If bGoBack Or bGoForward Then Exit Sub
    Y = Y + 1
    X = X + 1
    myCol.Add txtAddress.Text
    If X = 1 Then Exit Sub
    TB1.Buttons(1).ButtonMenus.Add , , myCol.Item(X - 1)
End Sub

Private Sub WB1_NewWindow2(ppDisp As Object, Cancel As Boolean)
    'Copie de la Form
    Dim frm As New frmLeMans

    frm.WB1.RegisterAsBrowser = True
    
    Set ppDisp = frm.WB1.object
    frm.Show
End Sub

Private Sub WB1_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)
    On Error Resume Next
    
    DoEvents
    DoEvents
    DoEvents
    
    If Enable = True And Command = CSC_NAVIGATEBACK Then
        TB1.Buttons.Item(1).Enabled = True
    ElseIf Enable = False And Command = CSC_NAVIGATEBACK Then
        TB1.Buttons.Item(1).Enabled = False
    End If

    If Enable = True And Command = CSC_NAVIGATEFORWARD Then
        TB1.Buttons.Item(2).Enabled = True
    ElseIf Enable = False And Command = CSC_NAVIGATEFORWARD Then
        TB1.Buttons.Item(2).Enabled = False
    End If
    
    txtAddress.Text = WB1.LocationURL
End Sub

Private Sub mnuWindow_Click()
    'Nouvelle fenêtre
    Dim runApp As Double
    
    runApp = Shell(App.Path & "\" & App.EXEName)
End Sub

Private Sub mnuOpenFile_Click()
    'Ouvrir fichier
    With CD1
        .Filter = "Web Page (*.html)|*.html|All File (*.*)|*.*"
        .ShowOpen
    End With
    WB1.Navigate CD1.FileName
End Sub

Private Sub mnuSaveAs_Click()
    'Sauvegarder
    WB1.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuPageSetup_Click()
    'Mise en page
    WB1.ExecWB OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuPrint_Click()
    'Impression
    WB1.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER
End Sub

Private Sub mnuPrintPreview_Click()
    'Prévisualiser
    WB1.ExecWB OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuProperties_Click()
    'Propriétés de la page
    WB1.ExecWB OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuOffLine_Click()
    'Paramètres OffLine
    If mnuOffLine.Checked = True Then
        mnuOffLine.Checked = False
        WB1.Offline = False
    Else
        mnuOffLine.Checked = True
        WB1.Offline = True
    End If
End Sub

Private Sub mnuCopy_Click()
    'Copier
    WB1.ExecWB OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuSelectAll_Click()
    'Sélectionner tout
    With WB1
        .SetFocus
        .ExecWB OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT
    End With
End Sub

Private Sub mnuPaste_Click()
    'Coller
    WB1.ExecWB OLECMDID_PASTE, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuSource_Click()
    'Afficher fichier source
    frmSource.Show
End Sub

Private Sub mnuAddFavorites_Click(Index As Integer)
    'Ajouter les favoris au runtime
    If mnuAddFavorites.Item(0) Then
        If MsgBox("Voulez-vous ajouter " & txtAddress.Text & " au favoris ?", _
            vbOKCancel) = vbOK Then
            Load mnuAddFavorites(mnuAddFavorites.UBound + 1)
            With mnuAddFavorites(mnuAddFavorites.UBound)
                .Caption = txtAddress.Text
                .Tag = txtAddress.Text
                .Visible = True
            End With
        Else
            Exit Sub
        End If
        
    Else
        WB1.Navigate mnuAddFavorites(Index).Tag
    End If
End Sub

Private Sub mnuAbout_Click()
    frmAbout.Show
End Sub

Private Sub mnuExit_Click()
    Unload Me
    End
End Sub