' Все объекты объявления в форуме
Public Type tpAdds
User As String ' Имя пользователя
Email As String ' Имя почты
AddDate As Date ' Дата записи
Subject As String ' Тело
Body As String ' Текст
Section As String ' Секция
End Type
Public adds() As tpAdds ' Объявления на одну тему
Public tags(10) As String ' Список тегов
Public fso ' Объект файловой системы
Public frmMain As Form ' Форма для вывода данных
' Читаем все файлы html
Public Function funReadHtml(frm As Form, MaxAdds As Long) ' Максимальное число объявлений, 0 - все загружаем
Dim fname As String, html, buf, i As Long
Dim cnn As ADODB.Connection
' Инициализация тегов для html файла
Set frmMain = frm
' Поиск имени
tags(0) = "size=""2"">"
tags(1) = "<br>"
' Поиск Email
tags(2) = "mailto:"
tags(3) = """"
' Поиск даты и времени
tags(4) = "alt=""Email""></a><br><br>"
tags(5) = "<br></font>"
' Поиск темы
tags(6) = "<u>"
tags(7) = "</u>"
' Поиск сообщения
tags(8) = "Сообщение:<br>"
tags(9) = "</font></td>"
' Разбор файлов
With Application.FileSearch
.NewSearch
.LookIn = CurrentProject.Path & "\Data"
.SearchSubFolders = False
.fileName = "*.htm"
If .Execute() > 0 Then
Set cnn = New ADODB.Connection
cnn.CursorLocation = adUseClient
If CurrentProject.IsConnected = True Then
cnn.Open CurrentProject.AccessConnection.ConnectionString
End If
If MaxAdds = 0 Then MaxAdds = .FoundFiles.Count
funPrintStatus " --- Старт: " & Now
For i = 1 To MaxAdds
fname = .FoundFiles(i)
funPrintStatus "Прочитан файл: " & fname & ": " & Now
' Читаем файл
Call fsoReadAllFile(fname, html)
' Разбор файла
If Len(html) > 10 Then
funWriteHtml cnn, html, fGetFileName(fname)
fMoveFile fname, fname & "1"
End If
Next i
funPrintStatus "--- Конец: " & Now
If CurrentProject.IsConnected = True Then
cnn.Close
End If
Else
MsgBox "В каталоге: " & .LookIn & " файлы не найдены! Возможно они были переименованы", vbExclamation, "Администратор"
End If
End With
End Function
' Сохраняем информацию в массиве объявлений
Public Function funWriteHtml(cnn As ADODB.Connection, html, fileName As String)
Dim i As Long, n As Long, p1 As Long, p2 As Long, k As Long, buffer As String, Sec As String
' Поиск границы данных, далее идет форма
'p2 = InStr(1, html, "<!---" & fileName & "--->")
p2 = InStr(1, html, ".htm--->")
buf = Split(Left(html, p2), "<tr>")
' Число строк
n = UBound(buf)
' Название секции
p1 = InStr(1, buf(1), "<b> > </b>")
p1 = InStr(p1 + 10, buf(1), "<b> > ") + 6
p2 = InStr(p1, buf(1), " </b>")
If p2 > p1 Then Sec = Mid(buf(1), p1, p2 - p1)
If InStr(1, Sec, "<") Then Sec = ""
If n > 2 Then
ReDim adds(n - 3) ' Пропускаем 3 строки сверху
For i = 3 To n
p1 = 1 ' Начало поиска
adds(i - 3).Section = Sec
For j = 0 To 4
' Начало поиска
k = InStr(p1, buf(i), tags(j * 2))
' Левый тег найден
If k > 0 Then
p1 = k + Len(tags(j * 2))
p2 = InStr(p1, buf(i), tags(j * 2 + 1))
' Результат поиска правого тега - положительный
If p2 > p1 Then
buffer = Mid(buf(i), p1, p2 - p1)
Select Case j
Case 0: adds(i - 3).User = buffer
Case 1: adds(i - 3).Email = buffer
Case 2: adds(i - 3).AddDate = CDate(Replace(buffer, "<br>", " "))
Case 3: adds(i - 3).Subject = buffer
Case 4: adds(i - 3).Body = buffer
End Select
' Новая позиция поиска
p1 = p2 + Len(tags(j * 2 + 1))
End If
End If
Next
Next
' Добавляем данные в конференцию
dnn_Forum_PostAdd cnn, fileName
End If
End Function
' Получаем имя файла
Public Function fGetFileName(strPath As String) As String
Dim fs
On Error GoTo 999
Set fs = CreateObject("Scripting.FileSystemObject")
fGetFileName = fs.GetFileName(strPath)
Set fs = Nothing
Exit Function
999:
MsgBox Err.Description, vbCritical, strPath
Err.Clear
End Function
Public Function fMoveFile(strPath1 As String, strPath2 As String) As Boolean
Dim fs
On Error GoTo 999
Set fs = CreateObject("Scripting.FileSystemObject")
fs.MoveFile strPath1, strPath2
Set fs = Nothing
Exit Function
999:
'MsgBox Err.Description, vbCritical, strPath
Err.Clear
fDeleteFile = False
End Function
' Загрузка всего файла в буфер
Public Function fsoReadAllFile(fname, buffer)
Dim f
' Создаем файловую систему
fsoCreateFileSystem
' Читаем весь файл
If (fso.FileExists(fname)) Then
Set f = fso.OpenTextFile(fname, 1, -1)
buffer = f.ReadAll
f.Close
fsoReadAllFile = True
Else
fsoReadAllFile = False
End If
End Function
Public Function fsoCreateFileSystem()
If IsEmpty(fso) Then
Set fso = CreateObject("Scripting.FileSystemObject")
End If
End Function
' Печать информации
Private Sub funPrintStatus(txt As String)
On Error GoTo 999
If frmMain.txtStatus.ListCount > 500 Then
frmMain.txtStatus.RowSource = ""
End If
frmMain.txtStatus.RowSource = txt & ";" & frmMain.txtStatus.RowSource
DoEvents
frmMain.Repaint
Exit Sub
999:
frmMain.txtStatus.RowSource = ""
End Sub
'
' Добавляем объявления в конференцию Dotnetnuke
' Работает только при подключении к серверу с процедурой: Forum_PostAdd
'
Private Function dnn_Forum_PostAdd(cnn As ADODB.Connection, fileName As String) As Boolean
' Вспомогательные параметры
Dim cmd As New ADODB.Command, i As Long, PostID As Long, cnt As Long
On Error GoTo 999
If CurrentProject.IsConnected = False Then
MsgBox "Необходимо adp проект связать с базой данных dotnetnuke", vbCritical, "Admin"
Exit Function
End If
PostID = 0
Set cmd.ActiveConnection = cnn
cmd.CommandText = "dnn_Forum_PostAdd" ' По умолчанию процедура добавления: Forum_PostAdd
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Refresh ' Запрос параметров процедуры
Dim rst As New ADODB.Recordset
For i = 0 To UBound(adds)
' Инициализируем данные
cmd.Parameters("@ParentPostID") = PostID
cmd.Parameters("@ForumID") = 1 ' Access Forum
cmd.Parameters("@UserID") = 19
cmd.Parameters("@RemoteAddr") = ""
cmd.Parameters("@Notify") = 0
cmd.Parameters("@Subject") = adds(i).Subject
cmd.Parameters("@Body") = adds(i).Body & "P.S. " & adds(i).Section & "<br>Автор: <a href=""mailto:" & adds(i).Email & """>" & adds(i).User & "</a> от " & adds(i).AddDate & " <a href=""http://www.leadersoft.ru/rusboard/data/" & fileName & """>Источник ...</a>"
cmd.Parameters("@IsPinned") = 0
cmd.Parameters("@PinnedDate") = adds(i).AddDate
cmd.Parameters("@IsClosed") = 0
cmd.Parameters("@Image") = ""
cmd.Parameters("@mediaURL") = ""
cmd.Parameters("@mediaNAV") = ""
cmd.Parameters("@ObjectTypeCode") = 0
cmd.Parameters("@ObjectID") = 0
cmd.Parameters("@FileAttachmentURL") = ""
cmd.Execute RecordsAffected:=cnt, options:=adExecuteNoRecords
If cnt <> 0 And i = 0 Then
PostID = DMax("PostID", "dnn_Forum_Posts") ' Запрос последнего добавленного сообщения
End If
Next
Exit Function
999:
MsgBox Err.Description, vbCritical, "Администратор"
End Function |