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