Merge do Word pelo Access abrindo em um novo documento

Neste post, gostaria de dividir uma das minhas grandes dificuldades em pesquisas pela Internet, que é abrir um documento Word com Mala Direta viculada ao Access e salvar em um novo documento com um novo nome. Depois de muita pesquisa eu finalmente consegui chegar uma solução misturando dois codigos que encontrei em um Forum Americano. Segue abaixo:


Sub MailMerge2()
    Dim wd As Object
    Dim wdocSource As Object
 
    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    If wd Is Nothing Then
        Set wd = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    Set wdocSource = wd.Documents.Open("C:\temp\Teste.doc") 'abre o documento onde tem a mala direta
    wdocSource.MailMerge.MainDocumentType = wdFormLetters
'vincula a Banco de Dados e Tabela com o documento
    wdocSource.MailMerge.OpenDataSource _
        Name:="C:\controleboletas\Teste.mdb", _
        LinkToSource:=True, AddToRecentFiles:=False, _
        Connection:="QUERY qryLabelQuery", _
        SQLStatement:="SELECT * FROM [TblTeste]"
 'mescla os dados e cria um novo documento
    With wdocSource.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = 1
            .LastRecord = 1
        End With
        .Execute Pause:=False
    End With
   
    'salva o novo documento com um novo nome
    Arquivo = "TesteNovoDoc"
    wd.ActiveDocument.SaveAs ("C:\temp\" & Arquivo & ".doc")
    wd.Visible = False
    wdocSource.Close SaveChanges:=False
 
    'abre o novo arquivo
    Set wdocSource = wd.Documents.Open("C:\temp\" & Arquivo & ".doc")
    wd.Visible = True
   
   
    Set wdocSource = Nothing
    Set wd = Nothing
   
End Sub

Tratar Nome de Arquivo

Caros colegas, este um código muito usado quando temos que tratar o nome de um determinado arquivo antes de salva-lo:


Function trata_nome(NOME As String) As String

Dim Data As String
Dim TotalCampo As Double
Dim CampoAtu As Double
Dim ProvAtu As String
Dim y As String

TotalCampo = Len(NOME) 'verifica a qtde de caracteres de um campo
CampoAtu = 1

Do While Not TotalCampo = CampoAtu
  
   ProvAtu = Trim(Mid(NOME, CampoAtu, 1))
  
   If ProvAtu = "/" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "_" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "Ç" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "C" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "ç" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "C" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "Ã" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "A" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "ã" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "a" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "Õ" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "O" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "õ" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "o" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "É" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "E" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "È" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "E" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "é" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "e" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "è" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "e" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "À" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "A" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
  
   ElseIf ProvAtu = "Á" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "A" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "á" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "a" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "à" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "a" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "Ó" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "O" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "Ò" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "O" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "ó" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "o" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   ElseIf ProvAtu = "ò" Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & "o" & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   
   ElseIf ProvAtu = "." Then
  
   NOME = Trim(Mid(NOME, 1, CampoAtu - 1)) & Trim(Mid(NOME, CampoAtu + 1, TotalCampo))
  
   
  
   End If
  
   CampoAtu = CampoAtu + 1
 
Loop

 trata_nome = NOME
End Function

Extenso no VBA

Este é um código que não é de minha autoria, mas sempre me foi muito util, consiste em transformar um numero no extenso do mesmo, fiz algumas pequenas mudanças que deixaram o código um pouco melhor e mais limpo. Espero que seja util para vocês tambem.

Clique aqui e baixe o exemplo:

____________________________________________

Public Function Extenso2008(nValor As String) As String

'Modificado: Osmar Bonfim


'Faz a validação do argumento
If IsNull(nValor) Or nValor > 999999999.99 Then Exit Function

'Declara as variáveis da função
Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String

'Define matrizes com extensos parciais
Dim strUnid(19) As String
strUnid(1) = "um ": strUnid(2) = "dois ": strUnid(3) = "três ": strUnid(4) = "quatro ": strUnid(5) = "cinco ": strUnid(6) = "seis ": strUnid(7) = "sete ": strUnid(8) = "oito ": strUnid(9) = "nove ": strUnid(10) = "dez ": strUnid(11) = "onze ": strUnid(12) = "doze ": strUnid(13) = "treze ": strUnid(14) = "quatorze ": strUnid(15) = "quinze ": strUnid(16) = "dezesseis ": strUnid(17) = "dezessete ": strUnid(18) = "dezoito ": strUnid(19) = "dezenove "
Dim strDezena(9) As String
strDezena(1) = "dez ": strDezena(2) = "vinte ": strDezena(3) = "trinta ": strDezena(4) = "quarenta ": strDezena(5) = "cinqüenta ": strDezena(6) = "sessenta ": strDezena(7) = "setenta ": strDezena(8) = "oitenta ": strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) = "cento ": strCentena(2) = "duzentos ": strCentena(3) = "trezentos ": strCentena(4) = "quatrocentos ": strCentena(5) = "quinhentos ": strCentena(6) = "seiscentos ": strCentena(7) = "setecentos ": strCentena(8) = "oitocentos ": strCentena(9) = "novecentos "

'Divide o valor em vários grupos
strValor = Format$(nValor, "0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo

'Processa cada grupo
For intContador = 1 To 4
strParte = strGrupo(intContador)

intTamanho = Switch(Val(strParte) < inttamanho =" 3"> "00" Then
strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
End If
End If

If intTamanho = 2 Then
If Val(Right(strParte, 2)) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If

If intTamanho = 1 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
End If
Next intContador

'Gera o formato final do texto
If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil, ", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
Else
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Left(strFinal, 1) = "u" Then
Extenso2008 = "H" & Mid$(strFinal, 1)
Else
Extenso2008 = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
End If


End Function

______________________________________________

Somar Horas no Access pelo VBA

Uma das coisas que mais me perguntam é como somar horas em um formulário no Access, como sabem se você simplemente pedir para somar um campo a outro ele trará um resultado incorreto, mas neste exemplo abaixo a idéia é converte as horas em numeros, soma-las e o resultado voltar a converte-los em horas.

Segue abaixo duas funções, uma para converter horas em numeros e a outra para converter numero em horas.

Clique aqui e baixe um exemplo


_________________________________________________
Public Function HrStr(dblHora As Double) As String
'Pega um valor numérico e o converte para Horas/Minutos
'Ex: 123,5 = "123:30"
'Ex: 23,9833333333333 = "23:59"

Dim strHoras As String
Dim strMinutos As String

'Pega as horas (parte inteira)
strHoras = CStr(Fix(dblHora))

'Pega os minutos
strMinutos = Format$(Abs((dblHora - Fix(dblHora)) * 60), "00")

'Verifica se o total de minutos é 60
If strMinutos = "60" Then
strMinutos = "00"
strHoras = CStr(CDbl(strHoras) + 1)
End If

'Concatena os dois
HrStr = strHoras & ":" & strMinutos

End Function

'Esta outra função faz o contrário: pega um string no formato de horas e converte para número:

Public Function HrDbl(stHora As String) As Double
'Converte um string de hora (formato (h)hh:mm) para Double
'Ex: "135:30" = 135,5
'Ex: "23:59" = 23,9833333333333
Dim dblHoras As Double
Dim intMinutos As Integer
Dim blnDoisPontos As Boolean, blnNum As Boolean
Dim strNum As String

'Verifica se o sinal de dois pontos ':' está na terceira casa
'da direita para esquerda
If Asc(Left(Right(stHora, 3), 1)) = 58 Then
blnDoisPontos = True
Else
blnDoisPontos = False
End If

'Verifica se o resto dos dígitos são numéricos
strNum = Left(stHora, Len(stHora) - 3) & Right(stHora, 2)
If IsNumeric(strNum) = True Then
blnNum = True
Else
blnNum = False
End If

'Sai do procedimento se o formato estiver incorreto
If (blnDoisPontos = False) Or (blnNum = False) Then
MsgBox "Informe a hora no formato hh:mm", vbCritical + vbOKOnly
Exit Function
End If

'Pega os minutos
If CDbl(strNum) < 0 Then

intMinutos = CInt(Right(strNum, 2)) * (-1) Else intMinutos = CInt(Right(strNum, 2))

End If

'Pega as horas

dblHoras = Fix(CDbl(Left(strNum, Len(strNum) - 2)))

'Calcula a hora

HrDbl = dblHoras + (intMinutos / 60)


End Function

Começando o Blog

Resolvi criar este blog para dividir com todos tudo que aprendi com relação a Access e VBA nestes muitos anos que trabalho com estas ferramentas, percebi que o que é mais difícil é conseguir bons tutoriais e informações claras, é nossa obrigação espalhar o que aprendemos, espero que gostem e venho muitas vezes visitar o meu blog, pois aqui encontraram muita coisa útil.