ProgrammingMSAccess.com

The ProgrammingMSAccess.COM Site

A set of vba Procedures that parse a frontpage 2000 guest register for entry into an access 2000 table; this set of procedures was originally developed for the tech republic web site (www.techrepublic.com)

'Declare these globally so they are
'available to more than one procedure;
'the txtobj1 and fs objects require
'a reference to the Microsoft
'Scripting Runtime library
Dim txtobj1 As Scripting.TextStream
Dim strTemp As String
Dim rst1 As ADODB.Recordset



Sub LookForNameStart()
Dim fs As Scripting.FileSystemObject

'Form a reference to the file system
'and use it ot open a text object based
'on the local file holding the GB register
Set fs = New Scripting.FileSystemObject
Set txtobj1 = _
fs.OpenTextFile _
("C:\Inetpub\wwwroot\TRSamples" & _
"\formrslt_copy(3).htm", _
ForReading)

'Open a recordset on the tblContacts table
Set rst1 = New ADODB.Recordset
rst1.Open "tblContacts", _
CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic

'Loop through text object to find line
'just before the FirstName field
Do Until txtobj1.AtEndOfStream
    strTemp = txtobj1.ReadLine
    If InStr(1, strTemp, "Contact_FirstName") _
        <> 0 Then
    ProcessContact
    End If
Loop

'Cleanup resources
rst1.Close
Set rst1 = Nothing
txtobj1.Close
Set txtobj1 = Nothing
Set fs = Nothing

End Sub

Sub ProcessContact()
On Error GoTo MyErrorTrap
Dim strFname As String
Dim strLname As String
Dim strCname As String
Dim strSt1 As String
Dim strSt2 As String
Dim strCity As String
Dim strRegion As String
Dim strPostalCode As String
Dim strCountry As String
Dim strEmailAddr As String
Dim intFirst As Integer
Dim intLen As Integer
Dim cmd1 As ADODB.Command

'Extract First Name in Proper Case
strTemp = txtobj1.ReadLine
If InStr(1, strTemp, "&nbsp;") = 0 Then
    intFirst = InStr(1, strTemp, ">") + 1
    intLen = InStr(InStr(1, strTemp, ">"), _
        strTemp, "<") - intFirst
    strFname = UCase(Mid(strTemp, intFirst, 1)) & _
        LCase(Mid(strTemp, intFirst + 1, intLen - 1))
Else
    strFname = ""
End If

'Extract Last Name in Proper Case
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
If InStr(1, strTemp, "&nbsp;") = 0 Then
    intFirst = InStr(1, strTemp, ">") + 1
    intLen = InStr(InStr(1, strTemp, ">"), _
        strTemp, "<") - intFirst
    strLname = UCase(Mid(strTemp, intFirst, 1)) & _
        LCase(Mid(strTemp, intFirst + 1, intLen - 1))
Else
    strLname = ""
End If

'Extract Organization Name in any case
txtobj1.SkipLine
txtobj1.SkipLine
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
If InStr(1, strTemp, "&nbsp;") = 0 Then
    intFirst = InStr(1, strTemp, ">") + 1
    intLen = InStr(InStr(1, strTemp, ">"), _
        strTemp, "<") - intFirst
    strCname = CleanText(Mid(strTemp, _
        intFirst, intLen))
Else
    strCname = ""
End If

'Extract first and second address lines
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
If InStr(1, strTemp, "&nbsp;") = 0 Then
    intFirst = InStr(1, strTemp, ">") + 1
    intLen = InStr(InStr(1, strTemp, ">"), _
        strTemp, "<") - intFirst
    strSt1 = CleanText(Mid(strTemp, intFirst, _
        intLen))
Else
    strSt1 = ""
End If
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
If InStr(1, strTemp, "&nbsp;") = 0 Then
    intFirst = InStr(1, strTemp, ">") + 1
    intLen = InStr(InStr(1, strTemp, ">"), _
        strTemp, "<") - intFirst
    strSt2 = CleanText(Mid(strTemp, _
        intFirst, intLen))
Else
    strSt2 = ""
End If

'Extract City, Region, Postal Code, and Country
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
intFirst = InStr(1, strTemp, ">") + 1
intLen = InStr(InStr(1, strTemp, ">"), strTemp, "<") - intFirst
strCity = Mid(strTemp, intFirst, intLen)
If strCity = "&nbsp;" Then strCity = ""
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
intFirst = InStr(1, strTemp, ">") + 1
intLen = InStr(InStr(1, strTemp, ">"), strTemp, "<") - intFirst
strRegion = Left(Mid(strTemp, intFirst, intLen), 20)
If strRegion = "&nbsp;" Then strRegion = ""
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
intFirst = InStr(1, strTemp, ">") + 1
intLen = InStr(InStr(1, strTemp, ">"), strTemp, "<") - intFirst
strPostalCode = Mid(strTemp, intFirst, intLen)
If strPostalCode = "&nbsp;" Then strPostalCode = ""
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
intFirst = InStr(1, strTemp, ">") + 1
intLen = InStr(InStr(1, strTemp, ">"), strTemp, "<") - intFirst
strCountry = Mid(strTemp, intFirst, intLen)
If strCountry = "&nbsp;" Then strCountry = ""

'Extract Email address; use as string in VBA
'proc, but it adds to table as hyperlink
txtobj1.SkipLine
txtobj1.SkipLine
txtobj1.SkipLine
strTemp = txtobj1.ReadLine
intFirst = InStr(1, strTemp, ">") + 1
intLen = InStr(InStr(1, strTemp, ">"), strTemp, "<") - intFirst
strEmailAddr = Mid(strTemp, intFirst, intLen)
If strEmailAddr = "&nbsp;" Then strEmailAddr = ""

'Use this print set for debugging purposes
'Debug.Print
'Debug.Print strFname & " " & strLname
'Debug.Print strCname
'Debug.Print strSt1
'Debug.Print strSt2
'Debug.Print strCity & ", "; strRegion & " " & strPostalCode
'Debug.Print strCountry
'Debug.Print strEmailAddr


'Add a record if it has a valid primary key
If strFname <> _
"" And strLname <> "" And _
strEmailAddr <> "" Then
    With rst1
        .AddNew
        If strFname <> _
            "" Then .Fields("FirstName") = _
            strFname
        If strLname <> _
            "" Then .Fields("LastName") = _
            strLname
        If strCname <> _
            "" Then .Fields("CompanyName") = _
            strCname
        If strSt1 <> _
            "" Then .Fields("Address") = _
            strSt1
        If strSt2 <> _
            "" Then .Fields("Address1") = _
            strSt2
        If strCity <> _
            "" Then .Fields("City") = _
            strCity
        If strRegion <> _
            "" Then .Fields("StateOrProvince") = _
            strRegion
        If strPostalCode <> _
            "" Then .Fields("PostalCode") = _
            strPostalCode
        If strCountry <> _
            "" Then .Fields("Country") = _
            strCountry
        If strEmailAddr <> _
            "" Then .Fields("EMailName") = _
            strEmailAddr
        .Update
    End With
End If

MyExit:
Exit Sub

MyErrorTrap:
If Err.Number = -2147217887 Then
'Trap duplicate key error and replace record
    Set cmd1 = New ADODB.Command
    With cmd1
        .ActiveConnection = _
            CurrentProject.Connection
        .CommandText = "DELETE * " & _
            "FROM tblContacts " & _
            "WHERE tblContacts.EMailName " & _
            "= '" & strEmailAddr & "'"
        .CommandType = adCmdText
        .Execute
    End With
    Resume
Else
    Debug.Print Err.Number; Err.Description
    Resume MyExit
End If

End Sub

Function CleanText(strText As String)

'Replace HTML special characters
'such as &amp; with & and &quot; with "
CleanText = Replace(strText, "&amp;", "&")
CleanText = Replace(CleanText, "&quot;", """")

End Function

Want to understand  Microsoft Access so that you can program it to do more tasks like this?  Get Programming Microsoft Office Access 2003 by Rick Dobson from Microsoft Press.  Learn more about the book by clicking here.

Copyright 1999 CAB, Inc. All rights reserved. Republication or redistribution of CAB, Inc. content, including by framing or similar means, is expressly prohibited without the prior written consent of CAB, Inc. CAB, Inc. shall not be liable for any errors in the content, or for any actions taken in reliance thereon.