重命名文件

On Error Resume Next
Dim dd As String
Dim k%

‘‘提取文件夾名稱
dd = Dir(Sheets("Sheet1").Cells(1, 2) & "*", vbDirectory)
Do
dd = Dir
‘‘判斷是否為文件夾
If dd <> "" And InStr(1, dd, ".") = 0 Then
Dim aa
Set aa = CreateObject("Scripting.FileSystemObject")
k = k + 1
‘‘文件夾重命名
aa.MoveFolder Sheets("Sheet1").Cells(1, 2) & dd, Sheets("Sheet1").Cells(1, 2) & "\改名" & k
End If

Loop Until Len(dd) = 0
Set aa = Nothing

‘爬去數據

Dim arr, brr, i%, s$, html, Ta, n%, j%, str$, Url$, Db, tr, td
tempPath = Cells(1, 2)
If Mid(tempPath, Len(tempPath), 1) <> "\" Then
tempPath = tempPath & "\"
End If
If Dir(tempPath, vbDirectory) = "" Then
MsgBox "錯誤！需要處理的文件目錄不存在 " & tempPath
Exit Sub
End If
Dim fn
fn = Dir(tempPath & "*.htm")
Do While fn <> ""
Set html = CreateObject("htmlfile")
dataTxt = GetCode("UTF-8", tempPath & fn) ‘tempPath & fn
html.body.innerhtml = dataTxt
If (InStr(dataTxt, "tooltip-title") = 0) Then
oneclick dataTxt, onenum
onenum = onenum + 1
Else
twoclick dataTxt, twonum
twonum = twonum + 1
End If
fn = Dir()
Loop

‘table數據

Set Db = html.all.tags("table")(3)
i = 0: j = 0
For Each tr In Db.Rows
m = 0
i = i + 1: j = 0
If i > 1 Then
For Each td In tr.Cells
m = m + 1
Sheets("Sheet3").Cells(m, pagenum) = Replace(td.innerText, Chr(10) & Chr(10), Chr(10))
Next
End If

　　　 pagenum = pagenum + 1

Next

‘頁面編碼

Public Function GetCode(CodeBase, Url) ‘第一個參數是設置編碼方式(GB2312或UTF-8)第二個參數是地址.
Dim xmlHTTP1
Set xmlHTTP1 = CreateObject("Microsoft.XMLHTTP")
xmlHTTP1.Open "get", Url, True
xmlHTTP1.send
While xmlHTTP1.readyState <> 4
DoEvents
Wend
GetCode = xmlHTTP1.responseBody
If CStr(GetCode) <> "" Then GetCode = BytesToBstr(GetCode, CodeBase)
Set xmlHTTP1 = Nothing
End Function

Public Function BytesToBstr(strBody, CodeBase)
Dim ObjStream
Set ObjStream = CreateObject("Adodb.Stream")
With ObjStream
.Type = 1
.Mode = 3
.Open
.write strBody
.Position = 0
.Type = 2
.Charset = CodeBase
BytesToBstr = .ReadText
.Close
End With
Set ObjStream = Nothing
End Function

爬去網頁離線數據