百度|上传|下载
Imports System.IO
Imports System.Net
Imports System.Web
Public Delegate Sub BaiduAlbumEventHandler(ByVal msg As String) '事件委托
Public Class baiduAlbum
''' 声明事件
Public Event UpPicsComplete As BaiduAlbumEventHandler
Public Event UpPicsProcess As BaiduAlbumEventHandler
Public Event DownPicsComplete As baiduAlbumEventHandler
Public Event DownPicProcess As BaiduAlbumEventHandler
Public Event DeletePicsComplete As BaiduAlbumEventHandler
Public Event DeletePicProcess As BaiduAlbumEventHandler
'定义数据成员
'''用户
Dim _username As String
Dim _password As String
Dim _userDomain As String
Dim _userHeadPic As String
'''全部
Dim _albumUsedSpace As Double
Dim _albumCount As Integer
Dim _pictureCount As Integer
'''相册
Dim _albumID As ArrayList
Dim _albumName As ArrayList
Dim _albumDesc As ArrayList
Dim _albumPower As ArrayList
Dim _albumURL As ArrayList
Dim _albumPicCount As ArrayList
'''图片
Dim _pictureID() As ArrayList
Dim _pictureDesc() As ArrayList
Dim _pictureURL() As ArrayList
Dim _pictureSize() As ArrayList
Dim Encode As System.Text.Encoding = System.Text.Encoding.GetEncoding("GB2312") '编码方式
Dim commandURL As String '操作命令地址
Dim Http As HttpProc '实现http协议的类
Dim r As System.Text.RegularExpressions.Regex '正则表达式
Dim m As System.Text.RegularExpressions.Match
''' 登录
Function Login(ByVal username As String, ByVal password As String) As Boolean
_username = username
Dim postData, LoginURL As String
LoginURL = "http://passport.baidu.com/?login" '登陆地址
postData = "username=" + HttpUtility.UrlEncode(username, Encode) + "&password=" + HttpUtility.UrlEncode(password, Encode) '请求数据
Http = New HttpProc(LoginURL, postData)
Dim RespHtml As String
RespHtml = Http.Proc(True)
If Http.strErr <> "" Then
MsgBox(Http.strErr)
Http.strErr = ""
ElseIf Len(RespHtml) < 200 Then
_userDomain = GetDomain(_username) '获取用户域名
If _userDomain <> "" Then
Http.cookiePost = Http.cookieGet
commandURL = "http://hiup.baidu.com/" + _userDomain + "/commit"
Return True
End If
ElseIf InStr(RespHtml, "不存在<") > 0 Then
MsgBox("你输入的用户名不存在")
ElseIf InStr(RespHtml, ">登录密码错误") > 0 Then
MsgBox("登录密码错误")
Else
MsgBox("登录失败")
End If
Return False
End Function
'-----------------------------------以下实现对相册的管理操作--------------------------------------------------------------------------
''' 创建相册
Function CreateNewAlbum(ByVal albumName As String, Optional ByVal albumDesc As String = "", Optional ByVal albumPower As String = "0") As Boolean
Dim respHtml As String
Http.strPostdata = "cm=1&ct=3&spAlbumName=" + HttpUtility.UrlEncode(albumName, Encode) + "&spAlbumDescri=" + HttpUtility.UrlEncode(albumDesc, Encode) + "&spAlbumPower=" + albumPower
Http.strUrl = commandURL
respHtml = Http.Proc
m = r.Match(respHtml, "writestr\(.+成功")
If m.Success Then
Return True
End If
Return False
End Function
''' 修改相册
Function ModifyAlbum(ByVal oldAlbumIndex As Integer, ByVal newAlbumName As String, Optional ByVal newAlbumDesc As String = "", Optional ByVal newAlbumPower As String = "0") As Boolean
Dim respHtml As String
Http.strPostdata = "cm=2&ct=3&spAlbumName_o=" + HttpUtility.UrlEncode(albumName(oldAlbumIndex), Encode) + "&spAlbumName=" + HttpUtility.UrlEncode(newAlbumName, Encode) + "&spAlbumDescri=" + HttpUtility.UrlEncode(newAlbumDesc, Encode) + "&spAlbumPower=" + newAlbumPower
Http.strUrl = commandURL
respHtml = Http.Proc
m = r.Match(respHtml, "writestr\(.+成功")
If m.Success Then
Return True
End If
Return False
End Function
''' 删除相册
Function DeleteAlbum(ByVal AlbumIndex As Integer) As Boolean
Dim respHtml As String
Http.strPostdata = "spAlbumName_o=" + HttpUtility.UrlEncode(albumName(AlbumIndex), Encode) + "&spAlbumID_o=" + albumID(AlbumIndex) + "&ct=3&cm=4&del=1"
Http.strUrl = commandURL
respHtml = Http.Proc
m = r.Match(respHtml, "writestr\(.+成功")
If m.Success Then
Return True
End If
Return False
End Function
''' 移动相册
Function MoveAlbum(ByVal fromAlbumIndex As Integer, ByVal toAlbumIndex As Integer) As Boolean
Dim respHtml As String
Http.strPostdata = "spAlbumName_o=" + HttpUtility.UrlEncode(albumName(fromAlbumIndex), Encode) + "&spAlbumID_o=" + albumID(fromAlbumIndex) + "&spAlbumName=" + HttpUtility.UrlEncode(albumName(toAlbumIndex), Encode) + "&spAlbumID=" + albumID(toAlbumIndex) + "&ct=3&cm=3&del=0"
Http.strUrl = commandURL
respHtml = Http.Proc
m = r.Match(respHtml, "writestr\(.+成功")
If m.Success Then
Return True
End If
Return False
End Function
'批量下载图片
Function DownloadPictures(ByVal downPicList As ArrayList, ByVal savePath As String)
Dim downList As New ArrayList
downList.AddRange(downPicList)
Dim down As New System.Net.WebClient
Dim process As Integer
Do While downList.Count > 0
Try
down.DownloadFile(downList(0), savePath + Path.GetFileName(downList(0)))
process += 1
RaiseEvent DownPicProcess(process)
downList.RemoveAt(0)
Catch ex As Exception
''MsgBox("网络错误！")
'Exit Function
End Try
Loop
downList = Nothing
down.Dispose()
down = Nothing
RaiseEvent DownPicsComplete("sucess")
End Function
'上传图片
Function uploadPicture(ByVal upPictureList As ArrayList, ByVal albumIndex As Integer)
Dim i, k, process As Integer
'单个表单只允许最多同时上传3个文件
'因此通过循环上传来实现批量上传
Dim upPicList As New ArrayList
upPicList.AddRange(upPictureList)
Do While upPicList.Count > 0
If upPicList.Count >= 3 Then
k = 3
Else
k = upPicList.Count
End If
'向表单添加要上传的前k个文件
Dim form As New ArrayList '要上传的表单集合
form.Add(New EntityFormValue("BrowserType", "1"))
form.Add(New EntityFormValue("spAlbumName", albumName(albumIndex)))
For i = 0 To k - 1
form.Add(New EntityFormValue("spPhotoText", System.IO.Path.GetFileName(upPicList(i))))
form.Add(New EntityFormFile("spPhotofile", upPicList(i)))
Next
Http.strUrl = "http://hiup.baidu.com/" + _userDomain + "/upload"
Dim respHtml As String = Http.PostMultipartForm(form) '上传并返回结果
If Http.strErr <> "" Then
MsgBox(Http.strErr)
Http.strErr = ""
Exit Function
End If
Dim str As String = respHtml
m = r.Match(respHtml, "(?<=haidai\()\d,\d(,)\d") '用正则表达式处理返回结果
If Not m.Success Then
MsgBox("发生意外错误，请重新登录再试")
Else
respHtml = Replace(m.Value, ",", "")
End If
'因为每次最多同时上传3个文件，所以返回的结果只有3个代码,其中0代表上传成功，1代表上传失败
Dim sucessList As New ArrayList
For i = 0 To k - 1
If Mid(respHtml, i + 1, 1) = "0" Then '成功
process += 1
RaiseEvent UpPicsProcess(process) '上传进度
sucessList.Add(upPicList(i)) '记录上传成功文件
System.Threading.Thread.Sleep(200) '暂停0.2秒
Else
System.Threading.Thread.Sleep(400) '暂停0.4秒
End If
Next
'从任务列表中清除已经上传的任务
For i = 0 To sucessList.Count - 1
For k = 0 To upPicList.Count - 1
If sucessList(i) = upPicList(k) Then
upPicList.RemoveAt(k)
Exit For
End If
Next
Next
sucessList = Nothing
form = Nothing
System.Threading.Thread.Sleep(800) '暂停0.8秒
Loop
RaiseEvent UpPicsComplete("sucess")
End Function
'修改图片
Function modifyPic(ByVal albumIndex As Integer, ByVal picIndex As Integer, ByVal picDesc As String) As Boolean
Dim respHtml As String
Http.strPostdata = "cm=2&ct=4&spPhotoID=" & pictureID(albumIndex, picIndex) & "&spPhotoName=" & HttpUtility.UrlEncode(picDesc, Encode) & "&spAlbumName_o=" & HttpUtility.UrlEncode(albumName(albumIndex), Encode) & "&spAlbumName=" & HttpUtility.UrlEncode(albumName(albumIndex), Encode)
Http.strUrl = commandURL
respHtml = Http.Proc
m = r.Match(respHtml, "writestr\(.+成功")
If m.Success Then
Return True
End If
Return False
End Function
'删除图片
Function DeletePic(ByVal albumIndex As Integer, ByVal picIndex As Integer) As Boolean
Dim respHtml As String
Http.strPostdata = "cm=3&ct=4&spPhotoID=" & pictureID(albumIndex, picIndex) & "&spAlbumName_o=" & HttpUtility.UrlEncode(albumName(albumIndex), Encode)
Http.strUrl = commandURL
respHtml = Http.Proc
m = r.Match(respHtml, "writestr\(.+成功")
If m.Success Then
Return True
End If
Return False
End Function
''' 批量删除图片
Sub DeletePictures(ByVal albumIndex As Integer, ByVal delPicList As ArrayList)
Dim delList As New ArrayList
delList.AddRange(delPicList)
Dim process As Integer
Do While delList.Count > 0
If Me.DeletePic(albumIndex, delList(0)) Then
process += 1
delList.RemoveAt(0)
RaiseEvent DeletePicProcess(process) '删除进度
Else
System.Threading.Thread.Sleep(2000)
End If
Loop
delList = Nothing
RaiseEvent DeletePicsComplete("complete")
End Sub
'移动图片
Function MovePic(ByVal picIndex As Integer, ByVal fromAlbumIndex As Integer, ByVal toAlbumIndex As Integer) As Boolean
Dim respHtml As String
Http.strPostdata = "cm=2&ct=4&spPhotoID=" & pictureID(fromAlbumIndex, picIndex) & "&spPhotoName=&spAlbumName_o=" & HttpUtility.UrlEncode(albumName(fromAlbumIndex), Encode) & "&spAlbumName=" & HttpUtility.UrlEncode(albumName(toAlbumIndex), Encode)
Http.strUrl = commandURL
respHtml = Http.Proc
m = r.Match(respHtml, "writestr\(.+成功")
If m.Success Then
Return True
End If
Return False
End Function
'--------------------------------------以下实现获取用户相册信息-------------------------------------------------------------------------------
'
Function GetAlbum() As Boolean
_albumID = New ArrayList
_albumURL = New ArrayList
_albumName = New ArrayList
_albumDesc = New ArrayList
_albumPower = New ArrayList
_albumPicCount = New ArrayList
_userHeadPic = GetUserHeadPic() '获取头像地址
If GetAlbumsInfo("http://hi.baidu.com/" + _userDomain + "/album") Then '获取目录信息
Dim i As Integer
For i = 0 To _albumCount - 1 '获取每个相册信息
If Not GetAlbumInfo(i) Then
Return False
End If
Next
Return True
Else
Return False
End If
End Function
'获取头像地址
Private Function GetUserHeadPic() As String
Dim respHtml As String
Http.strPostdata = ""
Http.strUrl = "http://hi.baidu.com/" + _userDomain + "/profile"
respHtml = Http.Proc
If Http.strErr <> "" Then
Http.strErr = ""
Return "/XrssFile/2007-5/5/200755104618909.jpg"
End If
m = r.Match(respHtml, "http://himg.baidu.com/sys/portrait/item/\w+\.\w{3}")
Return m.Value
End Function
'获取相册目录信息
Private Function GetAlbumsInfo(ByVal albumURL As String) As Boolean
_pictureCount = 0
Dim respHtml As String
Http.strPostdata = ""
Http.strUrl = albumURL
respHtml = Http.Proc
If respHtml = "" Then
Return False
End If
m = r.Match(respHtml, "(?<=purl:"")[^""]+")
Do While m.Success
_albumURL.Add("http://hi.baidu.com" + m.Value) '相册url
m = m.NextMatch
Loop
m = r.Match(respHtml, "(?<=pname:"")[^""]*")
Do While m.Success
_albumName.Add(System.Web.HttpUtility.HtmlDecode(m.Value)) '相册名字
m = m.NextMatch
Loop
m = r.Match(respHtml, "(?<=pnum:"")[^""]+")
Do While m.Success
_albumPicCount.Add(CInt(m.Value)) '相册中图片数
_pictureCount += CInt(m.Value) '图片总数
m = m.NextMatch
Loop
m = r.Match(respHtml, "(?<=document\.getElementById\(""jdt""\)\.width=)\d+\.?\d*")
If m.Success Then _albumUsedSpace = CDbl(m.Value) '获取相册已用空间
_albumCount = _albumName.Count '相册数目
ReDim _pictureID(_albumCount - 1)
ReDim _pictureDesc(_albumCount - 1)
ReDim _pictureSize(_albumCount - 1)
ReDim _pictureURL(_albumCount - 1)
'''' 以下获取相册ID
m = r.Match(respHtml, "/modify/albumdel/\w+")
If Not m.Success Then '如果仅有‘默认相册’
_albumID.Add("0")
Return True
End If
Http.strUrl = "http://hiup.baidu.com/" + _userDomain + m.Value
respHtml = Http.Proc
If respHtml = "" Then
Return False
End If
Dim str As String = r.Split(respHtml, "<select.+name=.?spAlbumID")(1)
m = r.Match(str, "(?<=id=""acid"".+value=.?)\d+")
_albumID.Add("0")
_albumID.Add(m.Value)
m = r.Match(str, "(?<=<option.+value=.?)\d+")
m = m.NextMatch
Do While m.Success
_albumID.Add(m.Value) '相册ID
m = m.NextMatch
Loop
Return True
End Function
'获取指定相册信息
Private Function GetAlbumInfo(ByVal albumIndex) As Boolean
Dim pageIndex As Integer '分页索引
Dim pageCount As Integer '共有多少页
Dim respHtml, htmlCode As String
Http.strPostdata = ""
pageCount = _albumPicCount(albumIndex) \ 20 - CInt(_albumPicCount(albumIndex) Mod 20 > 0)
If pageCount = 0 Then pageCount = 1
For pageIndex = 0 To pageCount - 1
Http.strUrl = _albumURL(albumIndex) + "/index/" + CStr(pageIndex)
htmlCode = Http.Proc
If htmlCode = "" Then
Return False
End If
respHtml += htmlCode
Next
_pictureURL(albumIndex) = New ArrayList
_pictureSize(albumIndex) = New ArrayList
_pictureDesc(albumIndex) = New ArrayList
_pictureID(albumIndex) = New ArrayList
'-------------------------------------------------------------------
'获取相册简介
m = r.Match(respHtml, "(?<=简介：</strong>)[^<]*")
_albumDesc.Add(System.Web.HttpUtility.HtmlDecode(m.Value))
'-------------------------------------------------------------------
m = r.Match(respHtml, "(?<=pid:"")[^""]+")
Do While m.Success
_pictureID(albumIndex).Add(m.Value) '图片ID
m = m.NextMatch
Loop
m = r.Match(respHtml, "(?<=pname:"")[^""]*")
Do While m.Success
_pictureDesc(albumIndex).Add(System.Web.HttpUtility.HtmlDecode(m.Value)) '图片描述
m = m.NextMatch
Loop
m = r.Match(respHtml, "(?<=psrc:"")[^""]+")
Do While m.Success
_pictureURL(albumIndex).Add(m.Value) '图片url
m = m.NextMatch
Loop
m = r.Match(respHtml, "(?<=psize:"")[^""]+")
Do While m.Success
_pictureSize(albumIndex).Add(m.Value) '图片大小
m = m.NextMatch
Loop
Return True
End Function
'-------------------------------------------以下为属性-----------------------------------------------------------
''' 获取用户名
ReadOnly Property username() As String
Get
Return _username
End Get
End Property
''' 获取用户密码
ReadOnly Property password() As String
Get
Return _password
End Get
End Property
''' 获取用户域名
ReadOnly Property userDomain() As String
Get
Return _userDomain
End Get
End Property
'''获取用户头像
ReadOnly Property userHeadPic()
Get
Return _userHeadPic
End Get
End Property
''' 相册已用空间
ReadOnly Property albumUsedSpace() As Double
Get
Return _albumUsedSpace
End Get
End Property
''' 相册个数
ReadOnly Property albumCount() As Integer
Get
Return _albumCount
End Get
End Property
''' 图片总数
ReadOnly Property pictureCount() As Integer
Get
Return _pictureCount
End Get
End Property
''' 获取某个相册ID
ReadOnly Property albumID(ByVal albumIndex As Integer) As String
Get
Return _albumID(albumIndex)
End Get
End Property
''' 获取某个相册名称
ReadOnly Property albumName(ByVal albumIndex As Integer) As String
Get
Return _albumName(albumIndex)
End Get
End Property
''' 获取某个相册的描述
ReadOnly Property albumDesc(ByVal albumIndex As Integer) As String
Get
Return _albumDesc(albumIndex)
End Get
End Property
''' 获取某个相册的图片数
ReadOnly Property AlbumPicCount(ByVal albumIndex As Integer) As Integer
Get
Return _albumPicCount(albumIndex)
End Get
End Property
''' 图片ID
ReadOnly Property pictureID(ByVal albumIndex As Integer, ByVal pictureIndex As Integer) As String
Get
Return _pictureID(albumIndex)(pictureIndex)
End Get
End Property
''' 图片名称
ReadOnly Property pictureDesc(ByVal albumIndex As Integer, ByVal pictureIndex As Integer) As String
Get
Return _pictureDesc(albumIndex)(pictureIndex)
End Get
End Property
''' 图片大小
ReadOnly Property pictureSize(ByVal albumIndex As Integer, ByVal pictureIndex As Integer) As String
Get
Return _pictureSize(albumIndex)(pictureIndex)
End Get
End Property
''' 图片地址
ReadOnly Property pictureURL(ByVal albumIndex As Integer, ByVal pictureIndex As Integer, Optional ByVal bigPic As Boolean = False) As String
Get
If bigPic Then
Return Replace(_pictureURL(albumIndex)(pictureIndex), "/abpic/", "/pic/") '大图
Else
Return _pictureURL(albumIndex)(pictureIndex) '小图
End If
End Get
End Property
'--------------------------------------以下实现用户名和域名的相互转换--------------------------------------------------------
'获取与用户名对应的空间域名
Private Function GetDomain(ByVal UserName As String) As String
Http.strPostdata = ""
Http.strUrl = "http://hi.baidu.com/sys/checkuser/" + UserName
Dim respHtml As String = Http.Proc
If Http.strErr <> "" Then
MsgBox(Http.strErr)
Http.strErr = ""
Exit Function
End If
Dim arr() As String = Split(respHtml, "/")
Return arr(1)
End Function
'获取与域名对应的用户名
'Private Function GetUserName(ByVal username As String) As String
' Dim arr() As String = Split(GetHTML("http://hi.baidu.com/" + username + "/profile"), "http://hi.baidu.com/" + username + """>")
' arr = Split(arr(0), "title=""")
' If UBound(arr) > 0 Then Return Trim(Replace(arr(1), "的空间", ""))
'End Function
End Class