VBA - Função de arredondamento com incremento personalizado

Outro dia precisei de uma função para transformar 1,1 em 2 e assim por diante (arredondar para cima sempre que a decimal for maior que zero) e com a ajuda do grande mestre Gib@ que conseguiu garimpar no suporte da Microsoft, deixo aqui para futuras consultas, pois os materiais da Microsoft costumam mudar de lugar ou simplesmente sumir. O link original: http://support.microsoft.com/kb/155696/pt-br

O exemplo a seguir cria um procedimento chamado RoundToNearest, que aceita três parâmetros:

   Parameter     Value

   ---------     ---------------------------------------------------------

   Amt           The numeric value you want to round

   RoundAmt      The increment to which Amt will be rounded

   Direction     Constant indicating which direction to round (up or down)

                                  

Por exemplo, RoundToNearest (3,33, 0,1, vb_roundup) retorna o valor 3.4.

1.       Crie um módulo e digite as seguintes linhas na seção declarações:

2.             Option Explicit

3.             Public Const vb_roundup = 1

      Public Const vb_rounddown = 0

Observação: Versões 1. x e 2.0, use a palavra "Global" em vez de "Público".

4.       Crie o procedimento a seguir.

Observação: No código de exemplo a seguir, um sublinhado (_) ao final de uma linha é usado como um caractere de 
continuação de linha. Remova o sublinhado do final da linha quando recriar esse código no Access Basic.

5.             Function RoundToNearest (Amt As Double, RoundAmt As Variant, _

6.                                      Direction As Integer) As Double

7.                On Error Resume Next

8.                Dim Temp As Double

9.                Temp = Amt / RoundAmt

10.            If Int(Temp) = Temp Then

11.               RoundToNearest = Amt

12.            Else

13.               If Direction = vb_rounddown Then

14.                  Temp = Int(Temp)

15.               Else

16.                  Temp = Int(Temp) + 1

17.               End If

18.               RoundToNearest = Temp * RoundAmt

19.            End If

20.         End Function

                                                 

21.   Para testar essa função, digite cada uma das linhas a seguir na janela Depurar 
(ou janela Verificação imediata no 1. x e 2.0) e, em seguida, pressione ENTER.

? RoundToNearest (0.25, vb_roundup, 1.36)

Observe que o procedimento retorna 1.5.

? RoundToNearest (1.36, 0.05, vb_rounddown)

Observe que o procedimento retorna 1.35.

? RoundToNearest (1.36, 0.75, vb_roundup)

Observe que o procedimento retorna 1.5, que é dois incrementos de 0,75.

Observação: Para usar a função acima na propriedade OrigemDoControle de um controle em um formulário, 
você precisará substituir as constantes vb_roundup e vb_rounddown com seus valores de número inteiro.

Desanexando arquivos de uma pasta do Outlook

Escrevi este código para desanexar arquivos dos e-mails de uma pasta (que aqui vou chama-la de "Pasta a ser lida") com a condição de que o e-mail esteja marcado como "não lido". Utilizo o código para automação de um processo em que preciso processar vários arquivos do tipo texto (*.txt) em determinado horário da noite. ;-)

Option Compare Database
Option Explicit

Dim olapp           As New Outlook.Application
Dim pasta           As Outlook.Folder
Dim item            As Outlook.MailItem
Dim i               As Integer
Dim arq_anexo       As Outlook.Attachment
Dim repositorio     As String
    
    
Public Sub desanexa()

    'Define a pasta a ser lida
    Set pasta = olapp.GetNamespace("MAPI").Folders("Caixa de correio - Paulo K. Todoroki").Folders("Pasta a ser lida")
    
    For i = 1 To pasta.Items.Count
        DoEvents
        'Se a mensagem for do tipo E-MAIL  e marcada como NÃO LIDA
        If pasta.Items(i).Class = olMail And pasta.Items(i).UnRead = True Then
            'Para cada anexo da mensagem
            'Necessário o loop porque o primeiro anexo pode ser uma imagem com a assinatura
            For Each arq_anexo In pasta.Items(i).Attachments
                DoEvents
                arq_anexo.SaveAsFile "C:\Arquivos\" & arq_anexo.FileName
            Next arq_anexo
        End If
        
        'Marcar a mensagem como lida
        pasta.Items(i).UnRead = False
        
    Next
    
End Sub

Preenchendo textbox's em formulários desvinculados no Access

Iniciando pelas boas práticas de programação: nada mais lógico do que nomear um TextBox com o mesmo nome do campo da tabela obviamente respeitando os prefixos. Exemplo: no formulário o campo txt_nome recebe o valo do campo... nome! Tenho convivido com situações onde nem sempre isso ocorre. Campo como CNPJ tem variações e é carregado nos formulários em caixas de texto com nomes variados como txt_cnpj, txt_cpfcnpj, txt_cnpj_cli e por ai vai. Considerando que o boa prática foi respeitada, segue um código que preenche os campos de um formulário sem a necessidade de referenciá-los um a um. Escrevi o código para facilitar o dia a dia do desenvolvedor que sempre tem um pedido do tipo "é só acrescentar mais um campo...". Acrescentado o campo e o TextBox correspondente, nada é alterado no código. ;-)

Option Compare Database
Option Explicit

Private Sub Comando8_Click() 

    Dim nome_campo As String
    Dim nome_txt As String
    Dim campo_do_form As Control
    Dim formulario As Form

    ssql = "SELECT * FROM CLIENTES"
    Set rst = New ADODB.Recordset
    rst.Open ssql, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    rst.MoveFirst

    Set formulario = Form_frm_teste      
    For Each campo_do_form In formulario
        nome_campo = Replace(campo_do_form.Name, "txt_", "")
        If Left(campo_do_form.Name, 3) = "txt" Then
            campo_do_form = rst.Fields(nome_campo).Value
        End If
    Next

    rst.Close
    Set rst = Nothing

End Sub

Bug

Até mesmo um simples jogo de paciência tem bug... estava com 9 cartas abertas e um espaço e olha só a mensagem! :-)

Mais um bom site sobre VBA

http://www.anthony-vba.kefra.com/

Se eu não publico nada de novo, pelo menos indico onde tem coisa boa...

;-)

Verificar existência de pasta

Às vezes a gente cria uma macro no VBA que utiliza alguma pasta específica e precisa criá-la antes de colocá-la em uso.
Nem sempre é fácil pedir para o usuário final criar uma pasta, pois acreditem se quiser, tem gente com dificuldade para realizar essa tarefa...
Abaixo um código para verificar se a pasta existe e se não existir, cria em seguida.

Sub pasta_existe()

    'Verificar se existe
    If Dir("C:\TESTE\") = vbNullString Then
        'Se não existir, criar
        MkDir "C:\TESTE"
    End If

End Sub

Adobe Reader 10 - download completo

Para quem faz manutenção em computadores, é mais prático ter o arquivo de instalação completo do Adobe Reader, pois fazer download durante a instalação é demorado.
Vou deixar o link para consultas, pois demorei muito para... achar o link do download completo!

http://www.adobe.com/support/downloads/product.jsp?platform=windows&product=10

;-)

Como utilizar a planilha enquanto o UserForm está na tela

Dica boba e super simples, mas talvez alguém ainda não saiba:
Quanto tiver um UserForm aberto na tela e necessitar navegar pela planilha, altere a propriedade "Modal" do formulário para FALSE e veja o resultado.
É como se fosse uma tela "flutuando" sobre a planilha...

;-)

Desproteger planilhas via VBA

Este é um dos códigos mais "manjados" da internet.
Não sei a autoria, estou deixando aqui apenas para futuras consultas.

Sub DesprotegerPlanilhaAtiva()

Dim i, i1, i2, i3, i4, i5, i6 As Integer, j As Integer, k As Integer, l As Integer, m As Integer, n As Integer

On Error Resume Next

For i = 65 To 66

For j = 65 To 66

For k = 65 To 66

For l = 65 To 66

For m = 65 To 66

For i1 = 65 To 66

For i2 = 65 To 66

For i3 = 65 To 66

For i4 = 65 To 66

For i5 = 65 To 66

For i6 = 65 To 66

For n = 32 To 126

ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

If ActiveSheet.ProtectContents = False Then

MsgBox "Planilha desprotegida com sucesso!!!"

Exit Sub

End If

Next

Next

Next

Next

Next

Next

Next

Next

Next

Next

Next

Next

End Sub

O drive de CD/DVD sumiu...

Demorou mas aconteceu comigo também: o drive de cd/dvd aparece no setup... mas nem sinal dele no Windows Explorer.
Encontrei na internet diversas soluções alterando o registro do Windows, o que não é indicado para principiantes pois um erro no procedimento pode causar mais problemas do que ajudar.
Felizmente no site da Microsoft tem um programa que faz isso automaticamente, bem do jeito que o usuário gosta: alguns click's e pronto!
Segue o link abaixo:

http://support.microsoft.com/kb/314060/pt-br

;-)

Outlook - enviando e-mail numa determinada data

Outro dia precisei agendar o envio de um e-mail e procurei no Outlook alguma opção para esta finalidade.
Depois de muito pesquisar no help como "agendamento" e coisas semelhantes, acabei descobrindo que, na verdade a coisa é tratada meio que na "contramão".
Em vez de agendar para enviar em tal data, a regra é ... atrasar o envio até tal data!
Tudo muito simples, depois que você criar a mensagem, clique em Opções > atrasar o envio da mensagem até... e depois é só enviar o e-mail. Ele ficará parado na caixa de saída até a data determinada.
Simples não?
Sim, simples depois que se aprende como fazer!
;-)

Mais informações sobre programação no Outlook VBA e quem diria... no site da Microsoft! Pesquisar no site da Microsoft é um verdadeiro trabalho de garimpagem, haja vista a imensa quantidade de informações disponíveis. Material sobre programação no Outlook ainda é escasso em relação aos outros aplicativos do pacote Office, assim qualquer descoberta merece ser divulgada. ;-)


 http://msdn.microsoft.com/en-us/library/gg537298(v=office.12).aspx

Macetes com o ListBox no Access

Utilizando o ListBox num formulário Access, me deparei com alguns problemas e o primeiro deles, quase imperceptível: dependendo da quantidade de dados, o carregamento não é completo.
Por exemplo, carregar apenas uma coluna, o método "AddItem" do ListBox vai na boa, o detalhe é que se a quantidade de linhas é muito grande, as últimas não são carregadas!
Pior de tudo é que o Access nem dá mensagem de erro, simplesmente não carrega.
O número de linhas diminui a medida em que o número de colunas aumenta.

Em tempo, considerando uma quantidade muito grande de registros, talvez o ListBox não seja a melhor solução.
Tenho um aplicativo em que a quantidade de registros varia normalmene de 1 a 20, mas existem situações que podem ultrapassar a 3 mil. São exceções, mas podem ocorrer, por isso mantive a solução do ListBox.

Bem, continuando com a ajuda do amigo Gib@, mudei o carregamento do ListBox, apenas alterando a fonte de dados para uma tabela (sem carregamento por VBA).

Carregando uma grande quantidade de registros, o problema que surge é a navegação.
Pela barra de rolagem vertical, demora para se chegar até o último registro.
Um Requery aqui não funciona obviamente.

Após um tempinho tentando descobrir a causa dessa péssima navegabilidade, criei um "quebra-galho" mas que funciona: selecionar o último registro da lista e em seguida selecionar o primeiro.
Dessa forma, ao navegar pela barra de rolagem vertical todos os registros são exibidos mais rapidamente.

Essa questão na navegabilidade é mais facilmente verificada se montar ume exemplo, colocar aqui em palavras fica meio abstrato.

Uma outra forma de carregar o ListBox com uma quantiade grande de registros é clonar o RecordSet, veja exemplo mais abaixo.
Aí aparece outro problema: as colunas são colocadas em ordem alfabética.
Se o carregamento é por VBA, o ListBox.ColumnOrder não funciona,o que força a outro "quebra-galho": utilizar alias para as colunas no SQLÇ de forma que fiquem na ordem desejada e não colocar cabeçalhos de coluna no ListBox.
Para isso, basta utilizar Labels acima do ListBox, o resultado visual é bem melhor, visto que podemos trabalhar as propriedades de modo bem flexível.

Option Compare Database
Option Explicit

Private Sub carrega_lista()

    Dim rst As New ADODB.Recordset
    Dim ssql As String
    
    Me.lst_teste.RowSource = ""
    
    ssql = "SELECT cod as a_001, "
    ssql = ssql & "Empresa as     a_001,"
    ssql = ssql & "Contato as     a_002,"
    ssql = ssql & "Cargo   as     a_003,"
    ssql = ssql & "FROM fornecedores "
    
    rst.Open ssql, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    rst.MoveFirst
    
    Set Me.lst_teste.Recordset = rst.Clone
    
    Me.lst_teste.Selected(rst.RecordCount) = True
    Me.lst_teste.Selected(1) = True
    
    rst.Close
    Set rst = Nothing
        
    MsgBox "fim"

End Sub

;-)

Onde buscar informações e ajuda sobre o Access

Às vezes não é preciso ter um monte de links para buscar ajuda na programação do Access.
Minhas fontes de consultas são poucas, mas nesses sites quase sempre encontro o que preciso e sempre que possível, procuro ajudar também quem necessita.
Abaixo os links que estão sempre nos meus favoritos:

http://www.expertaccess.com.br/forumnew/default.asp
http://comunidade.itlab.com.br/eve
http://usandoaccess.com.br/index.htm
http://ativoaccess.com.br/
http://www.mvps.org/
http://www.accessfaq.com.br/webroot/

No mvps.org tem material para todos os aplicativos do pacote Office.

;-)

Listar arquivos de uma pasta

Não me lembro se publiquei anteriormente outra planilha com a mesma função, mas eu precisei novamente e como o prompt do DOS é bloqueado no meu trabalho, escrevi este código.
Quem puder usar o prompt, basta dar um DIR c:\pasta *.* > lista.txt e depois editar o TXT.

;-)

Option Explicit
Dim caminho         As String
Dim arquivo         As String
Dim i               As Integer
 
 
Private Sub cmd_lista_Click()
On Error GoTo erro
 
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Selecione a pasta"
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            caminho = .SelectedItems(1)
        End If
    End With
 
    Range("A:A").Clear
    Range("A1").Value = "Lista dos arquivos"
   
    arquivo = Dir(caminho & "\*.*")
   
    i = 2
    Do Until arquivo = ""
        Cells(i, 1) = arquivo
        i = i + 1
        arquivo = Dir
    Loop
   
    Worksheets("Plan1").Columns("A:A").AutoFit
   
    Range("A2").Select
    ActiveWindow.FreezePanes = True
   
    Exit Sub
   
erro:
    MsgBox Err.Description, vbOKOnly
    Exit Sub
 
 
End Sub

Criar um compromisso no Outlook

Public Function CreateAppointment(SubjectStr As String, BodyStr As String, AllDay As Boolean)
 
     Dim OlApp                  As Outlook.Application
     Dim Appt                   As Outlook.AppointmentItem
    
     Set OlApp = CreateObject("Outlook.Application")
     Set Appt = OlApp.CreateItem(olAppointmentItem)
    
     Appt.Subject = SubjectStr
     'Formato da data = mes/dia/ano
     Appt.Start = #10/20/2011 1:00:00 PM#
     Appt.End = #10/20/2011 2:00:00 PM#
     'Appt.AllDayEvent = AllDay
     Appt.Body = BodyStr
     Appt.ReminderMinutesBeforeStart = 5
     Appt.Save
    
     Set Appt = Nothing
     Set OlApp = Nothing
    
End Function
 
 
Private Sub testsub()
     CreateAppointment "Teste", "Texto", False
End SubCri

Código de barras no Office

A forma mais rápida de se gerar um código de barras é simplesmente trocar a fonte do seu número para uma fonte de barras.
Neste link, tem a fonte para o código 3 de 9, um dos mais populares e utilizados: http://www.idautomation.com/fonts/free/

Lembrando que, o caracter de abertura e fechamento de leitura é o asterisco (*), ou seja, se o se código é 123456, utilize "*123456*" (sem as aspas) e troque a fonte para IDAutomationHC39M.ttf.

A maioria dos leitores já vem habilitado para leitura desse código de barras, mas eventualmente se não vier, basta dar uma olhada no manual que lá tem as instruções para configurar o seu leitor.

Não custa lembrar que...
- Quem faz a leitura do código de barras é o leitor e não o programa, portanto, não existe código ou programa para leitura de código de barras neste caso;
- Para maior segurança, é interessante acrescentar um dígito verificador. O algoritmo mais utilizado é o famoso módulo 11, facilmente encontrado na internet.



;-)

Outlook VBA - Desanexando todos arquivos

Outro dia me deparei com uma situação diferente: ter de desanexar aproximadamente 150 arquivos/e-mails.

Adaptando um código que peguei na internet, resolvi a parada movendo todos os e-mails para uma pasta temporária, criada apenas para esta finalidade e resolvi o problema na boa.

Abaixo o código.

Option Explicit
 
Public Sub salvar_anexos()
On Error GoTo erro
 
    Dim objApp          As Outlook.Application
    Dim pasta_outlook   As Outlook.MAPIFolder
    Dim objItem         As Object
    Dim arq_anexo       As Outlook.Attachment
    Dim pasta           As String
 
    'Pasta onde serão gravados os arquivos anexos dos emails:
    pasta = "C:\Teste"
   
    Set objApp = Outlook.Application
    Set pasta_outlook = objApp.ActiveExplorer.CurrentFolder
   
    If MsgBox("Deseja desanexar todos os arquivos da pasta " & pasta_outlook.Name, vbYesNo) = vbNo Then Exit Sub
   
    For Each objItem In pasta_outlook.Items
        DoEvents
        'Se o objeto é do tipo email, começa a desanexar os arquivos
        If objItem.Class = olMail Then
            For Each arq_anexo In objItem.Attachments
                DoEvents
                arq_anexo.SaveAsFile pasta & "\" & arq_anexo.FileName
            Next arq_anexo
        End If
    Next objItem
 
    MsgBox "Processo finalizado!", vbOKOnly
   
    Exit Sub
 
erro:
    MsgBox Err.Number & " - " & Err.Description, vbOKOnly
    Exit Sub
   
End Sub

Office nas nuvens

Ainda não estou na nuvem, mas creio que se tornará inevitável...

Link do Office365 para quem quiser conhecer:

http://www.microsoft.com/pt-br/office365/what-is-office365.aspx

;-)

Coletando dados de pesquisas com o Outlook e Access

Outro dia estava procurando uma forma de fazer uma pesquisa de satisfação por e-mail e a primeira dificuldade foi justamente criar um texto que o usuário não pudesse modificar.

Apesar de não chegar no modelo que queria, acabei descobrindo um recurso do Access que facilitou muito.

O formulário final não é lá dos melhores em termos de estética, mas cumpre sua função.

Segue o link para quem quiser experimentar:

http://office.microsoft.com/pt-br/access-help/coleta-de-dados-por-meio-de-mensagens-de-email-HA010015427.aspx

;-)