'Microsoft HTML Object Libraryが必要
Sub GET_last_modified()
'Google Chromeを起動
'CreateObject("WScript.Shell").Run ("chrome.exe")
Dim objIE As Object
Dim html As String
Dim 行末 As Long
Dim h
Dim Rtn
Rtn = MsgBox(Chr(10) & "読み込み 実行", vbYesNo, "選択")
If Rtn = vbYes Then
'Application.ScreenUpdating = False
'================================
Dim myBook, mySheet
myBook = ActiveWorkbook.Name
mySheet = ActiveSheet.Name
Worksheets(mySheet).Select
Worksheets(mySheet).Activate
i = 2
行末 = Worksheets(mySheet).Cells(Rows.Count, 2).End(xlUp).Row
Set h = CreateObject("MSXML2.XMLHTTP")
Set objIE = CreateObject("InternetExplorer.application")
'Set objIE = CreateObject("WScript.Shell").Run("chrome.exe")
Set WSH = CreateObject("WScript.Shell")
'Set WSH = CreateObject("WScript.Shell").Run("chrome.exe")
Do
If Len(Worksheets(mySheet).Range("c" & i).Value) < 1 Then
If Len(Worksheets(mySheet).Range("b" & i).Value) < 5 Then
Exit Do
End If
'Do While objIE.Busy Or objIE.ReadyState <> 4
DoEvents
'Loop
h.Open "HEAD", Worksheets(mySheet).Range("b" & i).Value, False
Worksheets(mySheet).Range("C" & i).Select
h.send
Dim headers
headers = h.getAllResponseHeaders()
If InStr(headers, "Last-Modified") > 0 Then
Worksheets(mySheet).Range("C" & i).Value = h.getResponseHeader("Last-Modified") '通信回数を減らしたい場合はheadersをSplitしてください
Else
If InStr(headers, "last-modified") > 0 Then
Worksheets(mySheet).Range("C" & i).Value = h.getResponseHeader("last-modified") '通信回数を減らしたい場合はheadersをSplitしてください
ElseIf InStr(headers, "date") > 0 Then
Worksheets(mySheet).Range("C" & i).Value = h.getResponseHeader("date") '通信回数を減らしたい場合はheadersをSplitしてください
Else
Worksheets(mySheet).Range("C" & i).Value = "Last-Modifiedが見つかりません"
End If
End If
End If
'End If
flg = ""
i = i + 1
状況 = Int(i / 行末 * 100)
未完 = 100 - 状況
If 状況 > 0 And 未完 > 0 Then
Application.StatusBar = "(" & i & "/" & 行末 & "行目を処理中…)"
End If
If i > 行末 Then
'Exit Do
End If
Loop
Application.StatusBar = False
Application.StatusBar = ""
'================================
' Application.ScreenUpdating = True
MsgBox "取り込みが完了しました"
End If 'If Rtn = vbYes Then
' Application.ScreenUpdating = True
End Sub
Sub サイト確認マクロall()
'Google Chromeを起動
'CreateObject("WScript.Shell").Run ("chrome.exe")
Dim objIE As Object
Dim html As String
Dim 行末 As Long
Dim h
Dim Rtn
Rtn = MsgBox(Chr(10) & "読み込み 実行", vbYesNo, "選択")
If Rtn = vbYes Then
Dim myBook, mySheet
myBook = ActiveWorkbook.Name
mySheet = ActiveSheet.Name
'Application.ScreenUpdating = False
'================================
Worksheets(mySheet).Select
Worksheets(mySheet).Activate
i = 2
行末 = Worksheets(mySheet).Cells(Rows.Count, 2).End(xlUp).Row
Set h = CreateObject("MSXML2.XMLHTTP")
Set objIE = CreateObject("InternetExplorer.application")
'Set objIE = CreateObject("WScript.Shell").Run("chrome.exe")
Set WSH = CreateObject("WScript.Shell")
'Set WSH = CreateObject("WScript.Shell").Run("chrome.exe")
Do
If Len(Worksheets(mySheet).Range("d" & i).Value) < 1 Then
If Len(Worksheets(mySheet).Range("c" & i).Value) < 5 Then
Exit Do
End If
'Do While objIE.Busy Or objIE.ReadyState <> 4
DoEvents
'Loop
h.Open "HEAD", Worksheets(mySheet).Range("b" & i).Value, False
Worksheets(mySheet).Range("c" & i).Select
h.send
Dim headers
headers = h.getAllResponseHeaders()
Worksheets(mySheet).Range("c" & i).Value = headers '通信回数を減らしたい場合はheadersをSplitしてください
End If
'End If
flg = ""
i = i + 1
状況 = Int(i / 行末 * 100)
未完 = 100 - 状況
If 状況 > 0 And 未完 > 0 Then
Application.StatusBar = "(" & i & "/" & 行末 & "行目を処理中…)"
End If
If i > 行末 Then
'Exit Do
End If
Loop
Application.StatusBar = False
Application.StatusBar = ""
'================================
' Application.ScreenUpdating = True
MsgBox "取り込みが完了しました"
End If 'If Rtn = vbYes Then
' Application.ScreenUpdating = True
End Sub
'■全シートの改行を削除する
Sub call_ReplaceNewLine()
Dim ws As Worksheet
'本来Excelの改行はLfですが、Windowsの改行のvbCrlfも念のため削除
'Windowsではあまり使わないvbCrも同様に削除。
For Each ws In ActiveWorkbook.Worksheets
ws.UsedRange.Replace vbCrLf, ""
ws.UsedRange.Replace vbLf, ""
ws.UsedRange.Replace vbCr, ""
Next ws
End Sub