Wondering if someone might be able to help me solve this issue. Have an Access database where I want to send an email for each "Submit" box that is checked is checked. Have tried several thing and either get 1 record processed before the code stops or will give me several emails for the same record without moving on. Any help with where I am missing the boat would be much appreciated. Below is what I have for the code:
Dim r As DAO.Recordset
Set r = CurrentDb.OpenRecordset("SELECT * FROM [CIs_All_Statuses] WHERE [Submit] = True")
If r.RecordCount = 0 Then
MsgBox ("No records selected")
GoTo Done
Else
End If
r.MoveFirst
i = 1
Begin:
Do Until r.EOF = True
product = r![Product Name]
serial = r![Serial Number]
agency = r![Company]
User = r![Used By]
Submit = r![Submit]
Processed = r![Processed]
If Processed = True Then
r.Edit
r("Submit").Value = False
r.Update
r.MoveNext
GoTo Begin
Else
End If
r.Edit
r("Processed").Value = True
r.Update
r.Edit
r("Submit").Value = False
r.Update
r.MoveNext
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
' prevent 429 error, if outlook not open
On Error Resume Next
Err.Clear
Set oOutlook = GetObject(, "Outlook.application")
If Err.Number <> 0 Then
Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
.To = "#email.com"
.CC = Me.Used_By
.Subject = "EmailTicket: [Subject]"
.Body = "Equipment to be verified:" & Space(2) & product & vbCrLf & "Serial Number:" & Space(2) & serial & vbCrLf & "Agency:" & Space(2) & agency & vbCrLf & "User Name:" & Space(2) & User & vbCrLf & vbCrLf & "By inserting the user name in the CC line the Customer Information on the Incident Customer tab will be auto-completed. ONLY append information to the end of the SUBJECT LINE"
.Display
End With
r.MoveNext
Check:
Do While r.EOF = False
NextComputer = r![Serial Number]
If (serial = NextComputer) Then
r.Edit
r("Submit").Value = False
r.Update
r.Edit
r("Processed").Value = True
r.Update
r.MoveNext
GoTo Check
Else
r.MovePrevious
End If
Loop
r.MovePrevious
Loop
r.Close
Set r = Nothing
Done:
End Sub
It is - among other things - the GoTo Check.
Remove that and rebuild your loop.
Also, you only need one .Edit and .Update for each record.
Related
I use the following code assigned to a CommandButton to automatically attach the workbook to an email so users can send it out. Is there a way to attach the workbook without the code, so the people receiving the email do not have the full code, but the sender keeps it in their copy? (The recipients only need to see the data, they do not interact with the form, but the sender interacts with it several times a day.) When I save the Workbook as .xlsx, it gives me an yes/no/help MsgBox that I would like to avoid during the sending - to keep it as a "one-click" operation.
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
Option Explicit
Sub CDO_Mail_Workbook()
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
'TempFileName = wb.Name & " " & Format(Now, "yyyy-mmm-dd")
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
'FileExtStr = "." & LCase(Right(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".", , 1)))
FileExtStr = ".xlsm"
Application.DisplayAlerts = False
' wb.SaveAs Filename:=TempFilePath & TempFileName & FileExtStr, FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.SaveCopyAs Filename:=TempFilePath & TempFileName & "Copy" & FileExtStr
Workbooks.Open (TempFilePath & TempFileName & "Copy" & FileExtStr)
ActiveWorkbook.SaveAs Filename:=TempFilePath & TempFileName & "-email" & ".xlsx", FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.Close False
'wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
'.To = "noone#noone.com"
'.CC = ""
.BCC = ""
.From = "noone#noone.com"
.Subject = "Test - " & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & "-email" & ".xlsx"
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & "-email" & ".xlsx"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
To send a single worksheet with the vba code removed, I've used this:
Option Explicit
'This procedure will send the ActiveSheet in a new workbook
'For more sheets use : Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Sub CDO_Mail_ActiveSheet_Or_Sheets()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim iMsg As Object
Dim iConf As Object
Dim sh As Worksheet
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Dim wb As Workbook
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
'Or if you want to copy more then one sheet use:
'Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Change all cells in Destwb to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Next sh
Destwb.Worksheets(1).Select
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
Application.DisplayAlerts = False
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close savechanges:=False
End With
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "noone#noone.com"
'.CC = ""
'.BCC = ""
.From = "noone#noone.com"
.Subject = "Test-" & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
I am struggling with the above error when trying to write the Visual Basic code for a 2010 Access Form. I am trying to get ensure that the associate and the Team Lead get the same email. When I first wrote the code, it worked initially. I have since added an "issue date" to the form, but not to the email. I attempted to add the issue date to the Script, but that did not work. I have since removed both the issue date from the form and the script. Any help would appreciated:
Private Sub cmdEmail_Click()
Dim objOutlook As Object
Dim objMailItem As Object
Const olMailItem As Integer = 0
Dim objMailItem1 As Object
Const olMailItem1 As Integer = 0
Set objOutlook = CreateObject("Outlook.Application")
Set objMailItem = objOutlook.CreateItem(olMailItem)
Set objMailItem1 = objOutlook.CreateItem(olMailItem1)
Dim strPathAttach As String
On Error GoTo err_Error_handler
'set receipient, you can use a DLookup() to retrieve your associate Email address
objMailItem.To = DLookup("Email_ID", "dbo_Noble_Associates", "[Fullname]='" & Me.cboAssociate & "'")
objMailItem1.To = DLookup("Email_ID", "dbo_TeamLeads$", "[Fullname]='" & Me.txtTeamLead & "'")
'set subject with text and Form values
objMailItem.Subject = "Attendance Violation " & Me.cboAssociate
objMailItem1.Subject = "Attendance Violation " & Me.cboAssociate
'set body content with text and Form values etc.
objMailItem.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
objMailItem1.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
' display email
' objMailItem.Display
' sending mail automaticly
objMailItem.Send
objMailItem1.Send
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
exit_Error_handler:
On Error Resume Next
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
Exit Sub
err_Error_handler:
Select Case Err.Number
'trap error 287
Case 287
MsgBox "Canceled by user.", vbInformation
Case Else
MsgBox "Error " & Err.Number & " " & Err.Description
End Select
Resume exit_Error_handler
End Sub
Private Sub CheckEmail_Click()
End Sub
Private Sub cmdSaveandNew_Click()
If Me.txtOccurrence_Date & "" = "" Then
MsgBox "Please enter the date."
Me.txtOccurrence_Date.SetFocus
Exit Sub
ElseIf Me.cboAssociate & "" = "" Then
MsgBox "Please select the associate's name."
Me.cboAssociate.SetFocus
Exit Sub
ElseIf Me.txtPoints & "" = "" Then
MsgBox "Please enter the number of Points."
Me.txtPoints.SetFocus
Exit Sub
End If
If Me.CheckEmail = True Then
cmdEmail_Click
End If
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cmd_Cancel_Click()
Me.Undo
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cboassociate_AfterUpdate()
Me.txtTeamLead.Value = Me.cboAssociate.Column(1)
End Sub
Private Sub cboFullname_AfterUpdate()
Me.txtCurrentpoints.Value = Me.cbofullname.Column(1)
End Sub
Private Sub CboType_AfterUpdate()
Me.txtPoints.Value = Me.CboType.Column(1)
End Sub
I am open to any suggestions.
I'm using Ron de Bruins code for emailing many different files to different people, as shown below. But the issue I have is, if an email address exists in column B and the corresponding workbook doesn't exist it still creates an email but with no attachment, as there isn't one. Would anyone know how to modify the code so that if a workbook didn't exist it doesn't create the email?
Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You can set a flag to go to the next item if the file does not exist:
Dim noFile as Boolean
noFile = True
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
noFile = False
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
if Not noFile then .Send
There are other ways to do this (see for example Sidharth Rout's suggestion which checks for the existence of files before even starting to create the email); I chose the above because it minimizes the amount of change needed in your existing code (just three lines, easy to see what they do).
Some people would prefer to invert the logic, with a hasFile boolean:
Dim hasFile as Boolean
hasFile = False
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
hasFile = True
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
if hasFile then .Send
I'm hoping someone has already developed a script to do this.
I'm need to query all objects in AD (users, computers, containers (OU's), everything exceot for the forest root) and show which objects in AD do not have the "Include inheritable permissions from this object's parent" attribute checked.
Thanks much
If you show some initiative, I can help in VBS. I wrote a VBS a while ago to query everything in AD for below attributes via LDAP, and putting results in Excel and plain text file.
"objectCategory"
"objectClass"
"objectGUID"
"objectSid"
"sIDHistory"
"sAMAccountName"
"description"
"sAMAccountType"
"userAccountControl"
"whenCreated"
"whenChanged"
"givenName"
"sn"
"displayName"
"title"
"mail"
"physicalDeliveryOfficeName"
"memberOf"
"telephoneNumber"
"mobile"
"pager"
"company"
"lastLogon"
"badPwdCount"
"badPasswordTime"
"streetAddress"
"l"
"postalCode"
"st"
"co"
I will show you my first 50/360 lines of code:
Const ADS_SCOPE_SUBTREE = 2
Const PageSize = 2000
Const GAP = "——————————————————————————————————————————————————"
'=== Public Variables ===
Dim aADProp, sRootLDAP, oRecordSet, oFSO, oLogFile, oExcel, oWB, oWS
Dim lObjects, lComputersEnabled, lUsersEnabled, lComputersDisabled, lUsersDisabled, lOtherDisabled, lExcelRow
Dim aUAC ' AD's UserAccountControl flags array
Dim aSAT ' AD's sAMAccountType flags array
'==================================================
Main
'==================================================
Sub Main
Init
ConnectAD
If Err.Number = 0 Then ProcessRecords
CleanUp
End Sub
'--------------------------------------------------
Sub Init
Dim dNow
dNow = Now
Wscript.echo dNow & vbTab & "Init"
DefineADProp
DefineUACArray
DefineSATArray
Set oFSO = CreateObject("scripting.filesystemobject")
Set oLogFile = oFSO.CreateTextFile(WScript.ScriptFullName & "_" & Join(Array(Year(dNow),Month(dNow),Day(dNow)),".") & ".log")
sRootLDAP = "'LDAP://" & GetObject("LDAP://RootDSE").Get("defaultNamingContext") & "'"
LogT vbCrlf & Q(WScript.ScriptFullName) & " started."
Logg "RootLDAP: " & sRootLDAP
Logg "Listing AD Attributes: " & Join(aADProp,", ")
Logg GAP
lObjects = 0
lUsersEnabled = 0
lUsersDisabled = 0
lComputersEnabled = 0
lComputersDisabled = 0
lOtherDisabled = 0
If Err.Number = 0 Then
lExcelRow = 1
Set oExcel = CreateObject("Excel.Application")
oExcel.visible = True
Set oWB = oExcel.Workbooks.Add
Set oWS = oWB.Worksheets(1)
oWS.Cells(lExcelRow,1) = "distinguishedName"
oWS.Range(oWS.Cells(lExcelRow,2),oWS.Cells(lExcelRow,UBound(aADProp)+2)) = aADProp
End If
End Sub
Yes I made a mistake and didn't post the question initially. When I posted originally, I wasn't able to enumerate all AD objects and had a question about that, but it is since been resolved and the code below works (in case anyone else needs it - sharing is OK). No need to try and reinvent the wheel if the code already existed. And many thanks to Rems # Petri
'
'//----------------------------- Code below -----------------------------//
'
Const SE_DACL_PROTECTED = &H1000
Dim objRootDSE
With WScript.CreateObject("WScript.Network")
Set objRootDSE = GetObject ("LDAP://" & .UserDomain & "/RootDSE")
End With
strDomainDN = objRootDSE.Get("DefaultNamingContext")
Set objCommand = CreateObject("ADODB.Command")
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection
objCommand.Properties("Searchscope") = 2 ' SUBTREE
objCommand.Properties("Page Size") = 250
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False
objCommand.CommandText = "SELECT ADsPath FROM 'LDAP://" & strDomainDN & "'"
Set objRecordSet = objCommand.Execute
On Error Resume Next
If Not objRecordSet.eof Then
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
ModUser objRecordSet.Fields("ADsPath").Value
objRecordSet.MoveNext
Loop
End If
objRecordset.Close : objConnection.Close
wscript.echo vbCrLf & "-- All done --" : wscript.quit 0
Sub ModUser(strADsPath)
Dim objUser, objNtSecurityDescriptor, intNtSecurityDescriptorControl
Set objuser = GetObject(strADsPath)
Set objNtSecurityDescriptor = objUser.Get("ntSecurityDescriptor")
intNtSecurityDescriptorControl = objNtSecurityDescriptor.Control
If (intNtSecurityDescriptorControl And SE_DACL_PROTECTED) Then
Wscript.Echo objUser.sAMAccountName & " (" & objUser.distinguishedName & ") is NOT checked"
End If
End Sub
Has anyone been able to download email that contains attachment with CDO in vb6?
Can you help me with an example?
I'm still not sure where you want to retrieve email from but here is some code for retrieving email from an Exchange server. I did this as an experiment to learn some methods I would need on another project so it is not production quality but should get you started. This code is dependent on an Exchange client already being setup on the computer this is running on.
This function creates a session and logs in:
Function Util_CreateSessionAndLogon(Optional LogOnName As Variant) As Boolean
On Error GoTo err_CreateSessionAndLogon
Set objSession = CreateObject("MAPI.Session")
objSession.Logon , , False, False
Util_CreateSessionAndLogon = True
Exit Function
err_CreateSessionAndLogon:
Util_CreateSessionAndLogon = False
Exit Function
End Function
This function get information on items in the inbox and demonstrates some of the available properties.
Public Function GetMessageInfo(ByRef msgArray() As String) As Long
Dim objInboxFolder As Folder ' Folder object
Dim objInMessages As mapi.Messages ' Messages collection
Dim objMessage As Message ' Message object
Dim InfoRtnString
Dim i As Long
Dim lngMsgCount As Long
InfoRtnString = ""
If objSession Is Nothing Then
If Util_CreateSessionAndLogon = False Then
Err.Raise 429, "IBS_MAPI_CLASS", "Unable to create MAPI session object."
Exit Function
End If
End If
Set objInboxFolder = objSession.Inbox
Set objInMessages = objInboxFolder.Messages
lngMsgCount = objInMessages.Count
ReDim msgArray(0) 'initalize the array
For Each objMessage In objInMessages
If i / lngMsgCount * 100 > 100 Then
RaiseEvent PercentDone(100)
Else
RaiseEvent PercentDone(i / lngMsgCount * 100)
End If
InfoRtnString = ""
i = i + 1
ReDim Preserve msgArray(i)
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.ID
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.Subject
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.Sender
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.TimeSent
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.TimeReceived
InfoRtnString = InfoRtnString & Chr$(0) & "" 'objMessage.Text
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.Unread
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.Attachments.Count
msgArray(i) = InfoRtnString
DoEvents
Next
GetMessageInfo = i
End Function
This function demonstrates getting attachments from a message.
Function GetAttachments(msgID As String, lstBox As ListBox) As Boolean
Dim objMessage As Message ' Messages object
Dim AttchName As String
Dim i As Integer
Dim x As Long
If objSession Is Nothing Then
x = Util_CreateSessionAndLogon()
End If
Set objMessage = objSession.GetMessage(msgID)
For i = 1 To objMessage.Attachments.Count
Select Case objMessage.Attachments.Item(i).Type
Case Is = 1 'contents of a file
AttchName = objMessage.Attachments.Item(i).Name
If Trim$(AttchName) = "" Then
lstBox.AddItem "Could not read"
Else
lstBox.AddItem AttchName
End If
lstBox.ItemData(lstBox.NewIndex) = i
Case Is = 2 'link to a file
lstBox.AddItem objMessage.Attachments.Item(i).Name
lstBox.ItemData(lstBox.NewIndex) = i
Case Is = 1 'OLE object
Case Is = 4 'embedded object
lstBox.AddItem "Embedded Object"
lstBox.ItemData(lstBox.NewIndex) = i
End Select
Next i
GetAttachments = True
End Function