Sub Web表示()
ダイアログ表示
With UserForm1
.Caption = "HTMLファイルへテーブル挿入" & va
End With
urla = ThisWorkbook.Worksheets("操作ページ").Cells(zf, 1)
UserForm1.web1.Navigate urla
enchk = 0
Call 読込終了確認
' UserForm1.Show 0
End Sub
----------------------------------------------------------------
Sub 読込終了確認()
timck = Timer + 4
Do
If enchk = 1 Then: Exit Do
If Timer > timck Then: Exit Do
DoEvents
Loop
If enchk = 0 Then
MsgBox "Webページの取り込みに失敗しました。"
End If
End Sub
|
| ユーザーフォーム コードウインドウ |
Private Sub web1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
urlb = URL
enchk = 1
End Sub
|
Sub ソース取り込み()
貼り付けシート作成
For Each sheet_name In Worksheets
If sheet_name.Name = "HTMLソース" Then
Application.DisplayAlerts = False
Worksheets("HTMLソース").Delete
Application.DisplayAlerts = True
Exit For
End If
Next
Sheets.Add.Name = "HTMLソース"
Worksheets("HTMLソース").Move After:=Sheets(Sheets.Count)
ソース取込
Set oHttp = CreateObject("Microsoft.XMLHTTP")
oHttp.Open "GET", urlb, False
oHttp.Send
dathaml = StrConv(oHttp.responseBody, 64) '文字化けの場合下記に変える
dathaml = oHttp.responsetext
Worksheets("HTMLソース").Select
tmp = Split(dathaml, Chr(10))
For i = 0 To UBound(tmp)
Cells(i + 1, 1) = tmp(i)
Next
Set oHttp = Nothing
'UserForm1.Hide
復帰削除
Cells.Replace What:=Chr(13), Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Range("A1").Select
End Sub
|
Sub テーブル挿入()
If Val(Application.Version) > 11 Then
ThisWorkbook.Sheets("操作ページ").Select
For Each zu In ActiveSheet.Shapes
shname = zu.Name
If InStr(1, shname, "Text", 1) > 0 Then
shname1 = zu.Name
End If
Next
Set ObjText1 = ActiveSheet.Shapes(shname1)
ddd = ObjText1.TextFrame.Characters().Text
Else
’Execl2003以前は変数へ代入値255以下の制限があり細工が必要（記述省略）
End If
Sheets("HTMLソース").Select
endr = Cells(10000, 1).End(xlUp).Row
For i = 1 To endr
stsu = InStr(Cells(i, 1), "リンクテーブル注入")
If stsu > 0 Then
If InStr(Cells(i + 1, 1), "リンクテーブルEND") = 0 Then
MsgBox "テーブル挿入済み"
sumi = 1
Exit Sub
End If
cnt = cnt + 1
sts = 1
ia = i + 1
Do
ens = InStr(sts, ddd, Chr(10))
If ens = 0 Then
Exit Do
End If
d1 = Mid(ddd, sts, ens - sts)
'挿入行を空ける
Rows(ia).Insert Shift:=xlDown
Cells(ia, 1) = "'" & d1
ia = ia + 1
sts = ens + 1
Loop
Exit For
End If
Next
Call テーブル色付け
ファイル名の指定
n1 = InStrRev(urlb, "\")
n2 = InStrRev(urlb, ".")
dai = Mid(urlb, n1 + 1, n2 - n1 - 1)
End Sub
|
Sub ファイル保存()
If ThisWorkbook.Worksheets("操作ページ").Cells(3, 12) = "" Then
phn = Replace(urlb, dai & ".html", "") '上書き保存
Else
phn = ThisWorkbook.Worksheets("操作ページ").Cells(3, 12) '指定フォルダ
End If
Worksheets("HTMLソース").Activate
endr = Cells(10000, 1).End(xlUp).Row
With ActiveSheet
endr = Cells(10000, 1).End(xlUp).Row
Open phn & dai & ".html" For Output As #1
For i = 1 To endr
gyou = .Cells(i, 1)
Print #1, gyou
Next
Close #1
End With
End Sub
|
Sub 番号取得実行()
ダイアログ表示
UserForm1.Caption = "力士番号取得" & va
urla = "http://www.sumo.or.jp/honbasho/banzuke/index?rank=1"
前データ削除
Sheets("関取番号").Select
Cells.ClearContents
IEへ表示
UserForm1.web1.Navigate urla
enchk = 0
Call 読込終了確認 ’(7)[1]と同じ
ia = 1
Call ソース取り込み
Call 番号貼付け
Sheets("関取番号").Select
End Sub
|
Sub ソース取り込み() -----下記のみ(7)[1]と異なります---- dathaml = StrConv(oHttp.responseBody, 64) dathaml = oHttp.responsetext '文字化けの場合上記に変える End Sub |
Sub 番号貼付け()
Sheets("HTMLソース").Select
endr = Cells(10000, 1).End(xlUp).Row
For i = 1 To endr
kensaku = InStr(Cells(i, 1), "profile")
If kensaku > 0 Then
datr = Cells(i, 1)
stss = InStr(1, datr, "id=")
'力士No
rikno = Mid(datr, stss + 3, 4)
ecds1 = InStr(stss, datr, ">")
ecds2 = InStr(ecds1, datr, "&#")
namae = Mid(datr, ecds1 + 1, ecds2 - 1 - ecds1)
Worksheets("関取番号").Cells(ia, 1) = namae
Worksheets("関取番号").Cells(ia, 2) = Val(rikno)
'顔写真No
datr1 = Cells(i - 4, 1)
stss = InStr(1, datr1, "60/")
kaono = Mid(datr1, stss + 3, 8)
Worksheets("関取番号").Cells(ia, 3) = kaono
ia = ia + 1
End If
Next
End Sub
|
| 【修正前例】<STYLE>A{text-decoration:none;color:#000000};A:ACTIVE{color:#000000};A・・・・ 【修正後例】<STYLE>A{text-decoration:none;color:#000000;}A:ACTIVE{color:#000000;}A・・・・ |
Sub Web表示()
ダイアログ表示
With UserForm1
.Caption = "HTMLタグ修正" & va
End With
urla = ThisWorkbook.Worksheets("操作ページ").Cells(zf, 1)
UserForm1.web1.Navigate urla
urlb = ""
Call 読込終了確認
bbase = ActiveWindow.Caption
End Sub
|
| ユーザーフォーム コードウインドウ |
Private Sub web1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
urlb = URL
End Sub
|
Sub ソース取り込み()
Application.ScreenUpdating = False
貼り付けシート作成
ソース取込
Set oHttp = Nothing
------------ 以上は[1]と同じです -------
'復帰削除
Cells.Replace What:=Chr(13), Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Range("A1").Select
'改行削除
Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Range("A1").Select
End Sub
|
Sub タグ修正()
Dim mae As String '訂正キーワード文字
Dim ato As String '訂正キーワード文字
Dim sts As Integer '
Dim ia As Integer '注入END行
Dim stsu As Integer 'スタート文字数
sumi = 0
mae = Worksheets("操作ページ").Cells(11, 4)
ato = Worksheets("操作ページ").Cells(15, 4)
Sheets("HTMLソース").Select
endr = Cells(10000, 1).End(xlUp).Row
For i = 1 To endr
stsu = InStr(Cells(i, 1), mae)
If stsu > 0 Then
Cells(i, 1) = ato
sumi = 1
cnt = cnt + 1
End If
Next
ファイル名の指定
n1 = InStrRev(urlb, "\")
n2 = InStrRev(urlb, ".")
dai = Mid(urlb, n1 + 1, n2 - n1 - 1)
End Sub
|
Sub ファイル保存()
Application.ScreenUpdating = True
If ThisWorkbook.Worksheets("操作ページ").Cells(3, 7) = "" Then
uwa = "上書き"
phn = Replace(urlb, dai & ".html", "") '上書き保存
Else
phn = ThisWorkbook.Worksheets("操作ページ").Cells(3, 7) '指定フォルダ
End If
------- HTMLタグ保存用ブック ---------------------
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True
Windows(bbase).Activate
Sheets("HTMLソース").Select
Cells.Select
Selection.Copy
HTMLを貼るブック作成
Workbooks.Add
Range("A1").Select
ActiveSheet.Paste
Range("A2").Select
bname = ActiveWindow.Caption
Application.CutCopyMode = False
Range("A3").Select
------ HTMLファイル保存 ------------------------
Windows(bname).Activate
Sheets("Sheet1").Select
保存
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=phn & dai & ".prn", FileFormat _
:=xlTextPrinter, CreateBackup:=False
Application.DisplayAlerts = True
ダミ−のブックを閉じる
Application.DisplayAlerts = False
Application.Windows(dai & ".prn").Activate
ActiveWorkbook.Close
Application.DisplayAlerts = True
ファイル名変更
fff = Dir(phn & dai & ".html")
If fff = "" Then
Name phn & dai & ".prn" As phn & "\" & dai & ".html"
Else
Kill phn & dai & ".html"
Name phn & dai & ".prn" As phn & "\" & dai & ".html"
End If
元ブックを表示
Windows(bbase).Activate
Range("A1").Select
Application.CutCopyMode = False
ActiveWindow.WindowState = xlMaximized
End Sub
|