Manipulando a área de transferência do Windows (ClipBoard)

Requisito:
Marcar a referência "Microsoft Forms Object Library".
Se tiver um form no VBA, a referência estará automaticamente marcada.

;-)

Dim area As DataObject
Dim texto As String

Sub colar_da_area_de_transferencia()
  
   Dim temp_area As New DataObject
   temp_area.GetFromClipboard
   MsgBox temp_area.GetText
  
End Sub

Sub limpa_area_transferencia()

   Dim temp_area As New DataObject
   temp_area.SetText ""
   temp_area.PutInClipboard

End Sub

Sub copiar_para_area_de_transferencia()

   Dim temp_area As New DataObject
   temp_area.SetText "Texto"
   temp_area.PutInClipboard

End Sub

Desvio padrão em VBA

Escrito no Excel, mas facilmente adaptável aos outros aplicativos do Office.

;-)

Option Explicit
 
' variáveis para cálculo do desvio padrão
'========================================
Dim valores()      As Double
Dim desvio_padrao  As Double
Dim qtd_valores    As Integer
Dim soma           As Double
Dim soma_1         As Double
Dim i              As Integer
Dim media          As Double
'========================================

'Cálculo de desvio padrão
'Exemplo para valores na coluna A a partir de A1
'Os valores devem estar em células contíguas
'Resultado em B1
 
 
Sub calcular()
 
     qtd_valores = Range("A1").CurrentRegion.Rows.Count
     ReDim valores(qtd_valores)
 
     For i = 1 To qtd_valores
          valores(i) = Sheets("plan1").Cells(i, 1)
     Next i
    
     desvio_padrao = f_desvio_padrao(qtd_valores, valores)
     Sheets("plan1").Cells(1, 4) = "Desvio Padrão = " & desvio_padrao
 
End Sub
 
Function f_media(ByVal x As Long, valores() As Double)
    
     soma = 0
     For i = 1 To x
         soma = soma + valores(i)
     Next i
 
     f_media = soma / x
 
End Function
 
Function f_desvio_padrao(ByVal qtd_valores As Integer, valores() As Double)
 
     soma_1 = 0
     media = f_media(qtd_valores, valores)
     For i = 1 To qtd_valores
          soma_1 = soma_1 + (valores(i) - media) ^ 2
     Next i
 
     f_desvio_padrao = Sqr(soma_1 / (qtd_valores - 1))
 
End Function

Selecionar arquivo via caixa de diálogo - WORD VBA

É... de vez em quando eu faço alguma coisa no VBA do Word...

Dim fd          As FileDialog
dim arquivo  As String

Private Sub Abrir()
    
  Set fd = Application.FileDialog(msoFileDialogFilePicker)
  If fd.Show = -1 Then
      arquivo = fd.SelectedItems(1)
      MsgBox "O arquivo selecionado é " & arquivo
  Else
      arquivo = ""
      Exit Sub
  End If
  Set fd = Nothing

End Sub

;-)

Inserindo assinatura no Outlook - VBA

Ultimamente o Outlook tem sido o "alvo" das minhas necessidades de automatização...
Segue código para inserir assinatura numa mensagem criada via VBA.
Detalhe importante: o formato do e-mail deve ser HTML.

;-)

Option Explicit
Dim assinatura As Variant
 
Public Function pega_assinatura(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    pega_assinatura = ts.readall
    ts.Close
End Function
 
Sub Cria_mensagem_HTML()
'Creates a new e-mail item and modifies its properties.
 
    Dim olapp As Outlook.Application
    Dim objMail As MailItem
    Set olapp = Outlook.Application
    'Create mail item
    Set objMail = olapp.CreateItem(olMailItem)
   
    assinatura = pega_assinatura("C:\Documents and Settings\" & _
  Environ("username") & "\AppData\Roaming\Microsoft\Assinaturas\Paulo.htm")
 
    With objMail
       'Set body format to HTML
       'a tag 
 quebra linha
       'a tag  formata o texto para negrito
       .BodyFormat = olFormatHTML
       .HTMLBody = "Texto " & assinatura
       .Display
    End With
 
End Sub

Navegando num formulário contínuo do Access...

... com a mesma facilidade do Excel.
Este código é de autoria do Jaques Zetune da ForumAccess.
Estou deixando aqui mais para consultas, pois as vezes eu preciso e não tenho à mão.
Não esquecer de colocar um checkbox com o nome chkNavegLoop, valor padrão 1.


;-)

Option Explicit

Const cDataSheet = 2, cContinuous = 1

Private Sub Form_Load()
    Me.KeyPreview = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    DoKeys Me, KeyCode, Shift
End Sub

Public Sub DoKeys(wForm As Form, KeyCode As Integer, Shift As Integer)
    Dim wCtl As Control, wIgnore As Integer
    'a tecla Shift está pressionada ?
    If Shift <> 0 Then Exit Sub
    'o formulário está sendo visualizado em modo contínuo?
    If wForm.CurrentView <> cDataSheet And wForm.DefaultView <> cContinuous Then Exit Sub

On Error Resume Next

    Set wCtl = Screen.ActiveControl
    'testa o comportamento da tecla Enter no controle
    wIgnore = (wCtl.EnterKeyBehavior <> 0)
    'verifica se a barra de rolagem está ativada If Not wIgnore Then wIgnore = (wCtl.ScrollBars <> 0)
    'verifica se o controle em questão está com o texto “Ignore Setas” na propriedade Tag
    'indicando que a intercepção de teclas deve ser ignorada no mesmo
    If Not wIgnore Then wIgnore = (InStr(wCtl.Tag, "Ignore Setas") > 0)
    If wIgnore Then Exit Sub
    'sincroniza o registro corrente do formulário com o seu RecordsetClone
    Me.RecordsetClone.Bookmark = Me.Bookmark
    
    Select Case KeyCode
        Case vbKeyDown
            If Me.RecordsetClone.AbsolutePosition + 1 = Me.RecordsetClone.RecordCount And Me!chkNavegLoop Then
            'tentou ir além do topo e a navegação em loop está ativa
                DoCmd.GoToRecord , , acFirst
            Else
                DoCmd.GoToRecord , , acNext
            End If
            KeyCode = 0
        Case vbKeyUp
            If Me.RecordsetClone.AbsolutePosition = 0 And Me!chkNavegLoop Then
            'tentou ir além do final e a navegação em loop está ativa
                DoCmd.GoToRecord , , acLast
            Else
                DoCmd.GoToRecord , , acPrevious
            End If
            KeyCode = 0
    End Select
End Sub

Ajustar um UserForm para o tamanho da tela

E também não deixar o usuário clicar no "X" para fechar o UserForm.
Muito bom para quem gosta de mexer na interface do Excel via VBA, assim é possível voltar todas as configurações colocando o código no botão SAIR.

;-)

Private Sub CommandButton2_Click()
     Application.WindowState = xlMaximized
     Me.Height = Application.Height
     Me.Width = Application.Width
     Me.Left = Application.Left
     Me.Top = Application.Top
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Cancel = True
    MsgBox "clicar no botão sair!!!"
End Sub

Executar um processo quando o e-mail chegar

Esta é bem interessante: toda vez que chegar um e-mail com um determinado título, executar um processo.
Vamos usar como título, "executa_processo".
Assim, caso eu queira disparar um processo, basta que o meu computador esteja ligado e o Outlook aberto. Quando chegar uma mensagem com o título acima, o processo "minha_rotina" é executado.

;-)

Evento new_mail:
 
Private Sub Application_NewMail()   
   Call Procura   
End Sub
 
 
Sub Procura()
    'Procura mensagem na caixa de entrada
    'Critério: Assunto da mensagem
   
    Dim mySearch        As Search
    Dim myResults       As Results
    Dim intCounter      As Integer
    Dim strMessages     As String
 
    Set mySearch = AdvancedSearch(Scope:="Inbox", Filter:="urn:schemas:mailheader:subject = 'executa_processo'")
    Set myResults = mySearch.Results
    If myResults.Count > 0 Then
        Call minha_rotina
    Else
        Exit Sub
    End If
       
  
End Sub

Copiar informações de um e-mail no Outlook - VBA

Vou deixar registrado aqui vários trechos de códigos em VBA, para facilitar a consulta. Afinal, basta ter uma conexão com a internet, certo?
Segue abaixo, um exemplo para copiar dados de um e-mail selecionado no Outlook para qualquer outro aplicativo Office.
Detalhes:
- Referenciar o Outlook no projeto VBA;
- O e-mail precisa estar selecionado na caixa de entrada (para este exemplo).

;-)

 
Option Explicit
 
Dim oApp As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oWindow As Object
Dim omail As Outlook.MailItem
 
Private Sub Comando12_Click()
 
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oWindow = oApp.ActiveWindow
    Set omail = oApp.ActiveExplorer.Selection.Item(1)
   
    txt_remetente = omail.SenderName  'Remetente
    txt_cc = omail.CC         'Com cópia
    txt_assunto = omail.Subject    'Assunto
    txt_mensagem = omail.Body        'Mensagem
    txt_para = omail.To          'Destinatário
    txt_data = omail.ReceivedTime
   
End Sub