Отправляет email-рассылки с помощью сервиса Sendsay

Программирование и готовые решения

Подписаться Бесплатная «Серебряная» новостная рассылка . Подписчиков 5.408 RSS
←   Июнь 2007   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30


За последние 60 дней ни разу не выходила


Сайт рассылки: http://blog.leadersoft.ru
Открыта: 29-08-2000

Автор
leadersoft.ru

Статистика

5.408 подписчиков
0 за неделю
←   Все выпуски   →

Microsoft Access - программирование и готовые решения


Выпуск 80. Импорт данных в Dotnetnuke

Подписка:  "Microsoft Access - программирование и готовые решения"
Дата:           16.07.2007
Автор:         Админ Leadersoft.ru
Сайт:           http://help.leadersoft.ru/
Категория: Создание adp проектов

     Данная статья ориентирована на тех, кто хорошо разбирается в программировании и структурах различных файлов. Она может быть полезна тем, кто разрабатывает конверторы для импорта или экспорта разных баз данных
О Dotnetnuke
    Технология www.Dotnetnuke.com - это быстрая разработка сайтов, с использованием простых инструментов редактирования. Вам не надо знать программирование для того, чтобы создать профессиональный сайт с великолепным дизайном. Пока не будем говорить в этой рассылке о ее преимуществах, но они, конечно, значительны
Введение в тему  
        Сама база данных сайта Dotnetnuke написана на Microsoft SQL Server и хорошо интегрируется с Microsoft Access. Это и будет показано в этом примере. Суть работы. Имеется много однотипных файлов из конференции на perl в формате htm, которые хорошо читаются браузерами, но из-за большого количества сообщений более 7500 штук, конференция медленно работает. Потребовалось перенести ее в другую базу данных. Этот пример показывает, как можно быстро выполнить импорт данных в Dotnetnuke за несколько минут.
       В качестве вариантов рассматривалась конференция на MySQL (phpBB), но из-за слабой защиты от спама, да и не возможности прямого доступа из Access этот вариант отпал. Лучший выбор пока dotnetnulke, т.к. к конференции прилагается еще и много бесплатных модулей: http://client.leadersoft.ru/Технологии/Разработкасайтов/tabid/76/Default.aspx
Алгоритм решения
Предварительная работа
1. Необходимо определить структуру для сохранения прочитанных сообщений (Автор, Дата, Тема, Сообщение и т.п.)
2. Найти теги, которые будут определять сообщения. Например, <font>Тема: Импорт данных </font>. Тег font определяет внутри htm тему, которую мы потом сохраним в нашей структуре.
3. Найти процедуру в конференции (или создать ее самому), которая будет сохранять в базе данных сообщения. Запустив ее и передав параметры сообщений, мы тем самым сможем быстро заполнить базу данных информацией из файлов htm
4. Найти код на VBA, который в цикле читает все файлы из папки. Это нужно, если файлов много и не надо их вводить по одному в программу для разбора.
5. Найти программы, которые читают содержимое и переименовывают файлы операционной системы. Это пригодится нам, для чтения файла в буфер для анализа. Это лучше, когда весь файл читается, а не анализируется построчно.  После разбора файла его нужно переименовать, чтобы не использовать повторно, т.к. возможны сбои при чтении нескольких  файлов. Например, формат другой, пустые файлы и т.п. И нам придется запускать программу повторно.
Основная работа
  Далее мы переходим к программированию и создаем управляющую форму и VBA код. Он указан ниже. Его можно, конечно, настроить и на   другой тип htm файлов.
Заключение
  Проще будет, если Вы скачаете пример по этой ссылке: http://help.leadersoft.ru/Загрузка/tabid/75/Default.aspx Раздел dotnetnuke или Конвертеры
  Если остались вопросы их можно задать в блоге: http://help.leadersoft.ru/tabid/126/EntryID/15/Default.aspx
P.S. Для загрузки примеров нужна регистрация на сайте: http://help.leadersoft.ru
Код на VBA
' Все объекты объявления в форуме
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
В избранное