Save PDF attachments only using If UCase + SaveAsFile + SenderEmailAddress - vba

I have two VBA macros that are slightly different and I want to combine the best of both.
Both save attachments within a selection of emails, however:
Macro A saves every attachment within the selection as a PDF. Some are JPEG signatures or disclaimers etc. that I don't want. The plus side is that it uses eml.SenderEmailAddress which is super as I want the name of the saved attachment to include 'someone#something.com'
Macro B saves every attachment within the selection as a PDF but uses the If UCase function to filter out PDF files only. For instance if an email contains a .txt and .pdf file, only the PDF file is considered. I don't have to clean out fake pdfs.
I cannot figure out how to incorporate SenderEmailAddress into this macro.
How do I merge the features in bold above?
Macro A)
Sub SaveAttachmentsFromSelectedItemsPDF()
Dim currentItem As Object
Dim currentAttachment As Attachment
Dim saveToFolder As String
Dim savedFileCountPDF As Long
saveToFolder = "the_path_private_its_a_work_one_lol"
savedFileCountPDF = 0
For Each currentItem In Application.ActiveExplorer.Selection
For Each currentAttachment In currentItem.Attachments
If UCase(Right(currentAttachment.DisplayName, 4)) = ".PDF" Then
currentAttachment.SaveAsFile saveToFolder & "\" & _
Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 4) & "_" & Format(Now, "yyyy-mm-dd_hh-mm-ss") & ".pdf"
savedFileCountPDF = savedFileCountPDF + 1
End If
Next currentAttachment
Next currentItem
MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation
End Sub
Macro B)
Sub attsave_yann()
Dim win As Outlook.Explorer
Dim sel As Outlook.Selection
Dim att As Outlook.Attachments
Dim eml As MailItem
Dim i As Integer
Dim fn As String
Dim objAtt As Outlook.Attachment
Dim myRandom As Double
Randomize 'Initialize the Rnd function
myRandom = Rnd 'Generate a random number between 0-1
' Count = Count + 1
Set win = Application.ActiveExplorer
Set sel = win.Selection
For Each eml In sel
Set att = eml.Attachments
If UCase(Right(att.DisplayName, 4)) = ".PDF" Then
For i = 1 To att.Count
fn = "the_path_private_its_a_work_one_lol" & eml.SenderEmailAddress & "_" & Rnd & "_.pdf"
att(i).SaveAsFile fn
Next i
End If
Next
End Sub

B is almost there:
Sub attsave_yann()
Dim eml As MailItem
Dim fn As String
Dim objAtt As Outlook.Attachment
Randomize 'Initialize the Rnd function
For Each eml In Application.ActiveExplorer.Selection
For Each objAtt In eml.Attachments
'need to test objAtt.DisplayName
If UCase(objAtt.DisplayName) Like "*.PDF" Then
fn = "the_path_private_its_a_work_one_lol" & _
DomainOnly(eml.SenderEmailAddress) & "_" & Rnd & "_.pdf"
objAtt.SaveAsFile fn
End If
Next objAtt
Next
End Sub
'return only the part after the `#`
Function DomainOnly(sAddr as string)
Dim arr
arr = Split(sAddr, "#")
if UBound(arr) = 0 then
DomainOnly = sAddr
Else
DomainOnly = arr(1)
End If
End Function

Related

How to get function value in main sub VBA

I would like to get the value (The regex result) of the function below inside my main sub in orde to add it to the title of my file, how can I do this ?
Public Sub Process_SAU(Item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
Dim Code as String
Code = ExtractText
' Folder location when I want to save my file
saveFolder = "C:\Users\gdeange1\Desktop\suggestion updates\UpdateBusinessInformation\Processed_By_Bulks"
For Each object_attachment In Item.Attachments
' Criteria to save .doc files only
If InStr(object_attachment.DisplayName, ".json") Then
object_attachment.SaveAsFile saveFolder & "\" & Format(Now(), "dd-mm-yyyy") & "_" & Code & "_" & object_attachment.DisplayName
End If
Next
End Sub
Function ExtractText(Str As String) ' As String
Dim regEx As New RegExp
Dim NumMatches As MatchCollection
Dim M As Match
regEx.Pattern = "((.*))[A-Z]{0}(Danièle Loubert|Véronique Mantha|Julie-Emmanuelle Carle|Nicolas Bertrand|Martine Jean)"
Set NumMatches = regEx.Execute(Str)
If NumMatches.Count = 0 Then
ExtractText = "Blabla"
Else
Set M = NumMatches(0)
ExtractText = M.SubMatches(0)
End If
Code = ExtractText
End Function
The code I tried above did not work.
Thank's for your help!
You might have copied the function ExtractText(Str As String) , but this function expects a string value to be passed while using this function, which you are missing. If you pass a string type value while using the function in your main code, it should work.
You pass Item to Public Sub Process_SAU(Item As MailItem).
Similarly, you have to pass Str to Function ExtractText(Str As String) As String.
Option Explicit
Private Sub test_Process_SAU()
Dim currItem As Object
' with a selected item
Set currItem = ActiveExplorer.Selection(1)
' or
' with an open item
'Set currItem = ActiveInspector.currentItem
If currItem.Class = olMail Then
Process_SAU currItem
End If
End Sub
Public Sub Process_SAU(Item As MailItem)
Dim Code As String
' Pass the applicable string to the function
Code = ExtractText(Item.body)
Debug.Print " Code: " & Code
Dim object_attachment As outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Users\gdeange1\Desktop\suggestion updates\UpdateBusinessInformation\Processed_By_Bulks"
For Each object_attachment In Item.Attachments
If InStr(object_attachment.DisplayName, ".json") Then
object_attachment.SaveAsFile saveFolder & "\" & Format(Now(), "dd-mm-yyyy") & "_" & Code & "_" & object_attachment.DisplayName
End If
Next
End Sub
Function ExtractText(Str As String) As String
Dim regEx As New regExp
Dim NumMatches As MatchCollection
Dim M As Match
regEx.Pattern = "((.*))[A-Z]{0}(Danièle Loubert|Véronique Mantha|Julie-Emmanuelle Carle|Nicolas Bertrand|Martine Jean)"
Set NumMatches = regEx.Execute(Str)
If NumMatches.count = 0 Then
ExtractText = "Blabla"
Else
Set M = NumMatches(0)
ExtractText = M.Value
End If
End Function

How to extract PDF attachments from Outlook and save to Folder

I need VBA code to use in Outlook to extract the PDF attachments from emails and save into a designated folder. The user will choose the emails.
I have the below code but need it amended.
Public Sub SaveAutoAttach(item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
' Folder location when I want to save my file
saveFolder = "D:\Data\Archive"
For Each object_attachment In item.Attachments
' Criteria to save .doc files only
If InStr(object_attachment.DisplayName, ".doc") Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
Next
End Sub
As per your request, the following macro will save any PDF attachments from one or more user selected items.
Option Explicit
Sub SaveAttachmentsFromSelectedItemsPDF()
Dim currentItem As Object
Dim currentAttachment As Attachment
Dim saveToFolder As String
Dim savedFileCountPDF As Long
saveToFolder = "c:\users\domenic\desktop" 'change the path accordingly
savedFileCountPDF = 0
For Each currentItem In Application.ActiveExplorer.Selection
For Each currentAttachment In currentItem.Attachments
If UCase(Right(currentAttachment.DisplayName, 4)) = ".PDF" Then
currentAttachment.SaveAsFile saveToFolder & "\" & _
Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 4) & "_" & Format(Now, "yyyy-mm-dd_hh-mm-ss") & ".pdf"
savedFileCountPDF = savedFileCountPDF + 1
End If
Next currentAttachment
Next currentItem
MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation
End Sub

Splitting Word document into multiple .txt files using a macro

I am splitting a single MS Word document into multiple using a custom delimiter. I am able to create multiple files in MS Word format, but I want to create multiple .txt files instead.
The code that I am using now is:
Sub SplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim X As Long
Dim Response As Integer
arrNotes = Split(ActiveDocument.Range, delim)
Response = MsgBox("This will split the document into " &
UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
If Response = 7 Then Exit Sub
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
X = X + 1
Set doc = Documents.Add
doc.Range = arrNotes(I)
doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")
doc.Close True
End If
Next I
End Sub
Sub test()
' delimiter & filename
SplitNotes "%%%%%%%%%%%%%%", "Notes "
End Sub
Can anyone help me with this please?
Try this and see if it does what you want.
Sub SplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim X As Long
Dim Response As Integer
arrNotes = Split(ActiveDocument.Range, delim)
Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
If Response = 7 Then Exit Sub
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
X = X + 1
Set doc = Documents.Add
doc.Range = arrNotes(I)
doc.SaveAs ThisDocument.Path & "\" & strFilename & ".txt"
doc.Close True
End If
Next I
End Sub
Sub test()
' delimiter & filename
SplitNotes "///", "Notes "
End Sub

VBA; how to extract all files names from a folder - without using Application.FileDialog object

As in the Question: the task is to extract all files names from a folder, but the folder path needs to be hard coded into the macro, to prevent these dialog boxes asking me things and wasting my time.
I will not change this folder. It will be the same one until the end of time, and I want to extract the files names into the Excel column, starting from second row.
this is the folder I want to extract ALL files names from.
"C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\"
this is my portion of code:
Option Explicit
Sub GetFileNames()
Dim axRow As Long ' inside the Sheet("Lista") row#
Dim xDirectory As String
Dim xFname As String ' name of the file
Dim InitialFoldr$
Dim start As Double
Dim finish As Double
Dim total_time As Double
start = Timer
ThisWorkbook.Sheets("Lista").Range("D2").Activate
InitialFolder = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst"
If Right(InitialFolder, 1) <> "\" Then
InitialFolder = InitialFolder & "\"
End If
Application.InitialFolder.Show
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
xFname = Dir(xDirectory, vbArchive)
' Dir's job is to return a string representing
' the name of a file, directory, or an archive that matches a specified pattern.
Do While xFname <> "" ' there is already xFname value (1st file name) assigned.
ActiveCell.Offset(xRow) = xFname
xRow = xRow + 1 ' następny xRow
xFname = Dir()
Loop
End If
End With
finish = Timer ' Set end time.
total_time = Round(finish - start, 3) ' Calculate total time.
MsgBox "This code ran successfully in " & total_time & " seconds", vbInformation
End Sub
this is the line that crushes:
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
And two more important questions in the .png file.
Please, respond to them as well - it's very important 4 me.
Or if U guys know any other method to do this faster just don't hesitate and share Your Code with me - I'll be very grateful.
Sub Files()
Dim sht As Worksheet
Dim strDirectory As String, strFile As String
Dim i As Integer: i = 1
Set sht = Worksheets("Sheet1")
strDirectory = "C:\Users\User\Desktop\"
strFile = Dir(strDirectory, vbNormal)
Do While strFile <> ""
With sht
.Cells(i, 1) = strFile
.Cells(i, 2) = strDirectory + strFile
End With
'returns the next file or directory in the path
strFile = Dir()
i = i + 1
Loop
End Sub
See example below
Public Sub Listpng()
Const strFolder As String = "C:\SomeFolder\"
Const strPattern As String = "*.png"
Dim strFile As String
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
Debug.Print strFile '<- view this in Immediate window; Ctrl+g will take you there
strFile = Dir
Loop
End Sub
There's a couple of procedures I use depending on whether I want subfolders as well.
This loops through the folder and adds path & name to a collection:
Sub Test1()
Dim colFiles As Collection
Dim itm As Variant
Set colFiles = New Collection
EnumerateFiles "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "*.xls*", colFiles
For Each itm In colFiles
Debug.Print itm
Next itm
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
This second way goes through the subfolders as well returning path & name. For some reason if you change InclSubFolders to False it only returns the name - got to sort that bit out.
Sub Test2()
Dim vFiles As Variant
Dim itm As Variant
vFiles = EnumerateFiles_2("C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "xls*")
For Each itm In vFiles
Debug.Print itm
Next itm
End Sub
Public Function EnumerateFiles_2(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles_2 = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function

Count Outlook VBA attachment

Can you help me to improve the below VBA code to be able to correctly count e-mails + attachments form a selected range (outlook 2010)
Sub CountAttachmentsMulti()
Set mySelect = Outlook.ActiveExplorer.Selection
For Each Item In mySelect
j = Item.Attachments.Count + j
i = i + 1
Next Item
MsgBox "Selected " & i & " messages with " & j & " attachements"
End Sub
That is the code the problem is that counts also as attachments the picture in the signatures and give a wrong count meaning more attachments then the actually are
Can you help to amend the code to bypass from counting the images in signatures
BR
Gabi
Try this
Sub CountAttachmentsValid()
Dim olkItem As Outlook.mailitem
Dim olkAttachment As Outlook.attachment
Dim strFilename As String
Dim strExtension As String
Dim lngExtIndex As Long
Dim strBaseFilename As String
Dim cnt As Long
Dim mySelect As Selection
Dim iExt As Long
Dim validExtString As String
Dim validExtArray() As String
validExtString = ".doc .docx .xls .xlsx .msg .pdf .txt" ' <---- Update as needed
validExtArray = Split(validExtString, " ")
Set mySelect = Outlook.ActiveExplorer.Selection
For Each olkItem In mySelect
For Each olkAttachment In olkItem.Attachments
On Error GoTo cannotPerformOperation
strFilename = olkAttachment.FileName
lngExtIndex = InStrRev(strFilename, ".")
strBaseFilename = Left(strFilename, lngExtIndex - 1)
strExtension = Mid(strFilename, lngExtIndex)
For iExt = 0 To UBound(validExtArray)
If LCase(strExtension) = LCase(validExtArray(iExt)) Then
cnt = cnt + 1
Exit For
End If
Next iExt
skipped:
Next olkAttachment
Next olkItem
GoTo exiting
cannotPerformOperation:
'Debug.Print " ** " & olkAttachment.DisplayName & " not counted"
Resume skipped
exiting:
MsgBox "Selected " & mySelect.count & " messages with " & cnt & " recognized attachments"
End Sub