Option Explicit
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Dim otl As Object
Sub Main()
Dim i%, av, lr%, r As Range, j%, hr%, sh As Worksheet, oln%, ns$, tbsh As Worksheet
Set sh = Sheets("List1") ' where file list is created
Set tbsh = Sheets("Sheet2")
ListFiles
ZtoA ' order file list
oln = 1
Set otl = CreateObject("Outlook.Application")
Do
ns = ""
lr = sh.Range("a" & Rows.Count).End(xlUp).Row
If InStr(sh.Cells(lr, 1), "xls") > 0 Then
av = Split(sh.Cells(lr, 1).Value, ".")
sh.Range("f" & lr + 2) = sh.Range("a1")
sh.Range("f" & lr + 3) = av(0) & "*"
sh.Range("a1:a" & lr).AdvancedFilter _
xlFilterCopy, sh.Range("f" & lr + 2 & ":f" & lr + 3), sh.Range("h" & lr + 2), 0
Set r = tbsh.Range("a:a").Find(sh.Cells(sh.Range("h" & Rows.Count).End(xlUp).Row, 8), tbsh.Cells(1, 1), xlValues)
If Not r Is Nothing Then
For j = sh.Range("h" & Rows.Count).End(xlUp).Row To lr + 3 Step -1
ns = ns & sh.Cells(1, 1) & sh.Cells(j, 8) & vbLf
Next
SaveAsDraft r.Offset(, 1), r.Offset(, 2), "see attached file(s).", oln, ns
oln = oln + 1
Else
MsgBox "Not found on Sheet2", vbCritical, sh.Cells(sh.Range("h" & Rows.Count).End(xlUp).Row, 8)
End If
Do Until sh.Cells(sh.Range("h" & Rows.Count).End(xlUp).Row, 8) = Range("a1") Or hr = 1
hr = sh.Range("h" & Rows.Count).End(xlUp).Row
Set r = sh.Range("a:a").Find(sh.Cells(hr, 8), Cells(1, 1), xlValues)
If Not r Is Nothing Then r.EntireRow.Delete
sh.Cells(sh.Range("h" & Rows.Count).End(xlUp).Row, 8).ClearContents
Loop
Else
sh.Cells(lr, 1).EntireRow.Delete
End If
Loop Until sh.Range("a2") = ""
End Sub
Sub SaveAsDraft(sendto$, sendcc, ebody, oln%, ns$)
Dim mlmsg As Outlook.MailItem, f, i%
f = Split(ns, vbLf)
Set mlmsg = otl.CreateItem(0)
With mlmsg
.To = sendto
.cc = sendcc
.Body = ebody
.Subject = "Message #" & oln
.Display
For i = LBound(f) To UBound(f)
If Len(f(i)) > 0 Then .Attachments.Add f(i)
Next
.Save
' .Close
End With
End Sub
Sub ZtoA()
Dim lr%, ws As Worksheet
Set ws = Sheets("List1")
lr = ws.Range("a" & Rows.Count).End(xlUp).Row
Range("A2:A" & lr).Select
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=Range("A2"), SortOn:=0, Order:=xlDescending, DataOption:=0
With ws.Sort
.SetRange Range("a2:a" & lr)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = 1
.Apply
End With
End Sub
Sub ListFiles()
Dim Msg As String, Directory As String, f As String, r&
Msg = "Select a location containing the files you want to list."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
r = 1
Sheets("List1").Activate
Cells.ClearContents
Cells(r, 1) = Directory
Cells(r, 2) = "Size"
Cells(r, 3) = "Date/Time"
Range("A1:C1").Font.Bold = True
' Get first file
f = Dir(Directory, vbReadOnly + vbHidden + vbSystem)
Do While f <> ""
r = r + 1
Cells(r, 1) = f
Cells(r, 2) = FileLen(Directory & f)
Cells(r, 3) = FileDateTime(Directory & f)
' Get next file
f = Dir
Loop
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO, path$, r As Long, x&, pos%
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
