Option Compare Database
Option Explicit
'Public Sub ImportExcelData()
'
'On Error GoTo IED_Error
'
'Dim MyDb As Database, rsIn As Recordset, rsOut As Recordset, strSource As String, intPos As Integer, intZ As Integer
'Dim strFullName As String, lngNID As Long
'
'Set MyDb = CurrentDb
'Set rsIn = MyDb.OpenRecordset("Select * From ExcelData Where [CONTACT] is not null;", dbOpenDynaset)
'Set rsOut = MyDb.OpenRecordset("ExcelTemp", dbOpenDynaset)
'
'DoCmd.SetWarnings False
'DoCmd.RunSQL "Delete * From ExcelTemp;"
'DoCmd.SetWarnings True
'
'strSource = InputBox("Enter a Source Code for this import", "Source Code")
'intZ = 0
'lngNID = DMax("[CustomerID]", "header", "") + 1
'
'Do Until rsIn.EOF
' strFullName = Trim(rsIn![CONTACT])
' intPos = InStr(1, strFullName, " ")
' With rsOut
' .AddNew
' !ID = lngNID
' !Source = strSource
' If intPos > 0 Then
' !FirstName = LTrim(Left(strFullName, intPos - 1))
' !Surname = Mid(strFullName, intPos + 1)
' Else
' !FirstName = strFullName
' !Surname = "Unknown"
' End If
' !Suburb = Trim(rsIn!City)
' !Email = Trim(rsIn!INETADDR)
' !Home = Trim(rsIn!Phone1)
' !Work = Trim(rsIn!Phone2)
' !Mobile = Trim(rsIn!Phone3)
' .Update
' End With
' intZ = intZ + 1
' rsIn.MoveNext
' lngNID = lngNID + 1
'Loop
'
'MsgBox intZ & " records imported. Duplicated surnames will now be displayed.", vbInformation, "Import Completed"
'
'DoCmd.OpenQuery "qryExcelDupSurname"
'
'IED_Exit:
' Exit Sub
'
'IED_Error:
' MsgBox Err.Number & " " & Err.Description
' Resume IED_Exit
'End Sub
Sub ImportContactsFromOutlook()
' This code is based in Microsoft Access.
' Set up DAO objects (uses existing "Header" table)
Dim Rst As DAO.Recordset, iNumContacts As Integer, i As Integer
Set Rst = CurrentDb.OpenRecordset("Header")
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olNs As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty
Set olNs = ol.GetNamespace("MAPI")
Set cf = olNs.GetDefaultFolder(olFolderContacts)
Set objItems = cf.Items
iNumContacts = objItems.Count
If iNumContacts <> 0 Then
For i = 1 To iNumContacts
If TypeName(objItems(i)) = "ContactItem" Then
Set c = objItems(i)
Rst.AddNew
Rst!FirstName = c.FirstName
If c.LastName = "" Then
Rst!LastName = "Unknown"
Else
Rst!LastName = c.LastName
End If
'rst!Address = c.BusinessAddressStreet
'rst!City = c.BusinessAddressCity
'rst!State = c.BusinessAddressState
'rst!Zip_Code = c.BusinessAddressPostalCode
' Custom Outlook properties would look like this:
' rst!AccessFieldName = c.UserProperties("OutlookPropertyName")
Rst.Update
End If
Next i
Rst.Close
MsgBox "Finished."
Else
MsgBox "No contacts to export."
End If
End Sub
Public Sub AddNewContact()
Dim Olapp As Outlook.Application
Set Olapp = CreateObject("Outlook.Application")
' Logon. Doesn't hurt if you are already running and logged on...
Dim olNs As Outlook.NameSpace
Set olNs = Olapp.GetNamespace("MAPI")
olNs.Logon
' Create and Open a new contact.
Dim olItem As Outlook.ContactItem
Set olItem = Olapp.CreateItem(olContactItem)
' Setup Contact information...
With olItem
.FullName = "James Smith"
.Birthday = "9/15/1975"
.CompanyName = "Microsoft"
.HomeTelephoneNumber = "704-555-8888"
.Email1Address = "someone@microsoft.com"
.JobTitle = "Developer"
.HomeAddress = "111 Main St." & vbCr & "Charlotte, NC 28226"
End With
' Save Contact...
olItem.Save
' Create a new appointment.
Dim olAppt As Outlook.AppointmentItem
Set olAppt = Olapp.CreateItem(olAppointmentItem)
' Set start time for 2-minutes from now...
olAppt.Start = Now() + (2# / 24# / 60#)
' Setup other appointment information...
With olAppt
.Duration = 60
.Subject = "Meeting to discuss plans..."
.Body = "Meeting with " & olItem.FullName & " to discuss plans."
.Location = "Home Office"
.ReminderMinutesBeforeStart = 1
.ReminderSet = True
End With
' Save Appointment...
olAppt.Save
' Send a message to your new contact.
Dim OlMail As Outlook.MailItem
Set OlMail = Olapp.CreateItem(olMailItem)
' Fill out & send message...
OlMail.To = olItem.Email1Address
OlMail.Subject = "About our meeting..."
OlMail.Body = _
"Dear " & olItem.FirstName & ", " & vbCr & vbCr & vbTab & _
"I'll see you in 2 minutes for our meeting!" & vbCr & vbCr & _
"Btw: I've added you to my contact list."
OlMail.Send
' Clean up...
MsgBox "All done...", vbMsgBoxSetForeground
olNs.Logoff
Set olNs = Nothing
Set OlMail = Nothing
Set olAppt = Nothing
Set olItem = Nothing
Set Olapp = Nothing
End Sub
Function AttachMail()
Dim db As DAO.Database
Dim td As DAO.TableDef
On Error GoTo Errorhandler
Set db = CurrentDb()
Set td = db.CreateTableDef("tblInbox")
'Within the following line, replace <mailbox name> with the actual
'Exchange mailbox name created on your computer. For example:
' Nancy Davolio
td.Connect = "Exchange 4.0;MAPILEVEL=Mailbox - ""|;"
td.Connect = td.Connect & "DATABASE=C:\OutlookStuff\outlook_stuff.mdb;"
'Within the following line, replace <profile name> with the actual
'name of your email profile created on your computer. For example:
' Microsoft Outlook
td.Connect = td.Connect & "PROFILE=Microsoft Outlook"
'Substitute the name of the email folder you wish to attach.
'In this example, we will attach the Inbox folder.
td.SourceTableName = "Inbox"
db.TableDefs.Append td
Application.RefreshDatabaseWindow
MsgBox "Table Appended!"
Exit Function
Errorhandler:
MsgBox "Error " & Err & " " & Error
Exit Function
End Function
Public Sub ImportOutlookItems()
Dim Olapp As Outlook.Application
Dim Olmapi As Outlook.NameSpace
Dim Olfolder As Outlook.MAPIFolder
Dim OlAccept As Outlook.MAPIFolder
Dim OlDecline As Outlook.MAPIFolder
Dim OlFailed As Outlook.MAPIFolder
Dim OlMail As Object 'Have to late bind as appointments e.t.c screw it up
Dim OlItems As Outlook.Items
Dim OlRecips As Outlook.Recipients
Dim OlRecip As Outlook.Recipient
Dim Rst As Recordset
Set Rst = CurrentDb.OpenRecordset("tblTemp") 'Open table tbl_temp
'Create a connection to outlook
Set Olapp = CreateObject("Outlook.Application")
Set Olmapi = Olapp.GetNamespace("MAPI")
'Open the inbox
Set Olfolder = Olmapi.GetDefaultFolder(olFolderInbox)
Set OlItems = Olfolder.Items
'Set up the folders the mails are going to be deposited in
Set OlAccept = Olfolder.Folders("Accept")
Set OlDecline = Olfolder.Folders("Decline")
Set OlFailed = Olfolder.Folders("Failed")
'Set up a loop to run till the inbox is empty (otherwise it skips some)
Do Until OlItems.Count = 0
'Reset the olitems object otherwise new incoming mails and moving mails get missed
Set OlItems = Olfolder.Items
For Each OlMail In OlItems
'For each mail in the collection check the subject line and process accordingly
If OlMail.UnRead = True Then
OlMail.UnRead = False 'Mark mail as read
Rst.AddNew
Rst!Name = OlMail.SenderName
If InStr(1, OlMail.Subject, "Accept") > 0 Then
Rst!Status = "Attending"
Rst!DateSent = OlMail.ReceivedTime
OlMail.Move OlAccept
ElseIf InStr(1, OlMail.Subject, "Decline") > 0 Then
Rst!DateSent = OlMail.ReceivedTime
Rst!Status = "Decline"
OlMail.Move OlDecline
Else
Rst!DateSent = OlMail.ReceivedTime
Rst!Status = "Failed"
OlMail.Move OlFailed
End If
Rst.Update
End If
Next
Loop
MsgBox "Your wish is my command. New mails have been checked. Please check the tbl_temp for details", vbOKOnly
End Sub
Public Sub ForwardEmail(strAddr As String, intRpt As Integer)
' open outlook and process email form sourcefolder by forwarding them
' and moving them to the Forwarded folder
'On Error Resume Next
Dim oOutlook As Outlook.Application
Dim oNameSpace As Outlook.NameSpace
Dim oStartFolder As Outlook.MAPIFolder
Dim oSourceFolder As Outlook.MAPIFolder
Dim oSentFolder As Outlook.MAPIFolder
Dim oMailItem As Outlook.MailItem
Dim oForewardItem As Outlook.MailItem
Dim oAttachment As Outlook.Attachment
Dim oMyObject As Object
Dim fWeOpenedOutlook As Boolean
Dim i As Long
Dim lngHowMany As Long
Set oOutlook = New Outlook.Application
If oOutlook.ActiveExplorer Is Nothing Then
fWeOpenedOutlook = True
End If
Set oNameSpace = oOutlook.GetNamespace("MAPI")
Set oStartFolder = oNameSpace.GetDefaultFolder(olFolderInbox)
Select Case intRpt
Case 1
Set oSourceFolder = oStartFolder.Folders("EQReport1")
'lngHowMany = oSourceFolder.Items.Count
'For i = lngHowMany To 1 Step -1
Set oMyObject = oSourceFolder.Items(1)
If oMyObject.Class = 43 Then
Set oMailItem = oSourceFolder.Items(1).Copy
oMailItem.To = strAddr
oMailItem.Forward
oMailItem.Send
DoEvents
End If
Set oMyObject = Nothing
Set oMailItem = Nothing
Set oSourceFolder = oStartFolder.Folders("EQReport2")
Set oMyObject = oSourceFolder.Items(1)
If oMyObject.Class = 43 Then
Set oMailItem = oSourceFolder.Items(1).Copy
oMailItem.To = strAddr
oMailItem.Forward
oMailItem.Send
DoEvents
End If
Set oMyObject = Nothing
Set oMailItem = Nothing
'Next
Case 2
Set oSourceFolder = oStartFolder.Folders("EQReport2")
Set oMyObject = oSourceFolder.Items(1)
If oMyObject.Class = 43 Then
Set oMailItem = oSourceFolder.Items(1).Copy
oMailItem.To = strAddr
oMailItem.Forward
oMailItem.Send
DoEvents
End If
Set oMyObject = Nothing
Set oMailItem = Nothing
Case 3
Set oSourceFolder = oStartFolder.Folders("EQReport3")
End Select
Set oSourceFolder = Nothing
Set oStartFolder = Nothing
Set oNameSpace = Nothing
If fWeOpenedOutlook Then
'oOutlook.Quit
End If
Set oOutlook = Nothing
End Sub
Function IsEmail(strText)
Dim RegEx
Set RegEx = New RegExp
RegEx.Pattern = "^[\w\-\._]+@[\w\-]{2,}(\.[\w\-]{2,})+$"
'or "^([\w-_]+\.)*[\w-_]+\@ ([\w-_]+\.)+[a-zA-Z]{2,3}$"
RegEx.ignoreCase = True
RegEx.Global = True
IsEmail = RegEx.Test(strText)
End Function
Function testEmail() As Boolean
Dim MyDb As Database, rsClients As Recordset, strEmail As String
Set MyDb = CurrentDb
Set rsClients = MyDb.OpenRecordset("Select * From Header Where Unsubscribe = False And Email is not null;", dbOpenDynaset)
Do Until rsClients.EOF
strEmail = rsClients!Email
If IsEmail(strEmail) Then
' email address ok
'Debug.Print "OK"
testEmail = True
rsClients.Edit
rsClients!BadEmail = False
rsClients.Update
Else
' email address not ok
'Debug.Print "False"
rsClients.Edit
rsClients!BadEmail = True
rsClients.Update
End If
rsClients.MoveNext
Loop
DoCmd.OpenQuery "qryBadEmails"
End Function
I'm also surprised this kb hasn't been posted yet though:
