powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Как вставить HTML таблицу в Word средствами VB ?
12 сообщений из 12, страница 1 из 1
Как вставить HTML таблицу в Word средствами VB ?
    #35189418
Zioner
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Как вставить HTML таблицу в Word средствами VB ?

Есть вариант вставки из файла:

Selection.InsertFile FileName:="files.htm"


А как это сделать не через файл, типа так:

HTMLText = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01//EN"" ""http://www.w3.org/TR/html4/strict.dtd"">" & _
"<html>" & _
"<head>" & _
"<title>AAA</title>" & _
"</head>" & _
"<body>" & _
"<table border border-collapse: collapse >" & _
"<tr>" & _
"<td>11</td>" & _
"<td>14</td>" & _
"</tr>" & _
"<tr>" & _
"<td>222</td>" & _
"<td>112</td>" & _
"</tr>" & _
"</table>" & _
"</body>" & _
"</html>"

Selection.TypeText Text:=strHTMLText <-??????

заранее Спасибо!

P.S.
Здесь в форуме нашел такой вопрос - но в ответе ссылка - которая уже не рабротает
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35192531
Zioner
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
up
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35193322
AndrF
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Я сейчас делаю под один заказ отчеты в Word. Точнее - сначала формирую их в обычном HTML-формате, а потом открываю его Word-ом, сохраняю в doc-формате, вставляю оглавление и переносы страниц в нужные места. В итоге получается нормальный Word-овский документ. При этом работы собственно с Word-овской объектной моделью миниум.
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35193389
Фотография BION
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
AndrFЯ сейчас делаю под один заказ отчеты в Word. Точнее - сначала формирую их в обычном HTML-формате, а потом открываю его Word-ом, сохраняю в doc-формате, вставляю оглавление и переносы страниц в нужные места. В итоге получается нормальный Word-овский документ. При этом работы собственно с Word-овской объектной моделью миниум.

Если не трудно примерчик, тоже интересуюсь, да и другим на будущее.
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35193400
AndrF
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
BIONЕсли не трудно примерчик, тоже интересуюсь, да и другим на будущее.

Примерчик чего? Как открыть HTML-ку Word-ом и сохранить уже в Word-овском формате? Проделай это в Word-е записывая макрос и посмотри получившийся код там пара строчек в итоге будет...
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35193415
Фотография BION
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
AndrF BIONЕсли не трудно примерчик, тоже интересуюсь, да и другим на будущее.

Примерчик чего? Как открыть HTML-ку Word-ом и сохранить уже в Word-овском формате? Проделай это в Word-е записывая макрос и посмотри получившийся код там пара строчек в итоге будет...

Да эт старая исторя, я прост думал можт ты непосредственно в новый док встраиваешь HTML какньть через xml xsl и т.д., но раз так то вопросов более не имею.
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35193466
Фотография BION
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Кстати, можно скопировать HTML структуру в буфер и просто Selection.PasteAndFormat (wdPasteDefault)
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35221865
Zioner
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Сделал макрос для вставки из clipboard,
но вставляется как текст.

Как сказать что вбуфере обмена HTML-текст, чтоб вставляло в Word
как табличку (а не текст с <тегами>)?


Sub d2()
'
' d2 Макрос
'
'
Dim HTMLText As String
Dim doClip As DataObject

Set doClip = New DataObject

HTMLText = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01//EN"" ""http://www.w3.org/TR/html4/strict.dtd"">" & _
"<html>" & _
"<head>" & _
"<title>AAA</title>" & _
"</head>" & _
"<body>" & _
"<table border border-collapse: collapse >" & _
"<tr>" & _
"<td>11</td>" & _
"<td>14</td>" & _
"</tr>" & _
"<tr>" & _
"<td>222</td>" & _
"<td>112</td>" & _
"</tr>" & _
"</table>" & _
"</body>" & _
"</html>"

doClip.SetText HTMLText
doClip.PutInClipboard

Set doClip = Nothing

Selection.PasteAndFormat (wdPasteDefault)

End Sub
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35222197
Фотография Андрей159
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Private Sub Zapit(ZapitURLName)
Call SoundPlay(1)
On Error GoTo ER
ZapitURLName = Trim(ZapitURLName)
If Lichilnik > 200 Then
Inet1(0).Execute CStr(ZapitURLName), "GET /"
' Inet1(0).Execute CStr(ZapitURLName), "GET /"
' Inet1(0).Execute CStr(ZapitURLName), "GET /"
Else
Inet1(0).Execute CStr(ZapitURLName), "GET /"
End If
If TmpZapitURLName = ZapitURLName Then
PovtZapitURLName = PovtZapitURLName + 1
Else
PovtZapitURLName = 0
DblPovtZapitURLName = 0
End If

TmpZapitURLName = ZapitURLName

If DblPovtZapitURLName > 2 Then
List1.AddItem "Сервер відмовляється надсилати будь-які дані ! " + ZapitURLName
Call MnuQuit_Click
End If

If PovtZapitURLName > 2 Then
List1.AddItem "Дану сторінку пропущено автоматично. Сервер не відповідає ! " + ZapitURLName
DblPovtZapitURLName = DblPovtZapitURLName + 1
PovtZapitURLName = 0
Call Command9_Click
End If

Exit Sub
ER:
Call SoundPlay(15)
Inet1(0).Cancel
List1.AddItem "Виявлено помилку доступу до даного адресу ! " + ZapitURLName
Call Command9_Click
End Sub
Private Sub Command1_Click()
Timer2.Interval = 1000
RegimPravki = False
Command1.Enabled = False
Command5.Enabled = False
Dim r As Byte
Dim z As Boolean
NameFile = "D:\Проекти\Програма скачування\Верховна Рада\temp2.htm" ' Початковий

Nxt:


If ScanDocument <> "" Then NameFile = ScanDocument: ScanDocument = "": Unload FrmScanFile: GoTo ddd

If AnalizAllFile = "Кінець" Then BC = 0: AnalizAllFile = "": Unload FileWord: Timer1.Interval = 0: Command5.Enabled = True: Exit Sub
If AnalizAllFile = "Початок" Or AnalizAllFile <> "" Then Call AnalizFile: NameFile = AnalizAllFile: GoTo ddd



'GoTo ddd
Close 10

Call PrPause
Text1.Text = ""
SS = ""
Open NameFile For Output As #10

Inet1(0).protocol = icHTTP
List1.AddItem "З'єднуюсь з сервером..." + URLName

Call Zapit(URLName)
pomilka = False


While Inet1(0).StillExecuting
If pomilka = True Then
Close 10
io = VznatiVilniyURL()
If io = "Буфер порожній" Then Form1.Caption = "Буфер порожній"
URLName = Trim(io)
Timer1.Interval = 5000
Exit Sub
End If
DoEvents
Wend
List1.AddItem "Завершив закачку (цикл) " + URLName


Close 10
If pomilka = True Then Exit Sub
Form1.Caption = "Сторінку завантажено у віртуальну пам'ять"
ddd:


Call BazaStorinok(True) ' Відкрити базу даних сторінок
Call RozkladFile
Call BazaStorinok(False) ' Закрити базу даних сторінок
If URLName = "Буфер порожній" Then Form1.Caption = "Завантаження завершено": Command1.Enabled = True: Exit Sub
GoTo Nxt

End Sub
Private Sub RozkladFile()
Dim SS As Variant
Dim s1 As String
Dim n1 As Variant
Dim n2 As Variant
Dim n3 As Variant
Dim Maxn As Variant
Dim nNameNewFile As String
Dim a As String
Dim gg As Boolean
Dim Pzn As String
Dim io As String
Dim PoslidovnZavant As Byte
Maxn = 0
n1 = 0
SS = ""

MemData(0) = ""
Close 10
Open NameFile For Input As #10
Monitoring.Caption = "Аналіз: Розглядаю файл... -> " + NameFile

n1 = FileLen(NameFile)
Maxn = n1
If n1 = 0 Then pomilka = True: List1.AddItem "Сервер не відповідає. Зациклена помилка.": GoTo pomilka1
On Error GoTo Puk
SS = Input$(FileLen(NameFile), 10)
'Перевірка на облом
Popandos = False
If AnalizAllFile = "" Then ' якщо нормальний режим роботи і попандос
If InStr(1, SS, "На сьогоднi Ваш лiмiт перегляду сторiнок вичерпано", vbTextCompare) <> 0 Then List1.AddItem "Повідомлення від сервера. Вичерпаний ліміт!": Call MnuQuit_Click
Else ' якщо перевіряються файли і бачимо попандос, то мітимо на незакачені і продовжуємо роботу
If InStr(1, SS, "На сьогоднi Ваш лiмiт перегляду сторiнок вичерпано", vbTextCompare) <> 0 Then
Popandos = True
Call SoundPlay(2)
End If
End If


If InStr(1, SS, "</html>", vbTextCompare) = 0 Then List1.AddItem "Увага! Помилка! Сторінка не завершена": Call SoundPlay(6): GoTo pomilka1

Golova1:
For n1 = 1 To Maxn

'Взнаємо реальну назву документа
If LCase(Mid(SS, n1, 7)) = LCase("<TITLE>") Then
For n2 = n1 + 7 To n1 + 500
If LCase(Mid(SS, n2, 8)) = LCase("</TITLE>") Then
GoTo m2
End If
Next
End If
Next
m2:
If SS = "" Then pomilka = True: List1.AddItem "Сервер не відповідає. Зациклена помилка.": GoTo pomilka1
RealNameFile = LCase(Mid(SS, n1 + 7, n2 - n1 - 7))
Monitoring.Caption = "Аналіз: Розглядаю файл... -> " + NameFile + "-" + RealNameFile












'Взнаємо назву документа
n1 = 0
n2 = 0
n3 = 0
For n1 = 1 To Maxn
If LCase(Mid(SS, n1, 13)) = LCase("res>Документ ") Or LCase(Mid(SS, n1, 13)) = LCase("res>Документ<") Or LCase(Mid(SS, n1, 14)) = LCase("res> Документ ") Or LCase(Mid(SS, n1, 14)) = LCase("res> Документ<") Then
For n2 = n1 + 13 To n1 + 200
If LCase(Mid(SS, n2, 3)) = LCase("<b>") Then
n1 = n2: GoTo m1
End If
Next n2
End If

Next n1
GoTo m3
m1:
For n3 = n1 + 3 To n1 + 50
If LCase(Mid(SS, n3, 4)) = LCase("</b>") Then
NameNewFile = LCase(Mid(SS, n1 + 3, n3 - n1 - 3)) ' даєм значення змінній
GoTo m3
End If
Next n3
m3:
Monitoring.Caption = "Аналіз: Розглядаю файл... -> " + NameFile + "-" + RealNameFile + "-" + NameNewFile

For PoslidovnZavant = 0 To 2
If NastrPoslidovnistZavantajenna(PoslidovnZavant) = "Завантаження сторінок" Then GoSub VznatiNomerStorinki
If NastrPoslidovnistZavantajenna(PoslidovnZavant) = "Завантаження готових HTML ссилок" Then GoSub VznatiGotoviSsilki
If NastrPoslidovnistZavantajenna(PoslidovnZavant) = "Завантаження Java ссилок" Then GoSub VznatiJavaSsilku
Next



'MsgBox RealNameFile
'MsgBox NameNewFile
'MsgBox ZagalKstStorinok
Text1.Text = RealNameFile + Chr(13) + "Кількість сторінок=" + Str(ZagalKstStorinok) + Chr(13) + NameNewFile

'Збереження документа
nNameNewFile = URLName
For n1 = 1 To Len(nNameNewFile)
If Mid(nNameNewFile, n1, 1) = "/" Then Mid(nNameNewFile, n1, 1) = "Z"
If Mid(nNameNewFile, n1, 1) = "\" Then Mid(nNameNewFile, n1, 1) = "z"
If Mid(nNameNewFile, n1, 1) = "|" Then Mid(nNameNewFile, n1, 1) = "_"
If Mid(nNameNewFile, n1, 1) = Chr(34) Then Mid(nNameNewFile, n1, 1) = "'"
If Mid(nNameNewFile, n1, 1) = "?" Then Mid(nNameNewFile, n1, 1) = "_"
If Mid(nNameNewFile, n1, 1) = "&" Then Mid(nNameNewFile, n1, 1) = "_"
Next

If AnalizAllFile = "" Then
GGotFile = "D:\Проекти\Програма скачування\Верховна Рада\Архів\" + Trim(nNameNewFile) + ".htm"
'Збереження в тимчасовий файл
Open GGotFile For Output As #11
For n1 = 1 To Maxn
Print #11, Mid(SS, n1, 1);
Next n1
Close #11
Trafik1 = Trafik1 + Trafik
Trafik = 0
Label8.Caption = Trim(Str(Trafik1))
Monitoring.Caption = "Виконано збереження документа"
List2.AddItem "Save->" + URLName
ZakachanoStorinokKst = ZakachanoStorinokKst + 1
Label15.Caption = Str(ZakachanoStorinokKst)
Call SoundPlay(7)
End If
'Основний документ також збережено
If AnalizAllFile = "" Then
If DopovnitiBazuStorinok(URLName) = "Доповнено новий запис" Then
List1.AddItem "Доповнено основний запис " + NameNewFile
End If
End If
'Позначити документ зробленим
If AnalizAllFile = "" Then
If PoznachennaZavantajenim(URLName) = "ОК" Then
List1.AddItem "Завантажено і збережено успішно"
End If
Else
URLName = Left(FileWord.File1.List(BC - 1), Len(FileWord.File1.List(BC - 1)) - 4)

If InStr(1, SS, " Про внесення змін ", vbBinaryCompare) <> 0 Or InStr(1, SS, " Про внесення зміни ", vbBinaryCompare) <> 0 Or InStr(1, SS, " Про внесення доповнень ", vbBinaryCompare) <> 0 Or InStr(1, SS, " Про внесення доповнення ", vbBinaryCompare) <> 0 Or InStr(1, SS, ">Про внесення змін ", vbBinaryCompare) <> 0 Or InStr(1, SS, ">Про внесення зміни ", vbBinaryCompare) <> 0 Or InStr(1, SS, ">Про внесення доповнень ", vbBinaryCompare) <> 0 Or InStr(1, SS, ">Про внесення доповнення ", vbBinaryCompare) <> 0 Then
Pzn = PoznachennaNeZavantajenim(URLName, "Поставити мітку: Про внесення змін")
List1.AddItem "Під час аналізу збережено як необов'язкове!"
End If
If Popandos = True Then
Pzn = PoznachennaNeZavantajenim(URLName, "Позначити незавантаженим")
If Pzn = "ОК" Then
List1.AddItem "Попандос! Сторінка повинна обновитись!" + " " + URLName
End If
If Pzn = "Perfect" Then
List1.AddItem "********Було виправлено" + " " + URLName
End If
Else
List1.AddItem "********Пройдено тест!" + " " + Str(Len(SS) / 1000) + " " + URLName
End If
End If

Popandos = False
Close 10
If AnalizAllFile <> "" Then Exit Sub
pomilka1:
io = Trim(VznatiVilniyURL())
If io = "Буфер порожній" Then Form1.Caption = "Буфер порожній"
URLName = Trim(io)
Exit Sub
'------------------------------------------------------------------------
VznatiGotoviSsilki:
'Шукаємо готові ссилки
'If NastrZavantajennaGotovihSsilok = False Then Return
' For n1 = 1 To Maxn
' a = LCase("/cgi-bin/laws/main.cgi?user=o") '"/cgi-bin/laws/main.cgi?user=a&find=1&typ="
' If LCase(Mid(SS, n1, Len(a))) = a Then
' a = Mid(SS, n1 + Len(a), 25)
' a = Left(a, InStr(2, a, "'", vbBinaryCompare) - 1)
' a = "zakon1.rada.gov.ua/cgi-bin/laws/main.cgi?user=o" + a
' If DopovnitiBazuStorinok(a) = "Доповнено новий запис" Then
' List1.AddItem "Готова ссилка - " + a
' List2.AddItem "Load->" + a
' Call SoundPlay(4)
' End If
' End If
' a = LCase("/cgi-bin/laws/main.cgi?user=n")
' If LCase(Mid(SS, n1, Len(a))) = a Then
' a = Mid(SS, n1 + Len(a), 25)
' a = Left(a, InStr(2, a, "'", vbBinaryCompare) - 1)
' a = "zakon1.rada.gov.ua/cgi-bin/laws/main.cgi?user=n" + a
' If DopovnitiBazuStorinok(a) = "Доповнено новий запис" Then
' List1.AddItem "Готова ссилка - " + a
' List2.AddItem "Load->" + a
' Call SoundPlay(4)
' End If
' End If
' Next
Return
'------------------------------------------------------------------------
VznatiJavaSsilku:
'Шукаємо JAVA ссилки
If NastrZavantajennaJavaSsilok = False Then Return
For n1 = 1 To Maxn
If LCase(Mid(SS, n1, 9)) = LCase("OpenDoc('") Then
For n2 = n1 + 9 To n1 + 100
If LCase(Mid(SS, n2, 2)) = LCase("')") Then GoTo m4
Next n2
End If
GoTo m5
m4:
If LCase(Mid(SS, n1 + 9, n2 - n1 - 9)) = "nreg" Then GoTo m5
If DopovnitiBazuStorinok("zakon1.rada.gov.ua/cgi-bin/laws/main.cgi?nreg=" + LCase(Mid(SS, n1 + 9, n2 - n1 - 9))) = "Доповнено новий запис" Then
List1.AddItem "Доповнено JAVA- " + LCase(Mid(SS, n1 + 9, n2 - n1 - 9))
List2.AddItem "Load->" + LCase(Mid(SS, n1 + 9, n2 - n1 - 9))
Call SoundPlay(12)
End If

m5:
Next n1
Return

'------------------------------------------------------------------------
VznatiNomerStorinki:
'Взнаємо скільки є сторінок в загальному
ZagalKstStorinok = 0
TmpZagalKstStorinok = ""

If NastrZavantajennaStorinok = False Then Return

gg = False
For n1 = 1 To Len(RealNameFile)
If LCase(Mid(RealNameFile, n1, 4)) = LCase("стор") Then
For n2 = n1 To Len(RealNameFile)
If LCase(Mid(RealNameFile, n2, 1)) = LCase(")") Then
TmpZagalKstStorinok = Space(1000)
For n3 = n2 To n2 - 4 Step -1
If gg = True Then Mid(RealNameFile, n3, 1) = " "
If Mid(RealNameFile, n3, 1) = " " Then gg = True
If Mid(RealNameFile, n3, 1) <> ")" Then Mid(TmpZagalKstStorinok, n3, 1) = Mid(RealNameFile, n3, 1)
Next
ZagalKstStorinok = Val(Trim(TmpZagalKstStorinok))
End If
Next n2
End If
Next n1

'Збереження в буфер
For n1 = 2 To ZagalKstStorinok
If DopovnitiBazuStorinok("zakon1.rada.gov.ua/cgi-bin/laws/main.cgi?page=" + Trim(Str(n1)) + "&nreg=" + NameNewFile) = "Доповнено новий запис" Then
List1.AddItem "Доповнено сторінку - " + NameNewFile + "№ " + Str(n1)
List2.AddItem "Load->" + NameNewFile + "№ " + Str(n1)
Call SoundPlay(11)
End If
Next
ZagalKstStorinok = 0

Return
Puk:
Close 10
Propustiti = Propustiti + 1
Label16.Caption = Str(Propustiti)
List1.AddItem "Сторінка не збереглась " + NameNewFile
List2.AddItem "Сторінка не збереглась->" + NameNewFile
End Sub

Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Command1.Caption = "Зупинити" Then
Command5.Enabled = True
Command1.Caption = "Скачати весь сайт Верховної Ради"
Command1.Enabled = True
Exit Sub
End If
End Sub

Private Sub Command10_Click()
Propustiti = Propustiti - 1
If Propustiti < 0 Then Propustiti = 0
Label16.Caption = Str(Propustiti)
End Sub

Private Sub Command11_Click()
Propustiti = Propustiti + 1
Label16.Caption = Str(Propustiti)
End Sub



Private Sub Command12_Click()
Dim pola As BazaStorinok
Dim n As Integer
Dim p As String
Dim maxnn As Integer

If RegimPravki = True Then
Call BazaStorinok(False)
Call BazaStorinok(True)
If Check1.Value = False Then
If List1.ListIndex + 1 > 0 Then
n = List1.ListIndex + 1
Get #2, n, pola
pola.PolURLAdres = "Delete"
pola.PolNameDoc = "Delete"
pola.PolStatusZakachki = False
pola.PolKategory = ""
Put #2, n, pola
Monitoring.Caption = "Інвертовано призначення"
End If
End If
If Check1.Value = 1 Then
If Val(Text3.Text) < List1.ListCount Then
For n = Val(Text2.Text) To Val(Text3.Text)
Get #2, n, pola
pola.PolURLAdres = "Delete"
pola.PolNameDoc = "Delete"
pola.PolStatusZakachki = False
pola.PolKategory = ""
Put #2, n, pola
Next
End If
End If
End If
Call Command4_Click
End Sub

Private Sub Command2_Click()
RegimPravki = False
List1.Clear
End Sub
Private Sub Command3_Click()
RegimPravki = False
Form1.Caption = "Доповнено сторінку: " + DopovnitiBazuStorinok(URLTXT)
URLTXT.Text = ""
End Sub

Private Sub Command4_Click()
RegimPravki = True
Dim pola As BazaStorinok
Dim n As Integer
Dim p As String
Call BazaStorinok(False)
Call BazaStorinok(True)
List1.Clear
Dim maxnn As Integer
For n = 1 To 32000
Get #2, n, pola
If EOF(2) = True Then GoTo dali
p = Right(" " + RTrim(Str(n)), 5) + " "
If pola.PolStatusZakachki = False Then p = p + "Завантажено - " Else p = p + " "
List1.AddItem p + pola.PolURLAdres
Next n
dali:
End Sub

Private Sub Command5_Click()
RegimPravki = False
Timer1.Interval = 5000
Command5.Enabled = False
End Sub

Private Sub Command6_Click()
Dim pola As BazaStorinok
Dim n As Integer
Dim p As String
Dim maxnn As Integer

If RegimPravki = True Then
Call BazaStorinok(False)
Call BazaStorinok(True)
If Check1.Value = False Then
If List1.ListIndex + 1 > 0 Then
n = List1.ListIndex + 1
Get #2, n, pola
pola.PolStatusZakachki = True
Put #2, n, pola
Monitoring.Caption = "Інвертовано призначення"
End If
End If
If Check1.Value = 1 Then
If Val(Text3.Text) < List1.ListCount Then
For n = Val(Text2.Text) To Val(Text3.Text)
Get #2, n, pola
pola.PolStatusZakachki = True
Put #2, n, pola
Next
End If
End If
End If
Call Command4_Click
End Sub

Private Sub Command7_Click()
Dim pola As BazaStorinok
Dim n As Integer
Dim p As String
Dim maxnn As Integer

If RegimPravki = True Then
Call BazaStorinok(False)
Call BazaStorinok(True)
If Check1.Value = False Then
If List1.ListIndex + 1 > 0 Then
n = List1.ListIndex + 1
Get #2, n, pola
pola.PolStatusZakachki = False
pola.PolKategory = ""
Put #2, n, pola
Monitoring.Caption = "Інвертовано призначення"
End If
End If
If Check1.Value = 1 Then
If Val(Text3.Text) < List1.ListCount Then
For n = Val(Text2.Text) To Val(Text3.Text)
Get #2, n, pola
pola.PolStatusZakachki = False
pola.PolKategory = ""
Put #2, n, pola
Next
End If
End If
End If
Call Command4_Click
End Sub


Private Sub Command8_Click()
Command8.Enabled = False
End Sub

Private Sub Command9_Click()
Propustiti = Propustiti + 1
Inet1(0).Cancel
' Timer1.Interval = 2000
List1.AddItem "Ця сторінка динамічно пропускається!"







RegimPravki = False
Close 10
Timer1.Interval = 0
Command1.Caption = "Скачати весь сайт Верховної Ради"
Call BazaStorinok(False)
Call BazaStorinok(True)


io = VznatiVilniyURL()
List1.AddItem "Наступний адрес: " + io
If io = "Буфер порожній" Then Form1.Caption = "Буфер порожній"
URLName = io
Call Command1_Click



End Sub

Private Sub Form_Load()
URLName = "zakon1.rada.gov.ua/cgi-bin/laws/main.cgi?user=a&find=1&typ=21" 'Початкова сторінка
VidkluchitiProVnesennaZmin = MnuProVnesennaZmin
Propustiti = 0

NastrZavantajennaStorinok = True
NastrZavantajennaGotovihSsilok = True
NastrZavantajennaJavaSsilok = True
NastrSoundPlay = 3

NastrPoslidovnistZavantajenna(0) = "Завантаження сторінок"
NastrPoslidovnistZavantajenna(1) = "Завантаження готових HTML ссилок"
NastrPoslidovnistZavantajenna(2) = "Завантаження Java ссилок"


Command5.Enabled = True
Timer2.Interval = 1000
Timer1.Interval = 0
Call SoundPlay(16)
End Sub

Private Sub Inet1_StateChanged(Index As Integer, ByVal State As Integer)
Dim nf As Byte
Dim io As String
On Error GoTo ER

If Kn(Index).BackColor <> &HC0C0C0 Then
Select Case State
Case 12
If List2.ListCount > 1 Then List2.ListIndex = List2.ListCount - 1
Call SoundPlay(3)
Lichilnik = 0
Timer2.Interval = 1000
stemp = Inet1(Index).GetChunk(100)
MemData(0) = stemp
Monitoring.Caption = "Завантажується сторінка..." + URLName
List1.AddItem "Завантажується сторінка..." + URLName
Kn(0).BackColor = &H8080FF
While stemp <> ""
If PerevirkaProstoyu1 <> PerevirkaProstoyu Then PerevirkaProstoyu1 = PerevirkaProstoyu: Trafik = Trafik + Len(PerevirkaProstoyu1)
If Kn(0).Caption = "\" Then Kn(Index).Caption = ""
If Kn(0).Caption = "|" Then Kn(Index).Caption = "\"
If Kn(0).Caption = "/" Then Kn(Index).Caption = "|"
If Kn(0).Caption = "-" Then Kn(Index).Caption = "/"
If Kn(0).Caption = "" Then Kn(Index).Caption = "-"
If Kn(0).Caption = "Err" Then Kn(Index).Caption = ""
Print #10, stemp;
stemp = Inet1(Index).GetChunk(100)
PerevirkaProstoyu = stemp
MemData(0) = MemData(0) + stemp

If InStr(1, MemData(0), " Про внесення змін ", vbBinaryCompare) <> 0 Or InStr(1, MemData(0), " Про внесення зміни ", vbBinaryCompare) <> 0 Or InStr(1, MemData(0), " Про внесення доповнень ", vbBinaryCompare) <> 0 Or InStr(1, MemData(0), " Про внесення доповнення ", vbBinaryCompare) <> 0 Or InStr(1, MemData(0), ">Про внесення змін ", vbBinaryCompare) <> 0 Or InStr(1, MemData(0), ">Про внесення зміни ", vbBinaryCompare) <> 0 Or InStr(1, MemData(0), ">Про внесення доповнень ", vbBinaryCompare) <> 0 Or InStr(1, MemData(0), ">Про внесення доповнення ", vbBinaryCompare) <> 0 Then
Pzn = PoznachennaNeZavantajenim(URLName, "Поставити мітку: Про внесення змін")

Inet1(0).Cancel
List1.AddItem "Обминаєм сторінку 'Про внесення змін'"
Text1.Text = MemData(0) + stemp
Monitoring.Caption = "Пропускаємо сторінку..." + URLName
List1.AddItem "Пропускаємо сторінку..." + URLName
Call SoundPlay(8)

pomilka = True
MemData(0) = ""
Print #10, "Обминули цю сторінку!"
Close 10
Command1.Caption = "Зупинити"
Command1.Enabled = True

io = Trim(VznatiVilniyURL())
If io = "Буфер порожній" Then Form1.Caption = "Буфер порожній"
URLName = Trim(io)
Timer1.Interval = 1000


Exit Sub
End If

If Len(MemData(0)) > 25 Then MemData(0) = Right(MemData(0), 25)
pomilkatmr = pomilkatmr - 1: If pomilkatmr < 1 Then pomilkatmr = 0
Wend
Print #10, stemp
Call SoundPlay(10)

' DblPovtZapitURLName = 0
Case 11
Kn(0).BackColor = &HC0&: Kn(0).Caption = "Err"
Monitoring.Caption = "Помилка завантаження!"
List1.AddItem "Помилка завантаження! " + URLName
Call SoundPlay(9)
pomilka = True
Call SoundPlay(9)
List1.AddItem "Виконується автоматичне з'єднання з сервером повторно"
pomilkatmr = pomilkatmr + 1
If pomilkatmr > 3 Then MnuQuit_Click
Timer1.Interval = 5000
Command1.Caption = "Зупинити"
Command1.Enabled = True


End Select
End If
Exit Sub
ER:
pomilka = True
Call SoundPlay(9)
List1.AddItem "Виконується автоматичне з'єднання з сервером повторно"
pomilkatmr = pomilkatmr + 1
If pomilkatmr > 3 Then MnuQuit_Click
Timer1.Interval = 5000
Command1.Caption = "Зупинити"
Command1.Enabled = True
Resume Next

End Sub

Private Sub Kn_Click(Index As Integer)
If Kn(Index).BackColor = &HC0C0C0 Then Kn(Index).BackColor = &HFF00&: Exit Sub
Kn(Index).BackColor = &HC0C0C0: Exit Sub
End Sub





Private Sub MnuElsePokaz_Click()
If List1.Visible = False Then
List1.Visible = True
List2.Visible = False
Else
List1.Visible = False
List2.Visible = True
End If
End Sub

Private Sub MnuKorist_Click()
Koristuvach.Show
End Sub

Private Sub MnuManagerAnaliz_Click()
FileWord.Show
End Sub

Private Sub MnuManagerNewLoad_Click()
NewDownload.Show
End Sub

Private Sub MnuManagerScanHtml_Click()
FrmScanFile.Show
End Sub



Private Sub MnuNastroyka_Click()
Nastroyka.Show
End Sub
Private Sub MnuProVnesennaZmin_Click()
MnuProVnesennaZmin = Not (MnuProVnesennaZmin)
VidkluchitiProVnesennaZmin = MnuProVnesennaZmin
End Sub

Private Sub MnuQuit_Click()
Call SoundPlay(14)
Dim fi As Integer
Inet1(0).Cancel
Open "D:\Проекти\Програма скачування\Верховна Рада\Raport.txt" For Output As #7
Print #7, Date
Print #7, Time
For fi = 1 To List1.ListCount
Print #7, List1.List(fi)
Next
Close 7
If Command8.Enabled = False Then Shell "c:\p.exe"
End
End Sub

Private Sub MnuSound_Click()
If MnuSound.Caption = "Всі звуки" Then MnuSound.Caption = "Основні звуки": NastrSoundPlay = 2: Exit Sub
If MnuSound.Caption = "Основні звуки" Then MnuSound.Caption = "Відсутні звуки": NastrSoundPlay = 3: Exit Sub
If MnuSound.Caption = "Відсутні звуки" Then MnuSound.Caption = "Всі звуки": NastrSoundPlay = 1: Exit Sub
End Sub

Private Sub Timer1_Timer()
Dim io As String
RegimPravki = False
Close 10
Timer1.Interval = 0
Command1.Caption = "Скачати весь сайт Верховної Ради"
Call BazaStorinok(False)
Call BazaStorinok(True)


io = VznatiVilniyURL()
List1.AddItem "Наступний адрес: " + io
If io = "Буфер порожній" Then Form1.Caption = "Буфер порожній"
URLName = io
Call Command1_Click
End Sub

Private Sub Timer2_Timer()
Static Prisutnist As Boolean
Prisutnist = Not (Prisutnist)
If PerevirkaProstoyu2 = PerevirkaProstoyu Then Lichilnik = Lichilnik + 1: ZagalniyLichilnik = ZagalniyLichilnik + 1 Else Lichilnik = 0: PerevirkaProstoyu2 = PerevirkaProstoyu

Label5.Caption = Trim(Str(Lichilnik))
Label13.Caption = Trim(Str(ZagalniyLichilnik))
Label5.FontUnderline = Prisutnist


If Lichilnik > 400 Then Call MnuQuit_Click
Label7.Caption = Trim(Str(Trafik))
If Ll1.Caption <> "" And Ll2.Caption <> "" Then Label10.Caption = Left(Str(Val(Ll2.Caption) / Val(Ll1.Caption) * 100), 4) + "%"
End Sub








ммм Типа кусочек в котором я разбираю каждий код прим. <TITLE> ...</TITLE> ...
конечно старим способом, поскольку не пользовался ф-ей instr()...
но работает.
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35222199
Фотография Андрей159
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Ой не то! То мило только сохраняет, а вот ето уже разбирает все строчки....



Static n As Variant
Dim n1 As Variant
Dim WrdPola As BazaStorinok
Dim OsnovnaNazvaDoc As String
Dim PotNomStrDocStr As String

Close 5
Open "d:\Проекти\Програма скачування\Верховна Рада\База сторінок.txt" For Random As #5 Len = Len(WrdPola)

Poch:
m1:
n = n + 1
Get #5, n, WrdPola
If EOF(5) = True Then GoTo dali
'1 - взнаємо основну назву (наступний не збережений)
'Якщо цей документ являється сторінкою, то пропускаємо його
'Якщо цей документ вже збережений, то пропускаєм його


OsnovnaNazvaDoc = Trim(Mid(WrdPola.PolURLAdres, InStr(1, WrdPola.PolURLAdres, "nreg=", vbTextCompare) + 5))
If InStr(1, WrdPola.PolURLAdres, "page=", vbTextCompare) <> 0 Then GoTo m1
If Asc(Trim(WrdPola.PolNameDoc)) <> 0 Then GoTo m1
n1 = 0
m2:
n1 = n1 + 1
Get #5, n1, WrdPola
If EOF(5) = True Then GoTo Poch
PotNomStrDocStr = "1"
If OsnovnaNazvaDoc = Trim(Mid(WrdPola.PolURLAdres, InStr(1, WrdPola.PolURLAdres, "nreg=", vbTextCompare) + 5)) Then
If InStr(1, WrdPola.PolURLAdres, "page=", vbTextCompare) <> 0 Then
PotNomStrDocStr = Mid(WrdPola.PolURLAdres, InStr(1, WrdPola.PolURLAdres, "page=", vbTextCompare) + 5)
PotNomStrDocStr = Left(PotNomStrDocStr, InStr(1, PotNomStrDocStr, "&", vbTextCompare) - 1)
Command1.Enabled = False
Else
Command1.Enabled = True
End If
Else
GoTo m2
End If
If PotNomStrDocStr = "1" Then DocumentaYeOsnovniy = True Else DocumentaYeOsnovniy = False
'List1.AddItem OsnovnaNazvaDoc + "->" + PotNomStrDocStr
Call AnalizFile(WrdPola.PolURLAdres)
WrdPola.PolNameDoc = NazvaFaylu
Put #5, n, WrdPola
GoTo m2







'2 - дивимось скільки є сторінок
'3 - вибираємо лише сторінки
'4 - зберігаємо як збережене















GoTo Poch
dali:
Close 2
MsgBox "Знайдено - " + Str(LichLapokUkr)
MsgBox "Відсутнє в - " + Str(LichLapokEng)
MsgBox "Кінець"
End Sub

Private Sub ZapovnennaBuferuUmov(ParTxt1 As String, ParTxt2 As String, StatusP As Integer, Par3 As String)
Poshuk1(MaxPosh, 0, 0) = ParTxt1
Poshuk1(MaxPosh, 1, 0) = ParTxt2
Poshuk1(MaxPosh, 2, 0) = Str(StatusP)
Poshuk1(MaxPosh, 4, 0) = Par3
If ParTxt2 = "" Then Poshuk1(MaxPosh, 3, 0) = "Точно" Else Poshuk1(MaxPosh, 3, 0) = "Початок і кінець"

MaxPosh = MaxPosh + 1
End Sub




Private Sub AnalizFile(AFURLAdres As String)
Dim StatusIsnuvannaFile As String

Dim f As Variant
Dim MaxF As Variant
Dim KstEnter As Integer
Dim KstProbil As Integer

Dim KontrolDubleEnter As Boolean


Dim ZisPRE As Boolean
Dim ZisDIV As Boolean
Dim ZisNOSCRIPT As Boolean
Dim ZisFORM As Boolean
Dim ZisSTYLE As Boolean
Dim ZisHTML As Boolean
Dim ZisHEAD As Boolean
Dim ZisTITLE As Boolean
Dim ZisBODY As Boolean
Dim ZisMETA As Boolean
Dim ZisLINK As Boolean
Dim ZisSCRIPT As Boolean
Dim ZisTABLE As Boolean
Dim ZisTR As Boolean
Dim ZisTD As Boolean
Dim ZisTH As Boolean
Dim ZisA As Boolean
Dim ZisB As Boolean
Dim ZisIMG As Boolean
Dim ZisFONT As Boolean
Dim ZisIFRAME As Boolean
Dim ZisINPUT As Boolean
Dim ZisNOALIGN As Boolean
Dim ZisCENTER As Boolean
Dim ZnaydenoKomandu As String
Dim DeYeCaKomanda As Variant
Dim KrokDali As Variant
Dim Tmp As Variant
Dim TK As String ' Тимчасова команда
Dim FormatTxt As Variant
Dim tmpStrTxt1 As String ' можна буде потім стерти

Dim FP As Integer
' PRE - це є золота серединка

PosRead = 1

StatusIsnuvannaFile = IsnuvannaFile(AFURLAdres)
Lbl1.Caption = "Відкрили файл:" + StatusIsnuvannaFile
If InStr(1, StatusIsnuvannaFile, "Існує Файл", vbTextCompare) = 0 Then Exit Sub
'Dim ZWord As Word.Application
'Set ZWord = New Word.Application
'ZWord.Visible = True
'Dim ZDoc As Word.Document
If DocumentaYeOsnovniy = True Then
If RegomAlfa = 1 Then Set ZDoc = ZWord.Documents.Add
TmpSS = ""
End If





VivodimoNaEkran = Space(MaxPosh - 1)

dali:
DeYeCaKomanda = 0
KrokDali = 1
ZnaydenoKomandu = ""
Tmp = 0
DoEvents
'//------------ Шукаємо і підганяєм команду

For FP = 0 To MaxPosh - 1
Tmp = InStr(PosRead, IFSS, Poshuk1(FP, 0, 0), vbTextCompare)
If (Tmp < DeYeCaKomanda And Tmp <> 0) Or DeYeCaKomanda = 0 Then
DeYeCaKomanda = Tmp
ZnaydenoKomandu = Str(FP)
End If
Next
If Poshuk1(Val(ZnaydenoKomandu), 0, 0) = "" Then ZnaydenoKomandu = ""
'//----------- Фільтр від перенагрузок Word
If ZnaydenoKomandu <> "" Then KrokDali = DeYeCaKomanda - PosRead + 1
If KrokDali > 1000 Then KrokDali = 1000

PBr1.Value = PosRead / Len(IFSS) * 200
'//------------ Вивід у Word
If DeYeCaKomanda <> 0 Then
If VivodimoNaEkran = Space(MaxPosh - 1) Then
FormatTxt = Mid(IFSS, PosRead, KrokDali - 1)

TmpSS = TmpSS + FormatTxt
If Strogo = True And RegomAlfa = 1 Then ZWord.Selection.TypeText Text:=FormatTxt
End If
PosRead = PosRead + KrokDali - 1
Else
If Strogo = True And RegomAlfa = 1 Then ZWord.Selection.TypeText Text:=Mid(IFSS, PosRead, 1)
PosRead = PosRead + 1
End If


'//------------ Якщо підігнали команду, то переглядаєм її
If ZnaydenoKomandu <> "" Then
FP = Val(ZnaydenoKomandu)



If InStr(1, Poshuk1(FP, 4, 0), "*!*", vbTextCompare) <> 0 Then
If Poshuk1(FP, 3, 0) = "Початок і кінець" Then Poshuk1(FP, 3, 0) = "Від і до ключ"
If Poshuk1(FP, 3, 0) = "Точно" Then Poshuk1(FP, 3, 0) = "Ключ"
End If
If Porivnanna(Poshuk1(FP, 0, 0), Poshuk1(FP, 1, 0), Poshuk1(FP, 3, 0)) Then

Status1(FP) = Val(Trim(Poshuk1(FP, 2, 0)))
If RegomAlfa = 1 Then
If InStr(1, Poshuk1(FP, 4, 0), "Жирний включити", vbTextCompare) <> 0 Then ZDoc.Application.Selection.Font.Bold = True
If InStr(1, Poshuk1(FP, 4, 0), "Жирний виключити", vbTextCompare) <> 0 Then ZDoc.Application.Selection.Font.Bold = False
End If

If InStr(1, Poshuk1(FP, 4, 0), "Показати1", vbTextCompare) <> 0 Then Mid(VivodimoNaEkran, 1, 1) = " "
If InStr(1, Poshuk1(FP, 4, 0), "Скрити1", vbTextCompare) <> 0 Then Mid(VivodimoNaEkran, 1, 1) = "*"
If InStr(1, Poshuk1(FP, 4, 0), "Показати2", vbTextCompare) <> 0 Then Mid(VivodimoNaEkran, 2, 1) = " "
If InStr(1, Poshuk1(FP, 4, 0), "Скрити2", vbTextCompare) <> 0 Then Mid(VivodimoNaEkran, 2, 1) = "*"
If InStr(1, Poshuk1(FP, 4, 0), "Показати3", vbTextCompare) <> 0 Then Mid(VivodimoNaEkran, 3, 1) = " "
If InStr(1, Poshuk1(FP, 4, 0), "Скрити3", vbTextCompare) <> 0 Then Mid(VivodimoNaEkran, 3, 1) = "*"
If InStr(1, Poshuk1(FP, 4, 0), "Початок", vbTextCompare) <> 0 Then Strogo = True
If InStr(1, Poshuk1(FP, 4, 0), "Кінець", vbTextCompare) <> 0 Then Strogo = False


If InStr(1, Poshuk1(FP, 4, 0), "LINK", vbTextCompare) <> 0 Then

If InStr(1, StrTxt, "OpenDoc('", vbTextCompare) <> 0 Then
If VivodimoNaEkran = Space(MaxPosh - 1) And Strogo = True Then
tmpStrTxt1 = Mid(StrTxt, InStr(1, StrTxt, "OpenDoc('", vbTextCompare) + 8)
tmpStrTxt1 = Left(tmpStrTxt1, InStr(1, tmpStrTxt1, "')", vbTextCompare) - 1)

For IFn9 = 1 To Len(tmpStrTxt1)
If Mid(tmpStrTxt1, IFn9, 1) = "/" Then Mid(tmpStrTxt1, IFn9, 1) = "Z"
If Mid(tmpStrTxt1, IFn9, 1) = "\" Then Mid(tmpStrTxt1, IFn9, 1) = "z"
If Mid(tmpStrTxt1, IFn9, 1) = "|" Then Mid(tmpStrTxt1, IFn9, 1) = "_"
If Mid(tmpStrTxt1, IFn9, 1) = Chr(34) Then Mid(tmpStrTxt1, IFn9, 1) = "'"
If Mid(tmpStrTxt1, IFn9, 1) = "?" Then Mid(tmpStrTxt1, IFn9, 1) = "_"
If Mid(tmpStrTxt1, IFn9, 1) = "&" Then Mid(tmpStrTxt1, IFn9, 1) = "_"
Next
tmpStrTxt1 = "zakon1.rada.gov.uaZcgi-binZlawsZmain.cgi_nreg=" + tmpStrTxt1 + ".doc"
'Можна було б ще шукати в тітлах і давати спливаючі підказки...
'link
If RegomAlfa = 1 Then

ZWord.ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="D:\Проекти\Програма скачування\Готові\" + tmpStrTxt1, SubAddress:="", ScreenTip:="", TextToDisplay:=">"

End If
End If
End If
End If


If InStr(1, Poshuk1(FP, 4, 0), "Зберегти назву", vbTextCompare) <> 0 Then
Lbl3.Caption = "Назва документа: " + StrTxt

NazvaFaylu = Trim(Mid(AFURLAdres, InStr(1, AFURLAdres, "nreg=", vbTextCompare) + 5))
' Stop
NomerStorinki = Val(Mid(StrTxt, InStr(1, StrTxt, "Стор.", vbTextCompare) + 6))
ZagKstStorinok = Val(Mid(StrTxt, InStr(InStr(1, StrTxt, "Стор.", vbTextCompare) + 7, StrTxt, "з", vbTextCompare) + 2))
Lbl4.Caption = "Назва файлу=" + NazvaFaylu + "; Поточна сторінка=" + Str(NomerStorinki) + "; Заг.ксть стор=" + Str(ZagKstStorinok)
End If


If InStr(1, Poshuk1(FP, 4, 0), "одноразовий", vbTextCompare) <> 0 Then Poshuk1(FP, 0, 0) = "DJKLINOV": Poshuk1(FP, 1, 0) = "DJKLINOV": Poshuk1(FP, 2, 0) = "DJKLINOV": Poshuk1(FP, 3, 0) = "DJKLINOV": Poshuk1(FP, 4, 0) = "DJKLINOV"

GoTo Kinec
End If

End If





Kinec:
If PosRead < Len(IFSS) Then GoTo dali
NomerPP = NomerPP + 1




Dim IFPovnaNazvaFile As Variant
IFNameFile = NazvaFaylu
For IFn9 = 1 To Len(IFNameFile)
If Mid(IFNameFile, IFn9, 1) = "/" Then Mid(IFNameFile, IFn9, 1) = "Z"
If Mid(IFNameFile, IFn9, 1) = "\" Then Mid(IFNameFile, IFn9, 1) = "z"
If Mid(IFNameFile, IFn9, 1) = "|" Then Mid(IFNameFile, IFn9, 1) = "_"
If Mid(IFNameFile, IFn9, 1) = Chr(34) Then Mid(IFNameFile, IFn9, 1) = "'"
If Mid(IFNameFile, IFn9, 1) = "?" Then Mid(IFNameFile, IFn9, 1) = "_"
If Mid(IFNameFile, IFn9, 1) = "&" Then Mid(IFNameFile, IFn9, 1) = "_"
Next


If NomerStorinki = ZagKstStorinok Then
If RegomAlfa = 1 Then
ZWord.ActiveDocument.SaveAs FileName:="D:\Проекти\Програма скачування\Готові\" + IFNameFile + ".doc", FileFormat:=wdFormatDocument, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ZDoc.Close
End If
If RegomAlfa <> 0 Then
Open "D:\Проекти\Програма скачування\Пошук\" + IFNameFile + ".txt" For Output As #9
Print #9, TmpSS
Close 9
End If
End If
Exit Sub
End Sub
Private Function Porivnanna(Komandi1 As String, Komandi2 As String, Stile As String) As Boolean
Dim TmpPosRead1 As Variant
Dim TmpPosRead2 As Variant
StrTxt = ""
Lbl1.Caption = "Знайдено: " + Komandi1 + " " + Komandi2
If Stile = "Точно" Then
If LCase(Mid(IFSS, PosRead, Len(Komandi1))) = LCase(Komandi1) Then PosRead = PosRead + Len(Komandi1): Porivnanna = True: Exit Function
Lbl2.Caption = ""
End If

If Stile = "Початок і кінець" Then
If LCase(Mid(IFSS, PosRead, Len(Komandi1))) = LCase(Komandi1) Then
TmpPosRead1 = PosRead + Len(Komandi1)
TmpPosRead2 = InStr(TmpPosRead1, IFSS, Komandi2, vbTextCompare)
If TmpPosRead2 = 0 Then Stop ' Помилка
PosRead = TmpPosRead2 + Len(Komandi2)
Porivnanna = True
StrTxt = Mid(IFSS, TmpPosRead1, TmpPosRead2 - TmpPosRead1)
Lbl2.Caption = "Параметри: " + StrTxt
Exit Function
End If
End If

If Stile = "Ключ" Then
If LCase(Mid(IFSS, PosRead, Len(Komandi1))) = LCase(Komandi1) Then Porivnanna = True: Exit Function
Lbl2.Caption = ""
End If

If Stile = "Від і до ключ" Then
If LCase(Mid(IFSS, PosRead, Len(Komandi1))) = LCase(Komandi1) Then
TmpPosRead1 = PosRead + Len(Komandi1)
TmpPosRead2 = InStr(TmpPosRead1, IFSS, Komandi2, vbTextCompare)
If TmpPosRead2 = 0 Then Stop ' Помилка
Porivnanna = True
StrTxt = Mid(IFSS, TmpPosRead1, TmpPosRead2 - TmpPosRead1)
Lbl2.Caption = "Параметри: " + StrTxt
If Komandi1 = "style=" + Chr(34) + "color: black" + Chr(34) + "><b>" Then MsgBox StrTxt
Exit Function
End If
End If
End Function
Private Sub VznayemoEnteri(FormatTxt)
Exit Sub

Dim f1 As Variant
Dim f2 As Variant

Che1:
f1 = InStr(1, FormatTxt, Chr(13))
f2 = InStr(1, FormatTxt, Chr(10) + Chr(10))
If f1 <> 0 Then
If f2 < f1 And f2 <> 0 Then
FormatTxt = Left(FormatTxt, f2 - 1) + Mid(FormatTxt, f2 + 1)
Else
Mid(FormatTxt, f1, 1) = " "
End If
GoTo Che1
End If


End Sub
Private Function IsnuvannaFile(IFNameFile As String) As String
IFSS = ""
Dim IFn9 As Variant
Dim IFPovnaNazvaFile As Variant
For IFn9 = 1 To Len(IFNameFile)
If Mid(IFNameFile, IFn9, 1) = "/" Then Mid(IFNameFile, IFn9, 1) = "Z"
If Mid(IFNameFile, IFn9, 1) = "\" Then Mid(IFNameFile, IFn9, 1) = "z"
If Mid(IFNameFile, IFn9, 1) = "|" Then Mid(IFNameFile, IFn9, 1) = "_"
If Mid(IFNameFile, IFn9, 1) = Chr(34) Then Mid(IFNameFile, IFn9, 1) = "'"
If Mid(IFNameFile, IFn9, 1) = "?" Then Mid(IFNameFile, IFn9, 1) = "_"
If Mid(IFNameFile, IFn9, 1) = "&" Then Mid(IFNameFile, IFn9, 1) = "_"
Next

IsnuvannaFile = "Файлу не існує"
IFPovnaNazvaFile = "D:\Проекти\Програма скачування\Верховна Рада\Архів\" + Trim(IFNameFile) + ".htm"
On Error GoTo er

Open IFPovnaNazvaFile For Input As #8
IFSS = Input$(FileLen(IFPovnaNazvaFile), 8)
Close #8
IsnuvannaFile = "Існує неповноцінний файл"
If InStr(1, IFSS, "</html>", vbTextCompare) <> 0 Then IsnuvannaFile = "Існує файл повноцінний"

If InStr(1, IFSS, " Про внесення змін ", vbBinaryCompare) <> 0 Or InStr(1, IFSS, " Про внесення зміни ", vbBinaryCompare) <> 0 Or InStr(1, IFSS, " Про внесення доповнень ", vbBinaryCompare) <> 0 Or InStr(1, IFSS, " Про внесення доповнення ", vbBinaryCompare) <> 0 Or InStr(1, IFSS, ">Про внесення змін ", vbBinaryCompare) <> 0 Or InStr(1, IFSS, ">Про внесення зміни ", vbBinaryCompare) <> 0 Or InStr(1, IFSS, ">Про внесення доповнень ", vbBinaryCompare) <> 0 Or InStr(1, IFSS, ">Про внесення доповнення ", vbBinaryCompare) <> 0 Then
IsnuvannaFile = "Існує файл з Про внесення змін..."
End If
If InStr(1, IFSS, "На сьогоднi Ваш лiмiт перегляду сторiнок вичерпано", vbTextCompare) <> 0 Then IsnuvannaFile = "Існує файл з попандосом!"
Close 8
Exit Function
er:
Close 8
Exit Function
End Function

Private Sub Form_Load()
Set ZWord = New Word.Application
ZWord.Visible = True

' Значок "*!*" - не буде перескакувати курсор і не пропустить для виведення те що шукаємо"
' Слово "одноразовий" - виконається пошук лише один раз, потім з бази витреться

'Call ZapovnennaBuferuUmov("Документ", "b></a>", 0, "*!* Зберегти файл одноразовий")
Call ZapovnennaBuferuUmov("<HTML>", "", 0, "")
Call ZapovnennaBuferuUmov("</HTML>", "", 0, "")
Call ZapovnennaBuferuUmov("<HEAD>", "", 0, "")
Call ZapovnennaBuferuUmov("</HEAD>", "", 0, "")
Call ZapovnennaBuferuUmov("<TITLE>", "</TITLE>", 0, "Зберегти назву") 'Call ZapovnennaBuferuUmov("</TITLE>", "", 0, "")
Call ZapovnennaBuferuUmov("<BODY ", ">", 0, "")
Call ZapovnennaBuferuUmov("</BODY>", "", 0, "")
Call ZapovnennaBuferuUmov("<META ", ">", 0, "")
Call ZapovnennaBuferuUmov("<LINK ", ">", 0, "")
Call ZapovnennaBuferuUmov("<STYLE ", ">", 0, "Скрити1") 'Мусить бути пара
Call ZapovnennaBuferuUmov("</STYLE>", "", 0, "Показати1")
Call ZapovnennaBuferuUmov("<SCRIPT ", ">", 0, "Скрити2") 'Мусить бути пара
Call ZapovnennaBuferuUmov("</SCRIPT>", "", 0, "Показати2")
Call ZapovnennaBuferuUmov("<TABLE ", ">", 0, "")
Call ZapovnennaBuferuUmov("</TABLE>", "", 0, "")
Call ZapovnennaBuferuUmov("<TR>", "", 0, "")
Call ZapovnennaBuferuUmov("<TR ", ">", 0, "")
Call ZapovnennaBuferuUmov("</TR>", "", 0, "")
Call ZapovnennaBuferuUmov("<TD ", ">", 0, "")
Call ZapovnennaBuferuUmov("<TD>", "", 0, "")
Call ZapovnennaBuferuUmov("</TD>", "", 0, "")
Call ZapovnennaBuferuUmov("<TH ", ">", 0, "")
Call ZapovnennaBuferuUmov("</TH>", "", 0, "")
Call ZapovnennaBuferuUmov("<A ", ">", 0, "LINK")
Call ZapovnennaBuferuUmov("</A>", "", 0, "")
Call ZapovnennaBuferuUmov("<IMG ", ">", 0, "")
Call ZapovnennaBuferuUmov("<FONT ", ">", 0, "")
Call ZapovnennaBuferuUmov("</FONT>", "", 0, "")
Call ZapovnennaBuferuUmov("&NBSP;", "", 0, "")
Call ZapovnennaBuferuUmov("<IFRAME ", ">", 0, "")
Call ZapovnennaBuferuUmov("</IFRAME>", "", 0, "")
Call ZapovnennaBuferuUmov("<BR>", "", 0, "")
Call ZapovnennaBuferuUmov("<FORM ", ">", 0, "Скрити3") 'Мусить бути пара
Call ZapovnennaBuferuUmov("</FORM>", "", 0, "Показати3")
Call ZapovnennaBuferuUmov("<B>", "", 0, "Команда: Жирний включити")
Call ZapovnennaBuferuUmov("</B>", "", 0, "Команда: Жирний виключити")
Call ZapovnennaBuferuUmov("<NOSCRIPT ", ">", 0, "")
Call ZapovnennaBuferuUmov("<NOSCRIPT>", "", 0, "")
Call ZapovnennaBuferuUmov("</NOSCRIPT>", "", 0, "")
Call ZapovnennaBuferuUmov("<NOALIGN>", "", 0, "")
Call ZapovnennaBuferuUmov("</NOALIGN>", "", 0, "")
Call ZapovnennaBuferuUmov("<INPUT ", ">", 0, "")
Call ZapovnennaBuferuUmov("<CENTER>", "", 0, "")
Call ZapovnennaBuferuUmov("</CENTER>", "", 0, "")
Call ZapovnennaBuferuUmov("<PRE ", ">", 0, "Початок")
Call ZapovnennaBuferuUmov("</PRE>", "", 0, "")
Call ZapovnennaBuferuUmov("<DIV ", ">", 0, "")
Call ZapovnennaBuferuUmov("</DIV>", "", 0, "")
Call ZapovnennaBuferuUmov("<!", ">", 0, "")
Call ZapovnennaBuferuUmov("<HR ", ">", 0, "")

Call ZapovnennaBuferuUmov("<HR ", ">", 0, "")
Call ZapovnennaBuferuUmov("Сторiнки:", ">", 0, "Кінець")


'Call ZapovnennaBuferuUmov(" З А К О Н У К Р А Ї Н И" + Chr(13), "", 0, "")
End Sub
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35222331
Zioner
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
а проще нельзя сделать?
Ведь както Word сам это делает:

Selection.InsertFile FileName:="files.htm"

только чтоб не из файла?
...
Рейтинг: 0 / 0
Как вставить HTML таблицу в Word средствами VB ?
    #35230073
Zioner
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Разобрался:

Нашел в инете - процедура записи HTML в буфер обмена HTMLToClipboard,
и все нормально работает:

Private Declare Function RegisterClipboardFormat Lib "user32" _
Alias "RegisterClipboardFormatA" (ByVal lpString As String) _
As Long

Public Sub HTMLToClipboard(HTMLText As String)
Dim nCFHTML As Long
Dim nClipboardText As String

nCFHTML = RegisterClipboardFormat("HTML Format")

nClipboardText = "Version:0.9" & vbCrLf
nClipboardText = nClipboardText & "StartHTML:-1" & vbCrLf
nClipboardText = nClipboardText & "EndHTML:-1" & vbCrLf
nClipboardText = nClipboardText & "StartFragment:000081" & vbCrLf
nClipboardText = nClipboardText & "EndFragment:°°°°°°" & vbCrLf

nClipboardText = nClipboardText & HTMLText & vbCrLf

nClipboardText = Replace(nClipboardText, "°°°°°°", _
Format$(Len(nClipboardText), "000000"))

With New DataObject
.Clear
.SetText StrConv(nClipboardText, vbFromUnicode), nCFHTML
.PutInClipboard
End With
End Sub

Sub insertHTMLtest()

Dim HTMLText As String
HTMLText = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01//EN"" ""http://www.w3.org/TR/html4/strict.dtd"">" & _
"<html>" & _
"<head>" & _
"<title>AAA</title>" & _
"</head>" & _
"<body>" & _
"<table border border-collapse: collapse >" & _
"<tr>" & _
"<td>11</td>" & _
"<td>14</td>" & _
"</tr>" & _
"<tr>" & _
"<td>РУССКИЙ ТЕКСТ</td>" & _
"<td>112</td>" & _
"</tr>" & _
"</table>" & _
"</body>" & _
"</html>"

HTMLToClipboard (HTMLText)


Selection.PasteAndFormat (wdPasteDefault)

End Sub


Только еще проблема возникла:
При выводе текста вместо русских букв - карявки
Как можно перекодировать текст в буфере обмена.
Или может есть какие другие варианты?
...
Рейтинг: 0 / 0
12 сообщений из 12, страница 1 из 1
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Как вставить HTML таблицу в Word средствами VB ?
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]