[Resolvido]Como dininuir o Zoom em navegador

ola pessoal recentemente navegando no fórum me enderecei por um navegador só que gostaria de diminuir o zoom no navegador da internet (tem como?)

https://www.dropbox.com/s/1a8th0255wn9sim/Browser%20Access.rar
desde já agradeço a todos

Bom dia,
No módulo FrmExplorer, substitua o código existente por este (só ao 2º clique é que o zoom actua)
Option Compare Database
Option Explicit
Dim Selecionado
Dim mstPath As String
Dim mboolRoot As Boolean
Dim mstFilePath As String
Dim mboolClick As Boolean
Dim mboolUp As Boolean
Dim Linha
Private varSTC As String 'VARIÁVEL CORRESPONDENTE A "StatusTextChange"

' Sinalizadores de navegação do Navegador usados para definir
' ou alterar o status dos botões Avançar e Voltar.
Dim gSinalizAvançar As Boolean
Dim gSinalizVoltar As Boolean
Dim gPrimeiroURL As String
' sinalizador de animação do Navegador usado para dizer qual
' imagem está exibida no momento durante a animação.
Dim gLuaAtual As Integer

Private Sub CtlActiveX1_StatusTextChange(ByVal Text As String)
Debug.Print "<< StatusTextChange >>" ' a mãozinha

On Error GoTo CtlActiveX1_StatusTextChange_Error

If Text <> "" Then ' quando <> "" corresponde ao endereço do link
Debug.Print " StatusTextChange - Text : " & Text
End If
'Coloca na variável private (lá em acima) o valor do text para ser usado em
'"Private Sub Navegador_NewWindow2"
varSTC = Text
Me.rotStatus.Caption = Text



On Error GoTo 0
Exit Sub

CtlActiveX1_StatusTextChange_Error:


MsgBox "ERRO " & Err.Number & " - (" & Err.Description & ")"

End Sub



Sub GirarÍcones(blnEstado As Boolean)

If blnEstado = True Then
' Define propriedade TimerInterval.
Me.TimerInterval = 100
' Se blnEstado é True, oculta terra1 e gira de lua1 até lua8.
Me!terra1.Visible = False
Else
' Se blnEstado é False, oculta todos os controles imagem, exceto terra1.
Me!terra1.Visible = True
' Define TimerInterval como 0 para que o evento não continue sendo acionado.
Me.TimerInterval = 0
End If

End Sub

Sub VerificarURL()
' Este procedimento é usado para assegurar que o botão Voltar permaneça ativado,
' a não ser que o usuário tenha retornado ao URL inicial.

If gSinalizVoltar = True And gPrimeiroURL <> Me!CtlActiveX1.LocationURL Then
Me!cmdVoltar.Enabled = True
Else
Me!CtlActiveX1.SetFocus
Me!cmdVoltar.Enabled = False
End If
End Sub




Private Sub CtlActiveX1_DownloadBegin()
' Anima ícones enquanto o controle está ocupado.
GirarÍcones True
End Sub

Private Sub CtlActiveX1_DownloadComplete()
' Suspende a animação de ícones.
GirarÍcones False
End Sub



Private Sub CtlActiveX1_NavigateComplete(ByVal URL As String)
' Define sinalizador para ativar o botão Voltar do formulário.
gSinalizVoltar = True
On Error Resume Next
' Se a variável usada para armazenar o primeiro URL está vazia,
' salva o URL atual na variável.
If Len(gPrimeiroURL) = 0 Then
gPrimeiroURL = Me!CtlActiveX1.LocationURL
End If
' Exibe o URL atual na caixa de texto do cabeçalho do formulário.
Me!txtVínculos = URL
' Chama o procedimento que determina como definir a propriedade
' Enabled do botão Voltar.
VerificarURL
End Sub

Private Sub cmdVoltar_Click()
On Error Resume Next
' Navega para o URL anterior.
Me.CtlActiveX1.GoBack
' Chama o procedimento que determina como é definida a propriedade
' Enabled do botão Voltar.
VerificarURL
' Ativa o botão Avançar.
gSinalizAvançar = True
Me!cmdAvançar.Enabled = True
End Sub

Private Sub cmdAvançar_Click()

On Error Resume Next
' Navega para frente até o URL anterior.
Me.CtlActiveX1.GoForward
Me.cmdVoltar.Enabled = True
End Sub



Private Sub cmdAtualizar_Click()
On Error Resume Next
' Força o controle WebBrowser a recarregar o URL atual.
Me!CtlActiveX1.Navigate Me!txtVínculos
Me.CtlActiveX1.Refresh
Me.WebBrowser0.Visible = True
End Sub
Public Function cmdAtualizar1()
On Error Resume Next
' Força o controle WebBrowser a recarregar o URL atual.
Me.CtlActiveX1.Refresh
End Function


Function RegistroExiste(rst As Recordset, strLocal As String) As Boolean
' Este procedimento é chamado a partir do evento cmdSalvarLocal_Click()
' para determinar se o endereço de hyperlink que o usuário está tentando
' salvar já existe na tabela Vínculos.
On Error Resume Next
DoCmd.Hourglass True
With rst
.MoveLast
If Err = 3021 Or .RecordCount = 0 Then
' Nenhum registro na tabela.
RegistroExiste = False
Else
.MoveFirst
.FindFirst "Hyperlink = '" & strLocal & "'"
If .NoMatch Then
' Nenhum registro coincidente na tabela.
RegistroExiste = False
Else
' Nenhum registro localizado.
RegistroExiste = True
End If
End If
End With
DoCmd.Hourglass False
End Function

Private Sub cmdSalvarLocal_Click()
' Este procedimento salva o hyperlink atual na tabela Vínculos.
Dim dbs As Database, rst As Recordset
Dim ctlHyper As Control, frmDiálogo As Form
Dim strHyperlink As String

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Vínculos", dbOpenDynaset)
Set ctlHyper = Me!CtlActiveX1

strHyperlink = "" & ctlHyper.LocationURL & ""
' Verifica se esta página já foi salva na tabela Vínculos.
If RegistroExiste(rst, strHyperlink) = True Then
MsgBox "Local já salvo na tabela"
DoCmd.Hourglass False
Exit Sub
End If
'Abre o formulário DiálogoSalvarURL.
DoCmd.OpenForm "DiálogoSalvarURL", acNormal, , , acEdit, acDialog, ctlHyper.LocationName & ";" & ctlHyper.LocationURL
If EstáCarregado("DiálogoSalvarURL") = False Then
' O usuário clicou em Cancelar, portanto sai deste procedimento.
DoCmd.Hourglass False
Exit Sub
End If

' Adiciona o novo registro e, em seguida, fecha o formulário DiálogoSalvarURL.
With rst
.AddNew
!Descrição = Forms!DiálogoSalvarURL!txtDescriçãoSalva
!HyperLink = strHyperlink
.Update
End With
DoCmd.Close acForm, "DiálogoSalvarURL", acSaveNo
DoCmd.Hourglass False
End Sub

Private Sub cmdPesquisar_Click()
Dim Caminho As String
On Error Resume Next
' Navega para a home page.
Caminho = "www.google.com.br"
Me.WebBrowser0.Visible = True
''Zoom to 25%
'Me.WebBrowser0.Object.ExecWB OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, CLng(25), vbNull
Me.CtlActiveX1.Object.ExecWB OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, CLng(50), vbNull
Me!CtlActiveX1.Navigate Caminho
End Sub


Private Sub Form_Load()
Me.lbxExplorer.RowSourceType = "value list"

Me.lbxExplorer.AddItem ("Bilbioteca" & ";" & "C:\Users\" & Environ("UserName") & "\AppData\Roaming\Microsoft\Windows\Libraries\")
Me.lbxExplorer.AddItem ("Meus Documentos" & ";" & "C:\Users\" & Environ("UserName") & "\AppData\Roaming\Microsoft\Windows\Libraries\Documents.library-ms")
Me.lbxExplorer.AddItem ("Imagens" & ";" & "C:\Users\" & Environ("UserName") & "\AppData\Roaming\Microsoft\Windows\Libraries\Pictures.library-ms")
Me.lbxExplorer.AddItem ("Músicas" & ";" & "C:\Users\" & Environ("UserName") & "\AppData\Roaming\Microsoft\Windows\Libraries\Music.library-ms")
Me.lbxExplorer.AddItem ("Vídeos" & ";" & "C:\Users\" & Environ("UserName") & "\AppData\Roaming\Microsoft\Windows\Libraries\Videos.library-ms")
Me.lbxExplorer.AddItem ("Downloads" & ";" & "C:\Users\" & Environ("UserName") & "\Downloads")
Me.lbxExplorer.AddItem ("Área de Trabalho" & ";" & "C:\Users\" & Environ("UserName") & "\Desktop")
Me.lbxExplorer.AddItem ("Usuário" & ";" & "C:\Users\")
WebBrowser0.Navigate URL:="https://i.servimg.com/u/f69/14/49/91/69/earth-11.gif"
' Inicializa variável pública usada para animação do ícone de navegação na web.
gLuaAtual = 1
' Navega para o destino Home.
On Error Resume Next
Me!CtlActiveX1.Navigate Me!txtVínculos
If Err Then
' Verifica a propriedade IE30Present da classe clsIE30Status
' para determinar se IE3.0 está presente nesta máquina.
Dim objIE3Status As New clsIE30Status
If objIE3Status.IE30Present = False Then
'MsgBox "Você só pode visualizar este formulário em um computador que também tenha o Microsoft Internet Explorer 3.0 ou posterior instalado.", vbCritical, "Erro ao Carregar o Navegador"
'DoCmd.Close acForm, Me.Name
'Exit Sub
End If
End If


End Sub


Private Sub Form_Timer()
' Este procedimento anima o ícone que mostra uma lua girando.
' O formulário contém 8 ícones de lua diferentes e um ícone da terra.
' O ícone da terra é exibido por padrão. Quando o navegador está ocupado,
' o procedimento GirarÍcones define a propriedade TimerInterval, a qual
' especifica quando os ícones são girados.
Select Case gLuaAtual
Case 1
Me!lua2.Visible = True
Me!lua1.Visible = False
Case 2
Me!lua3.Visible = True
Me!lua2.Visible = False
Case 3
Me!lua4.Visible = True
Me!lua3.Visible = False
Case 4
Me!lua5.Visible = True
Me!lua4.Visible = False
Case 5
Me!lua6.Visible = True
Me!lua5.Visible = False
Case 6
Me!lua7.Visible = True
Me!lua6.Visible = False
Case 7
Me!lua8.Visible = True
Me!lua7.Visible = False
Case 8
Me!lua1.Visible = True
Me!lua8.Visible = False
End Select

If gLuaAtual < 8 Then
gLuaAtual = gLuaAtual + 1
Else
gLuaAtual = 1
End If
End Sub


Private Sub Imagem52_Click()
'"C:\Program Files (x86)\Windows Live\Messenger\msnmsgr.exe"
End Sub

Private Sub lbxExplorer_Click()
Dim Linha As Integer

Selecionado = True

Linha = Me.lbxExplorer.ListIndex
If Selecionado = True Then

Me.txtVínculos = Me.lbxExplorer.Column(1, Linha)
Me.txtVínculos.SetFocus
Me.WebBrowser0.Visible = False
End If



End Sub

Private Sub Pesquisar_Click()
DoCmd.OpenForm "FrmEndereco"
Me.WebBrowser0.Visible = True
End Sub

Private Sub Sair_Click()
DoCmd.Close
End Sub

Private Sub txtVínculos_AfterUpdate()
On Error Resume Next
' Se o usuário inseriu um endereço (URL) neste controle,
' tenta navegar para o endereço.
If Len(Me!txtVínculos) > 0 Then
Me!CtlActiveX1.Navigate Me!txtVínculos

End If
End Sub


Private Sub txtVínculos_Change()
Me.CtlActiveX1.Navigate Me!txtVínculos
End Sub

Private Sub txtVínculos_GotFocus()
Me.CtlActiveX1.Navigate Me!txtVínculos
End Sub


'--------------------------------------------------
' Updated By Mehmet Acikgoz (30 July 1998)
'--------------------------------------------------

' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of Dev Ashish
'


Private Sub cmdNavUp_Click()
Dim stTmp As String
Dim i As Integer
mboolUp = True
If Len(mstPath) = 2 Then
Me!lblPath.Caption = ""
Me.Caption = "Explorer"
Call sFillRoot
Else
For i = Len(mstPath) To 1 Step 0 - 1
stTmp = Mid$(mstPath, i, 1)
If stTmp = "\" Then
mstPath = Left$(mstPath, i - 1)
Call sNavigate(mstPath)
'Me!lbxFiles.Requery
Exit For
End If
Next i
End If
End Sub

Private Sub Form_Error(DataErr As Integer, Response As Integer)
DoCmd.Hourglass False
End Sub

Private Sub Form_Open(Cancel As Integer)
Dim strUser As String
strUser = VBA.Environ("UserName")

Call sFillRoot
Me!lblPath.Caption = ""
Me.WebBrowser0.Visible = False


End Sub

Private Sub sFillRoot()
Dim strAllDrives As String
Dim strTmp As String, strOut As String
Dim loDir As clsDir

Set loDir = New clsDir

strAllDrives = fGetDrives()

strOut = vbNullString

mboolRoot = True

Do
strTmp = Mid$(strAllDrives, 1, InStr(strAllDrives, vbNullChar) - 1)
strAllDrives = Mid$(strAllDrives, InStr(strAllDrives, vbNullChar) + 1)
strOut = strOut & strTmp & ";"
Loop While strAllDrives <> ""

'trim strOut
strOut = Left$(strOut, Len(strOut) - 1)

'populate the ListBox
With Me!lbxfolders
.RowSourceType = "Value List"
.RowSource = strOut
End With

Set loDir = Nothing
mstPath = vbNullString

End Sub


Private Sub lbxFiles_DblClick(Cancel As Integer)
Dim varRet
Dim stPath As String

If mstPath = vbNullString Then
stPath = Left$(Me!lbxfolders, Len(Me!lbxfolders) - 1)
Else
stPath = mstPath & "\" & Me!lbxfolders
End If
varRet = fHandleFile(stPath & "\" & Me!lbxFiles, WIN_NORMAL)
End Sub

Private Sub lbxFolders_Click()
'Coloca os campos nome que estão na lst_Explorer, em campo Text no form
'para serem usados no acesso do browses
'Dim Linha As Integer

Selecionado = True
Linha = Me.lbxfolders.ListIndex
If Selecionado = True Then

Me.txtVínculos = Me.lbxfolders.Column(0, Linha)
Me.txtVínculos.SetFocus
'DoCmd.RunCommand acCmdCopy
'DoCmd.RunCommand acCmdPaste
Me.txtVínculos.SetFocus

Me!CtlActiveX1.Navigate Me!txtVínculos
Me.WebBrowser0.Visible = False

End If


End Sub

Private Sub lbxFolders_DblClick(Cancel As Integer)
Dim stPath As String
Dim stOut As String
Dim stFiles As String
Dim i As Long

If mstPath = vbNullString Then
stPath = Left$(Me!lbxfolders, Len(Me!lbxfolders) - 1)
Else
stPath = mstPath & "\" & Me!lbxfolders
Me.txtVínculos.Value = mstPath & "\" & Me!lbxfolders
Me!CtlActiveX1.Navigate Me!txtVínculos
End If

mboolClick = False: mboolUp = False
'Me!lbxFiles.RowSource = ""
Call sNavigate(stPath)

End Sub

Sub sNavigate(stPath As String)
Dim stFolders As String

stFolders = fCreateFolderList(stPath)

If stFolders <> vbNullString Then
'Populate Folders List Box
With Me!lbxfolders
.RowSourceType = "Value List"
.RowSource = stFolders
End With
mstPath = stPath
Else
mboolClick = False: mboolUp = False
DoCmd.Hourglass True
'Me!lbxFiles.Requery
DoCmd.Hourglass False
End If

Me!cmdNavUp.Enabled = (mboolRoot)
Me.Caption = mstPath & "\ - Explorer"
Me!lblPath.Caption = mstPath & "\"
End Sub

Function fListFill(ctl As Control, varID As Variant, lngRow As Long, _
lngCol As Long, intCode As Integer) As Variant

Static sastFiles() As String
Static slngCount As Long
Static sloclDir As clsDir
Dim i As Long
Dim varRet As Variant
Dim x As Long

Select Case intCode
Case acLBInitialize
Set sloclDir = New clsDir
If Not mstFilePath = vbNullString _
And mboolClick And Not mboolUp Then
With sloclDir
.FillFiles mstFilePath

slngCount = .GetFileCount

If slngCount > 0 Then
ReDim sastFiles(0 To slngCount - 1)
For i = 1 To slngCount
sastFiles(i - 1) = .NameOfFile(i)
Next i
PDF_accSortStringArray sastFiles()
End If
End With
Else
slngCount = 0
End If
varRet = True

Case acLBOpen
varRet = Timer

Case acLBGetRowCount
varRet = slngCount

Case acLBGetValue
If slngCount > 0 And mboolClick And Not mboolUp Then
varRet = sastFiles(lngRow)
Else
varRet = vbNullString
End If

Case acLBEnd
Set sloclDir = Nothing
Erase sastFiles
End Select
fListFill = varRet
End Function

obrigado funcionou perfeitamente