LEADERSOFT.ru Разработка на заказ программ и сайтов
Раздел обучения информационным технологиям
Разработка программ на Access
Форум DNN - хранит сообщения в базе данных Microsoft SQL Server. Этот пример показывает как можно использовать Access для автоматизированной загрузки сообщений в форум. Обратите внимание на dnn_Forum_PostAdd. Application.FileSearch - не работает в Office 2007, используйте другую функцию (Dir) для получения списка файлов
Свойства продукта

 Microsoft Office: 2000,2002,2003  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\06 Массивы\la_array.mdb
 Язык интерфейса: Русский

   

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""></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 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 StringAs 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 StringAs 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 StringAs 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


Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access