作者MitchellChen (米球)
看板Visual_Basic
标题[VBA ] 请问一下 这个该怎样修改 才会正常执行
时间Tue Mar 4 14:49:57 2008
这是一个抓奇摩评价的VBA
是一个高手Jackylu写的
可是我怎跑 第十七行就是说有问题
可以请各位高手协助一下吗?
原始来源来自
http://vba.blogspot.com/
如何把yahoo奇摩拍卖的评价汇入EXCEL,使用巨集或VBA
* 以下VBA执行前,请将UserID填入自己的Yahoo拍卖ID喔,并请登入yahoo拍卖.
* 将以下VBA原封不动copy的module1下即可.
* 没有写的很完整,想要防呆或增加功能,就自己试试罗~
* 若要捉别人的,程式只要做小修改即可......
Private Declare Function URLDownloadToFile Lib "urlmon" Alias
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub GetYahooEva()
UserID = "xxxxxx" '请填入自己的帐号
HtmlFile = "C:\JackyLu.txt"
TargetUser = "
http://tw.user.bid.yahoo.com/tw/show/rating?userID=" & UserID
DownloadFile CStr(TargetUser), CStr(HtmlFile)
AllData = UTF8ToBig5(HtmlFile)
TargetDataStart = "共 "
TargetDataStartLen = Len(TargetDataStart)
TargetDataStartPosition = InStr(AllData, TargetDataStart)
TargetDataStop = "<"
TargetDataStopLen = Len(TargetDataStop)
TargetDataStopPosition = InStr(TargetDataStartPosition + TargetDataStartLen,
AllData, TargetDataStop)
SheetCnt = Mid(AllData, TargetDataStartPosition + TargetDataStartLen,
TargetDataStopPosition - TargetDataStartPosition - TargetDataStartLen)
Workbooks.Add
Sheet1.Name = Format(Date, "yyyymmdd") & Format(Time, "hhmmss")
For SHN = 1 To SheetCnt
TargetUser = "
http://tw.user.bid.yahoo.com/tw/show/rating?userID=" & UserID &
"&pageNo=" & SHN
DownloadFile CStr(TargetUser), CStr(HtmlFile)
AllData = UTF8ToBig5(HtmlFile)
AllData = ReplaceUnnecessary(AllData)
AllData = TrimAllBlank(AllData)
Do
TargetDataStart = "评价为："
TargetDataStartLen = Len(TargetDataStart)
TargetDataStartPosition = InStr(AllData, TargetDataStart)
TargetDataStop = "[回应]"
TargetDataStopLen = Len(TargetDataStop)
TargetDataStopPosition = InStr(TargetDataStartPosition + TargetDataStartLen,
AllData, TargetDataStop)
If TargetDataStartPosition <> 0 Then
T = Mid(AllData, TargetDataStartPosition, TargetDataStopPosition -
TargetDataStartPosition)
NL1 = "买家满意度"
NL2 = "意见︰"
NL3 = "回覆︰"
T = Replace(T, NL1, Chr(10) & NL1)
T = Replace(T, NL2, Chr(10) & NL2)
T = Replace(T, NL3, Chr(10) & NL3)
x = x + 1
Cells(x, 1).FormulaR1C1 = T
AllData = Mid(AllData, TargetDataStopPosition)
Else
Exit Do
End If
Loop
Next
Columns("A:A").ColumnWidth = 200
Cells.EntireRow.AutoFit
ActiveWindow.Zoom = 75
End Sub
Function UTF8ToBig5(HtmlFile)
Dim objStream As Object
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 2
.Mode = 3
.Open
.Charset = "Big5" 'utf-8 Big5 或其他编码
.LoadFromFile HtmlFile
UTF8ToBig5 = .ReadText
.Close
End With
End Function
Function TrimAllBlank(TrimB)
TrimB = Replace(TrimB, " ", "")
If InStr(TrimB, " ") > 0 Then
TrimB = TrimAllBlank(TrimB)
End If
TrimAllBlank = TrimB
End Function
Function ReplaceUnnecessary(RUString)
RUString = Replace(RUString, Chr(9), "")
RUString = Replace(RUString, Chr(13), "")
RUString = Replace(RUString, Chr(10), "")
RUString = Replace(RUString, " ", "")
Do
LI = InStr(RUString, "<") If LI = 0 Then Exit Do RI = InStr(LI, RUString, ">")
RUString = Replace(RUString, Mid(RUString, LI, RI - LI + 1), "")
Loop
ReplaceUnnecessary = RUString
End Function
Public Function DownloadFile(URL As String, LocalFilename As String) As
Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
--
※ 发信站: 批踢踢实业坊(ptt.cc)
◆ From: 218.162.96.135
1F：推 Marty:他这个找评价的逻辑可能因为网页格式改了..所以没用了... 03/05 17:24
2F：→ Marty:把前面找评价的程式码改一改就可以了.. 03/05 17:25
3F：→ MitchellChen:这是前天才写的耶 03/05 20:17