Dim ajuda As Boolean
Dim Banco As String
Sub help()
   If ajuda Then
      MsgBox "Pedido de ajuda desativado." & vbLf & "Clique de novo para ativar"
      ajuda = False
      Exit Sub
   End If
   ajuda = True
   MsgBox "Clique no ícone desejado para obter ajuda"
End Sub
Sub CriaPlanilha(x)
    Set x = Sheets.Add
    x.Visible = False
End Sub
Sub DeletaPlanilha(p)
    If LCase(p.Cells(1, 1)) = "erro" Then
       Cells(3, 1) = p.Cells(1, 2)
    End If
    Application.DisplayAlerts = False
    p.Delete
End Sub
Sub AcessaWeb(url, x) ' recebe uma url para pesdquisar e devolve uma planilha escondida com a resposta
    CriaPlanilha x
    Set base = x.Cells(1, 1)
    With x.QueryTables.Add(Connection:= _
        "URL;http://" & url, Destination:=base)
        .Name = "nome"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .Refresh BackgroundQuery:=False
    End With
End Sub
Sub Horacerta()
    If ajuda Then
       ajuda = False
       MsgBox "Apenas clique no relógio para acertar o relógio do seu computador"
       Exit Sub
    End If
    Range("a2:d1000").ClearContents
    AcessaWeb "www.ruimedeiros.eti.br/Horacerta.asp", x
    Date = Format(x.Cells(1, 1))
    Time = Format(x.Cells(2, 1), "hh:mm:ss")
    MsgBox Format(x.Cells(1, 1), "dd/MM/yyyy") & " " & _
           Format(x.Cells(2, 1), "hh:mm:ss")
    DeletaPlanilha x
End Sub
Sub SqlAccess(sql, x)
    Set con = CreateObject("ADODB.Connection")
    con.Open "Provider=Microsoft.Jet.Oledb.4.0;data Source=" & Banco
    Set rst = con.Execute(sql)
    CriaPlanilha x
    If Left(LCase(Trim(sql)), 6) = "select" Then
        x.Cells(1, 1).CopyFromRecordset rst
    End If
    Set rst = Nothing
    Set con = Nothing
End Sub
Sub SqlWeb(sql, x)
    url = "www.ruimedeiros.eti.br/sql/executa.asp?SQL=" & sql
    AcessaWeb url, x
End Sub
Sub execsql(sql, x)
    Banco = Range("banco")
    Range("a3:d1000").ClearContents
    If LCase(Banco) = "web" Then
       SqlWeb sql, x
    Else
       SqlAccess sql, x
    End If
End Sub
Sub pesquisa()
    If ajuda Then
       ajuda = False
       MsgBox "Escreva na célula A2 um string a pesquisar na agenda" & _
       vbLf & "Depois clique aqui para pesquisar"
       Exit Sub
    End If
    quem = Trim(Cells(2, 1))
    Range("b2:c2").ClearContents
    sql = "select * from agendademo"
    execsql sql, x
    k = 3
    For i = 1 To 1000
       If x.Cells(i, 1) = "" Then Exit For
       linha = x.Cells(i, 1) & x.Cells(i, 2) & x.Cells(i, 3)
       If InStr(1, linha, quem, vbTextCompare) > 0 Then
          For j = 1 To 3
              Cells(k, j) = x.Cells(i, j)
          Next
          k = k + 1
       End If
    Next
    DeletaPlanilha x
End Sub
Sub cadastra()
    If ajuda Then
       ajuda = False
       MsgBox "Escreva nas células da linha 2 o nome, o endereço e o telefone a cadastrar" & _
       vbLf & "Depois clique aqui para pesquisar"
       Exit Sub
    End If
    sql = "insert into agendademo values('" & Cells(2, 1) & "','" & _
          Cells(2, 2) & "','" & Cells(2, 3) & "')"
    execsql sql, x
    DeletaPlanilha x
End Sub
Sub Apaga()
    If ajuda Then
       ajuda = False
       MsgBox "Escreva na célula A2 um nome completo para excluir da agenda"
       Exit Sub
    End If
    sql = "delete from agendademo where nome='" & Trim(Cells(2, 1)) & "'"
    execsql sql, x
    DeletaPlanilha x
End Sub