VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.2#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Form1"
   ClientHeight    =   10275
   ClientLeft      =   45
   ClientTop       =   375
   ClientWidth     =   17940
   BeginProperty Font 
      Name            =   "微软雅黑"
      Size            =   10.5
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   10275
   ScaleWidth      =   17940
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox Text4 
      Height          =   615
      Left            =   4200
      TabIndex        =   6
      Text            =   "https://so-kan.2345.com/search_[[Title]]/"
      Top             =   3000
      Visible         =   0   'False
      Width           =   11055
   End
   Begin VB.TextBox Text2 
      Height          =   615
      Left            =   4440
      TabIndex        =   5
      Text            =   "http://www.gongkaike.org/search.html?wd=[[Title]]&submit="
      Top             =   1800
      Width           =   11055
   End
   Begin VB.TextBox Text3 
      Height          =   4215
      Left            =   9120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   4
      Text            =   "Form1.frx":0000
      Top             =   5520
      Width           =   5775
   End
   Begin VB.PictureBox Picture1 
      Height          =   9735
      Left            =   12360
      ScaleHeight     =   9675
      ScaleWidth      =   5235
      TabIndex        =   3
      Top             =   240
      Width           =   5295
   End
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   6840
      Top             =   4440
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   30
      ImageHeight     =   28
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   1
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":1FA6
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ListView ListView1 
      Height          =   9015
      Left            =   240
      TabIndex        =   2
      Top             =   960
      Width           =   11895
      _ExtentX        =   20981
      _ExtentY        =   15901
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      Icons           =   "ImageList1"
      SmallIcons      =   "ImageList1"
      ColHdrIcons     =   "ImageList1"
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin VB.CommandButton Command1 
      Caption         =   "搜索"
      Height          =   495
      Left            =   4320
      TabIndex        =   1
      Top             =   240
      Width           =   1575
   End
   Begin VB.TextBox Text1 
      Height          =   495
      Left            =   240
      TabIndex        =   0
      Text            =   "超级少女"
      Top             =   240
      Width           =   3975
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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


Private Sub Command1_Click()
Dim Link As String
Dim Nr, Title, Url As String
Dim Fg() As String
If Text1.text <> "" Then

Link = Replace(Text2.text, "[[Title]]", Text1.text)
Text3.text = GetHTML2(Link)


ListView1.ListItems.Clear
s$ = Text3.text
P& = InStr(s, "<img")
l& = Len("<img")
 Do While P
 p2& = InStr(P + l, s, ">")
 Nr = Mid$(s, P + l, p2 - P - l)
 P = InStr(p2, s, "<img")
' Nr = Replace(Nr, """", "")
If InStr(Nr, "src=") > 0 Then
If InStr(Nr, "data-src=") > 0 Then
If InStr(Nr, "width=") > 0 Then
 'ListView1.ListItems.Add , , Nr, 1, 1
 x = InStr(Nr, "data-src=")
 y = Mid(Nr, x, Len(Nr) - x)
 y = Replace(y, "data-src=" & """", "")
 Url = Mid(y, 1, InStr(y, """") - 1)
 Url = Replace(Url, "//", "http://")
 x = InStr(Nr, "title=")
 y = Mid(Nr, x, Len(Nr) - x)
 y = Replace(y, "title=" & """", "")
 Title = Mid(y, 1, InStr(y, """") - 1)
 Nr = Title & "|" & Url
    Set Items = ListView1.ListItems.Add(, , Title, 1, 1)
        Items.SubItems(1) = Url
End If
End If
End If
Loop

End If
End Sub

Private Sub Command4_Click()

End Sub

Private Sub Form_Load()
With ListView1
    .ColumnHeaders.Clear
    .View = lvwReport
    .LabelEdit = 1
    .HideColumnHeaders = False
    .FullRowSelect = True
    .GridLines = True
    .ListItems.Clear
    .ColumnHeaders.Add 1, , "名称", 5000
    .ColumnHeaders.Add 2, , "链接", ListView1.Width - 5000 - 335
End With
If Dir(App.Path & "\Image", vbDirectory) = "" Then
    MkDir App.Path & "\Image"
End If
'WebBrowser1.Silent = True
End Sub

 Public Function GetBody(ByVal Url$, Optional ByVal Coding$ = "utf-8")
  Dim ObjXML
  On Error Resume Next
  Set ObjXML = CreateObject("Microsoft.XMLHTTP")
  With ObjXML
  .open "Get", Url, False, "", ""
  .setRequestHeader "If-Modified-Since", "0"
  .send
  GetBody = .responseBody
  End With
 GetBody = BytesToBstr(GetBody, Coding)
 Set ObjXML = 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

Public Function getWebHtml(browser As WebBrowser) As String
    Dim doc As Object
    Dim i As Object
    Dim strHtml As String
    
    Set doc = browser.Document
    For Each i In doc.All
        strHtml = strHtml & Chr(13) & i.innerHtml
    Next
    getWebHtml = strHtml
 End Function

Public Function GetHTML2(Url As String)
Dim text As String
Set xmlHTTP1 = CreateObject("Microsoft.XMLHTTP")
xmlHTTP1.open "get", Url, True
xmlHTTP1.send
While xmlHTTP1.readyState <> 4
DoEvents
Wend
GetHTML2 = xmlHTTP1.responseText
Set xmlHTTP1 = Nothing
End Function

Private Sub ListView1_DblClick()
If ListView1.ListItems.Count > 0 Then
    If ListView1.SelectedItem.Index > 0 Then
        'MsgBox ListView1.SelectedItem.SubItems(1)
        'ShellExecute Me.hWnd, "open", ListView1.SelectedItem.SubItems(1), vbNull, vbNull, 1
        r = URLDownloadToFile(0, ListView1.SelectedItem.SubItems(1), App.Path & "\Image\" & ListView1.SelectedItem.text, 0, 0)
        Picture1.Picture = LoadPicture(App.Path & "\Image\" & ListView1.SelectedItem.text)
    End If
End If

End Sub
