Muca Costa

Tente assim: NO FORM INICIAL Private Sub Form_Open(Cancel As Integer) Me.Refresh DoCmd.Restore DoCmd.ShowToolbar "ribbon", acToolbarNo End Sub PARA VOLTAR DoCmd.ShowToolbar "ribbon", acToolbarYes

Se puder anexar um exemplo do seu projeto, seria melhor para ajuda-lo...

Veja se é isso: Considerando que a caixa de texto é vg: If Me.vg = "vaga001" Then Me.vaga001.BackColor = vbRed Else Me.vaga001.BackColor = vbWhite End If

Tente assim: Dim olitem As Object Dim lrow As Integer Dim olattach As Object Dim str As String Const num As Integer = 6 Const path As String = "D:\Documents\Excel\Email\Outlook\AnexosMsg\Anexos\" 'Salva os anexos (CRIE ESSA PASTA) Const emailpath As String = "D:\Documents\Excel\Email\Outlook\AnexosMsg\Msg\" 'Salva os Email's (CRIE ESSA PASTA) Const olFolderInbox As Integer = 6 Set olp = CreateObject("Outlook.application") Set olmapi = olp.getnamespace("MAPI") Set olmail = olmapi.getdefaultfolder(num) If olmail.items.restrict("[UNREAD]=True").Count = 0 Then MsgBox ("Nenhum e-mail não lido") Else For Each olitem In olmail.items.restrict("[UNREAD]=True") lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1 Range("A" & lrow).Value = olitem.Subject Range("B" & lrow).Value = olitem.senderemailaddress Range("C" & lrow).Value = olitem.to Range("D" & lrow).Value = olitem.cc Range("E" & lrow).Value = olitem.body If olitem.attachments.Count <> 0 Then For Each olattach In olitem.attachments If Left(olattach.Filename, 5) = "teste" Then 'Busca o nome comum dos anexos, neste exemplo a palávra teste tem 5 caracteres olattach.SaveAsFile path & olattach.Filename & " - " & Format(Date, "MM-dd-yyyy") End If Next olattach End If str = olitem.Subject str = Replace(str, "/", "-") str = Replace(str, "|", "_") Debug.Print str olitem.SaveAs (emailpath & str & ".msg") olitem.unread = False DoEvents olitem.Save Next olitem End If ActiveSheet.Rows.WrapText = False MsgBox "Fim" End Sub

Veja o anexo e faça as adaptações necessárias às suas necessidades... BaixarAnexosMsg.rar

Dúvidas sem uma planilha anexada, fica complicado lhe ajudar...

Tente assim: Sub MessageBoxTimer() Dim AckTime As Integer, InfoBox As Object Set InfoBox = CreateObject("WScript.Shell") 'Configure a caixa de mensagem para fechar após 10 segundos AckTime = 10 Select Case InfoBox.Popup("Click OK (Se não clicar em OK, a planilha janela fecha automaticamente após 10 segundos).", _ AckTime, "© Muca Sistemas - 2021", 0) Case 1 Exit Sub Case -1 Application.ThisWorkbook.Save Application.Quit End Select End Sub

Veja o anexo, proposta em PDF... MalaDiretaFiltro.rar

Mais uma tentativa: Abra o Outlook Alt + F11 Inserir Módulo Insira a macro abaixo Crie uma pasta para EXTRAIR os email"s, por exemplo Email Execute a macro no Outlook A macro cria txt com nome EmailRemetente+DataEmissão e exclui(para lixeira) os email's Finalize o processo clicando no botão "Extrair" da planilha anexada... Ao final os arquivos txt serão excluídos do diretório Email Sub fncMensagens() 'Execute esta macro no Outlook, Altere o caminho abaixo Const cstrOutput As String = "D:\Downloads\Email\Relatório.txt" ' só mude o diretório, não mude o nome Relatório.txt Dim intFF As Integer Dim mli As MailItem Dim rcp As Recipient Dim ctt As ContactItem Dim nms As NameSpace Dim objAllItems As Outlook.Items Dim objFilteredItems As Outlook.Items Dim objItem As Object Dim strCriteria As String Dim strDepartament As String Dim strOfficeLocation As String Dim Dir As String Dir = "D:\Downloads\Email\" 'Altere o caminho Set nms = Application.GetNamespace("MAPI") 'Altere as pastas abaixo para como está configurado seu e-mail: Set objAllItems = nms.Folders("[email protected]").Folders("Notas Fiscais").Items intFF = FreeFile For Each objItem In objAllItems Open "D:\Downloads\Relatório.txt" For Output As #intFF If TypeName(objItem) = "MailItem" Then Set mli = objItem Print #intFF, "Título: " & mli.Subject Print #intFF, "Remetente: " & mli.SenderEmailAddress Print #intFF, "Data Envio: " & mli.SentOn Print #intFF, "MENSAGEM: " Print #intFF, mli.Body Print #intFF, "" Close #intFF NomeAntigo = "D:\Downloads\Email\Relatório.txt" NovoNome = Dir & mli.SenderEmailAddress & "-" & Format(mli.SentOn, "d.m.yyyy hh.mm.ss ") & ".txt" Name NomeAntigo As NovoNome objItem.Delete End If Next objItem Close #intFF End Sub OutlookTxtParaExcel.rar

Abra o Outlook Alt + F11 Inserir Módulo Insira a macro abaixo Modo de usar: abra um e-mail(dois click's) do Outlook e em seguida execute a macro no Outlook Dim mmli As MailItem Sub fncExport2Excel() Dim inp As Inspector Dim appExcel As Object Dim wks As Object Dim xExcelFile As String Dim xNextEmptyRow As String Set mmli = Nothing On Error Resume Next xExcelFile = "D:\Downloads\EmailsOutlook.xlsx" 'Mude para a pasta onde consta a planilha Excel(em anexo) Set mmli = ActiveInspector.CurrentItem If mmli Is Nothing Then MsgBox "Abra o e-mail que deseja extrair os dados.", vbCritical GoTo Fim End If Set appExcel = GetObject(, "Excel.Application") On Error GoTo 0 If appExcel Is Nothing Then Set appExcel = CreateObject("Excel.Application") End If appExcel.Visible = True Set wks = appExcel.Workbooks.Open(xExcelFile) Set wks = wks.Sheets(1) xNextEmptyRow = wks.Range("E1") wks.Range("A" & xNextEmptyRow) = fncGetInfo("NFS-e No. ") wks.Range("B" & xNextEmptyRow) = fncGetInfo("Razão Social: ") wks.Range("C" & xNextEmptyRow) = fncGetInfo("E-mail: ") wks.Range("D" & xNextEmptyRow) = fncGetInfo("CNPJ: ") Fim: End Sub Function fncGetInfo(str As String) As String Dim lngStart As Long Dim lngEnd As Long Dim strBody As String strBody = mmli.Body lngStart = InStr(strBody, str) lngEnd = InStr(lngStart + 1, strBody, vbNewLine) fncGetInfo = Mid(strBody, lngStart, lngEnd - lngStart + 1) End Function EmailsOutlook.xlsx

Se possível, envie, para análise, os arquivos outlook.

Esse exemplo tem o texto base na própria planilha; gerando PDF's ... GerarMala.rar

Tente adaptar o anexo às suas necessidades... Planilha_Exemplo.rar

Veja isso:

É isso mesmo! Sub Preencher() Range("E2:F2").Select Selection.AutoFill Destination:=Range("E2:F" & Planilha1.Cells(Rows.Count, "D").End(xlUp).Row) Range("E2:F" & Planilha1.Cells(Rows.Count, "D").End(xlUp).Row).Select Range("E1").Select End Sub