|
 |
| Recent blog posts: | |
|
| They have birthday today: | |
|
| Forums: | | |
|
| Discuss: | |
|
| Recent forum topics: | |
|
| Recent forum comments: | |
|
| Модератор: | |
|
Friday, 11 August 2006
|
| Avoid copying duplicate contacts to outlook from access Charliej2001@Googlemail.Com 14:12:22 |
| | Hi all
My access database has import/export capabiltiy of contact details
between outlook. The database is getting big now (1000+ contacts) and
so are the outlook address books that have the contacts info in them.
When I export contacts from access to outlook, it takes a long time
because there are so many contacts in the Outlook address book, and it
is checking all of these against the contacts coming in, so as to avoid
duplicates. Can anyones suggest a faster way of checking to see if the
contact already exists in outlook, and so wont be duplicated?
This is how im doing it at the moment
Sub ExportAllContactsToOutlook()
Dim MainContactRST As DAO.Recordset
Set MainContactRST = CurrentDb.OpenRecordset("Contact Details")
'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 cCheck 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
With MainContactRST
.MoveFirst
'Loop through the Contact Details records.
Do While Not .EOF
If iNumContacts <> 0 Then
For i = 1 To iNumContacts
If TypeName(objItems(i)) = "ContactItem" Then
Set cCheck = objItems(i)
If cCheck.CompanyName = MainContactRST!Company
_
And cCheck.FirstName = MainContactRST!FirstName
_
And cCheck.LastName = MainContactRST!LastName _
And cCheck.JobTitle = MainContactRST!JobTitle
Then
GoTo ContactAlreadyExists
End If
End If
Next i
End If
'Create a new Contact item.
Set c = ol.CreateItem(olContactItem)
'Specify which Outlook form to use.
c.MessageClass = "IPM.Contact"
'Add all items about contact from Access table to Outlook
address book
If MainContactRST!Company <> "" Then c.CompanyName =
MainContactRST!Company
If MainContactRST!FirstName <> "" Then c.FirstName =
MainContactRST!FirstName
If MainContactRST!MiddleName <> "" Then c.MiddleName =
MainContactRST!MiddleName
If MainContactRST!LastName <> "" Then c.LastName =
MainContactRST!LastName
If MainContactRST!Title <> "" Then c.Title =
MainContactRST!Title
If MainContactRST!Suffix <> "" Then c.Suffix =
MainContactRST!Suffix
If MainContactRST!JobTitle <> "" Then c.JobTitle =
MainContactRST!JobTitle
.
.
.
.
.
If MainContactRST!WebPage <> "" Then c.WebPage =
MainContactRST!WebPage
' Save and close the contact.
c.Save
ContactAlreadyExists:
.MoveNext
Loop
MainContactRST.Close
Set MainContactRST = Nothing
Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing
MsgBox "Finished exporting to Outlook"
End With
End Sub
|
| |  1 answer | Add comment |
|
| Export CSV and update column with Now() John Graham 13:37:17 |
| | I thought this would be easier, however I seem to be struggling with
this.
I'd like to create a command button that will look at a certain query I
have created and export the records as a csv file, and also update a
field called dateModified to Now(). That way the next time I run the
query, it looks for null records in dateModified and only executes
records that have not been processed.
I've seen two approaches mentioned. TransferText, and output file in
VBA. I'm fine with either, just need to find a good example.
John
|
| | 3 answer | Add comment |
|
| Search pattern Eric 13:35:37 |
| | Hi: I have two files. I search pattern ":" from emails text file and
save email contents into a database. Another search pattern "[" from
emails text file and same save it into database. Both database works
the same save emails which are in a text file and put them into
database. My problem is that the one which search ":" pattern has to be
change with search pattern "[" style one. It needs minor changes in
the search ":" pattern file but i dont know where would i do the
changes. Need Help
File Search ":" Pattern (Needs to be change)
--------------------------------
Option Compare Database
Option Explicit
Private Sub Command26_Click()
DoCmd.Close
End Sub
Private Sub cmdParse_Click()
DoCmd.SetWarnings False
Dim strfile As String
Dim AcctNum As String
AcctNum = "Account Number"
'Box
Credits----------------------------------------------------------------------------
'-----------------------------------------------------------------------------------
ChDir ("C:\MailSave\Requests\")
strfile = Dir("C:\MailSave\Requests\200" & "*.*")
Do While Len(strfile) > 0
FileCopy "C:\MailSave\Requests\" & strfile,
"C:\MailSave\GetInfo.txt"
Dim fileName As String
Dim stemp, linesfromfile, nextline As String
Dim iFIle As Integer
iFIle = FreeFile
Open "C:\MailSave\Requests\" & strfile For Input As iFIle
While Not EOF(1)
Line Input #1, nextline
linesfromfile = linesfromfile + nextline + Chr(13) + Chr(10)
Wend
Close iFIle
Call TestReplace
Me.txtEmail.Value = linesfromfile
Kill "C:\MailSave\Requests\" & strfile
strfile = Dir("C:\MailSave\Requests\200" & "*.*")
linesfromfile = ""
Dim strEmail As String
Dim bNameFound As Boolean
Dim bAddressFound As Boolean
Dim bCityStateZipFound As Boolean
Dim bSubjectFound As Boolean
Dim bReturnMethodFound As Boolean
Dim bAccountNumFound As Boolean
Dim bReturnDateFound As Boolean
Dim bCommentsFound As Boolean
Dim bBoxTypeFound As Boolean
Dim bBoxQtyFound As Boolean
Dim bCreditAmountFound As Boolean
Dim bConvertersFound As Boolean
Dim bSenderFound As Boolean
Dim bRequestDateFound As Boolean
Dim strStringBefore As String
Dim strName As String
Dim strAddress As String
Dim strCityStateZip As String
Dim strSubject As String
Dim strReturnMethod As String
Dim strAccountNum As String
Dim strCurrentChar As String
Dim strReturnDate As String
Dim strComments As String
Dim strBoxType As String
Dim strBoxQty As String
Dim strCreditAmount As String
Dim strConverterNumbers As String
Dim strSender As String
Dim strRequestDate As String
Dim lngLengthOfEmail As Long
Dim lngCharPointer1 As Long
Dim lngCharPointer2 As Long
Dim dbDatabase As DAO.Database
Dim rsRecordset As DAO.Recordset
If (IsNull(Me.txtEmail.Value)) Then
MsgBox "[Email] field is blank. Please try again.",
vbExclamation + vbOKOnly
Me.txtEmail.SetFocus
Exit Sub
End If
Me.txtStatusBar.Value = "Parsing..."
strEmail = Me.txtEmail.Value
' Initialize
bNameFound = False
bAddressFound = False
bCityStateZipFound = False
bSubjectFound = False
bReturnMethodFound = False
bAccountNumFound = False
bCommentsFound = False
bBoxQtyFound = False
bBoxTypeFound = False
bCreditAmountFound = False
bConvertersFound = False
bReturnDateFound = False
bSenderFound = False
bRequestDateFound = False
strRequestDate = ""
strName = ""
strAddress = ""
strCityStateZip = ""
strSubject = ""
strReturnMethod = ""
strAccountNum = ""
strStringBefore = ""
strComments = ""
strBoxQty = ""
strBoxType = ""
strCreditAmount = ""
strConverterNumbers = ""
strReturnDate = ""
strSender = ""
lngLengthOfEmail = Len(strEmail)
lngCharPointer1 = 0
' Search for request date, sender name
Do While (strCurrentChar <> ")")
'And (Not bCommentsFound))
strCurrentChar = Left(strEmail, 1)
If (strCurrentChar = ":") Then
' Search for keywords in string before ':'
If (InStr(strStringBefore, "Date")) Then
If (Not bRequestDateFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save name until crlf
Do While (strCurrentChar <> vbCr)
strRequestDate = strRequestDate & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bRequestDateFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Sender--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "kdb by")) Then
If (Not bSenderFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> ")")
strSender = strSender & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bSenderFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
Else
' Reset string before ':' and move to the next character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
Else
' Append this character to string that is before ':'
strStringBefore = strStringBefore & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
' Advance the character pointer
lngCharPointer1 = lngCharPointer1 + 1
Loop
'Get rid of 1st line, has keyword 'name' in name change form
'strCurrentChar = Left(strEmail, 1)
'Do While (strCurrentChar <> ".")
'Move to the next character
' strEmail = Right(strEmail, (Len(strEmail) - 1))
' strCurrentChar = Left(strEmail, 1)
' lngCharPointer1 = lngCharPointer1 + 1
'Loop
'Move to the next character=
Do While ((lngCharPointer1 <= lngLengthOfEmail))
'And (Not bCommentsFound))
strCurrentChar = Left(strEmail, 1)
If (strCurrentChar = ":") Then
' Search for keywords in string before ':'
'Name--------------------------------------------------------------
If (InStr(strStringBefore, "Name")) Then
If (Not bNameFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save name until crlf
Do While (strCurrentChar <> vbCr)
strName = strName & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bNameFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Subject--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Subject")) Then
If (Not bSubjectFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strSubject = strSubject & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bSubjectFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Return
Method--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Return Method")) Then
If (Not bReturnMethodFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strReturnMethod = strReturnMethod & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bReturnMethodFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Return
Date--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Date of Return")) Then
If (Not bReturnDateFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strReturnDate = strReturnDate & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bReturnDateFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Account
Number-------------------------------------------------------
ElseIf (InStr(strStringBefore, AcctNum)) Then
If (Not bAccountNumFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strAccountNum = strAccountNum & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bAccountNumFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'BoxType--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Type Of Box")) Then
If (Not bBoxTypeFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strBoxType = strBoxType & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bBoxTypeFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'BoxQty--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "How Many Boxes")) Then
If (Not bBoxQtyFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strBoxQty = strBoxQty & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bBoxQtyFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'CreditAmount--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Amount To Credit")) Then
If (Not bCreditAmountFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strCreditAmount = strCreditAmount & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bCreditAmountFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'ConverterNumbers--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "ConverterNumbers")) Then
If (Not bConvertersFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strConverterNumbers = strConverterNumbers &
strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bConvertersFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Comments--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Comments")) Then
If (Not bCommentsFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strComments = strComments & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bCommentsFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Address--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Address")) Then
If (Not bAddressFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strAddress = strAddress & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bAddressFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'CityStateZip--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Zip")) Then
If (Not bCityStateZipFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save city, state, zip until cr
Do While ((strCurrentChar <> vbCr) And (Not
(lngCharPointer1 > lngLengthOfEmail)))
strCityStateZip = strCityStateZip & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bCityStateZipFound = True
End If
Else
' Reset string before ':' and move to the next character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
Else
' Append this character to string that is before ':'
strStringBefore = strStringBefore & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
' Advance the character pointer
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Clear white space, from right
If (bNameFound) Then
strCurrentChar = Right(strName, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strName = Left(strName, (Len(strName) - 1))
strCurrentChar = Right(strName, 1)
Loop
End If
If (bSenderFound) Then
strCurrentChar = Right(strSender, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strSender = Left(strSender, (Len(strSender) - 1))
strCurrentChar = Right(strSender, 1)
Loop
End If
If (bSubjectFound) Then
strCurrentChar = Right(strSubject, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strSubject = Left(strSubject, (Len(strSubject) - 1))
strCurrentChar = Right(strSubject, 1)
Loop
End If
If (bReturnMethodFound) Then
strCurrentChar = Right(strReturnMethod, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strReturnMethod = Left(strReturnMethod, (Len(strReturnMethod) -
1))
strCurrentChar = Right(strReturnMethod, 1)
Loop
End If
If (bAccountNumFound) Then
strCurrentChar = Right(strAccountNum, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strAccountNum = Left(strAccountNum, (Len(strAccountNum) - 1))
strCurrentChar = Right(strAccountNum, 1)
Loop
End If
If (bAddressFound) Then
strCurrentChar = Right(strAddress, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strAddress = Left(strAddress, (Len(strAddress) - 1))
strCurrentChar = Right(strAddress, 1)
Loop
End If
If (bCityStateZipFound) Then
strCurrentChar = Right(strCityStateZip, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strCityStateZip = Left(strCityStateZip, (Len(strCityStateZip) -
1))
strCurrentChar = Right(strCityStateZip, 1)
Loop
End If
If (bReturnDateFound) Then
strCurrentChar = Right(strReturnDate, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strReturnDate = Left(strReturnDate, (Len(strReturnDate) - 1))
strCurrentChar = Right(strReturnDate, 1)
Loop
End If
If (bBoxTypeFound) Then
strCurrentChar = Right(strReturnDate, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strReturnDate = Left(strReturnDate, (Len(strReturnDate) - 1))
strCurrentChar = Right(strReturnDate, 1)
Loop
End If
If (bBoxQtyFound) Then
strCurrentChar = Right(strReturnDate, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strReturnDate = Left(strReturnDate, (Len(strReturnDate) - 1))
strCurrentChar = Right(strReturnDate, 1)
Loop
End If
If (bCreditAmountFound) Then
strCurrentChar = Right(strReturnDate, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strReturnDate = Left(strReturnDate, (Len(strReturnDate) - 1))
strCurrentChar = Right(strReturnDate, 1)
Loop
End If
If (bCommentsFound) Then
strCurrentChar = Right(strComments, 1)
Do While (strCurrentChar = " ")
' Advance 1 char, from right
strComments = Left(strComments, (Len(strComments) - 1))
strCurrentChar = Right(strComments, 1)
Loop
End If
Me.txtStatusBar.Value = "Parsing...Complete."
'Debug.Print _
' "Name Found: " & bNameFound & vbCrLf & _
' "Name: " & strName & vbCrLf & vbCrLf & _
' "Address Found: " & bAddressFound & vbCrLf & _
' "Address: " & strAddress & vbCrLf & vbCrLf & _
' "City, State, Zip Found: " & bCityStateZipFound & vbCrLf & _
' "City, State, Zip: " & strCityStateZip
If (bNameFound And bAddressFound And bCityStateZipFound And
bSubjectFound And bAccountNumFound) Then
Me.txtStatusBar.Value = "Creating record..."
' Found all the fields
Set dbDatabase = CurrentDb()
Set rsRecordset = dbDatabase.OpenRecordset("tblCustomers")
' Create a new record with parsed info
rsRecordset.AddNew
rsRecordset.Fields(1).Value = UCase(strRequestDate)
rsRecordset.Fields(2).Value = UCase(strName)
rsRecordset.Fields(3).Value = UCase(strSender)
rsRecordset.Fields(4).Value = UCase(strAddress)
rsRecordset.Fields(5).Value = UCase(strCityStateZip)
rsRecordset.Fields(6).Value = UCase(strSubject)
rsRecordset.Fields(7).Value = UCase(strReturnMethod)
rsRecordset.Fields(8).Value = UCase(strAccountNum)
rsRecordset.Fields(9).Value = UCase(strReturnDate)
rsRecordset.Fields(10).Value = UCase(strBoxType)
rsRecordset.Fields(11).Value = UCase(strBoxQty)
rsRecordset.Fields(12).Value = UCase(strCreditAmount)
rsRecordset.Fields(13).Value = UCase(strConverterNumbers)
rsRecordset.Fields(14).Value = UCase(strComments)
rsRecordset.Update
rsRecordset.Close
Set rsRecordset = Nothing
dbDatabase.Close
Set dbDatabase = Nothing
Else
'Could not find all or some of the fields
'Add incomplete record to exceptions table for manual processing.
Set dbDatabase = CurrentDb()
Set rsRecordset = dbDatabase.OpenRecordset("tblExceptions")
rsRecordset.AddNew
rsRecordset.Fields(1).Value = Me.txtEmail.Value
rsRecordset.Fields(2).Value = Now()
rsRecordset.Update
rsRecordset.Close
Set rsRecordset = Nothing
dbDatabase.Close
Set dbDatabase = Nothing
'MsgBox "Could not find a field. Please try again.", vbExclamation
+ vbOKOnly
End If
' Clear email field and get ready for another one
Me.txtEmail.Value = Null
Me.txtEmail.SetFocus
Kill "C:\MailSave\GetInfo.txt"
Loop
DoCmd.SetWarnings False
DoCmd.OpenQuery "qry_LoadWork", acViewNormal, acEdit
DoCmd.OpenQuery "qry_UpdateBCSubject", acViewNormal, acEdit
DoCmd.OpenQuery "qry_UpdateCRSubject", acViewNormal, acEdit
DoCmd.OpenQuery "qry_DeleteParsed", acViewNormal, acEdit
Me.txtStatusBar.Value = "Creating record...Complete."
Exit_cmdParse_Click:
Exit Sub
End Sub
--------------------------------------------------------------------------------------------------
File Search "[" Pattern
--------------------------------
Option Compare Database
Option Explicit
Private Sub Command26_Click()
DoCmd.Close
End Sub
Private Sub cmdParse_Click()
DoCmd.SetWarnings False
Dim strfile As String
Dim AcctNum As String
AcctNum = "Account Number"
ChDir ("C:\MailSave\Requests\")
strfile = Dir("C:\MailSave\Requests\200" & "*.*")
Do While Len(strfile) > 0
FileCopy "C:\MailSave\Requests\" & strfile,
"C:\MailSave\GetInfo.txt"
Dim fileName As String
Dim stemp, linesfromfile, nextline As String
Dim iFIle As Integer
iFIle = FreeFile
Open "C:\MailSave\Requests\" & strfile For Input As iFIle
While Not EOF(1)
Line Input #1, nextline
linesfromfile = linesfromfile + nextline + Chr(13) + Chr(10)
Wend
Close iFIle
Call TestReplace
Me.txtEmail.Value = linesfromfile
Kill "C:\MailSave\Requests\" & strfile
strfile = Dir("C:\MailSave\Requests\200" & "*.*")
linesfromfile = ""
Dim strEmail As String
Dim bRequestDateFound As Boolean
Dim bSenderFound As Boolean
Dim bSubjectFound As Boolean
Dim bNameFound As Boolean
Dim bAddressFound As Boolean
Dim bCityStateZipFound As Boolean
Dim bAccountNumFound As Boolean
Dim bInstallDateFound As Boolean
Dim bLastEventDateFound As Boolean
Dim bPPVHoldFound As Boolean
Dim bMonthlyRateFound As Boolean
Dim bServicesFound As Boolean
Dim bRequestTypeFound As Boolean
Dim bLanguageFound As Boolean
Dim bCRCPINFound As Boolean
Dim bEventNumDateRangeFound As Boolean
Dim bSummaryFound As Boolean
Dim bVerifyBoxFound As Boolean
Dim bMDPageIDFound As Boolean
Dim strStringBefore As String
Dim strCurrentChar As String
Dim strRequestDate As String
Dim strSender As String
Dim strSubject As String
Dim strName As String
Dim strAddress As String
Dim strCityStateZip As String
Dim strAccountNum As String
Dim strInstallDate As String
Dim strLastEventDate As String
Dim strPPVHold As String
Dim strMonthlyRate As String
Dim strServices As String
Dim strRequestType As String
Dim strLanguage As String
Dim strCRCPIN As String
Dim strEventNumDateRange As String
Dim strSummary As String
Dim strVerifyBox As String
Dim strMDPageID As String
Dim lngLengthOfEmail As Long
Dim lngCharPointer1 As Long
Dim lngCharPointer2 As Long
Dim dbDatabase As DAO.Database
Dim rsRecordset As DAO.Recordset
If (IsNull(Me.txtEmail.Value)) Then
MsgBox "[Email] field is blank. Please try again.",
vbExclamation + vbOKOnly
Me.txtEmail.SetFocus
Exit Sub
End If
Me.txtStatusBar.Value = "Parsing..."
strEmail = Me.txtEmail.Value
'Initialize----------------------------------------------
bRequestDateFound = False
bSenderFound = False
bSubjectFound = False
bNameFound = False
bAddressFound = False
bCityStateZipFound = False
bAccountNumFound = False
bInstallDateFound = False
bLastEventDateFound = False
bPPVHoldFound = False
bMonthlyRateFound = False
bServicesFound = False
bRequestTypeFound = False
bLanguageFound = False
bCRCPINFound = False
bEventNumDateRangeFound = False
bSummaryFound = False
bVerifyBoxFound = False
bMDPageIDFound = False
strStringBefore = ""
strRequestDate = ""
strSender = ""
strSubject = ""
strName = ""
strAddress = ""
strCityStateZip = ""
strAccountNum = ""
strInstallDate = ""
strLastEventDate = ""
strPPVHold = ""
strMonthlyRate = ""
strServices = ""
strRequestType = ""
strLanguage = ""
strCRCPIN = ""
strEventNumDateRange = ""
strSummary = ""
strVerifyBox = ""
strMDPageID = ""
lngLengthOfEmail = Len(strEmail)
lngCharPointer1 = 0
Do While (Not bSubjectFound)
strCurrentChar = Left(strEmail, 1)
If (strCurrentChar = ":") Then
'Novell
ID--------------------------------------------------------------
If (InStr(strStringBefore, "Date")) Then
If (Not bRequestDateFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> vbCr)
strRequestDate = strRequestDate & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bRequestDateFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Subject-----------------------------------------------------------
ElseIf (InStr(strStringBefore, "ubject")) Then
If (Not bSubjectFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save name until crlf
Do While (strCurrentChar <> "[")
strSubject = strSubject & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bSubjectFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
Else
' Reset string before ':' and move to the next character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
Else
' Append this character to string that is before ':'
strStringBefore = strStringBefore & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
' ' Advance the character pointer
lngCharPointer1 = lngCharPointer1 + 1
Loop
Do While (Not bMDPageIDFound)
strCurrentChar = Left(strEmail, 1)
If (strCurrentChar = "]") Then
'Novell
ID--------------------------------------------------------------
If (InStr(strStringBefore, "ovell ID")) Then
If (Not bSenderFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strSender = strSender & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bSenderFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
' Else
' ' Reset string before ':' and move to the next character
' strStringBefore = ""
' strEmail = Right(strEmail, (Len(strEmail) - 1))
' End If
' Else
' ' Append this character to string that is before ':'
' strStringBefore = strStringBefore & strCurrentChar
' ' Move to the next character
' strEmail = Right(strEmail, (Len(strEmail) - 1))
' End If
' ' Advance the character pointer
' lngCharPointer1 = lngCharPointer1 + 1
'Loop
' Do While ((lngCharPointer1 <= lngLengthOfEmail))
'And (Not bSummaryFound))
' strCurrentChar = Left(strEmail, 1)
' If (strCurrentChar = "]") Then
'Name--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "s Name")) Then
If (Not bNameFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strName = strName & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bNameFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Address-------------------------------------------------------------
ElseIf (InStr(strStringBefore, "treet")) Then
If (Not bAddressFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strAddress = strAddress & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bAddressFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'City, State,
Zip--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "Zip")) Then
If (Not bCityStateZipFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strCityStateZip = strCityStateZip & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bCityStateZipFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Account Number-------------------------------------------------------
ElseIf (InStr(strStringBefore, "count Number")) Then
If (Not bAccountNumFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strAccountNum = strAccountNum & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bAccountNumFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Install Date--------------------------------------------------------
ElseIf (InStr(strStringBefore, "stall Date")) Then
If (Not bInstallDateFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strInstallDate = strInstallDate & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bInstallDateFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Last Known Event
Date-------------------------------------------------------
ElseIf (InStr(strStringBefore, "Known Event Date")) Then
If (Not bLastEventDateFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strLastEventDate = strLastEventDate &
strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bLastEventDateFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'PPV Hold--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "PV Hold")) Then
If (Not bPPVHoldFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strPPVHold = strPPVHold & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bPPVHoldFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Monthly
Rate--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "onthly Rate")) Then
If (Not bMonthlyRateFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strMonthlyRate = strMonthlyRate & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bMonthlyRateFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Current
Services--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "urrent Services")) Then
If (Not bServicesFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strServices = strServices & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bServicesFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Request
Type--------------------------------------------------------------
ElseIf (InStr(strStringBefore, "ype of Request")) Then
If (Not bRequestTypeFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strRequestType = strRequestType & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bRequestTypeFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Language------------------------------------
ElseIf (InStr(strStringBefore, "anguage")) Then
If (Not bLanguageFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strLanguage = strLanguage & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bLanguageFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'CRC Pin Instructions-------------------------------------------------
ElseIf (InStr(strStringBefore, "Pin Instructions")) Then
If (Not bCRCPINFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strCRCPIN = strCRCPIN & strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
bCRCPINFound = True
' Reset string before ':' and move to the next
character
strStringBefore = ""
strEmail = Right(strEmail, (Len(strEmail) - 1))
End If
'Event Numbers/Date Range-----------------------
ElseIf (InStr(strStringBefore, "Date Range")) Then
If (Not bEventNumDateRangeFound) Then
' Get rid of front white space
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Do While (strCurrentChar = " ")
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
lngCharPointer1 = lngCharPointer1 + 1
Loop
' Save address until cr
Do While (strCurrentChar <> "[")
strEventNumDateRange = strEventNumDateRange &
strCurrentChar
' Move to the next character
strEmail = Right(strEmail, (Len(strEmail) - 1))
strCurrentChar = Left(strEmail, 1)
|
| | 1 answer | Add comment |
|
| Interactive query DeanL 12:57:43 |
| | Hi all,
I'm trying to create a form that will display the results of a query
that the user will decide on the fields searched. I need a form that
shows several fields, possibly in a list box or series of combo boxes
that the user can select the fields to search in. Then I need to use
the contents of one or more text fields that will contain the search
terms. Not all of the fields will be searched each time so how would I
go about setting this up?
Any help is greatly appreciated.
Many thanks, Dean...
|
| | 8 answers | Add comment |
|
| Querying a NON null value. Julian 12:37:20 |
| | How is it possible to query only those fields from a column which have a
value; the null fields of the columns should be ignored.
Julian
|
| | 1 answer | Add comment |
|
| password recovery Ramli2412@Gmail.Com 08:04:51 |
| | if i already know system.mda password for ms access 2.0, how can i
create a user so i can use xyz.mdb in access 2.0. xyz.mdb password i
forget. thanks
regards
|
| | Add comment |
|
| transferspreadsheet dropping a row 675i76 07:37:45 |
| |
We've been using a macro to import Excel spreadsheets into an access 2002
database. After 5 months of this we found an error on a report. It turns out
that access is ignoring the last row and last column of the spreadsheet. If
the spreadsheet has 12 columns and 1000 rows the table will have 11 columns
and 998 rows of data (one row is converted to field names). This happens
when using Transferspreadsheet in a macro and in VBA. The same result is
produced when using the wizard to get external data. We also discovered that
if we open the spreadsheet and save it (even without making a change) the
missing row and column will be imported correctly. I would imagine that when
we save it, it is saved with a different version of Excel than it was
created with. However, I can't imagine how Access would let this happen. By
the way, the spreadsheets come via internet from a third party. We have no
control over what they use to create it. We'd greatly appreciate any ideas.
Thanks.
We're running Access 2002 SP3 Excel 2002 SP3 VB 6.3
|
| | Add comment |
|
| Menubar settings fixed Guest 06:06:55 |
| | I have attempted to change a menubar settings so that users can do
nothing to it: move it, close it etc.
This occurred because Citrix users could pull the bar off the top of
the screen, close it and then never be able to find it again, and we
couldn't log in to fix it. We would change the menubar properties in
the next release, but they couldn't take effect as these properties
appear to be stored in the users registry settings.
This way, the settings are set so that the menubar is 'frozen' as soon
as the main switchboard is opened. I assume this same problem could
occur for non-Citrix users too, but it doesn't seem to for some reason.
This is what I did.
' Note: Protection Property has the following bit settings:
' 1 = Disallow Customizing
' 2 = Disallow Resizing
' 4 = Disallow Moving
' 8 = Disallow Showing/Hiding
' 16= Disallow Docking Changes
' To allow user to make any changes, set all bits off
'CommandBars("MyMainMenu").Protection = 0
' To allow user to make NO changes, set all bits on
CommandBars("MyMainMenu").Protection = 31
I can find no property that allows me to change the Show On Toolbars
Menu property.
Any comments appreciated, but this is posted mainly for information.
Ray
|
| | Add comment |
|
| Having problem creating an SQL stat. for a report Erick-Flores 03:16:17 |
| | Hello all
I am creating an Expense Report. There are to types of expenses:
Company expenses and Reimb Expeneses. The company expenses is under
"Expense Details Co" table and Reimb Expenses is under "Expense
Details" table. So I am creating this final report to see both type of
expenses separately but I CANT.
I got this report design from a website, but it only came with one
"Expense Details" table, so I add the Expense Details Co. The report
worked fine with only Expense Details but now that I am trying to add
the other table it wont work quite well for my final report.
Here is the SQL stat. that I am using to display the report, but again,
is not working the way I want.
I want to see in one group the Expense Details and on other group the
Expense Details Co.
SELECT DISTINCTROW [Expense Reports].*, [Expense
Details].ExpenseDetailID, [Expense Details].ExpenseItemAmount, [Expense
Details].ExpenseItemDescription, [Expense Details].ExpenseDate,
[Expense Categories].ExpenseCategory, Employees.EmployeeNumber,
Employees.FirstName, Employees.LastName, [Expense Details
Co].[EnpenseDetailID Co], [Expense Details Co].[ExpenseItemAmount Co],
[Expense Details Co].[ExpenseItemDescription Co], [Expense Details
Co].[ExpenseDate Co]
FROM (Employees INNER JOIN ([Expense Reports] INNER JOIN [Expense
Details Co] ON [Expense Reports].ExpenseReportID = [Expense Details
Co].[ExpenseReportID Co]) ON Employees.EmployeeID = [Expense
Reports].EmployeeID) INNER JOIN ([Expense Categories] RIGHT JOIN
[Expense Details] ON [Expense Categories].ExpenseCategoryID = [Expense
Details].ExpenseCategoryID) ON [Expense Reports].ExpenseReportID =
[Expense Details].ExpenseReportID
WHERE ((([Expense Reports].ExpenseReportID)=[forms]![Expense
Reports]![ExpenseReportID]));
I am almost sure that I have something wrong in the SQL but I dont know
where exactly..please help me
Thank you
|
| | 3 answer | Add comment |
|
| Opening an explorer window with access Kyle Crommett 01:29:37 |
| | My goal here is to get access to open a folder that is related to the
current displayed record. For example, if the customer's last name is
Smith, i want the folder "//server01/jobphotos/Smith" to pop up when
you click the Job photos button.
So far this is all I have for it...
RetVal = Shell("explorer /e,/root, //server01/jobphotos/Smith")
This works on a one time basis, but i need it to be variable so it
bases the folder name on the last name of the contact record. Any help
would be greatly appriceated. Thanks
|
| | 1 answer | Add comment |
|
| Losing subform current record after delete Guest 00:42:21 |
| | I've got a tab control that drives several things, and I'm running into
a problem.
The user searches for a particular patient using unbound controls, and
a patient subform displays the associated results. When the user
selects the patient they want in the sub form datasheet, this selection
drives the results shown in the other two main tabs of the form, like
patient details and transactions. The problem is, whenever the user
deletes a particular transaction in another tab, I lose the primary key
of the patient they previously selected at startup. Instead, the user
sees the transactions of the first patient in the underlying table.
For my transactions sub form, for example, I make this association as
such:
Me.subfrm_transaction_transactions.Form.Filter = "PATIENT_ID = " &
Me.FRM_SUB_PATIENT.Form!PATIENT_ID
I've created a variable to capture this patient ID, and this remedies
part of the problem, but I'm really hoping there's a more elegant way
to preserve the selected patient in the subform, regardless of any
actions the user makes elsewhere in the main tabs.
Thanks!
|
| | 1 answer | Add comment |
|
| Send Email from Access Using a custom Outlook Form Mr T 00:34:44 |
| | I know how to send email from Access and I know how to create a custom
form in Outlook. but.... How do I put the email info from Access into
the Outlook custom form ???
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim TheAddress As String
Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("Select * from tblMailingList Where
responded <>-1")
MyRS.MoveFirst
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
Do Until MyRS.EOF
' Create the e-mail message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = MyRS![emailaddress]
If MyRS!responded <> -1 Then
With objOutlookMsg
' Add the To recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo
If TheAddress = "Joe.Blow@somewhere.com" Then
.Subject = "Only " & [daysleft] & " Days Left Till Your
Report Is Due !"
.Body = " John," & _
"You have " & [daysleft] & " days remaining to
submit the your updates!"
.Importance = olImportanceHigh
Else
' Set the Subject, the Body, and the Importance of the e-mail
message.
.Subject = "***MANDATORY RESPONSE REQUIRED***"
.Body = "BLAH BLAH BLAH BLAH" & _
"Thank you for help."
.Importance = olImportanceHigh 'High importance
'Resolve the name of each Recipient.
End If
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Display
'.Send
End With
End If
MyRS.MoveNext
Loop
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub
Suggestions ???
|
| | 1 answer | Add comment |
Thursday, 10 August 2006
|
| sql and passing through open args Fredindy 23:49:35 |
| | I'm having trouble figuring out what I need to do here. Basically, I
want to pull data from several different tables and send them to a form
using open args. However, the form that is being fed need to have
certain columns of data concatenated. Here is the code I have so far.
I'm sure it's not right because it doesn't work right.
Private Sub cmdEdit_Click()
Dim sSQL As String
sSQL = "Select RENTAL.[RID], RENTAL.[EVENTID], EVENT.[NAME]" & _
" EVENT.[FILENUMBER], RENTAL.[RENTALDATE], RENTALITEM.[RENTALID]" &
_
" RENTAL.[RENTALITEM], RENTAL.[RENTALTYPE]," & _
" RENTALITEM.[PRICEPERUNIT], RENTAL.[QUANTITY]" & _
" FROM RENTALITEM " & _
"WHERE forms![frmRentalSearch].[RID] = RENTAL.[RID]"
DoCmd.OpenForm "frmEditRental", acNormal, OpenArgs:=sSQL
End Sub
Thanks for any help.
Fred
|
| | 10 answers | Add comment |
|
| query based on check boxes Somethings Amiss 22:37:46 |
| | I searched google groups for an answer but found none that I could
completely understand. I have a table. It contains fields such as
'client,date,hours,project,employee.' I have a form that lists all the
clients on one tab. On another tab in the same form all the employees
are listed. Each have a check box next to them (both client and
employee). I want to run a query based on what is checked on both
tabs. Thanks in advance for any and all help.
|
| | 3 answer | Add comment |
|
| Register DLL and OCX files during the packaging Wizard of MS Access Nitinit1984@Googlemail.Com 21:00:05 |
| | Hi,
I have created a biometric application in MS access that uses number of
DLL files and an OCX file. All DLL files should be loaded in Windows
System folder. I am using MS access 2003 Developer extension to create
a set up file for the application. How do i package the dll's and the
OCX files in such a way that all files are loaded in the windows system
folder and registered.
Regardsssss
Dr Nitin
|
| | Add comment |
|
| Sending and receiving emails with Ms Access Marek Bakalarczuk 20:55:49 |
| | Hi.
I want to make A Document Management System.
Everything is fine and beautyfull but... how to hell I can receive
emails with attachements, and how to store it in Access database table.
I'm trying 3rd day and I can't find out enything clever.
If You can help me I'll be glad and very, very happy.
Maybe some useful links?
Thanks in advance,
Marek Bakalarczuk
|
| | 7 answers | Add comment |
|
| Linking two tables in a pull down list SpankyTClown 19:54:33 |
| | Hi,
Problem:
How do I create a form that contains a pull down list for the source
and destination (reference the table definition shown below) that shows
the name of the item not the id number? The way I am doing it is
through a query which only allows one name field. So I thought to do
it through the pull down list, but it only displays the id. The pull
down list will display both but upon selection just the id is
displayed. I need the name to be displayed?
The following tabl is used:
Relationship Id - Key
Source Id - links to x table
Definitive Item Id - links to y table
Destination Id - links to x table
x Table:
id
name
Anyone have any suggestions on how to do this.
|
| | 1 answer | Add comment |
|
| Button to open new form triggers the form and the filter shows the proper key but screen is all blan Steven Little 18:43:15 |
| | I have a button on one screen that opens another form.
If I click it then the form opens but the fields are all blank.
I look at it in Design view and the filter shows the proper key.
If I close the new form and click the button on the 1st form again to open
it then this 2nd time the data shows correctly.
It is weird as I simply created an edit screen from the table and limit it
to the single record. This is simple and should work, but like many times in
Access it doesn't.
Any help here would be greatly appreciated!
Thanks,
Steve
|
| | 3 answer | Add comment |
|
| How To Open Document Of Unknown Type From VBA? Guest 17:58:04 |
| | I've got a UNC.
It's something like H:\CDL\Attachments\Deal000023.InitialOffering.doc.
I want to feed that UNC to MS Windows and let Windows worry about selecting
which application to use to open it. If there's no app defined for that UNC's
particular suffix, that's ok... we'll live with it.
Seems like a FileSystemObject should be able to do this, but I can't find such a
method.
'Shell' wants an executable.
Maybe an API call?
--
PeteCresswell
|
| | 7 answers | Add comment |
|
| Help with nested IIF statement in a query BerkshireGuy 17:54:42 |
| | Hello all.
This expression is in my query and it works well. However, if both
continues are false, I want it to say "Not Yet Issued". I've added
that and getting an #ERROR.
Any ideas?
TimeToIssue: IIf(Not
IsNull([ApprovedStandardTransDate]),DateDiff("d",[REceivedTransdate],[ApprovedStandardTransDate]),IIf(Not
IsNull([ApprovedSubStandardTransDate]),DateDiff("d",[REceivedTransdate],[ApprovedSubStandardTransDate]),"Not
Yet Approved"))
|
| | 3 answer | Add comment |
|
| Access SQL Delete problem Alan Conoco 14:45:02 |
| | Hi all,
I am trying to delete a subset of records (identified using my
InsertRemovePairs query) from a table names TradesDone.
When I execute the nested SELECT on its own it returns the correct
records. When I execute is nested in the DELETE it tries to delete
everything in my database....
What have I missed??
DELETE TradesDone.*
FROM TradesDone
WHERE EXISTS (
SELECT TradesDone.*
FROM InsertRemovePairs, TradesDone
WHERE InsertRemovePairs.TradeID = TradesDone.TradeID
AND InsertRemovePairs.AggressorBrokerID = TradesDone.AggressorBrokerID
AND InsertRemovePairs.Action = TradesDone.Action);
(Access 2000, Win NT)
Many thanks,
Alan
|
| | 7 answers | Add comment |
|
| Update Query won't update my values Hharriel@Gmail.Com 07:33:12 |
| | Hi All,
I have created an update query related to high school course
information (name of course; credit hour; course description, etc.) I
am updating a master course information table. I am updating two fields
in the master table; course name and credit hour. When I run a test,
the course name updates fine. However, I have three different values
that can be in the credit hour files: .05, 1, and 2 (also there are
some records that don't have the credit hour information). The
majority of the credit hour field does not update. Some of the .05s
and the 1 values update, but very few (something like 20 out of 275
records). When running the test update, in the credit hour field, it
mostly puts zeros.
I have checked to make sure that the field criteria for the table I am
updating from and the table I am updating to (the master course table)
are the same; "number".
Any help you all could provide would help a whole lot,
Thanks,
|
| | 3 answer | Add comment |
|
|
