百度|上传|下载

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