Rotinas VBA para MsOutlook: zipar anexos automaticamente para envio ao Grupo MsExcelBR
ale...@gmail.com
Amigos,
Criei um conjunto de rotinas VBA no Outlook para:
- verificar se os anexos de mensagens para o Grupo estão compactados e, se não estiverem, proceder à compactação (ZIP), e, em seguida,
- checar se a soma de seus tamanhos não ultrapassa os atuais 5Mb por mensagem. Se sim, o eMail não é enviado e é exibido um alerta.
Desde já informo que caso queiram utilizar estas rotinas, façam por sua conta e risco. Não posso garantir que funcionem e etc.
Pois nunca testei essa migração de código para outra máquina!
Já as utilizo por quase 1 semana… tudo ok. 😊
Desejando utilizá-las, há duas formas mais fáceis de adaptar o Outlook:
- Importando os arquivos descompactados previamente do arquivo Outlook_ZipModulesCode.zip. Esta é a forma mais segura, pois poderá avaliar se há ou não código preexistente no Projeto VBA.
- Para importar esses arquivos abra o VBE do Outlook e vá no menu Arquivo > Importar arquivo… e selecione cada um dos 4 arquivos. Alerto que, ao importar a classe ThisOutlookSession será criada a classe ThisOutlookSession1.OTM. Você terá que atuar manualmente nisso, movendo o código para ThisOutlookSession.OTM e, em seguida, removendo a classe recém criada ThisOutlookSession1.OTM.
- Substituindo o Projeto do VBA do Outlook pelo arquivo anexo (VBAProject.OTM, zipado como VBAProject.ZIP). Somente faça desta forma se estiver seguro de que não há nenhum código preexistente rodando no Outlook. Pois sobrescrevendo esse arquivo, obviamente, perderá o que lá havia. Uma boa pedida é fazer o backup do arquivo preexistente. Seguro morreu de velho!
- Para tanto, navegue no Explorer ao endereço %APDATA%\Microsoft\Outlook\ e, lá, faça a substituição do arquivo VBAProject.OTM
Uma terceira forma seria copiando e colando os códigos no VBA do Outlook:
Abra o VBE do Outlook (ALT + F11). Copie e cole as rotinas mais abaixo para dentro dos respectivos módulos.
A estrutura do Projeto deverá ser idêntica a esta:
\[..]/
ALeXceL
Oliveira/MG
XL 365
Rotinas para gravação em “ThisOutlookSession”:
Option Explicit
'***** MsOutLook Wrapper V1.0 20191209 - ALe...@GMail.Com
Public olApp As New clsOL 'instanciar olApp.ObjOL como uma Application (Outlook), usando enventos da Classe clsOL
Private Sub Application_Startup()
gstrKeyWord = "MSEXCELBR"
glngMaxSize = 5000000 'bytes >>> 5000000 = 5Mb
Set olApp.ObjOL = Outlook.Application
Call fnStantiateObjs
End Sub
Private Sub fnStantiateObjs()
Set olApp.oInsps = Application.Inspectors
Set olApp.oExpls = Application.Explorers
On Error Resume Next
Set olApp.oExpl = olApp.oExpls.Item(1)
On Error GoTo 0
End Sub
Rotinas para gravação em Módulo de Classe criado e nomeado como “clsOL”:
Option Explicit
'***** MsOutLook Wrapper V1.0 20191209 - ALe...@GMail.Com
Public ObjOL As Outlook.Application
Public WithEvents oExpls As Outlook.Explorers
Public WithEvents oExpl As Explorer
Public WithEvents oInsps As Outlook.Inspectors
Public WithEvents objMsg As Outlook.MailItem
Public bDiscardEvents As Boolean
Public oResponse As MailItem
Public Sub Initialize_ExplHandles()
Set oExpls = ObjOL.Application.Explorers
End Sub
Public Sub Initialize_InsplHandles()
Set oInsps = ObjOL.Application.Inspectors
End Sub
Private Sub Class_Terminate()
Stop
Set ObjOL.oInsps = Nothing
Set ObjOL.oExpls = Nothing
End Sub
Private Sub objMsg_Send(Cancel As Boolean)
Dim lngSizeOfAttachments As Long
Dim intAttachment As Integer
Dim intRecipient As Integer
Dim fToCheck As Boolean
For intRecipient = objMsg.Recipients.Count To 1 Step -1
If InStr(UCase(objMsg.Recipients(intRecipient)), UCase(gstrKeyWord)) > 0 Then
fToCheck = True
Exit For
End If
Next
If fToCheck Then
Call fnCheckAttachments(objMsg)
For intAttachment = objMsg.Attachments.Count To 1 Step -1
lngSizeOfAttachments = lngSizeOfAttachments + objMsg.Attachments(intAttachment).Size
Next
If lngSizeOfAttachments > glngMaxSize Then
MsgBox "O tamanho total do" & IIf(objMsg.Attachments.Count > 1, "s", "") & " anexo" & IIf(objMsg.Attachments.Count > 1, "s", "") & " (" & Format(lngSizeOfAttachments, "0,000,000") & " bytes) supera " & Format(VBA.Round(glngMaxSize / 1000000), "0.0") & " Mb. Confira.", vbOKOnly + vbCritical, "Mensagem não pode ser enviada"
Cancel = True
End If
End If
End Sub
Private Sub oExpls_NewExplorer(ByVal Explorer As Explorer)
If Explorer.Selection.Class = olMail Then
Set objMsg = Explorer.CurrentItem
End If
End Sub
Private Sub oInsps_NewInspector(ByVal Inspector As Inspector)
If Inspector.CurrentItem.Class = olMail Then
Set objMsg = Inspector.CurrentItem
End If
End Sub
Function fnCheckAttachments(ByRef objMsg As MailItem)
Dim intAttachment As Integer
Dim strAttachmentName As String
Dim strAttachmentExtension As String
Dim strZipFileName As String
Dim varZipDisplayName As String
Dim colRecipients As New Collection
Dim colSizes As New Collection
For intAttachment = objMsg.Attachments.Count To 1 Step -1
strAttachmentName = objMsg.Attachments(intAttachment).FileName
strAttachmentExtension = Split(strAttachmentName, ".")(1)
If InStr("ZIP*RAR", UCase(strAttachmentExtension)) = 0 Then
'É necessário compactar o arquivo...
If fnZipAttachment(objMsg, intAttachment, strZipFileName, varZipDisplayName) = True Then
objMsg.Attachments.Remove intAttachment
objMsg.Attachments.Add strZipFileName, olByValue, intAttachment, varZipDisplayName
Else
MsgBox "Falha na compactação: " & objMsg.Attachments(intAttachment).DisplayName
End If
End If
Next
End Function
Function fnZipAttachment(ByRef objMsg As MailItem, intAttachment As Integer, strZipFileName As String, varZipDisplayName As Variant) As Boolean
Dim strFileName As String
Dim strTempPath As String
strTempPath = modGetTemps.fnGetTempPath
strFileName = objMsg.Attachments(intAttachment).DisplayName
On Error Resume Next
VBA.Kill strTempPath & strFileName
On Error GoTo 0
objMsg.Attachments(intAttachment).SaveAsFile strTempPath & strFileName
If modZipAttachment.fnZipAttachment(strTempPath & strFileName, strZipFileName, varZipDisplayName) Then
fnZipAttachment = True
Else
fnZipAttachment = False
End If
End Function
Private Sub objMsg_AttachmentAdd(ByVal newAttachment As Attachment)
Dim intRecipient As Integer
If newAttachment.Type = olByValue Then
On Error Resume Next
objMsg.Save
On Error GoTo 0
If objMsg.Recipients.Count > 0 Then
For intRecipient = objMsg.Recipients.Count To 1 Step -1
If InStr(UCase(objMsg.Recipients(intRecipient)), UCase(gstrKeyWord)) > 0 Then
Call fnCheckAttachments(objMsg)
Exit For
End If
Next
Else
'
End If
End If
End Sub
Sub objMsg_AttachmentRemove(ByVal newAttachment As Attachment)
Dim objPanes As Panes
Set objPanes = ActiveExplorer.Panes
End Sub
Sub oExpls_Reply(ByVal objMsg As MailItem)
Stop
End Sub
'=====================================================================
Public Sub oExpl_SelectionChange()
On Error Resume Next
Set objMsg = oExpl.Selection.Item(1)
End Sub
' Reply
Public Sub objMsg_Reply(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = objMsg.Reply
afterReply
End Sub
Public Sub objMsg_Forward(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = objMsg.Forward
afterReply
End Sub
Public Sub objMsg_ReplyAll(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = objMsg.ReplyAll
afterReply
End Sub
Public Sub afterReply()
oResponse.Display 'provoca a criação de um novo objeto Inspector.
' do whatever here
End Sub
Rotinas para serem gravadas num módulo padrão a ser criado e nomeado como “modGetTemps”:
Option Explicit
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Function fnGetTempFileName(Optional ByVal strPrefix As Variant = "") As Variant
Dim lngRet As Long
Dim strTempFileName As String * 260
Dim strTempDir As String
strTempDir = fnGetTempPath
DoEvents
If strPrefix = "" Then
strPrefix = "TMP_REG"
End If
DoEvents
lngRet = GetTempFileName(strTempDir, strPrefix, ByVal 0&, strTempFileName)
fnGetTempFileName = Left(strTempFileName, InStr(strTempFileName, Chr(0)) - 1)
End Function
Function fnGetSysDir() As String
Dim Sys_Dir As String, Res As Long
Res = GetSystemDirectory(Sys_Dir, 0&)
Sys_Dir = String(Res - 1, " ")
Res = GetSystemDirectory(Sys_Dir, Res)
fnGetSysDir = IIf(Right(Sys_Dir, 1) <> "\", Sys_Dir & "\", Sys_Dir)
End Function
Function fnGetTempPath() As String
Dim lRet As Long
Dim lSize As Long
Dim sBuf As String * 260
lSize = 260
lRet = GetTempPath(ByVal lSize, sBuf)
If InStr(1, sBuf, Chr(0)) > 0 Then
fnGetTempPath = Left(sBuf, InStr(2, sBuf, Chr(0)) - 1)
Else
fnGetTempPath = ""
End If
End Function
Rotinas para serem gravadas num módulo padrão criado e nomeado como “modZipAttachment”:
Option Explicit
'***** MsOutLook Wrapper V1.0 20191209 - ALe...@GMail.Com
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public gstrKeyWord As String 'eMail ou parte do eMail de destinatário a ser monitorado
Public glngMaxSize As Long 'tamanho máximo, em bytes, da soma de anexos de uma mensagem para o eMail monitorado
Function fnZipAttachment(ByVal strAttachmentFileName As String, _
ByRef strZipFileName As String, _
ByRef varZipDisplayName As Variant) As Boolean
Dim objShell As Object
Dim lngFreeFile As Long
Dim strPathToTemp As String
strPathToTemp = Left(strAttachmentFileName, InStrRev(strAttachmentFileName, "\"))
varZipDisplayName = Right(strAttachmentFileName, Len(strAttachmentFileName) - InStrRev(strAttachmentFileName, "\"))
varZipDisplayName = Split(varZipDisplayName, ".")(0) & ".ZiP"
fnZipAttachment = False
On Error Resume Next
Kill strPathToTemp & varZipDisplayName
DoEvents: Call Sleep(100): DoEvents
On Error GoTo 0
If Dir(strPathToTemp & varZipDisplayName, vbNormal + vbDirectory + vbArchive) <> "" Then
Stop
End If
'Create an empty Zip File containing only the zip header
lngFreeFile = VBA.FreeFile
Open strPathToTemp & varZipDisplayName For Output As #lngFreeFile
Print #lngFreeFile, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #lngFreeFile
Set objShell = CreateObject("Shell.Application")
objShell.Namespace(strPathToTemp & varZipDisplayName).CopyHere (strAttachmentFileName)
DoEvents: Call Sleep(500): DoEvents
On Error Resume Next
Do While Not fnCanOpenExclusive(strPathToTemp & varZipDisplayName)
Do While Not fnCanOpenExclusive(strPathToTemp & varZipDisplayName)
DoEvents: Call Sleep(200): DoEvents
Loop
DoEvents: Call Sleep(200): DoEvents
Loop
strZipFileName = strPathToTemp & varZipDisplayName
fnZipAttachment = True
On Error GoTo 0
lblExit:
Exit Function
End Function
Private Function fnCanOpenExclusive(strFile As String) As Boolean
Dim lngFF As Long
lngFF = FreeFile
On Error GoTo lblCannot
'Lock Write -> possible only if zipping work is complete.
Open strFile For Binary Access Read Lock Write As lngFF
Close lngFF
fnCanOpenExclusive = True
lblExit:
Exit Function
lblCannot:
fnCanOpenExclusive = False
End Function