|
|
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
Как вставить 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. Здесь в форуме нашел такой вопрос - но в ответе ссылка - которая уже не рабротает ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 13.03.2008, 20:16 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
up ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 15.03.2008, 08:48 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
Я сейчас делаю под один заказ отчеты в Word. Точнее - сначала формирую их в обычном HTML-формате, а потом открываю его Word-ом, сохраняю в doc-формате, вставляю оглавление и переносы страниц в нужные места. В итоге получается нормальный Word-овский документ. При этом работы собственно с Word-овской объектной моделью миниум. ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 16.03.2008, 02:24 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
AndrFЯ сейчас делаю под один заказ отчеты в Word. Точнее - сначала формирую их в обычном HTML-формате, а потом открываю его Word-ом, сохраняю в doc-формате, вставляю оглавление и переносы страниц в нужные места. В итоге получается нормальный Word-овский документ. При этом работы собственно с Word-овской объектной моделью миниум. Если не трудно примерчик, тоже интересуюсь, да и другим на будущее. ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 16.03.2008, 10:10 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
BIONЕсли не трудно примерчик, тоже интересуюсь, да и другим на будущее. Примерчик чего? Как открыть HTML-ку Word-ом и сохранить уже в Word-овском формате? Проделай это в Word-е записывая макрос и посмотри получившийся код там пара строчек в итоге будет... ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 16.03.2008, 10:50 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
AndrF BIONЕсли не трудно примерчик, тоже интересуюсь, да и другим на будущее. Примерчик чего? Как открыть HTML-ку Word-ом и сохранить уже в Word-овском формате? Проделай это в Word-е записывая макрос и посмотри получившийся код там пара строчек в итоге будет... Да эт старая исторя, я прост думал можт ты непосредственно в новый док встраиваешь HTML какньть через xml xsl и т.д., но раз так то вопросов более не имею. ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 16.03.2008, 11:33 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
Кстати, можно скопировать HTML структуру в буфер и просто Selection.PasteAndFormat (wdPasteDefault) ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 16.03.2008, 12:32 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
Сделал макрос для вставки из 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 ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 28.03.2008, 20:00 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
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()... но работает. ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 29.03.2008, 03:20 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
Ой не то! То мило только сохраняет, а вот ето уже разбирает все строчки.... 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 ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 29.03.2008, 03:30 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
а проще нельзя сделать? Ведь както Word сам это делает: Selection.InsertFile FileName:="files.htm" только чтоб не из файла? ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 29.03.2008, 12:31 |
|
||
|
Как вставить HTML таблицу в Word средствами VB ?
|
|||
|---|---|---|---|
|
#18+
Разобрался: Нашел в инете - процедура записи 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 Только еще проблема возникла: При выводе текста вместо русских букв - карявки Как можно перекодировать текст в буфере обмена. Или может есть какие другие варианты? ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 02.04.2008, 14:51 |
|
||
|
|

start [/forum/topic.php?fid=60&fpage=195&tid=2162456]: |
0ms |
get settings: |
8ms |
get forum list: |
20ms |
check forum access: |
4ms |
check topic access: |
4ms |
track hit: |
42ms |
get topic data: |
10ms |
get forum data: |
2ms |
get page messages: |
90ms |
get tp. blocked users: |
1ms |
| others: | 224ms |
| total: | 405ms |

| 0 / 0 |
