Preenchendo tabela no Word com VBA

Automatizar tarefas no Word não é algo muito comum, desde que comecei a programar no Office, vi muito pouca coisa nesse sentido.
Para registro, vou postar alguns códigos para que sirva de aprendizado para quem está começando e para consultas aos que já utilizaram e esquecem de vez em quando (como eu...).
Abaixo 3 formas de se referenciar células de uma tabela no Word, lembrando que o uso de tabelas é muito útil principalmente em documentos que devem ser preenchidos como contratos, recibos, etc.


;-)

Option Explicit

Sub PreencheCelula()

    ActiveDocument.Tables(1).Rows(1).Cells(2).Range.Text = "Linha 1, coluna 2"
    
    ActiveDocument.Tables(1).Cell(2, 2).Range.Text = "Linha 2, coluna 2"

    ActiveDocument.Tables(1).Columns(2).Cells(3).Range.Text = "Linha 3, coluna 2"

End Sub

Cálculo de dígito verificador - módulo 10

O código do módulo 11 está perdido em algum lugar no blog, vou deixar aqui o cálculo do módulo 10.

;-)

Public Function modulo_10(sOrigem As String) As String
' Função para cálculo do dígito de auto conferência
    Dim iK          As Integer ' Contador
    Dim iValor      As Integer ' Variável para acumular valor
    Dim iDigito     As Integer ' Variável para o conteúdo de cada posição
 
    iValor = 0
    For iK = Len(sOrigem) To 1 Step -2      ' Inicia o laço começando da direita para a esquerda pulando 2 posições
        iDigito = (Val(sOrigem) \ (10 ^ (Len(sOrigem) - iK))) Mod 10
       
        If (iDigito * 2) >= 10 Then ' Se a multiplicação for maior ou igual a dez, soma-se os dígitos separadamente
            iValor = iValor + (((iDigito * 2) \ 10) + (iDigito * 2) Mod 10)
        Else ' Senão, multiplica-se e soma-se ao total
            iValor = iValor + (iDigito * 2)
        End If
       
        If (iK - 1) <= Len(sOrigem) Then
            ' Se não ultrapassar otamanho da string, soma-se ao total
            iDigito = (Val(sOrigem) \ (10 ^ (Len(sOrigem) - (iK - 1)))) Mod 10
            iValor = iValor + iDigito
        End If
    Next iK
 
    modulo_10 = Trim(Str((10 - IIf((iValor Mod 10) = 0, 10, (iValor Mod 10)))))
    ' Retorna o DAC
End Function

Como deixar o Google Maps mais rápido

As vezes o Google Maps fica irritantemente lento e para isso segue uma dica.
No link do Maps, acrescente uma vírgula e "force=lite" conforme abaixo:

https://www.google.com.br/maps/@-23.5679681,-46.5403448,15z?hl=pt-BR,force=lite

Obviamente que os cuidados básicos devem ser tomados como limpeza de arquivos temporários, cookies, etc.

;-)

Somente números numa caixa de texto

Método para não permitir a digitação de caracteres não numéricos numa caixa de texto:

Private Sub Texto1_KeyPress(KeyAscii As Integer)

    If InStr(1, "0123456789" & vbKeyDelete & Chr(8), Chr(KeyAscii)) = 0 Then
    KeyAscii = 0
    End If

End Sub

;-)

Extraindo só números de uma célula da planilha

Deve haver dezenas de maneiras diferentes de fazer, vou deixar registrada aqui uma delas.

;-)

Public Function fn_SoNumeros(texto As String) As Double

    Dim i As Integer
    Dim valor As String
    
    Application.Volatile
    
    'Loop de 1 a quantidade de caracteres da célula
    For i = 1 To Len(texto)
        
        'Se caracter for numérico, concatena na string
        If IsNumeric(Mid(texto, i, 1)) Then valor = valor & Mid(texto, i, 1)
    
    Next
    
    fn_SoNumeros = valor

End Function

Listar e-mails numa tabela do Access

As vezes a gente precisa de coisas diferentes e a necessidade acaba gerando códigos novos: como listar os e-mails numa tabela (com pouca adaptação, poderia ser uma planilha do Excel).

;-)

Sub Listar_emails_Access()
   
    Dim rst                 As New ADODB.Recordset
    Dim cnn                 As New ADODB.Connection
   
    Dim contador_itens      As Integer
    Dim nms                 As Outlook.NameSpace
    Dim fld                 As Outlook.MAPIFolder
    Dim itm                 As Object

    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
   
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & "C:Base.accdb"
   
    rst.Open "Tabela1", cnn, adOpenKeyset, adLockOptimistic
      
    contador_itens = fld.Items.Count

    For Each itm In fld.Items
        If itm.Class = olMail Then
            rst.AddNew
            rst!titulo = itm.Subject
            rst!Data = itm.ReceivedTime
            rst.Update
        End If
    Next itm
   
    rst.Close
    cnn.Close
   
    MsgBox "Fim"
 
End Subv