Vitor Hugo Ataide Almeida

Se não estiver claro, posso fornecer mais detalhes.

Caros amigos, preciso de uma força para realizar uma atividade.

Preciso que o Outlook avalie se o anexo (caso exista) contém determinadas palavras, como "CONFIDENCIAL", "RESTRITO".

Caso a palavra esteja no nome do anexo o e-mail poderá ser enviado, do contrário aparece msgbox pedindo para renomear o arquivo e não permite o envio da mensagem.

Exemplo:

[CONFIDENCIAL] Anexo do Outlook  

Restrito - Anexo do Outlook

Nos dois casos acima, o outlook permitiria a mensagem.

@Basole Segue planilha, no caso, quando os endereços de email se repetirem eu gostaria que ele enviasse apenas um, mas com todos os dados das respectivas linhas que contém esse email.

Atualmente ele envia 1 email para cada linha.

Email Automatc.xlsx

Caros, estou precisando de ajuda com uma macro.

Tenho uma planilha que envia e-mails automáticos com base na linha, se em determinada coluna o valor tiver abaixo de 20% ele encaminhará um email para o endereço de email contido em determinada coluna, acontece que as vezes possuem e-mails repetidos e gostaria que ele enviasse apenas um email com a informação de todas as respectivas linhas.

Portanto preciso de uma fórmula que avalie:

Se existem valores duplicados na coluna "G"

Caso sim, copie as informações das respectivas linhas em um mesmo e-mail.

'Enviar email
Sub Enviar_email(ByVal lLogin As String, ByVal lAR As String, ByVal lInvalidas As String, ByVal lValidas As String, ByVal lTotal As String, ByVal lPorcentagem As String, ByVal lEmail As String)
    Dim enderecos As Range
    Dim celula As Range
    Dim anexo As String
    Dim r As Integer
    Dim fim
    Dim enviar
    Dim objOlAppApp As Outlook.Application
    Dim objOlAppMsg As Outlook.MailItem
    Dim objOlAppRecip As Outlook.Recipient
    Dim objOlAppRecip2 As Outlook.Recipient
    Dim objOlAppAnexo As Outlook.Attachment
    
    'Criar objeto do outlook
    Set objOlAppApp = CreateObject("Outlook.Application")
    Set objOlAppMsg = objOlAppApp.CreateItem(olMailItem)

    With objOlAppMsg
        'Email do destinatário
        Set objOlAppRecip = .Recipients.Add("[email protected]")
        objOlAppRecip.Type = olTo
        Set objOlAppRecip2 = .Recipients.Add(lEmail)
        objOlAppRecip.Type = olCC
        
        'Grau de importância do email
        .Importance = olImportanceHigh
        'Cabeçalho do email
        .Subject = "[Confidencial] Manual XXXX - " & lAR
        'Texto do email
        
        
        '        .HTMLBody = "<b>À</b> <br>" _
        & "<b>XXXX  " & lTarefa & "</b>" & "<br>" & "<br>" _
        & "<b>A/C.: Sr(a)." & lPessoa & "</b>" & "<br>" _
        & lCopy & "<br>" & "<br>" _
        & "Assunto: XXXXX" & "<br>" & "<br>" _
        & "<b>XXXXXX</b>, inscrita no CNPJ nº. 0XXX, sediada na XXX, nº 9SS4, 12º andar, São Paulo/SP, CEP 000003, expõe o quanto segue anexo." & "<br>" & "<br>" & "<br>" & "<br>" _
        & "Atenciosamente," & "<br>" _
        & "Departamento XXXXs"
        '.Attachments.Add "CAMINHO DIRETÓRIO"
        '.Display
   

    'Liberar variáveis
    Set objOlAppApp = Nothing
    Set objOlAppMsg = Nothing
    Set objOlAppAnexo = Nothing
    Set objOlAppRecip = Nothing
    Set obgOlAppRecip2 = Nothing
End Sub


'Enviar emails das pendências
Sub lsEnviarAtrasos()
    Dim iTotalLinhas    As Long
    Dim i               As Long
    Dim lHoje           As Date

    Worksheets("5W2H").Select
    Cells(2, 1).Select

    iTotalLinhas = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    i = 2
    
    While i < iTotalLinhas
        If Cells(i, 6).Value >= Range("CP2").Value Then
            Enviar_email Cells(i, 1).Value, Cells(i, 2).Value, Cells(i, 3).Value, Cells(i, 4).Value, Cells(i, 5).Value, Cells(i, 6).Value, Cells(i, 7).Value
        End If
        i = i + 1
    Wend
End Sub

'Enviar emails e fechar aplicação
Sub lsValidaEnvio()

     If MsgBox("Deseja verificar as pendências e enviar por email?", vbYesNo, "Confirmar envio de email") = vbYes Then
        lsEnviarAtrasos
        
    End If
End Sub

@Basole Muito obrigado!!! Valeu mesmo !!

Para quem precisar, o código ficou assim:

Private WithEvents seuApp As Word.Application

Private Sub Document_Open()
Set seuApp = Word.Application
With ComboBox1

.AddItem ""
.AddItem "Documento Restrito"
.AddItem "Documento Confidencial"
.AddItem "Documento Interno"
.AddItem "Documento Público"


End With
End Sub

Private Sub seuApp_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
     ' * substitua a condição abaixo para a do seu combobox
    If ComboBox1.Value = "" Then
    MsgBox ("Antes de salvar, Classifique o Documento ! As opções se encontram no rodapé")
    Cancel = True
    Else
    Cancel = False
    End If
    
End Sub

Bom dia !!

Preciso de ajuda com word, um documento que não permita salvar ou salvar como sem que a ComboBox1 esteja preenchida... Tentei procurar de tudo na net mas não me ajudou.

Segue código que encontrei até o momento.

Private Sub DocumentBeforeSave()
    Dim vstoDoc As Document
    AddHandler vstoDoc.BeforeSave, AddressOf ThisDocument_BeforeSave
End Sub

Private Sub ThisDocument_BeforeSave(ByVal sender As Object, ByVal e As Microsoft.Office.Tools.Word.SaveEventArgs)
    If System.Windows.Forms.MessageBox.Show( _
        "Do you want to save the document?", "BeforeSave", _
        System.Windows.Forms.MessageBoxButtons.YesNo) = System.Windows.Forms.DialogResult.No Then
        e.Cancel = True
    End If
End Sub

up/+

Boa tarde pessoal!

Preciso de uma ajuda, uma macro que quando eu clique em novo email ou responder email/ responder a todos Tenha um assunto Fixo por exemplo o Subject = "[ASSUNTO FIXO]"

Mas não sei qual macro utilizar obrigado

Não funcionou, no caso a combo box 7 tem a data. Tentei alterar o seu código para combo box 7 mas não mudou nada

Bom dia,

Preciso de ajuda, tenho uma planilha de cadastro com formulário. Mas ao inserir a data ela inverte o dia com o mês.

Segue código utilizado, a data fica no combo box 7

Private Sub CommandButton1_Click()
    lsInserirTextBox frmCadastro, "Cadastro", 3
    
    lsLimparTextBox frmCadastro
    
    TextBox1.SetFocus
    
    MsgBox ("OTRS Inserido com Sucesso")
End Sub

Private Sub lsInserir(ByRef lTextBox As Variant, ByVal lSheet As String, ByVal lColunaCodigo As Long, ByVal lUltimaLinha As Long)
         If (TypeOf lTextBox Is MSForms.TextBox) Or (TypeOf lTextBox Is MSForms.ComboBox) Then
        Sheets(lSheet).Range(lTextBox.Tag & lUltimaLinha).Value = lTextBox.Text
    Else
If TypeOf lTextBox Is MSForms.OptionButton Then
            If lTextBox.Value = True Then
                Sheets(lSheet).Range(lTextBox.Tag & lUltimaLinha).Value = lTextBox.Caption
            End If
        End If
    End If
End Sub

Public Function lsInserirTextBox(formulario As UserForm, ByVal lSheet As String, ByVal lColunaCodigo As Long)
    Dim controle            As Control
    Dim lUltimaLinhaAtiva   As Long
    
    lUltimaLinhaAtiva = Worksheets(lSheet).Cells(Worksheets(lSheet).Rows.Count, lColunaCodigo).End(xlUp).Row + 1
    
    For Each controle In formulario.Controls
        lsInserir controle, lSheet, lColunaCodigo, lUltimaLinhaAtiva
    Next
End Function

Public Function lsLimparTextBox(formulario As UserForm)
    Dim controle            As Control
    Dim controle2           As Control
    
    For Each controle In formulario.Controls
        If TypeOf controle Is MSForms.TextBox Then
            controle.Text = ""
        End If
        
    For Each controle2 In formulario.Controls
        If TypeOf controle2 Is MSForms.ComboBox Then
            controle2.Text = ""
        End If
        
    Next
    Next
End Function

Private Sub CommandButton2_Click()
    lsLimparTextBox frmCadastro
    
    TextBox1.SetFocus
End Sub


Private Sub TextBox1_Change()

TextBox7.Value = Date
TextBox10.Value = Date
TextBox12.Value = Date
TextBox11.Value = Time


End Sub