Программирование на Visual Basic

Форум 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