Sub SalveTodosAnexos (objitem As MailItem)Dim objMessage As ObjectDim objHighlighted As Outlook.ItemsDim objAttachments As Outlook.AttachmentsDim strName, strLocation As StringDim dblCount, dblLoop As Double' If you are using this code you will need to edit this' line so that it matches the location within outlook' of the folder you intend to scan' NOTE!! Only edit the "Personal Folders\Processing..."
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Set fld = GetFolder("Personal Folders\Processing...")''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Set objHighlighted = fld.Items ' Tell it what to scan' This is the location of the folder I want to save my attachments to' You will most likely need to edit this to match the location of' the folder you intend to save your attachments in.' NOTE! Only edit C:\Documents and Settings\Administrator\Desktop\macro\''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Let strLocation = "C:\Documents and Settings\Administrator\Desktop\macro\"''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''On Error GoTo ExitSub' Check each selected item for attachments.' If attachments exist, save them to the Macro' folder on the Desktop.For Each objMessage In objHighlighted ' For each email in the folderIf objMessage.Class = olMail Then ' ONLY scan emails!!Set objAttachments = objMessage.Attachments' Now to set my loop to the amount of attachments' on the current email the script is processing.Let dblCount = objAttachments.CountIf dblCount <= 0 Then GoTo 100 ' If no attachments exsist' go to the next email.' I know this part looks weird...But If I counted' upwards, the script was not recognizing every' email and was skipping like half of them. By' counting downwards, this problem is resolved.' Thanks to Slovaktech.com for solving this one.For dblLoop = dblCount To 1 Step -1' This will be appended to the file name of each attachment to insure' that there are no duplicates, and therefor nothing gets overwrittenLet strID = " from " & Format(Date, "mm-dd-yy") 'Append the DateLet strID = strID & " at " & Format(Time, "hh`mm`ss AMPM") 'Append the Time' These lines are going to retrieve the name of the' attachment, attach the strID to it to insure it is' a unique name, and then insure that the file' extension is appended to the end of the file name.Let strName = objAttachments.Item(dblLoop).FileName 'Get attachment nameLet strExt = Right$(strName, 4) 'Store file ExtensionLet strName = Left$(strName, Len(strName) - 4) 'Remove file ExtensionLet strName = strName & strID & strExt 'Reattach Extension' Tell the script where to save it and' what to call itLet strName = strLocation & strName 'Put it all together' Save the attachment as a file.objAttachments.Item(dblLoop).SaveAsFile strName 'Save the attachment' This next line DELETES the email completly.' If you do not wish to delete the email' change this line to read objMessage.Save'''''''''''''''''''objMessage.Delete'''''''''''''''''''' This section of code is optional. It puts a 1 second' delay between file saves so that my strID is unique' for EVERY file. I do this because the script does' not confirm overwrites and this would be an issue for' the client I am writing this for. If this is not an' issue for you, just delete the entire section or' simply comment it out.''''''''''''''''''''''''''''''''''''''''Dim PauseTime, Start, Finish, TotalTimeLet PauseTime = 1Let Start = TimerDo While Timer < Start + PauseTimeLoopLet Finish = Timer''''''''''''''''''''''''''''''''''''''''Next dblLoopEnd IfNextExitSub:Set objAttachments = NothingSet objMessage = NothingSet objHighlighted = NothingSet objOutlook = NothingEnd Sub' This entire section of code was provided to me by Sue.' This is NOT my work and I am NOT taking credit for it.'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Function GetFolder(FolderPath)' folder path needs to be something like' "Public Folders\All Public Folders\Company\Sales"Dim aFoldersDim fldrDim iDim objNSOn Error Resume Next
Let strFolderPath = Replace(FolderPath, "/", "\")Let aFolders = Split(FolderPath, "\")'get the Outlook objects' use intrinsic Application object in form scriptSet objNS = Application.GetNamespace("MAPI")'set the root folderSet fldr = objNS.Folders(aFolders(0))'loop through the array to get the subfolder'loop is skipped when there is only one element in the arrayFor i = 1 To UBound(aFolders)Set fldr = fldr.Folders(aFolders(i))'check for errorsIf Err <> 0 Then Exit FunctionNextSet GetFolder = fldr' dereference objectsSet objNS = NothingEnd Function
Conheça também:
Série Piece of Cake
- PIECE OF CAKE - MS Excel - Zipando - Compacte no formato Zip
- PIECE OF CAKE - MS Excel - Zipando - Escolha os Arquivos a Compactar
- PIECE OF CAKE - MS Excel - Zipando - Escolha uma Pasta e Compacte
- PIECE OF CAKE - MS Excel - Zipando - Compacte Todos os Arquivos da Pasta
- PIECE OF CAKE - MS Excel - Zipando - Compacte a Planilha Atual
- PIECE OF CAKE - MS Excel - Zipando - Compacte e Envie por e-Mail
- PIECE OF CAKE - Connecting to Oracle 12g with Excel VBA
- PIECE OF CAKE - Extract Path From String
- PIECE OF CAKE - Detecta se Arquivo Existe
- PIECE OF CAKE - MS Excel - Finding Last Row
- PIECE OF CAKE - Obtendo Endereço IP
- PIECE OF CAKE - Criando Arquivo Texto Externo
- PIECE OF CAKE - Criando Tabelas no SQL Server a partir do MS Excel
- PIECE OF CAKE - Notação Húngara
- PIECE OF CAKE - Usando Stored Procedures
- PIECE OF CAKE - Microsoft Access - Removendo Prefixo das Tabelas
- PIECE OF CAKE - MS Access e MS Word - Técnica de Automação
- PIECE OF CAKE - MS Access - 5 Formas Manuais de Reparo
- PIECE OF CAKE - Correção de Métricas
- PIECE OF CAKE - Convertendo Texto em Imagem
- PIECE OF CAKE - Excel - Manipule o Google Maps em sua Planilha
- PIECE OF CAKE - VBA Excel - Traduzindo Planilhas - Google Translate API
- PIECE OF CAKE - Defina a Latitude e a Longitude
Séries Donut
- DONUT PROJECT 2018 - VBA - 12 - Aumente sua Produtividade
- DONUT PROJECT 2018 - VBA - 11 - Os Benefícios do Controle de Versão
- DONUT PROJECT 2018 - VBA - 10 - Loop For-Each
- DONUT PROJECT 2018 - VBA - 09 - Método Count
- DONUT PROJECT 2018 - VBA - 08 - Referenciando Ranges
- DONUT PROJECT 2018 - VBA - 07 - Amostra de Macro
- DONUT PROJECT 2018 - VBA - 06 - Recursos Adicionais
- DONUT PROJECT 2018 - VBA - 05 - Gravando a Primeira Macro
- DONUT PROJECT 2018 - VBA - 04 - Opções de Solução
- DONUT PROJECT 2018 - VBA - 03 - Requisitos e Preparação
- DONUT PROJECT 2018 - VBA - 02 - Continua Cético
- DONUT PROJECT 2018 - VBA - 01 - Maximizando Sua Eficiência
- DONUT PROJECT 2018 - Excel - Gravando Macro Altere SELECT por RANGE
- DONUT PROJECT 2018 - O que Desenvolvedores Aprendem com Michael Jordan
- DONUT PROJECT 2018 - Excel - Macros - Mudando o Mindset
- DONUT PROJECT 2018 - Excel - Acelerando Macros
- DONUT PROJECT 2015 - Extraindo e-Mails
- DONUT PROJECT 2015 - Função - Extraindo Elementos da String
- DONUT PROJECT 2015 - Função - Retornando Nº de ocorrências de um Caractere
- DONUT PROJECT 2015 - Função - Retorna Conteúdo Delimitado por 2 Caracteres
- DONUT PROJECT 2015 - Função - Retorna Apenas o Conteúdo Entre Parênteses
- DONUT PROJECT 2015 - Função - Extrai Conteúdo entre Parênteses
- DONUT PROJECT 2015 - Excel - Report Layout
- DONUT PROJECT 2015 - Excel - Grand Totals - Inserindo Totais na Tabela Dinâmica
- DONUT PROJECT 2015 - Excel - Mudando a Fonte de Dados da Tabela Dinâmica
- DONUT PROJECT 2015 - Excel - Aplicando Refresh em Tabelas Dinâmicas
- DONUT PROJECT 2015 - Como Manter Informações parcialmente Anônimas
- DONUT PROJECT 2015 - Excel - Limpando o Filtro da Tabela Dinâmica
- DONUT PROJECT 2015 - Excel - Criando Filtros Múltiplos na Tabela Dinâmica
- DONUT PROJECT 2015 - Excel - Criando Filtro de Relatório na Tabela Dinâmica
- DONUT PROJECT 2015 - Excel - Remover Campos Calculados da Tabela Dinâmica
- DONUT PROJECT 2015 - Excel - Remover Campos da Tabela Dinâmica
- DONUT PROJECT 2015 - Excel - Adicionar Campos Calculados na Tabela Dinâmica
- DONUT PROJECT 2015 - Excel - Apagar todas as Tabelas Dinâmicas
- DONUT PROJECT 2015 - Excel - Apagar Tabela Dinâmica Específica
- DONUT PROJECT 2015 - Adicionar Rodapé de Confidencialidade no Office
- DONUT PROJECT 2015 - Excel - Criando uma Tabela Dinâmica
- DONUT PROJECT - Use os add-ins do MS Excel e dê um salto em sua performance
- DONUT PROJECT - VBA - Automatize o Outlook para enviar um e-mail com anexo
- DONUT PROJECT - VBA - Outlook - Salvando arquivos anexados nos e-mails
- DONUT PROJECT - VBA - Criando uma Matriz de Datas MAT - Moving Annual Total
- DONUT PROJECT - VBA - Excel - Atualize Tabelas Dinâmicas
- DONUT PROJECT - VBA - Excel - Removendo os Caracteres Alfabéticos e Especiais
- DONUT PROJECT 2014 - VBA - Access - Criando uma Query com Parâmetros
- DONUT PROJECT 2014 - VBA - Access - Atualizando o conteúdo de uma Query
- DONUT PROJECT - VBA - Access - Saiba o Número de Registro de cada tabela
- DONUT PROJECT - VBA - Access - Extraia Dados sem Problemas de TIMEOUT
- DONUT PROJECT - VBA - Access - Lista o Tamanho de Todas as Tabelas
- DONUT PROJECT - VBA - Excel - Populando um ListBox no seu Formulário
- DONUT PROJECT - VBA - Excel - Importando arquivos CSV
- DONUT PROJECT - VBA - Excel - Deletando Conexões de Dados
- DONUT PROJECT - VBA - Excel - Obtendo o Nome da Planilha sem a Extensão
- DONUT PROJECT - VBA - WORD - Exportação Automatizada - DOC para PDF
Nenhum comentário:
Postar um comentário