Считывание данных из гостевой книги (стр. 3 из 3)

Как показано на рисунке 8 программа не работала, т.к. не находил необходимый файл. При этом появляется диалоговое окно с указанием номера ошибки и её описанием (См.Рис.9)

Рис.5

Рис.6

Рис.7

Рис.8

Рис.9

Рис.10

Рис.11

X_FirstName:

Sasha

X_LastName:

Sergheev

X_Organization:

College

X_WorkAddress:

A Russso 1

X_Address2:

A Russo 1

X_City:

Chishinev

X_State:

Moldova

X_ZipCode:

22222222

X_Country:

Moldova

X_Email:

sergheev@mail.md

Рис.12

Тексты программ в виде текстового файла и описание их подключения к системе MSOffice

'Объявите переменные глобально, так чтобы они были доступны больше чем одной ‘процедуре;

' Txtobj1 и объекты fs требуют ссылки на библиотеку Microsoft Scripting RunTime

Dim txtobj1 As Scripting.TextStream

Dim strTemp As String

Dim rst1 As ADODB.Recordset

Sub LookForNameStart()

Dim fs As Scripting.FileSystemObject

' Формируйте ссылку к системе файла, и используйте это, чтобы 'открыть текстовый ‘объект, основанный

' на локальном файле, который содержит регистр Гостевой книги

Set fs = New Scripting.FileSystemObject

Set txtobj1 = fs.OpenTextFile (“ F:\formrslt.htm", ForReading)

' Откройте recordset на tblContacts таблице

Set rst1 = New ADODB.Recordset

rst1.Open "tblContacts", CurrentProject.Connection, adOpenKeyset,_ adLockOptimistic

' Пройти цикл через текстовый объект для нахождения линии как раз ‘перед ‘FirstName полем

Do Until txtobj1.AtEndOfStream

strTemp = txtobj1.ReadLine

If InStr(1, strTemp, "X_FirstName") <> 0 Then

ProcessContact

End If

Loop

‘Очистить ресурсы

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

’Извлечь First Name в нужном регистре

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

’Извлечь Last Name в нужном регистре

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

’Извлечь Organization Name в любом регистре

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

’Извлечь строки с первым и вторым адресами

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

’Извлечь 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 = ""

’Извлечь Email address ; Использовать как строкe в VBA proc, но это добавляется к ‘таблице как гиперсвязь

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 = ""

' Используйте этот набор печати для отладки целей

'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

' Добавьте запись, если это имеет допустимый первичный ключ- клавишу

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

'Перехватчик дублирует ключевую ошибку и заменяет запись

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)

' Замените специальные символы HTML типа &amp; with & и &quot; with "

CleanText = Replace(strText, "&amp;", "&")

CleanText = Replace(CleanText, "&quot;", """")

End Function

Как описывалось выше этот набор процедур используется в приложении Access, для считывания данных с файла с расширением html. В этом файле хранятся данные о пользователях Гостевой книги.