Форум DNN - хранит сообщения в базе данных Microsoft SQL Server. Этот пример показывает как можно использовать Access для автоматизированной загрузки сообщений в форум. Обратите внимание на dnn_Forum_PostAdd. Application.FileSearch - не работает в Office 2007, используйте другую функцию (Dir) для получения списка файлов
Option Compare Database
' Все объекты объявления в форуме
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""/abrbr"
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
' Закрыть текущее соединение
Public Function fCloseConnect()
CurrentProject.OpenConnection "Provider="
End Function