Error 3000 Using VBA and HCL ( Lotus) notes - vba

I made a code to send some emails, using HCL NOTES and Excel, but I have been stuck.
ERROR 3000 appears when going through the line ".SEND 0, vaRecipient". I think what happens is that the connection with the database is lost, after going through the procedure of attaching an image to the body of the mail. Since if I remove those lines of code, no error arises.
Sub SendQuoteToEmail()
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim NRichTextItem As Object
Dim NrichTextHeader As Object
Dim NMimeImage As Object
Dim strImageType As String
Dim WordApp As Object
Dim EmbedObj As Object
Dim Body As Object
Dim NStream As Object
Dim Subject As String
Dim MailAddress As String
Dim MailAddressCC As String
Dim MailAddressCC2 As String
Dim MailAddressCCO As String
Dim MailAddressCCO2 As String
Dim AttchFiles1, AttchFiles2, AttchFiles3, AttchFiles4 As String
Dim AddImage As String
Dim pf As Integer
Dim Uf As Integer
Dim x As Double
'On Error Resume Next
Set a = ThisWorkbook.Sheets("Base Emails")
pf = 4
Uf = 0
Do While Uf = 0
cuit = Range("a" & pf).Value
If cuit <> Empty Then
Subject = UserForm1.SubjectBox & a.Cells(pf, "D") & " - CUIL N°: " & a.Cells(pf, "A") '
MailAddress = a.Cells(pf, "F")
MailAddressCC = UserForm1.TextBoxCC
MailAddressCC2 = UserForm1.TextBoxCC2
MailAddressCCO = UserForm1.TextBoxCCO
MailAddressCCO2 = UserForm1.TextBoxCCO2
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GETDATABASE("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
Set NDoc = NDatabase.CREATEDOCUMENT
With NDoc
.SendTo = MailAddress
.CopyTo = MailAddressCC & ", " & MailAddressCC2
.Subject = Subject
.Body = UserForm1.FirstLineBox & vbLf & vbLf & _
UserForm1.FirstParagraphBox & vbLf & vbLf & _
UserForm1.SecondParagraphBox & vbLf & vbLf & _
UserForm1.ThirdParagraphBox & vbLf
.SAVEMESSAGEONSEND = True
End With
AddImage = ThisWorkbook.Path & "\Image\" & Worksheets("Files").Range("A" & 5)
If AddImage <> "" Then
Set NStream = NSession.CREATESTREAM
Call NStream.Open(AddImage)
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
Call NStream.Close
End If
AttchFiles1 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 1)
If AttchFiles1 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment1")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles1, "Adjunto")
End If
AttchFiles2 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 2)
If AttchFiles2 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment2")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles2, "Adjunto")
End If
AttchFiles3 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 3)
If AttchFiles3 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment3")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles3, "Adjunto")
End If
AttchFiles4 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 4)
If AttchFiles4 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment4")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles4, "Adjunto")
End If
With NDoc
.PostedDate = Now()
.SEND 0, vaRecipient '<--- ERROR 3000
End With
Set NStream = Nothing
Set NDoc = Nothing
Set WordApp = Nothing
Set NSession = Nothing
Set EmbedObj = Nothing
pf = pf + 1
Else
Uf = 1
Exit Do
End If
Loop
VbMessage = "Sent messages"
Call Clean
End Sub
If I remove these lines of code, the procedure works. So I suppose that by manipulating "NSession", something happens, but I don't know what.
AddImage = ThisWorkbook.Path & "\Image\" & Worksheets("Files").Range("A" & 5)
If AddImage <> "" Then
Set NStream = NSession.CREATESTREAM
Call NStream.Open(AddImage)
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
Call NStream.Close
End If

You've got two pieces of incompatible code here.
.Body = UserForm1.FirstLineBox & vbLf & vbLf & _
UserForm1.FirstParagraphBox & vbLf & vbLf & _
UserForm1.SecondParagraphBox & vbLf & vbLf & _
UserForm1.ThirdParagraphBox & vbLf
And
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
You can't work with the message body both as Notes rich text (the first piece of code) and as MIME. You need to pick one or the other. I'm guessing you're going to pick MIME, in which case you are going to need to create a text/plain part and populate it with your three paragraphs of text.

Related

VBA application.Ontime TimeValue does not run

I'm trying to get a report done and sent out at 7:00am everyday. I put Application.Ontime TimeValue("7:00:00"), "DailyReport" in my code. This ran fine in the past, but after I modified some other codes in DailyReport sub (which should not affect Application.Ontime anyway) and check "Ignore other application using DDE", the report does not fire at 7:00am anymore.
Any help is greatly appreciated, guys!!!!
Option Explicit
Sub DailyReport()
Dim t As String 'Time to send daily Snapshot
Dim pr As Boolean 'Is process running/is there data for yesterday
ThisWorkbook.UpdateLink Name:="Y:\DATA COLLECTION 2018.xlsx"
Application.Calculate
t = Db.Range("C6").Value()
pr = Db.Range("D5").Value()
Db.ChartObjects("Chart 1").Chart.Refresh
Db.ChartObjects("Chart 3").Chart.Refresh
Db.ChartObjects("Chart 4").Chart.Refresh
Dim objOutlook As Object
Dim objMail As Object
Dim rng As Range
today = Format(Now(), "m/dd/yyyy")
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Set rng = Db.Range("B8:F16")
Dim myPic1 As String
Dim myPic2 As String
Dim myPic3 As String
Dim fileName1 As String
Dim fileName2 As String
Dim fileName3 As String
Dim myPath As String
Dim sj As String
myPic1 = "Feed.png"
myPic2 = "T and Vacuum.png"
myPic3 = "D.png"
myPath = "C:\Users\lab3\Downloads\"
fileName1 = myPath & myPic1
fileName2 = myPath & myPic2
fileName3 = myPath & myPic3
Db.ChartObjects("Chart 1").Chart.Export fileName1
Db.ChartObjects("Chart 3").Chart.Export fileName2
Db.ChartObjects("Chart 4").Chart.Export fileName3
With objMail
Dim cell As Range
Dim strto As String
For Each cell In Distribution.Range("A1:A100")
If cell.Value Like "?*#?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
If pr Then sj = "Daily Report " & today Else sj = "Daily Report " & today & " - No new data"
.To = strto
.Subject = sj
.HTMLBody = RangetoHTML(rng) & "<p><p>" & "<img src = '" & fileName1 & "'>" & "<p><p>" & _
"<img src = '" & fileName3 & "'>" & "<p><p>" & "<img src = '" & fileName2 & "'>"
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Application.SendKeys "%s"
Set objOutlook = Nothing
Set objMail = Nothing
Db.Range("C5").FormulaR1C1 = "TRUE"
Application.StatusBar = "Ready"
ThisWorkbook.Save
Application.OnTime TimeValue("7:00:00"), "DailyReport", True
End Sub
From documentatation of (https://msdn.microsoft.com/en-us/vba/excel-vba/articles/application-ontime-method-excel) :
Set Schedule to false to clear a procedure previously set with the same Procedure and EarliestTime values.

Email Reminder doesnt triggered (to send) even Value Change from Formula in Excel

I'm new to VB in Excel.
I made an email reminder program in Excel with value changed from formula (calculation) in one of the cell.
The problem is the email reminder did not pop up even though the conditions are met.
But when I put manually the number (to meet the condition), the email reminder did pop up.
Please help to make the program run if the cell value from calculation met the condition of the program. Thanks!
Here is the code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim completed As Boolean
Dim rowCount As Long
Dim i As Integer
Dim Objek As String
Dim SatKer As String
Dim Hari As String
Dim AlamatEmail As String
Dim xMailBody As String
rowCount = 2
If Target.Cells.Count > 1 Then Exit Sub
For i = 1 To 5
rowCount = rowCount + 1
Set xRg = Range("O" & CStr(rowCount))
Objek = ActiveSheet.Range("F" & CStr(rowCount)).Value
SatKer = ActiveSheet.Range("G" & CStr(rowCount)).Value
Hari = ActiveSheet.Range("O" & CStr(rowCount)).Value
AlamatEmail = ActiveSheet.Range("S" & CStr(rowCount)).Value
If xRg = Target And Target.Value < 4 Then
Call Mail_small_Text_Outlook(Objek, SatKer, Hari, AlamatEmail)
End If
Next i
End Sub
Sub Mail_small_Text_Outlook(Objek As String, SatKer As String, Hari As String, AlamatEmail As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Yth. Bapak Widi " & vbNewLine & vbNewLine & _
"Laporan Penilaian " & Objek & " milik " & SatKer & " mendekati batas akhir pengumpulan." & vbNewLine & _
"Laporan tersebut harus disubmit dalam " & Hari & " hari." & vbNewLine & vbNewLine & _
"Mohon cek status laporan penilaian untuk keterangan laporan lebih detail."
On Error Resume Next
With xOutMail
.To = AlamatEmail
.cc = ""
.BCC = ""
.Subject = "Laporan Penilaian " & Objek & " milik " & SatKer
.HTMLBody = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
The following should do what you expect, the code will loop through column O and if the value calculated is less than 4 then it will .Display the email:
Private Sub Worksheet_Calculate()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "O").End(xlUp).Row
'get the last row with data on Column O
Dim completed As Boolean
Dim rowCount As Long
Dim i As Integer
Dim Objek As String
Dim SatKer As String
Dim Hari As String
Dim AlamatEmail As String
Dim xMailBody As String
For i = 3 To LastRow 'loop from row 3 to last on Column O
Set xRg = Range("O" & i)
Objek = ws.Range("F" & i).Value
SatKer = ws.Range("G" & i).Value
Hari = ws.Range("O" & i).Value
AlamatEmail = ws.Range("S" & i).Value
If ws.Cells(i, "O").Value < 4 Then 'if value is less than 4 then send email
Call Mail_small_Text_Outlook(Objek, SatKer, Hari, AlamatEmail)
End If
Next i
End Sub
Sub Mail_small_Text_Outlook(Objek As String, SatKer As String, Hari As String, AlamatEmail As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Yth. Bapak Widi " & vbNewLine & vbNewLine & _
"Laporan Penilaian " & Objek & " milik " & SatKer & " mendekati batas akhir pengumpulan." & vbNewLine & _
"Laporan tersebut harus disubmit dalam " & Hari & " hari." & vbNewLine & vbNewLine & _
"Mohon cek status laporan penilaian untuk keterangan laporan lebih detail."
On Error Resume Next
With xOutMail
.To = AlamatEmail
.cc = ""
.BCC = ""
.Subject = "Laporan Penilaian " & Objek & " milik " & SatKer
.HTMLBody = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

Sharepoint version history in document via vba?

Here is my problem:
Duplicate versions
I checked the version history on the Sharepoint site and it doesn't show any duplicates.
Here is the code im using:
Sub versionhistory()
'
' versionhistory Macro
On Error Resume Next
' On Error GoTo message
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim strVersionInfo As String
Set dlvVersions = ThisDocument.DocumentLibraryVersions
'MsgBox ActiveDocument.Bookmarks.Count
Dim tbl As Word.Table
'Set tbl = ActiveDocument.Tables.Item(2)
Set tbl = ActiveDocument.Bookmarks("VersionTable").Range.Tables(1)
If dlvVersions.IsVersioningEnabled Then
strVersionInfo = "This document has " & dlvVersions.Count & " versions: " & vbCrLf
Call InsertVersionHistory(tbl, dlvVersions)
For Each dlvVersion In dlvVersions
strVersionInfo = strVersionInfo & _
" - Version #: " & dlvVersion.Index & vbCrLf & _
" - Modified by: " & dlvVersion.ModifiedBy & vbCrLf & _
" - Modified on: " & dlvVersion.Modified & vbCrLf & _
" - Comments: " & dlvVersion.Comments & vbCrLf
Next
Else
strVersionInfo = "Versioning not enabled for this document."
End If
'MsgBox strVersionInfo, vbInformation + vbOKOnly, "Version Information"
Set dlvVersion = Nothing
Set dlvVersions = Nothing
Call GetUserName
'message:
'MsgBox Err.Description
MsgBox ("Insert Version Number in the Header and type a Title in the [Insert Title here] on the front page. It will be automatically updated in the footer." & vbNewLine & vbNewLine & "Do Not Type in the Review and Version tables.")
End Sub
Private Function InsertVersionHistory(oVerTbl As Word.Table, oVersions As Office.DocumentLibraryVersions)
Dim rowIndex As Integer
Dim oVersion As Office.DocumentLibraryVersion
Dim oNewRow As Row
'test
Dim versionIndex As Integer
For rowIndex = 2 To oVerTbl.Rows.Count
oVerTbl.Rows.Item(2).Delete
Next rowIndex
rowIndex = 1
'test
versionIndex = oVersions.Count
For Each oVersion In oVersions
If (rowIndex > 5) Then
Return
End If
rowIndex = rowIndex + 1
oVerTbl.Rows.Add
Set oNewRow = oVerTbl.Rows(oVerTbl.Rows.Count)
oNewRow.Shading.BackgroundPatternColor = wdColorWhite
oNewRow.Range.Font.TextColor = wdBlack
oNewRow.Range.Font.Name = "Tahoma"
oNewRow.Range.Font.Bold = False
oNewRow.Range.Font.Size = 12
oNewRow.Range.ParagraphFormat.SpaceAfter = 4
With oNewRow.Cells(1)
'.Range.Text = oVersion.Index
.Range.Text = versionIndex
End With
With oNewRow.Cells(2)
.Range.Text = FormUserFullName(GetUserFullName(oVersion.ModifiedBy))
End With
With oNewRow.Cells(3)
.Range.Text = oVersion.Modified
End With
With oNewRow.Cells(4)
.Range.Text = oVersion.Comments
End With
versionIndex = versionIndex - 1
Next
Set oVersion = Nothing
End Function
Function GetUserFullName(userName As String) As String
Dim WSHnet, UserDomain, objUser
Set WSHnet = CreateObject("WScript.Network")
'UserDomain = WSHnet.UserDomain
'Set objUser = GetObject("WinNT://" & UserDomain & "/" & userName & ",user")
userName = Replace(userName, "\", "/")
Set objUser = GetObject("WinNT://" & userName & ",user")
'MsgBox objUser.FullName
GetUserFullName = objUser.FullName
End Function
Function FormUserFullName(userName As String) As String
Dim arrUserName As Variant
Dim changedUserName As String
arrUserName = Split(userName, ",")
Dim length As Integer
length = UBound(arrUserName) - LBound(arrUserName) + 1
If length >= 2 Then
changedUserName = arrUserName(1) & " " & arrUserName(0)
Else
changedUserName = userName
End If
FormUserFullName = changedUserName
End Function
Private Function GetUserName()
Dim userName As String
userName = ActiveDocument.BuiltInDocumentProperties("Author")
ActiveDocument.BuiltInDocumentProperties("Author") = FormUserFullName(userName)
End Function
I know this is old, but I was looking for the same thing and found this article. I'm still trying it out, but wanted to share before I got distracted with my real job.
From: SixSigmaGuy on microsoft.public.sharepoint.development-and-programming.narkive.com/...
Wanted to share my findings, so far. Surprisingly, I could not find
anything in the SharePoint Designer object/class that supported versions,
but the Office, Word, Excel, and PowerPoint objects do support it.. It
wasn't easy to find, but once I found it, it works great, as long as the
file in the document library is one of the Office documents.
Here's some sample code, written in Excel VBA, showing how to get the
version information for a paritcular SharePoint Document Library file
created in Excel:
Public viRow As Long
Function fCheckVersions(stFilename As String) As Boolean
' stFilename is the full URL to a document in a Document Library.
'
Dim wb As Excel.Workbook
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim stExtension As String
Dim iPosExt As Long
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 1) = stFilename
If Workbooks.CanCheckOut(stFilename) = True Then
Set wb = Workbooks.Open(stFilename, , True)
Set dlvVersions = wb.DocumentLibraryVersions
If dlvVersions.IsVersioningEnabled = True Then
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 3) = "Num
Versions = " & dlvVersions.Count
For Each dlvVersion In dlvVersions
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 4) = "Version: " & dlvVersion.Index
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 5) = "Modified Date: " & dlvVersion.Modified
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 6) = "Modified by: " & dlvVersion.ModifiedBy
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 7) = "Comments: " & dlvVersion.Comments
viRow = viRow + 1
Next dlvVersion
End If
wb.Close False
End If
Set wb = Nothing
DoEvents
End Function`
Fortunately, I discovered that Excel can open non-Excel files in most
cases. I.e., I can, for example, open a jpg file in Excel and use the
dlvVersions collection for that file.

How to export email addresses from outlook meeting request

I sent an outlook (2010) meeting request to all company (4000+) and now I would like to send an additional email to those who accepted the request or accepted tentatively.
How do I do that? When I hit Contact Atendees --> New Email to Atendees in the ribbon it just send a response to all company and not only those who accepted. I also tried to export the contacts but it can only export the name alias and not the entire email addresses.
Any suggestions?
Thanks
The basis of the solution is found here Get Meeting Attendee List Macro
Here it is with minor changes.
Option Explicit
Sub GetAttendeeList()
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount As String
Dim ino, it, ia, ide
Dim x As Long
Dim ListAttendees As mailitem
'On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients
On Error GoTo EndClean:
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "This code only works with meetings."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.location
strNotes = objItem.body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
Set ListAttendees = Application.CreateItem(olMailItem) ' <---
' Get The Attendee List
For x = 1 To objAttendees.count
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response (or Organizer)"
ino = ino + 1
Case 1
strMeetStatus = "Organizer"
ino = ino + 1
Case 2
strMeetStatus = "Tentative"
it = it + 1
ListAttendees.Recipients.Add objAttendees(x) ' <---
Case 3
strMeetStatus = "Accepted"
ia = ia + 1
ListAttendees.Recipients.Add objAttendees(x) ' <---
Case 4
strMeetStatus = "Declined"
ide = ide + 1
End Select
If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
Else
objAttendeeOpt = objAttendeeOpt & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
End If
Next
strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & vbCrLf & _
"Location: " & strLocation & vbCrLf & "Start: " & dtStart & vbCrLf & "End: " & dtEnd & _
vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
strCount = "Accepted: " & ia & vbCrLf & _
"Declined: " & ide & vbCrLf & _
"Tentative: " & it & vbCrLf & _
"No response: " & ino
'Set ListAttendees = Application.CreateItem(olMailItem)
ListAttendees.body = strCopyData & vbCrLf & strCount
ListAttendees.Display
ListAttendees.Recipients.ResolveAll ' <---
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub
Building upon what #niton wrote, I've added support for checking against the Global Address List. This code could be extended to search all address lists available to you by iterating through myAddressLists, however, in most cases, that will probably be more than wanted.
Note that this isn't optimized for speed, but even a list with a few hundred people invited against a GAL of tens of thousands won't take a computer very long to iterate through. Since this doesn't get run very often, the time saved for optimizing this just didn't seem worth it.
Option Explicit
Sub GetAttendeeList()
Dim x As Integer
Dim y As Integer
Dim ino As Integer
Dim it As Integer
Dim ia As Integer
Dim ide As Integer
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim strAttendeeName As String
Dim strAttendeeEmail As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount As String
Dim strCity As String
Dim folContacts As Outlook.MAPIFolder
Dim oContact As Outlook.ContactItem
Dim colItems As Outlook.Items
Dim oNS As Outlook.NameSpace
Dim ListAttendees As MailItem
Dim strNewRecord As String
Dim myAddressLists As AddressLists
Dim myAddressEntries As AddressEntries
Dim myAddressEntry As AddressEntry
Dim myExchangeUser As ExchangeUser
Dim myExchangeDL As ExchangeDistributionList
Dim myContactItem As ContactItem
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
Set myAddressLists = oNS.AddressLists
Set myAddressEntries = myAddressLists.Item("Global Address List").AddressEntries
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients
On Error GoTo EndClean:
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "This code only works with meetings."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.Location
strNotes = objItem.Body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
' Get The Attendee List
For x = 1 To objAttendees.Count
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response (or Organizer)"
ino = ino + 1
Case 1
strMeetStatus = "Organizer"
ino = ino + 1
Case 2
strMeetStatus = "Tentative"
it = it + 1
Case 3
strMeetStatus = "Accepted"
ia = ia + 1
Case 4
strMeetStatus = "Declined"
ide = ide + 1
End Select
strAttendeeName = objAttendees(x).Name
strAttendeeEmail = objAttendees(x).Address
Set oContact = colItems.Find("[Email1Address] = '" & strAttendeeEmail & "'")
If Not oContact Is Nothing Then
Debug.Print "Test", oContact.BusinessAddressCity
strCity = oContact.MailingAddressCity & ", " & oContact.MailingAddressState
End If
If InStr(strAttendeeEmail, "#") = 0 Then
Debug.Print "Searching: " & objAttendees(x).Name
Set myAddressEntry = myAddressEntries.GetFirst()
Do While Not myAddressEntry Is Nothing
If myAddressEntry.Address Like objAttendees(x).Address Then
Debug.Print "Found: " & myAddressEntry.Name
Set myExchangeUser = myAddressEntry.GetExchangeUser()
Set myExchangeDL = myAddressEntry.GetExchangeDistributionList()
Set myContactItem = myAddressEntry.GetContact()
If Not myExchangeUser Is Nothing Then
strAttendeeEmail = myExchangeUser.PrimarySmtpAddress
End If
If Not myExchangeDL Is Nothing Then
strAttendeeEmail = myExchangeDL.PrimarySmtpAddress
End If
If Not myContactItem Is Nothing Then
strAttendeeEmail = myContactItem.Email1Address
End If
GoTo ContactFound
End If
Set myAddressEntry = myAddressEntries.GetNext()
Loop
End If
ContactFound:
strNewRecord = objAttendees(x).Name & vbTab & strAttendeeEmail & vbTab & strMeetStatus & vbTab & strCity & vbCrLf
If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & strNewRecord
Else
objAttendeeOpt = objAttendeeOpt & strNewRecord
End If
Next
strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & vbCrLf & _
"Location: " & strLocation & vbCrLf & "Start: " & dtStart & vbCrLf & "End: " & dtEnd & _
vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
strCount = "Accepted: " & ia & vbCrLf & _
"Declined: " & ide & vbCrLf & _
"Tentative: " & it & vbCrLf & _
"No response: " & ino
Set ListAttendees = Application.CreateItem(olMailItem)
ListAttendees.Body = strCopyData & vbCrLf & strCount & vbCrLf & Time
ListAttendees.Display
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function

VBA To send mail using Filesearch

I have this code to send mail to multiple recipients using Lotus Notes. Right now I need to mention the entire file path for the attachments. My requirement is to use FileSearch method - mention any part of the name of the attachment within * * - so that the files get attached.
Sub Send()
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim direct As Object
Dim Var As Variant
Dim flag As Boolean
Dim cell As Range
Dim r As Excel.Range
Dim Name As String
Dim Annex As String
Dim recp As Variant
Dim cc As Variant
Dim Resp As Long
Resp = MsgBox(prompt:="Do you wish to send to the mail?", Buttons:=vbYesNo + vbInformation + vbDefaultButton2, Title:=AppHeader)
If Resp = vbYes Then
Sheets("Sheet2").Activate
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "E").Value) = "yes" Then
Set oSess = CreateObject("Notes.NotesSession")
Set oDB = oSess.GETDATABASE("", "")
Call oDB.OPENMAIL
flag = True
If Not (oDB.IsOpen) Then flag = oDB.Open("", "")
If Not flag Then
MsgBox "Can't open mail file: " & oDB.SERVER & " " & oDB.FILEPATH
GoTo exit_SendAttachment
End If
On Error GoTo err_handler
'Building Message
recp = Cells(cell.Row, "B").Value
cc = Cells(cell.Row, "C").Value
Set oDoc = oDB.CREATEDOCUMENT
Set oItem = oDoc.CREATERICHTEXTITEM("BODY")
oDoc.Form = "Memo"
oDoc.Subject = "HI" & "-" & Cells(cell.Row, "D").Value
oDoc.sendto = Split(recp, ",")
oDoc.copyto = Split(cc, ",")
oDoc.body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please find attached "
oDoc.postdate = Date
oDoc.SaveMessageOnSend = True
Name = Cells(cell.Row, "F").Value
Annex = Cells(cell.Row, "G").Value
Call oItem.EmbedObject(1454, "", Name)
Call oItem.EmbedObject(1454, "", Annex)
oDoc.Send False
End If
Next cell
MsgBox prompt:="Mail Sent", Buttons:=vbOKOnly + vbInformation, Title:=AppHeader
Exit Sub
'Attaching DATABASE
For Each r In Range("Fpath") '// Change to suit
If r.Value <> vbNullString Then
Call Send
End If
Next
oDoc.visable = True
'Sending Message
exit_SendAttachment:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing
'Done
err_handler:
If Err.Number = 7225 Then
MsgBox "File doesn't exist"
Else
MsgBox Err.Number & " " & Err.Description
End If
On Error GoTo exit_SendAttachment
Else
Sheets("Sheet1").Activate
End If
End Sub
Any thoughts will be highly appreciated.
It's been years since I have worked with Lotus notes. The last question that I answered on Lotus notes was way back in July 26, 2011 So be gentle on me if I miss any syntax. :p
Application.FileSearch method is no longer supported from XL2007+
Reference: Error message when you run a macro to search for a file in an Office 2007 program: "Run-time error 5111"
In case the above link dies, here is the screenshot.
As mentioned in that link You can use the FileSystemObject object to recursively search directories and to find specific files. Here is how we do that
In case the above link dies, here is the code from that link.
'~~> COURTESY: http://support.microsoft.com/kb/185601
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
Private Sub Command1_Click()
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String
sDir = InputBox("Type the directory that you want to search for", _
"FileSystemObjects example", "C:\")
sSrchString = InputBox("Type the file name that you want to search for", _
"FileSystemObjects example", "vb.ini")
MousePointer = vbHourglass
Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..."
lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
MousePointer = vbDefault
MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _
" directories", vbInformation
MsgBox "Total Size = " & lSize & " bytes"
End Sub
Private Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long) As Currency
Dim tFld As Folder, tFil As File, FileName As String
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, _
FileName))
nFiles = nFiles + 1
List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
FileName = Dir() ' Get next file
DoEvents
Wend
Label1 = "Searching " & vbCrLf & fld.Path & "..."
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
Next
End If
Exit Function
Catch: FileName = ""
Resume Next
End Function
Once you are able to select the files you can use the below code in a loop to add the attachments
stAttachment = "Blah Blah.Txt"
Set obAttachment = oDoc.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)