Во-первых, большое спасибо Алексею за созданный форум, за его личное участие в общении на нем, а также всем остальным форумчанам, благодаря которым, собственно, форму продолжает жизеь и обновляться. А также спасибо за столь удобную структуру, которая просто сама напрашивается на переработку в локальную версию .
Во-вторых, по сути. Что делает пример? Качает собственно файл форума, парсит его, дополняет базу вопросов и ответов. Обработка, т.е. парсинг, настраиваемый. То есть в параметрах проги можно указать конкретные строковые выражения, которые будут выполнять роль тегов. Все вопросы видны в перечне на главной форме, их можно посортировать по названию, автору, дате создания или количеству ответов. Можно поискать по заданным словам в этих полям или по периоду дат. Данные и прога традиционно разделены для удобства пользования.
Из прикладных решений, на которые бы хотелось обратить внимание.
1. Подвязка таблиц на загрузку проекта. Вещь, обсужденная уже столько раз, что рискую сказать только пару слов.
Идея такая: функция, отвечающая за правильную подвязку таблиц, обозначена в autoexec – макросе. Схема работы простая - ищет mdb с заданным именем базы в рабочей папке проги, иначе выдает окно, в котором предлагается указать путь к базе, если путь не указан, выходим, иначе освежаем связи, если есть необходимость. Как показывает опыт, такая схема достаточно удобна в эксплуатации.
Функция
OpenFile(ByVal InitDir As String, ByVal Fname As String, ByVal ffilter As String) As String
позаимствована исходно у Андрея Кравченко, но это не первоисточник, как оказалось.
По сути это обертка для API-функции:
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
2. Закачка файла форума.
Как известно, удобно закачивать файлы с помощью API-функции:
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Все в ней прекрасно, кроме одного. Она никак не отображает статус закачки. То есть угадать, насколько в данный момент закачан файл можно исключительно сторонним путем. Что не совсем удобно. Поэтому пришлось использовать данную функцию для закачки заведомо маленьких файлов сообщение в формате idc, оформленную в виде логической функции:
Function DownLoadFile(strURL As String, StrFileName As String) As Boolean
C первоисточником нелегко, я ее встречала на нескольких русскоязычных сайтах.
Что касаемо закачки здоровенного 10-мб файла собственно перечня сообщений, то для этих целей пришлось воспользоваться Microsoft Internet Transfer Control. У меня он 6.0 SP6. Не знаю, в версии ли дело или еще в чем, но контрол хладнокровно отказался от собственного весьма полезного свойства .Cancel. Так что пришлось пользовать его без этого свойства.
Сначала пытаемся определить размер файла – по заголовку «Content-length», с которым, кстати, не всегда может и повезти.
Причем, в данном случае мне не всегда везло с первого раза, так что пришлось назначить количество попыток для получения размера файла для закачки.
Private Const k_all_max As Long = 5
…
k_all = 0
lblRep:
k_all = k_all + 1
Application.SysCmd acSysCmdSetStatus, " Определение размера файла " + StrFileName
MSInet.URL = StrFileName
MSInet.Protocol = icHTTP
MSInet.RequestTimeout = 120
MSInet.Execute StrFileName, "HEAD"
Do
If Not MSInet.StillExecuting Then Exit Do
DoEvents
Loop
NAll = Val(MSInet.GetHeader("Content-length"))
If NAll = 0 And k_all < k_all_max Then GoTo lblRep
Есть один болезненный вопрос – со временем отклика RequestTimeout. Слишком большим ставить его не стоит, придется ждать лишнее время, если захочется завершить процесс или повторить не закончив. А слишком маленьким тоже не стоит – прервется закачка по какому-то мелкому поводу и все начинать сначала, так как в данном случае докачка не поддерживается.
Ну ладно, предположим, размер вы выяснили, теперь можно начинать качать с индикацией процесса. Индикацию можно оформить по таймеру. Для начала процесса сделаем вот что:
Private Const Interv As Long = 10000 ‘(в миллисекундах, лучше пореже сделать)
Dim Status As Boolean, vbStop As Boolean
…
vbStop = False: Status = True
Me.TimerInterval = Interv
MSInet.Execute StrFileName, "GET"
Вот и все. Закачка началась. Теперь надо обработать получаемый поток: на событие MSInet_StateChanged()
Private Sub MSInet_StateChanged(ByVal State As Integer)
Dim vtData() As Byte
On Error GoTo LblErr
Select Case State
Case icResponseCompleted
Open StrFileName2 For Binary Access Write As #2
vtData = MSInet.GetChunk(SzByte, icByteArray)
Do While LenB(CStr(vtData)) > 0
DoEvents
If vbStop = True Then Exit Sub
Put #2, , vtData
vtData = MSInet.GetChunk(SzByte, icByteArray)
Loop
If Status = True Then Status = False
Put #2, , vtData
Close #2
End Select
Exit Sub
LblErr:
Close #2
MsgBox Err.Description, vbCritical + vbOKOnly
End Sub
Теперь надо прописать индикацию закачки в событии таймера. Координацию со статусом закачки можно обеспечить логической переменной Status As Boolean, объявленной общей модуле.
Если Status = True, то качается файл.
Если Status = False, то закачка завершена или прервана.
Есть и вторая переменная, которая позволяет прервать закачку vbStop на событие формы, например, нажатие клавиши Esc.
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo LblErr
If KeyCode = vbKeyEscape Then vbStop = True: Status = False
Exit Sub
LblErr:
MsgBox Err.Description, vbCritical + vbOKOnly
End Sub
Обе эти переменные должны быть обработаны в процедуре получения данных MSInet_StateChanged() и в событии таймера, которое отвечает за индикацию процесса.
Private Sub Form_Timer()
Dim k As Long
On Error GoTo LblErr
If Len(StrFileName2) = 0 Then Exit Sub
If Len(Dir$(StrFileName2)) > 0 Then k = FileLen(StrFileName2) Else k = 0
If NAll > 0 Then
Application.SysCmd acSysCmdUpdateMeter, k / NAll * 100
Else
Application.SysCmd acSysCmdSetStatus, "Загрузка " + StrFileName + " " & k & " байт"
End If
If Status = False Then
MSInet.Execute StrFileName, "CLOSE"
If NAll > 0 Then
Application.SysCmd acSysCmdRemoveMeter
Else
Application.SysCmd acSysCmdClearStatus
End If
Me.TimerInterval = 0
If k = NAll Then
MsgBox "Файл " + StrFileName2 + " сохранен.", vbInformation + vbOKOnly
Else
MsgBox "Файл " + StrFileName2 + " сохранен " & k & " байт из " & NAll, vbInformation + vbOKOnly
End If
Close #1
Close #2
End If
Exit Sub
LblErr:
Close #1
Close #2
MsgBox Err.Description, vbCritical + vbOKOnly
End Sub
Вот, кстати, обход неработающего свойства Cancel :
MSInet.Execute StrFileName, "CLOSE"
Одна из ссылок http://www.codenet.ru/progr/vbasic/sendfile.php
Которое в ряде случаев срабатывает по истечении времени отклика RequestTimeout.
Вот общая работоспособная схема, которая позволит выкачать файл с визуальной индикацией. Возможно, возникнет желание употребить WinSock, тоже вполне возможно, там обработка события DataArrival(). А вообще оба контрола используют набор API-функций, некоторый перечень которых можно найти в примерах вот здесь, например http://www.vb.kiev.ua/
Вдруг кому захочется самому реализовать закачку, минуя Microsoft ActiveX, а может, еще и многопоточную ?, вот несколько примеров.
http://www.vb.kiev.ua/code/networks/multi_downloader.zip
http://www.vb.kiev.ua/code/networks/multidownloader_198.zip
3. Работа со строками.
В общем, сам процесс обработки можно назвать «парсингом», так как по сути оно где-то близко. В параметрах задаем «строковые скобки», при обнаружении которых можно извлекать само значение. Вот, например, для извлечения темы форума задаем «строковые скобки» такие:
StrZag1 = «<font size="2" face="Tahoma"><strong>»
StrZag2 = «</strong></font></a>»
Причем вхождение их должно после ссылки на url тела сообщения, а обнаружение этого самого линка должно быть обусловлено вхождением предыдущей пары «строковым скобок».
p5 = InStr(p4 + nfd2 + 1, StrTec, StrZag1) + nz1: p6 = InStr(p5, StrTec, StrZag2)
StrZag = Trim$(Mid$(StrTec, p5, p6 - p5))
Естественно, такая схема частично настраивается под конкретный файл, точнее, настраивается порядок следования и сами строковые выражения - ограничители, зато обработка строк идет достаточно быстро без дополнительных библиотек.
4. Считывание файла порциями в бинарном режиме.
Если файл весит 10 мб, то грузить его целиком в память нерационально, поэтому читаем его порциями в бинарном режиме по определенной схеме.
Читаем блоками, по размеру соответствующими нашему элементу – форумной теме с ее описанием – автором, ссылкой, датой, заголовком. Так как заранее мы не знаем размер блока, но определяем его в разумных завышенных пределах ?
NSym = 50000.
Заготавливаем переменную – буфер для чтения:
StrTec = Space$(NSym)
Стартуем с первого символа:
k = 1
После очередного чтения блока, смещаемся на последнюю позицию – а это конец последней по порядку «строковой скобки». А заканчиваем чтение не по достижении конца файла, а именно по позиции чтения. Последний раз мы читаем полупустую переменную, но не беда, мы-то обрабатываем по своим подстрокам – ограничителям.
NAll = FileLen(strFile): NRec = 0
NSym = 50000: StrTec = Space$(NSym): k = 1
Open strFile For Binary Access Read As #1
While k <= NAll
NRec = NRec + 1
Get #1, k, StrTec
…
k = k + p12 + nd2
DoEvents
Wend
5. Интерфейс – быстрая сортировка по полям.
Двойной щелчок по полю вызывает изменение цвета заголовка и собственно сортировку данных.
Реализуется таким образом.
Заголовки именуются единообразно с номером в названии. Например, LblSort1, LblSort2 … и т.д.
Под каждый заголовок создаем событие:
Private Sub lblSort1_DblClick(Cancel As Integer)
On Error GoTo LblErr
Call ClickSorting("zag", 1) ', где «zag» – имя поле в источнике данных формы, подвязанное в полю заголовка.
Exit Sub
LblErr:
MsgBox Err.Description
Err.Clear
End Sub
А вот функция, которая обрабатывает сортировку:
Private Const ColUn = 16777215
Private Const ColSort = 16709107
Private Const NumLbl = 5
…
FieldName – поле, по которому отсортируется,
NumSort – связка этого поля с номером метки,
Vid – обычно порядок сортировки (ASC или DESC) определяется самой функцией, как видно из кода, но этим параметром можно и жестко задать порядок сортировки. Vid = 1 по возрастанию, а больше – по убыванию.
Sub ClickSorting(ByVal FieldName As String, ByVal NumSort As Byte, Optional Vid As Byte = 0)
On Error GoTo LblErr
Dim SortOrd As String, i As Long
Dim NumRec As Long
If Me.Recordset.RecordCount = 0 Then Exit Sub
NumRec = Nz(Me!num_id.Value, 0)
Application.Echo False
For i = 1 To NumLbl
Controls("lblSort" & i).BackColor = ColUn
Next i
Controls("lblSort" & NumSort).BackColor = ColSort
SortOrd = Me.OrderBy
If Vid = 0 Then
If SortOrd Like "*" + FieldName + " DESC,*" Then
Me.OrderBy = FieldName + ", num_id"
Else
Me.OrderBy = FieldName + " DESC, num_id"
End If
Else
If Vid = 1 Then
Me.OrderBy = FieldName + ", num_id"
Else
Me.OrderBy = FieldName + " DESC, num_id"
End If
End If
If Len(Me.OrderBy) > 0 Then Me.OrderByOn = True Else Me.OrderByOn = False
If NumRec = 0 Then Exit Sub
Me!num_id.SetFocus
Me.Recordset.FindFirst "num_id=" & NumRec
Application.Echo True
Exit Sub
LblErr:
MsgBox Err.Description
Err.Clear
End Sub
Для пущей красоты мы сохраним поле сортировки по закрытии формы и порядок сортировки:
Private Sub Form_Close()
Dim SortOrd As String, sNum As Byte, vVid As Boolean
On Error GoTo LblErr
SortOrd = Me.frm_list_quest.Form.OrderBy: sNum = 1: vVid = False
If SortOrd Like "zag*" Then sNum = 1: vVid = False
If SortOrd Like "zag DESC*" Then sNum = 1: vVid = True
If SortOrd Like "name_autor*" Then sNum = 2: vVid = False
If SortOrd Like "name_autor DESC*" Then sNum = 2: vVid = True
If SortOrd Like "when*" Then sNum = 3: vVid = False
If SortOrd Like "when DESC*" Then sNum = 3: vVid = True
If SortOrd Like "num_id*" Then sNum = 4: vVid = False
If SortOrd Like "num_id DESC*" Then sNum = 4: vVid = True
If SortOrd Like "n_answ*" Then sNum = 5: vVid = False
If SortOrd Like "n_answ DESC*" Then sNum = 5: vVid = True
set_sort_kol_f_list sNum, vVid
Exit Sub
LblErr:
MsgBox Err.Description, vbCritical + vbOKOnly
End Sub
А на открытие считаем сохраненное значение:
Private Sub Form_Open(Cancel As Integer)
Dim SortOrd As String, sNum As Byte, vVid As Boolean
Dim i As Long
On Error GoTo LblErr
sNum = get_sort_kol_f_list(): vVid = get_vid_sort_f_list()
Call Me.frm_list_quest.Form.PaintZags(sNum)
Select Case sNum
Case 1
SortOrd = "zag"
Case 2
SortOrd = "name_autor"
Case 3
SortOrd = "when"
Case 4
SortOrd = "num_id"
Case 5
SortOrd = "n_answ"
End Select
If vVid = True Then SortOrd = SortOrd + " DESC, num_id" Else SortOrd = SortOrd + ", num_id"
Me.frm_list_quest.Form.OrderBy = SortOrd
Me.frm_list_quest.Form.OrderByOn = True
Exit Sub
LblErr:
MsgBox Err.Description, vbCritical + vbOKOnly
End Sub
6. Еще по интерфейсу - изменение строки в ленточной форме Shift + мышь.
Все очень просто. Выбираем «контрольный» элемент, который не позволит сжать строку до нуля. Его высота будет предельной. У нас это num_record. Для пущего удобства записываем на закрытие формы высоты строки и потом читаем.
Dim X1 As Long, Y1 As Long, vbRows As Boolean
…
Private Sub ОбластьДанных_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo LblErr
X1 = X: Y1 = Y
If Shift = acShiftMask Then
vbRows = True
Screen.MousePointer = 7
Else
vbRows = False
Screen.MousePointer = 0
End If
Exit Sub
LblErr:
MsgBox Err.Description
Err.Clear
End Sub
Private Sub ОбластьДанных_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo LblErr
If Shift = acShiftMask Then Screen.MousePointer = 7 Else Screen.MousePointer = 0
Exit Sub
LblErr:
MsgBox Err.Description
Err.Clear
End Sub
Private Sub ОбластьДанных_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo LblErr
Dim dy As Long, Hobl As Long
If vbRows = True Then
dy = Y - Y1: Hobl = Me.ОбластьДанных.Height + dy
Application.Echo False
If dy > 0 Then
Me.ОбластьДанных.Height = Hobl
Me!zag.Height = Hobl
Me!name_autor.Height = Hobl
Me!n_answ.Height = Hobl
Me!when.Height = Hobl
Me!num_id.Height = Hobl
И другие элементы, которые есть в области данных…
Else
If Hobl < Me!num_record.Height Then Hobl = Me!num_record.Height
Me!zag.Height = Hobl
Me!name_autor.Height = Hobl
Me!n_answ.Height = Hobl
Me!when.Height = Hobl
Me!num_id.Height = Hobl
Me.ОбластьДанных.Height = Hobl
End If
Application.Echo True
End If
vbRows = False
Screen.MousePointer = 0
Me.Repaint
Exit Sub
LblErr:
MsgBox Err.Description
Err.Clear
End Sub
7. Полезные функции
Сразу скажу, как правило, они где живут в Инете, созданы в большинстве своем не мной, поэтому просто упомяну о них.
'возвращает имя из URL, совместима с Access 97
Function GetNameURL(ByVal StrPth As String) As String
В принципе, на базе этой функции можно сделать много других ?
'вспомогательная, открыта ли форма
Function form_is_open(ByVal strFormName As String) As Boolean
'есть ли файл, доступен ли. Фактически обертка для Dir$, чтобы не было ошибки при отсутствующем доступе к диску.
Function FileEx(ByVal strFile As String) As Boolean
'аналог Replace под Acceess 97 с учетом постидущей строки Str2FindIf
Function Replace97(ByVal StrMain As String, _
ByVal Str2Find As String, _
ByVal Str2Ch As String, _
Optional ByVal Str2FindIf As String) As String
То есть если задано строковое выражение Str2FindIf, то замена Str2Find произойдет только при условии, что после Str2Find следует Str2FindIf. Это касается старых тем в форуме, где периодически вместо vbCrLf проскакивал vbCr. Некрасиво
|