Merge branch 'master' of git@git.coding.net:502647092/LoadFirstPic.git

master
j502647092 2015-06-12 00:02:25 +08:00
commit 32c498db7c
4 changed files with 718 additions and 0 deletions

165
Frm_Download.frm Normal file
View File

@ -0,0 +1,165 @@
VERSION 5.00
Begin VB.Form Frm_Download
Caption = "首图下载"
ClientHeight = 4800
ClientLeft = 60
ClientTop = 345
ClientWidth = 11565
LinkTopic = "Form1"
ScaleHeight = 4800
ScaleWidth = 11565
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton clear
Caption = "清空"
Height = 300
Left = 0
TabIndex = 3
Top = 285
Width = 1020
End
Begin 导出商品首图.TzProgressBar pb
Height = 255
Left = 1080
Top = 330
Width = 10440
_ExtentX = 18415
_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
Caption = "总进度"
BackColor = 8438015
StartColor = 8438015
End
Begin 导出商品首图.TzDownload dl
Height = 250
Left = 1065
Top = 60
Width = 10440
_ExtentX = 18415
_ExtentY = 450
ForeColor = 16777088
End
Begin VB.CommandButton dlc
Caption = "下载"
Height = 300
Left = 0
TabIndex = 2
Top = 0
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
Width = 3810
_ExtentX = 6720
_ExtentY = 2355
End
End
Attribute VB_Name = "Frm_Download"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'=================================Sleep========================================
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Savetime As Double
Private sd As Boolean
Private Sub clear_Click()
SName.clear
UName.clear
End Sub
Private Sub dl_OnFinished(ByVal Result As Boolean)
sd = Result
End Sub
Private Sub dlc_Click()
Dim i
Dim folder As String
Dim usetime As Double
If folder = "" Then folder = InputBox("请输入 日期-首图-公司名称-阿里账号-提单人名称!", , Format(Now, "m.d") & "-首图-公司名称-阿里账号-提单人名称")
If folder = "" Then folder = Format(Now, "m.d") & "-首图-公司名称-阿里账号-提单人名称"
usetime = timeGetTime
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"
Do
Sleep 50
Loop Until dl.IsFree
If Not sd Then GoTo red
'Debug.Print Replace(Trim(SName.List(i)), " ", "")
Next
usetime = Format((timeGetTime - usetime) / 1000, "0.00")
pb.Change pb.BarMax, "下载完成 共下载" & pb.BarMax & "件产品首图 耗时" & usetime & "秒!", &H80FF80
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Me.Hide
Cancel = True
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
dl.Left = dlc.Left + dlc.Width + 10
dl.Width = Me.Width - dl.Left - 20
dl.Top = 25
pb.Left = dlc.Left + dlc.Width + 10
pb.Width = Me.Width - dl.Left - 20
pb.Top = dl.Top + dl.Height + 50
End Sub
Public Sub Sleep(n As Long)
Savetime = timeGetTime
While timeGetTime < Savetime + n
DoEvents
Wend
End Sub
Private Sub SName_dblClick()
InputBox "", , SName.List(SName.ListIndex)
End Sub
Private Sub UName_AddItem()
pb.BarMax = UName.ListCount
pb.Change pb.BarMax, "以扫描到商品信息" & UName.ListCount & "条"
End Sub
Private Sub UName_dblClick()
InputBox "", , UName.List(UName.ListIndex)
End Sub

511
Frm_Main.frm Normal file
View File

@ -0,0 +1,511 @@
VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "ieframe.dll"
Begin VB.Form Frm_Main
Caption = "导出首图"
ClientHeight = 9390
ClientLeft = 120
ClientTop = 450
ClientWidth = 19035
LinkTopic = "Form1"
ScaleHeight = 9390
ScaleWidth = 19035
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton pic
Caption = "图片"
Height = 300
Left = 11400
TabIndex = 15
Top = 90
Width = 600
End
Begin VB.CommandButton manager
Caption = "商品"
Height = 300
Left = 10500
TabIndex = 14
Top = 90
Width = 600
End
Begin VB.CommandButton alibaba
Caption = "1688"
Height = 300
Left = 9600
TabIndex = 13
Top = 90
Width = 600
End
Begin VB.CommandButton oa
Caption = "OA"
Height = 300
Left = 8700
TabIndex = 12
Top = 90
Width = 600
End
Begin VB.CommandButton lookitem
Caption = "查看商品"
Height = 300
Left = 12300
TabIndex = 11
Top = 90
Width = 945
End
Begin SHDocVwCtl.WebBrowser web
Height = 915
Index = 2
Left = 9750
TabIndex = 10
Top = 1350
Width = 1155
ExtentX = 2037
ExtentY = 1614
ViewMode = 0
Offline = 0
Silent = 0
RegisterAsBrowser= 1
RegisterAsDropTarget= 1
AutoArrange = 0 'False
NoClientEdge = 0 'False
AlignLeft = 0 'False
NoWebView = 0 'False
HideFileNames = 0 'False
SingleClick = 0 'False
SingleSelection = 0 'False
NoFolders = 0 'False
Transparent = 0 'False
ViewID = "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
Location = "http:///"
End
Begin SHDocVwCtl.WebBrowser web
Height = 915
Index = 1
Left = 8580
TabIndex = 2
Top = 1335
Width = 1155
ExtentX = 2037
ExtentY = 1614
ViewMode = 0
Offline = 0
Silent = 0
RegisterAsBrowser= 1
RegisterAsDropTarget= 1
AutoArrange = 0 'False
NoClientEdge = 0 'False
AlignLeft = 0 'False
NoWebView = 0 'False
HideFileNames = 0 'False
SingleClick = 0 'False
SingleSelection = 0 'False
NoFolders = 0 'False
Transparent = 0 'False
ViewID = "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
Location = "http:///"
End
Begin VB.ListBox List1
Height = 7620
Left = 16830
TabIndex = 8
Top = 1695
Width = 1035
End
Begin VB.ListBox List2
Height = 780
Left = 45
TabIndex = 7
Top = 9315
Width = 17145
End
Begin VB.TextBox urlT
Height = 270
Index = 2
Left = 8700
TabIndex = 6
Text = "2"
Top = 480
Width = 7710
End
Begin VB.TextBox urlT
Height = 270
Index = 1
Left = 945
TabIndex = 4
Text = "1"
Top = 480
Width = 7710
End
Begin VB.TextBox urlT
Height = 270
Index = 0
Left = 945
TabIndex = 3
Text = "Text1"
Top = 105
Width = 7710
End
Begin SHDocVwCtl.WebBrowser web
Height = 7665
Index = 0
Left = 45
TabIndex = 1
Top = 1335
Width = 8535
ExtentX = 15055
ExtentY = 13520
ViewMode = 0
Offline = 0
Silent = 0
RegisterAsBrowser= 1
RegisterAsDropTarget= 1
AutoArrange = 0 'False
NoClientEdge = 0 'False
AlignLeft = 0 'False
NoWebView = 0 'False
HideFileNames = 0 'False
SingleClick = 0 'False
SingleSelection = 0 'False
NoFolders = 0 'False
Transparent = 0 'False
ViewID = "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
Location = "http:///"
End
Begin VB.Label pages
AutoSize = -1 'True
Caption = "页数"
Height = 180
Left = 13350
TabIndex = 9
Top = 150
Width = 360
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "网页链接:"
Height = 180
Left = 120
TabIndex = 5
Top = 525
Width = 810
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "主页链接:"
Height = 180
Left = 120
TabIndex = 0
Top = 150
Width = 810
End
End
Attribute VB_Name = "Frm_Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim strUrl As String
Private Sub alibaba_Click()
web(0).Navigate2 "http://work.1688.com/home/page/index.htm#nav/home"
End Sub
Private Sub Form_Load()
web(0).Navigate2 "http://192.168.0.8:83/"
End Sub
Private Sub Form_Resize()
On Error Resume Next
Dim lefthg
web(0).Top = 900
lefthg = Me.Height - web(0).Top
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
Next
' web(1).Width = Me.Width / 3 * 2 - 50
' web(1).Top = web(0).Top + lefthg / 2
' web(1).Height = lefthg / 2
' web(1).Left = 10
'
' web(2).Width = Me.Width / 3 * 2 - 50
' web(2).Top = web(0).Top + lefthg / 2
' web(2).Height = lefthg / 2
' web(2).Left = 10
List1.Left = Me.Width - List1.Width - 350
List1.Height = lefthg - 350
List1.Top = web(0).Top
End Sub
Private Sub getfp(webb As WebBrowser)
On Error Resume Next
Dim i, J, vDoc
Dim ix As Long
Dim itemname, itemurl
ix = webb.index
Set vDoc = webb.Document
itemname = resetfilename(vDoc.getelementsbytagname("input")("subject").Value)
ERR.clear
itemurl = vDoc.getelementsbytagname("input")("pictureUrl").Value
If ERR <> 0 Then
itempicurl = vDoc.getelementsbytagname("input")("pictureUrl")(0).Value
End If
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")
End If
End If
End If
End Sub
Private Function resetfilename(ByVal name As String) As String
name = clear(name, "/")
name = clear(name, "\")
name = clear(name, "*")
name = clear(name, "?")
name = clear(name, "<")
name = clear(name, ">")
name = clear(name, ":")
resetfilename = name
End Function
Private Function clear(name As String, P As String) As String
clear = Replace(name, P, "")
End Function
Private Sub Form_Unload(Cancel As Integer)
Unload Frm_Download
End Sub
Private Sub Label1_Click()
web(0).Visible = Not web(0).Visible
showweb (0)
End Sub
Private Sub Label2_Click()
'A A A DIV DIV
Dim vDoc, vTag_2, vTag_1, vTag, vTag1, vTag2, vTXT
Dim i As Integer
Set vDoc = web(0).Document
On Error Resume Next
For i = 0 To vDoc.All.length - 1
List1.AddItem 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 "A"
If UCase(vTag_2.TagName) = "A" And _
UCase(vTag_1.TagName) = "A" And _
UCase(vTag1.TagName) = "DIV" And _
UCase(vTag2.TagName) = "DIV" Then
If vTag.Class = "next" Then vTag.Click
End If
End Select
Next
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
Next
End Sub
Private Sub lookitem_Click()
Frm_Download.Show
End Sub
Private Sub manager_Click()
web(0).Navigate2 "http://offer.1688.com/offer/manage.htm?show_type=valid&tracelog=work_1_m_orderManage"
End Sub
'http://picman.1688.com/album/album_list.htm?tracelog=work_1_m_albumManage
'http://offer.1688.com/offer/manage.htm?show_type=valid&tracelog=work_1_m_orderManage
'http://login.1688.com/member/signout.htm
Private Sub oa_Click()
web(0).Navigate2 "http://192.168.0.8:83/"
End Sub
Private Sub pic_Click()
web(0).Navigate2 "http://picman.1688.com/album/album_list.htm?tracelog=work_1_m_albumManage"
End Sub
Private Sub urlT_DblClick(index As Integer)
urlT(index).SelStart = 0
urlT(index).SelLength = Len(urlT(index).Text)
End Sub
Private Sub urlT_KeyPress(index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then web(index).Navigate2 urlT(index).Text
End Sub
Private Sub web_BeforeNavigate2(index As Integer, ByVal pDisp As Object, url As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
If url <> "http:///" And url <> "" And url <> "about:blank" Then urlT(index) = url
'List3.AddItem url
End Sub
Private Sub web_DocumentComplete(index As Integer, ByVal pDisp As Object, url As Variant)
On Error Resume Next
If InStr(1, url, "operator=edit") Then Call getfp(web(index))
End Sub
Private Sub web_DownloadBegin(index As Integer)
web(index).Tag = False
urlT(index).Enabled = False
Me.Caption = "Loading..."
End Sub
'Private Sub web_DownloadBegin(index As Integer)
' web(index).Silent = True
'End Sub
Private Sub web_DownloadComplete(index As Integer)
Dim target, Title, Class
Dim itemurl As String
Dim itemname As String
web(index).Silent = True
web(index).Tag = True
urlT(index).Enabled = True
urlT(index).ForeColor = vbBlue
Me.Caption = "Load Complete"
showweb (index)
List1.clear
List2.clear
Dim vDoc, vTag_2, vTag_1, vTag, vTag1, vTag2, vTXT
Dim i As Integer
Set vDoc = web(index).Document
'On Error Resume Next
For i = 0 To vDoc.All.length - 1
List1.AddItem vDoc.All(i).TagName
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 st As Long
Dim en As Long
If UCase(vTag_2.TagName) = "INPUT" And _
UCase(vTag_1.TagName) = "TD" And _
UCase(vTag1.TagName) = "IMG" And _
UCase(vTag2.TagName) = "TD" Then
st = InStr(1, vTag.innerhtml, "data-lazyload-src=""") + Len("data-lazyload-src=""") 'data-lazyload-src="http://
st = InStr(st + 1, vTag.innerhtml, "/") + Len("/")
en = InStr(st, vTag.innerhtml, "jpg") + 3
itemurl = Mid(vTag.innerhtml, st, en - st)
itemurl = urlreset(itemurl)
'Debug.Print itemurl
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")
End If
End If
End If
End If
Case "META"
'商品展示部分直接获取首图信息
If vTag.property = "og:image" And vTag1.property = "og:title" Then
itemurl = urlreset(vTag.content)
itemname = vTag1.content
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")
End If
End If
End If
End If
' <meta property="og:image" content="http://i00.c.aliimg.com/img/ibank/2015/897/991/2210199798_196219354.310x310.jpg"/>
'<meta property="og:title" content="12支铅笔塑料盒 20*22CM环保吸塑包装 多规格pvc吸塑泡壳加工"/>
' ' If UCase(vTag_2.TagName) = "DIV" And _
' ' UCase(vTag_1.TagName) = "DIV" And _
' ' UCase(vTag1.TagName) = "SPAN" And _
' ' UCase(vTag2.TagName) = "UL" Then
' ' If vTag.class = "btn-edit" And vTag.target = "_blank" And vTag.title = "修改" Then List2.AddItem vTag.href
' ' End If
' Case "B"
' 'A SPAN B B B
'
' ' If UCase(vTag_2.TagName) = "A" And _
' ' UCase(vTag_1.TagName) = "SPAN" And _
' ' UCase(vTag1.TagName) = "B" And _
' ' UCase(vTag2.TagName) = "B" Then
' ' Me.Caption = "当前的任务有" & vTag.innerhtml & "个!"
' ' End If
'
' 'http://192.168.0.8:83/app1/TaskLadingCn/List.aspx?k=&RearchType=0&UId=0&KfId=4986&MgId=0&mgbm=0&bumen=0&followup=&FState=0&tdtype=-1&FSpeed=0&FMgSpeed=0&FKfSpeed=1&attr=0&AttrBus=0&selDate=0&strDate=&endDate=
' 'TD A IMG TD P
' Case "IMG"
' If UCase(vTag_2.TagName) = "TD" And _
' UCase(vTag_1.TagName) = "A" And _
' UCase(vTag1.TagName) = "TD" And _
' UCase(vTag2.TagName) = "p" Then
' 'List2.AddItem vTag_1.innerhtml
' Debug.Print vTag_1.innerhtml
' Debug.Print vTag.src
' End If
' Case "EM"
' If UCase(vTag_2.TagName) = "A" And _
' UCase(vTag_1.TagName) = "LI" And _
' UCase(vTag1.TagName) = "INPUT" And _
' UCase(vTag2.TagName) = "LI" Then
' pages = vTag.innerhtml
' End If
End Select
Next
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
Next
pages = "未加载..."
Cancel = True
End Sub
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 = "http://i01.c.aliimg.com/" & url
urlreset = url
'Debug.Print url
End Function
Private Sub showweb(index As Long)
Dim i As Long
For i = 1 To web.UBound
web(i).Visible = False
List2.Visible = False
Next
web(index).Visible = True
End Sub

37
首图导出工具.vbp Normal file
View File

@ -0,0 +1,37 @@
Type=Exe
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
UserControl=..\VB用户控件\TzDownload.ctl
UserControl=..\VB用户控件\TzListBox.ctl
Form=Frm_Download.frm
UserControl=..\VB用户控件\TzProgressBar.ctl
Startup="Frm_Main"
HelpFile=""
ExeName32="首图导出工具.exe"
Command32=""
Name="导出商品首图"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Microsoft"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

5
首图导出工具.vbw Normal file
View File

@ -0,0 +1,5 @@
Frm_Main = 0, 0, 984, 374, Z, 0, 0, 918, 535, C
TzDownload = 22, 22, 1006, 396, , 75, 75, 961, 524, C
TzListBox = 88, 88, 1072, 462, C, 22, 22, 940, 557, C
Frm_Download = 174, 51, 1224, 550, , 44, 44, 1028, 418, C
TzProgressBar = 88, 88, 1139, 462, , 0, 0, 0, 0, C