VB.NET 網絡爬蟲;爬取妹子;美女圖片--宅男福利

愛美之心，人皆有之，而美女自然人人都愛看。

在網上看到美女圖片的時候，大家是不是，都忍不住想偷偷的保存到硬碟裡？但實在太多了一個個下都不知道下到什麼時候呢？為了解決廣大男士的痛點;，而我作為一個VB業餘程序愛好者就是要為廣大的男士們提供便捷的方式；

特意將此VB爬蟲的製作過程和原始碼分享給大家。本文僅用作VB爬蟲技術探討，其他使用與作者無關。本文為作者原創，禁止轉載。

來先看看成果：

軟體界面：

製作過程：

1、首先你要知道基本的網頁原始碼構造

2、訪問http://meizi.geekyou.cn/網站讀取網頁原始碼（下面以IE瀏覽器為例，其它瀏覽器類似）

 2.1.正常訪問網站，然後按F12 瀏覽網站原始碼（我是以網絡嗅探形式查看代碼，審查元素也可以）

  2.2在響應正文裡面我們可以看到妹子圖的專輯地址

2.3通過訪問專輯地址我們可以得到圖片的真實下載地址

通過以上方式我們可以得到美女圖片的真實地址，然後就是批量下載即可！

3、由於本人比較懶思考，所以本程序是通過一次性獲得所有頁面的美女圖片專輯地址和一次性獲得美女圖片的真實地址，所以如果爬取的頁面比較多的話可能需要，很久很久 才能獲得圖片真實地址和下載文件，所以建議測試玩家 以50頁一次，為一次下載！

（當然有需要可以把程序改成邊獲取地址一邊下載。。。。。。）

4、下面貼上代碼

Imports System.IOImports System.NetImports System.Text.RegularExpressions
Public Class Form1    Dim pic As New Pic_net    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load        Application.DoEvents()    End Sub
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles BT_GO.Click        Down_pic()
    End Sub
    Private Sub TXT_START_TextChanged(sender As Object, e As EventArgs) Handles TXT_START.TextChanged        If Not IsNumeric(TXT_START.Text) Then            MessageBox.Show(「只允許輸入數字」)        End If    End Sub
    Private Sub TXT_XEND_TextChanged(sender As Object, e As EventArgs) Handles TXT_XEND.TextChanged        If Not IsNumeric(TXT_XEND.Text) Then            MessageBox.Show(「只允許輸入數字」)        End If    End Sub        ''' <summary>    ''' 開始爬取    ''' </summary>    ''' <returns></returns>    Function Down_pic() As Boolean        Get_path()        Label1.Text = "正在運行。。。。。"        pic.GET_ZJADD(Val(TXT_START.Text), Val(TXT_XEND.Text))        pic.GET_jpgADD()        Dim arr As ArrayList = pic.jpg_obj        Dim i As Integer = arr.Count        Dim J As Integer = 1        Label1.Text = "獲得" & i & "張圖片"        For Each xl In arr            Dim str As String = xl            If InStr(str.ToLower, ".gif") Then                pic.FileDown(xl, "C:\Users\Administrator\Desktop\MM\" & J & ".gif")            ElseIf InStr(str.ToLower, ".jpg") Then                pic.FileDown(xl, "C:\Users\Administrator\Desktop\MM\" & J & ".jpg")            End If            Label2.Text = "正在爬取第「 & J & 」張"            J += 1            Application.DoEvents()        Next        Return True
    End Function        ''' <summary>    ''' 獲得保存地址    ''' </summary>    ''' <returns></returns>    Function Get_path() As Boolean        Dim path As String = "C:\Users\" & Environment.UserName & "\Desktop\MM\"        If Directory.Exists(path) = False Then            Directory.CreateDirectory(path)            Return True        Else            Return False        End If    End FunctionEnd Class

Public Class Pic_net    Private Obj As New ArrayList  '獲得專輯地址    Public jpg_obj As New ArrayList  '獲得圖片下載地址    ''' <summary>    ''' 獲取網頁數據    ''' </summary>    ''' <param name="Url"></param>    ''' <param name="GetData"></param>    ''' <returns></returns>    Public Function NetGetData(ByVal Url As String, Optional ByVal GetData As String = "") As String        Dim tmp As String = ""        Try            Dim Request As HttpWebRequest  '定義http請求            Request = WebRequest.Create(Url + "?" + GetData) '創建HTTP請求            Request.Method = "GET" '請求方式GET            Dim Strm As Stream '定義流視圖            Strm = Request.GetResponse().GetResponseStream '獲得響應的流            Dim Sr As StreamReader = New StreamReader(Strm) '讀取響應正文New StreamReader(Strm, Encoding.GetEncoding("GB2312"))            tmp = Sr.ReadToEnd '由頭讀到尾        Catch ex As Exception            MsgBox(ex.Message)        End Try        Return tmp    End Function
    ''' <summary>    ''' 獲取網址列表    ''' </summary>    ''' <param name="Arr"></param>    ''' <param name="tf"></param>    ''' <param name="XREG"></param>    ''' <returns></returns>    Public Function Get_list(ByVal Arr As Object, ByRef tf As Boolean, ByRef XREG As String) As Object        Dim tmp As Object = Nothing        Try            Dim reg As New Regex(XREG)            Dim match As MatchCollection = reg.Matches(Arr)            ReDim tmp(match.Count)            If match.Count = 0 Then                tf = False            Else                tf = True            End If            Dim i As Integer = 0            For Each m As Match In match                tmp(i) = m.Value                i += 1                Application.DoEvents()            Next        Catch ex As Exception            MsgBox(ex.Message)        End Try
        Return tmp    End Function        ''' <summary>    ''' 獲取專輯地址    ''' </summary>    ''' <param name="xstart"></param>    ''' <param name="xend"></param>    ''' <returns></returns>    Public Function GET_ZJADD(ByVal xstart As Integer, ByVal xend As Integer) As Boolean        Dim tf As Boolean        Dim tmp As Object        For i As Integer = xstart To xend '2700頁            tmp = Get_list(NetGetData("http://meizi.geekyou.cn/page/" & i & "/"), tf, "(?<=window.location.href=').+?(?=')")            If tf = True Then                For Each xl In tmp                    If xl <> Nothing Then                        Obj.Add("http://meizi.geekyou.cn" & xl)                    End If                Next            End If            Application.DoEvents()        Next        Return True    End Function        ''' <summary>    ''' 獲取圖片真實地址    ''' </summary>    ''' <returns></returns>    Public Function GET_jpgADD() As Boolean        Dim tf As Boolean        Dim tmp As Object        For Each ad In Obj            tmp = Get_list(NetGetData(ad), tf, "(?<=data-original=" & Chr(34) & ").+?(?=" & Chr(34) & ")")            If tf = True Then                For Each xl In tmp                    If xl <> Nothing Then                        jpg_obj.Add(xl)                    End If                Next            End If            Application.DoEvents()        Next        Return True    End Function
    ''' <summary>    ''' 下載圖片    ''' </summary>    ''' <param name="URL"></param>    ''' <param name="saveFile"></param>    ''' <returns></returns>    Public Function FileDown(ByVal URL As String, ByVal saveFile As String) As Boolean        Dim myWebclient As WebClient        Dim SaveFileDialog1 As New SaveFileDialog()        Try            myWebclient = New WebClient()            myWebclient.DownloadFileAsync(New Uri(URL), saveFile)            Return True        Catch ex As Exception            Return False        End Try    End FunctionEnd Class
5、軟體體驗地址
連結：https://pan.baidu.com/s/18Ma4Tx2unEzd1Xu4bNy1Jw 
提取碼：3ukv 
6.VB小源碼主頁：www.vbxym.cn