diff --git a/Frm_Download.frm b/Frm_Download.frm index e13feb8..c81db6c 100644 --- a/Frm_Download.frm +++ b/Frm_Download.frm @@ -8,19 +8,34 @@ Begin VB.Form Frm_Download LinkTopic = "Form1" ScaleHeight = 4800 ScaleWidth = 11565 - StartUpPosition = 3 '窗口缺省 + StartUpPosition = 2 '屏幕中心 + Begin VB.CommandButton fl + Caption = "文件夹" + Height = 270 + Left = 0 + TabIndex = 5 + Top = 0 + Width = 1020 + End + Begin VB.TextBox folder + Height = 285 + Left = 1065 + TabIndex = 3 + Top = 0 + Width = 10455 + End Begin VB.CommandButton clear Caption = "清空" Height = 300 Left = 0 - TabIndex = 3 - Top = 285 + TabIndex = 2 + Top = 540 Width = 1020 End Begin 导出商品首图.TzProgressBar pb Height = 255 Left = 1080 - Top = 330 + Top = 570 Width = 10440 _ExtentX = 18415 _ExtentY = 450 @@ -38,9 +53,9 @@ Begin VB.Form Frm_Download StartColor = 8438015 End Begin 导出商品首图.TzDownload dl - Height = 250 + Height = 255 Left = 1065 - Top = 60 + Top = 300 Width = 10440 _ExtentX = 18415 _ExtentY = 450 @@ -50,28 +65,28 @@ Begin VB.Form Frm_Download Caption = "下载" Height = 300 Left = 0 - TabIndex = 2 - Top = 0 + TabIndex = 1 + Top = 255 Width = 1020 End - Begin 导出商品首图.TzListBox UName - Height = 1170 - Left = 0 - TabIndex = 0 - Top = 2055 - Width = 3795 - _ExtentX = 6694 - _ExtentY = 2064 - End Begin 导出商品首图.TzListBox SName Height = 1335 Left = -15 - TabIndex = 1 - Top = 720 + TabIndex = 0 + Top = 840 Width = 3810 _ExtentX = 6720 _ExtentY = 2355 End + Begin 导出商品首图.TzListBox UName + Height = 1170 + Left = 0 + TabIndex = 4 + Top = 2175 + Width = 3795 + _ExtentX = 6694 + _ExtentY = 2064 + End End Attribute VB_Name = "Frm_Download" Attribute VB_GlobalNameSpace = False @@ -93,18 +108,18 @@ End Sub Private Sub dlc_Click() On Error Resume Next - Dim i - Dim folder As String + If UName.ListCount = 0 Then MsgBox ("请先检索商品链接!"): Exit Sub + Dim I Dim UseTime As Double If folder = "" Then folder = InputBox("请输入 日期-首图-公司名称-阿里账号-提单人名称!", , Format(Now, "m.d") & "-首图-公司名称-阿里账号-提单人名称") - If folder = "" Then folder = Format(Now, "m.d") & "-首图-公司名称-阿里账号-提单人名称" + If folder = Format(Now, "m.d") & "-首图-公司名称-阿里账号-提单人名称" Then Exit Sub: MsgBox "未修改文件夹名称,已取消导出!" UseTime = timeGetTime - For i = 0 To UName.ListCount - 1 + For I = 0 To UName.ListCount - 1 red: - pb.Change i, "下载中 进度: " & i & "/" & pb.BarMax - UName.ListIndex = i - SName.ListIndex = i - dl.FileDownload UName.List(i), App.Path & "\" & folder & "\" & Trim(SName.List(i)) ' & ".jpg" + pb.Change I, "下载中 进度: " & I & "/" & pb.BarMax + UName.ListIndex = I + SName.ListIndex = I + dl.FileDownload UName.List(I), App.Path & "\" & folder & "\" & Trim(SName.List(I)) ' & ".jpg" Do Sleep 50 Loop Until dl.IsFree @@ -115,6 +130,14 @@ red: pb.Change pb.BarMax, "下载完成 共下载" & pb.BarMax & "件产品首图 耗时" & UseTime & "秒!", &H80FF80 End Sub +Private Sub fl_Click() + Shell "explorer.exe /n,/select," & App.Path & "\" & folder & "\", vbNormalFocus +End Sub + +Private Sub Form_Load() + If folder = "" Then folder = Format(Now, "m.d") & "-首图-公司名称-阿里账号-提单人名称" +End Sub + Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Me.Hide Cancel = True @@ -123,24 +146,30 @@ End Sub 'itempicurl (ix), App.Path & "\" & folder.Text & "\" & itemname(ix).Text & ".jpg" Private Sub Form_Resize() On Error Resume Next - - SName.Left = 5 - SName.Top = 600 - SName.Height = Me.Height - 600 - SName.Width = Me.Width / 2 - 10 - - UName.Left = Me.Width / 2 + 10 - UName.Top = 600 - UName.Height = Me.Height - 600 - UName.Width = Me.Width / 2 - 10 - + folder.Left = dlc.Left + dlc.Width + 10 + folder.Width = Me.Width - dl.Left - 20 + folder.Top = 0 + dl.Left = dlc.Left + dlc.Width + 10 dl.Width = Me.Width - dl.Left - 20 - dl.Top = 25 + dl.Top = 300 pb.Left = dlc.Left + dlc.Width + 10 pb.Width = Me.Width - dl.Left - 20 pb.Top = dl.Top + dl.Height + 50 + + SName.Left = 5 + SName.Top = pb.Top + pb.Height + 50 + SName.Height = Me.Height - 600 + SName.Width = Me.Width / 2 - 10 + + UName.Left = Me.Width / 2 + 10 + UName.Top = pb.Top + pb.Height + 50 + UName.Height = Me.Height - 600 + UName.Width = Me.Width / 2 - 10 + + dlc.Top = dl.Top + clear.Top = pb.Top End Sub Private Sub SName_dblClick() diff --git a/Frm_Index.frm b/Frm_Index.frm new file mode 100644 index 0000000..f078717 --- /dev/null +++ b/Frm_Index.frm @@ -0,0 +1,130 @@ +VERSION 5.00 +Begin VB.Form Frm_Index + Caption = "旺铺首页首图获取" + ClientHeight = 3285 + ClientLeft = 60 + ClientTop = 345 + ClientWidth = 4680 + LinkTopic = "Form1" + ScaleHeight = 3285 + ScaleWidth = 4680 + StartUpPosition = 2 '屏幕中心 + Begin 导出商品首图.TzListBox itemlist + Height = 3165 + Left = -15 + TabIndex = 0 + Top = 255 + Width = 4710 + _ExtentX = 8308 + _ExtentY = 5583 + End + Begin 导出商品首图.TzProgressBar pb + Height = 255 + Left = 15 + Top = 0 + Width = 4665 + _ExtentX = 8229 + _ExtentY = 450 + BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} + Name = "宋体" + Size = 9 + Charset = 134 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + BackColor = 16777088 + StartColor = 16777088 + End + Begin 导出商品首图.XmlHttp XmlHttp + Height = 240 + Left = 1545 + Top = 105 + Visible = 0 'False + Width = 240 + _ExtentX = 423 + _ExtentY = 423 + End +End +Attribute VB_Name = "Frm_Index" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Private Sub Form_Activate() + If itemlist.ListCount > 0 And pb.BarValue = pb.BarMax Then getitem Else MsgBox "未获取到任何商品信息,请确认用主浏览窗口打开!", vbCritical: Unload Me +End Sub + +Private Sub getitem() + Dim I As Long + pb.BarValue = 0 + pb.BarMax = itemlist.ListCount + For I = 0 To itemlist.ListCount - 1 + Dim html As String + Dim itemurl As String + Dim itemname As String + + pb.Change I, "已提取首图信息" & I & "/" & pb.BarMax + + html = XmlHttp.GetData(itemlist.List(I), ResponseBodyToText) + + If html = "" Then GoTo nii + Dim st As Long + Dim en As Long + st = InStr(1, html, "image"" content=""") + Len("image"" content=""") + If st <> 0 Then + en = InStr(st, html, """") + itemurl = urlreset(Mid(html, st, en - st)) + End If + st = InStr(en, html, "title"" content=""") + Len("title"" content=""") + If st <> 0 Then + en = InStr(st, html, """") + itemname = Mid(html, st, en - st) + End If + If Frm_Download.UName.AddItemNotSame(itemurl) Then + If Not (Frm_Download.SName.AddItemNotSame(resetfilename(Trim(itemname) & ".jpg"))) Then + Frm_Download.SName.AddItemNotSame resetfilename((Trim(itemname) & I) & ".jpg") + End If + End If + itemlist.ListIndex = I +nii: + Next + pb.Change pb.BarMax, "已提取首图信息" & pb.BarMax & "张,请到首图下载下载首图!" + Frm_Download.Show + MsgBox "已提取首图信息" & pb.BarMax & "张,请到首图下载下载首图!" + Unload Me +End Sub + +Private Function resetfilename(ByVal name As String) As String + On Error Resume Next + name = pclear(name, "/") + name = pclear(name, "\") + name = pclear(name, "*") + name = pclear(name, "?") + name = pclear(name, "<") + name = pclear(name, ">") + name = pclear(name, ":") + resetfilename = name +End Function + +Private Function pclear(name As String, P As String) As String + pclear = Replace(name, P, "") +End Function + +Public Function urlreset(ByVal url As String) As String + Dim st, en + 'Debug.Print url + st = InStr(1, url, "http://") + Len("http://") + st = InStr(st + 1, url, "/") + Len("/") + en = InStr(st, url, "jpg") + 3 + url = Mid(url, st, en - st) + url = Replace(url, ".310x310", "") + url = Replace(url, ".64x64", "") + url = Replace(url, ".32x32", "") + url = "http://i01.c.aliimg.com/" & url + urlreset = url + 'Debug.Print url +End Function diff --git a/Frm_Main.frm b/Frm_Main.frm index 63e45fc..0176388 100644 --- a/Frm_Main.frm +++ b/Frm_Main.frm @@ -9,7 +9,15 @@ Begin VB.Form Frm_Main LinkTopic = "Form1" ScaleHeight = 9390 ScaleWidth = 19035 - StartUpPosition = 3 '窗口缺省 + StartUpPosition = 2 '屏幕中心 + Begin VB.CommandButton getindex + Caption = "首页商品" + Height = 300 + Left = 12735 + TabIndex = 15 + Top = 90 + Width = 945 + End Begin 导出商品首图.Frm_Tols Frm Height = 240 Left = 9390 @@ -175,7 +183,7 @@ Begin VB.Form Frm_Main AutoSize = -1 'True Caption = "页数" Height = 180 - Left = 12720 + Left = 13920 TabIndex = 8 Top = 150 Width = 360 @@ -206,7 +214,7 @@ Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Savetime As Double -Dim strUrl As String +Dim strURL As String Dim uid As String Dim username As String Dim password As String @@ -234,18 +242,18 @@ Private Sub Form_Resize() web(0).Width = Me.Width - 50 web(0).Height = lefthg - 250 web(0).Left = 10 - Dim i As Long - For i = 1 To web.UBound - web(i).Width = Me.Width / 3 * 2 - 50 - web(i).Top = web(0).Top + lefthg / 2 - web(i).Height = lefthg / 2 - web(i).Left = 10 + Dim I As Long + For I = 1 To web.UBound + web(I).Width = Me.Width / 3 * 2 - 50 + web(I).Top = web(0).Top + lefthg / 2 + web(I).Height = lefthg / 2 + web(I).Left = 10 Next End Sub Private Sub getfp(webb As WebBrowser) On Error Resume Next - Dim i, J, vDoc + Dim I, J, vDoc Dim ix As Long Dim itemname, itemurl ix = webb.index @@ -260,7 +268,7 @@ Private Sub getfp(webb As WebBrowser) If InStr(1, itemurl, "http") <> 0 And InStr(1, itemurl, "jpg") <> 0 And InStr(1, itemurl, ".com//") = 0 Then If Frm_Download.UName.AddItemNotSame(itemurl) Then If Not (Frm_Download.SName.AddItemNotSame(resetfilename(Trim(itemname) & ".jpg"))) Then - Frm_Download.SName.AddItemNotSame resetfilename((Trim(itemname) & i) & ".jpg") + Frm_Download.SName.AddItemNotSame resetfilename((Trim(itemname) & I) & ".jpg") End If End If End If @@ -288,6 +296,46 @@ Private Sub Form_Unload(Cancel As Integer) End End Sub +Private Sub getindex_Click() +'detail.1688.com/offer/ +'On Error Resume Next + Dim target, Title, Class + Dim itemurl As String + Dim itemname As String + web(0).Silent = True + web(0).Tag = True + urlT(0).Enabled = True + urlT(0).ForeColor = vbBlue + Me.Caption = "Load Complete" + showweb (0) + Dim vDoc, vTag_2, vTag_1, vTag, vTag1, vTag2, vTXT + Dim I As Integer + Set vDoc = web(0).Document + On Error Resume Next + Dim alll As Long + alll = vDoc.All.Length + On Error GoTo 0 + For I = 2 To alll - 1 + On Error Resume Next + Set vTag_2 = vDoc.All(I - 2) + Set vTag_1 = vDoc.All(I - 1) + Set vTag = vDoc.All(I) + Set vTag1 = vDoc.All(I + 1) + Set vTag2 = vDoc.All(I + 2) + Select Case UCase(vDoc.All(I).TagName) + Case "TD" + Case "A" + '商品列表批量获取信息 + Dim a As String + a = vTag.href + If InStr(1, a, "detail.1688.com/offer/") > 0 Then + Frm_Index.itemlist.AddItemNotSame a + End If + End Select + Next + Frm_Index.Show +End Sub + Private Sub Label1_Click() web(0).Visible = Not web(0).Visible showweb (0) @@ -295,10 +343,10 @@ End Sub Private Sub Label5_Click() On Error Resume Next - Dim i As Long - For i = web.LBound To web.UBound - web(i).Stop - web(i).Tag = True + Dim I As Long + For I = web.LBound To web.UBound + web(I).Stop + web(I).Tag = True Next End Sub @@ -362,7 +410,7 @@ Private Sub web_DownloadComplete(index As Integer) Me.Caption = "Load Complete" showweb (index) Dim vDoc, vTag_2, vTag_1, vTag, vTag1, vTag2, vTXT - Dim i As Integer + Dim I As Integer Set vDoc = web(index).Document 'On Error Resume Next If InStr(1, web(index).LocationURL, "alilogin.aspx") Then @@ -371,16 +419,16 @@ Private Sub web_DownloadComplete(index As Integer) End If On Error Resume Next Dim alll As Long - alll = vDoc.All.length + alll = vDoc.All.Length On Error GoTo 0 - For i = 2 To alll - 1 + For I = 2 To alll - 1 On Error Resume Next - Set vTag_2 = vDoc.All(i - 2) - Set vTag_1 = vDoc.All(i - 1) - Set vTag = vDoc.All(i) - Set vTag1 = vDoc.All(i + 1) - Set vTag2 = vDoc.All(i + 2) - Select Case UCase(vDoc.All(i).TagName) + Set vTag_2 = vDoc.All(I - 2) + Set vTag_1 = vDoc.All(I - 1) + Set vTag = vDoc.All(I) + Set vTag1 = vDoc.All(I + 1) + Set vTag2 = vDoc.All(I + 2) + Select Case UCase(vDoc.All(I).TagName) Case "TD" Case "A" '商品列表批量获取信息 @@ -400,7 +448,7 @@ Private Sub web_DownloadComplete(index As Integer) If InStr(1, itemurl, "http") <> 0 And InStr(1, itemurl, "jpg") <> 0 And InStr(1, itemurl, ".com//") = 0 Then If Frm_Download.UName.AddItemNotSame(itemurl) Then If Not (Frm_Download.SName.AddItemNotSame(resetfilename(Trim(vTag.Title) & ".jpg"))) Then - Frm_Download.SName.AddItemNotSame resetfilename((Trim(vTag.Title) & i) & ".jpg") + Frm_Download.SName.AddItemNotSame resetfilename((Trim(vTag.Title) & I) & ".jpg") End If End If End If @@ -413,7 +461,7 @@ Private Sub web_DownloadComplete(index As Integer) If InStr(1, itemurl, "http") <> 0 And InStr(1, itemurl, "jpg") <> 0 And InStr(1, itemurl, ".com//") = 0 Then If Frm_Download.UName.AddItemNotSame(itemurl) Then If Not (Frm_Download.SName.AddItemNotSame(resetfilename(Trim(itemname) & ".jpg"))) Then - Frm_Download.SName.AddItemNotSame resetfilename((Trim(itemname) & i) & ".jpg") + Frm_Download.SName.AddItemNotSame resetfilename((Trim(itemname) & I) & ".jpg") End If End If End If @@ -424,9 +472,9 @@ End Sub Private Sub web_NewWindow2(index As Integer, ppDisp As Object, Cancel As Boolean) On Error Resume Next - Dim i - For i = 1 To web.UBound - If web(i).Tag Then Set ppDisp = web(i).object: showweb (i): pages = "已加载...": Exit Sub + Dim I + For I = 1 To web.UBound + If web(I).Tag Then Set ppDisp = web(I).object: showweb (I): pages = "已加载...": Exit Sub Next pages = "未加载..." Cancel = True @@ -447,9 +495,9 @@ Public Function urlreset(ByVal url As String) As String End Function Private Sub showweb(index As Long) - Dim i As Long - For i = 1 To web.UBound - web(i).Visible = False + Dim I As Long + For I = 1 To web.UBound + web(I).Visible = False List2.Visible = False Next web(index).Visible = True diff --git a/棣栧浘瀵煎嚭宸ュ叿.vbp b/棣栧浘瀵煎嚭宸ュ叿.vbp index 04ae086..b95d5fd 100644 --- a/棣栧浘瀵煎嚭宸ュ叿.vbp +++ b/棣栧浘瀵煎嚭宸ュ叿.vbp @@ -1,5 +1,5 @@ Type=Exe -Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\Windows\SysWow64\stdole2.tlb#OLE Automation +Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\Windows\SysWOW64\stdole2.tlb#OLE Automation Object={EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0; ieframe.dll Reference=*\G{662901FC-6951-4854-9EB2-D9A2570F2B2E}#5.1#0#C:\Windows\system32\winhttp.dll#Microsoft WinHTTP Services, version 5.1 Form=Frm_Main.frm @@ -9,6 +9,8 @@ Form=Frm_Download.frm UserControl=..\VB用户控件\TzProgressBar.ctl Module=MainBas; MainBas.bas UserControl=..\VB用户控件\Frm_Tols.ctl +Form=Frm_Index.frm +UserControl=..\VB用户控件\XmlHttp.ctl Startup="Frm_Main" HelpFile="" ExeName32="首图导出工具.exe" diff --git a/棣栧浘瀵煎嚭宸ュ叿.vbw b/棣栧浘瀵煎嚭宸ュ叿.vbw index 1fcff21..0c8fdd4 100644 --- a/棣栧浘瀵煎嚭宸ュ叿.vbw +++ b/棣栧浘瀵煎嚭宸ュ叿.vbw @@ -1,7 +1,9 @@ -Frm_Main = 22, 22, 1006, 396, , 44, 44, 1143, 418, C +Frm_Main = 1, 6, 1342, 663, , 44, 44, 1143, 418, C TzDownload = 0, 0, 0, 0, C, 0, 0, 984, 374, C TzListBox = 0, 0, 0, 0, C, 22, 22, 1006, 396, C -Frm_Download = 0, 0, 984, 374, , 110, 110, 1094, 484, C +Frm_Download = 511, 160, 1924, 817, , 72, 94, 1056, 468, C TzProgressBar = 0, 0, 0, 0, C, 44, 44, 1028, 418, C -MainBas = 88, 88, 1139, 462, -Frm_Tols = 66, 66, 1050, 440, , 132, 132, 1116, 506, C +MainBas = 22, 22, 1363, 679, +Frm_Tols = 0, 0, 1341, 657, I, 132, 132, 1116, 506, C +Frm_Index = 572, 229, 1913, 886, , 106, 189, 1447, 846, C +XmlHttp = 0, 0, 0, 0, C, 0, 0, 0, 0, C