第一个问题:
怎么样才能实现 点击 “填写一个” 这个链接,点击之后,就可以自己填写一个标题了,就可以避免一系列的下拉菜单。
第二个问题:
怎么样实现自动选择 车辆颜色。
第三个问题(最难,最重要):
怎么样才能实现自动上传照片。
劳烦这位大侠,可以写一点代码给我,慢慢研究,谢谢了。
[/quote]
来自三方案例..自己看着学习.给你一个学习方向...简单的还可以给你写..你这边层次太多...没空写..
模块内容:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function SetForegroundWindow Lib "user32" (ByVal HWnd As Long) As Long
Declare Function ClientToScreen Lib "user32" (ByVal HWnd As Long, lpPoint As POINTAPI) As Long
Type POINTAPI
x As Long
y As Long
End Type
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Private Const MOUSEEVENTF_RIGHTDOWN = &H8 ' right button down
Private Const MOUSEEVENTF_RIGHTUP = &H10 ' right button up
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 ' middle button down
Private Const MOUSEEVENTF_MIDDLEUP = &H40 ' middle button up
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
'============================================
Sub 客户信息查询()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LinkX$, AccountNo$
Dim IE As Object
Dim file
Dim doc As Object 'MSHTML.HTMLDocument
Dim txt As String
Dim i&, j&, k&, H&, fgh$
Dim t1$, t2$, t3$, a, b, c, d
Dim webs, webs2, webs3, webs4, webs5, dmt, dmt1, dmt2, usrno
Dim strText$, Strtext1, Strtext2
Dim strname$, str, str1$, str1b$, str2$, str2b$, str3$, str4$, str5$, str6$, str7$, str8$, str9$, str12$, str13$, arr, arr1, arr2, arr3, arr4, arr5, Item&, URL, Url1&
Dim S0, S1, S2, S3, S4, S5, S6, S7, S8
Dim str10$, str11$, ShellApp As Object, SaveName$, ZipFolder$, TargetFile$
Dim v() As String, myjs, BRR
Dim cifno$, cifcname$, ResultLink$
Dim dj_x As Long, dj_y As Long, dj_num&, pdf_x As Long, pdf_y As Long
Dim dWinFolder As New ShellWindows, t
Dim objIE As Object, myHWND
Dim Czpmxurl As String, Czpmxname As String
Dim Czpmxhwnd As Long, aA '窗口句柄
'删除IE的Cache缓存,非常重要!
Call DeleteCacheURLList
'--------------------------------------------------------------------------------------------------------MIS登录
'webs = ThisWorkbook.Sheets("Para1").Cells(221, 2).Value
Set IE = CreateObject("InternetExplorer.Application")
With ThisWorkbook.Sheets("Para1")
webs = .Cells(224, 2).Value & .Cells(222, 2).Value & .Cells(224, 4).Value & ChangeYZGPassword(.Cells(223, 2).Value) & .Cells(224, 6).Value & .Cells(224, 7).Value
'Debug.Print webs
usrno = .Cells(222, 2) '登录用户号参数
IE.Navigate webs
IE.Visible = True '若=0 False不显示 ,=1 True 显示
IE.Silent = True
'Application.WindowState = xlMaximized '窗体最大化
'----------------------------------------------------------------登录完成ok
Do While IE.Busy Or IE.ReadyState <> 4
DoEvents
Loop
'网页执行效率太低只好多等一会儿:-(
Application.Wait now + TimeValue("00:00:10")
Set dmt = IE.Document
IE.Document.getElementById("condition").Value = .Cells(226, 3)
IE.Document.getElementById("context").Focus
IE.Document.getElementById("context").Value = .Cells(227, 3)
IE.Document.getElementById("context").Click
Application.Wait now + TimeValue("00:00:03")
IE.Document.getElementById("context").Focus
SendKeys "{enter}"
SendKeys "{enter}" '回车开始查询
End With
Do While IE.Busy Or IE.ReadyState <> 4
DoEvents
Loop
'---------------------------------------------------------
Application.Wait now + TimeValue("00:00:05")
'-------------------------------------------------------------查找弹出窗口并控制它以取出网页的innerhtml
Do
For Each objIE In dWinFolder
If InStr(1, objIE.LocationURL, "customer.php?action=customerdetail&cifno=") > 0 Then
Czpmxname = objIE.LocationName '标题
Czpmxurl = objIE.LocationURL '链接
Exit Do '通过链接objIE.LocationURL包含的关键字查询,或用objIE.LocationName即窗口标题包含的关键字来查询
End If
Next
DoEvents
Loop
'此处借用的老师提供链接示例中的代码,非常感谢!
IE.Document.parentwindow.Eval "javascript:window.opener=null;window.open('','_self');window.close();" '在原ie窗口中打开
Set IE = objIE '转换ie窗口控制权终于成功了
Do Until IE.ReadyState = 4 And IE.Busy = False
DoEvents
Loop
Set dmt = IE.Document
'Debug.Print dmt.body.innerhtml
'------------------------------------------------------------已成功取得弹出ie窗口页面innerhtml
For i = 0 To dmt.Links.Length - 1
If dmt.Links(i).innertext = "综合账单" Then
Debug.Print "Links(i) i=" & i
dmt.Links(i).Click
DoEvents
Exit For
End If
Next
Application.Wait now + TimeValue("00:00:05")
'Set obj1 = IE.Document.frames
'i = 0
'On Error GoTo showmsg:
'While 1
'strname = strname & Chr(10) & obj1.Item(i).Name
'i = i + 1
'Wend
'showmsg:
'Debug.Print "本网页中有 " & i & " 个框架:" & strname
'经测试共有2个框架,目标按钮"btn_ok1"在第2个框架内
'Debug.Print IE.Document.frames(0).Document.body.innerhtml
'Debug.Print IE.Document.frames(0).Location
'Debug.Print IE.Document.frames(1).Document.body.innerhtml
'Debug.Print IE.Document.frames(1).Location
If InStr(1, IE.Document.frames(1).Document.body.innerhtml, "Pdf对账单") > 0 Then
'id=btn_ok1
Debug.Print "已找到生成pdf对账单的按钮"
Else
Exit Sub
End If
IE.Document.frames(1).Document.getElementById("btn_ok1").Click '点击按钮下载文件
t = Timer
Do Until FindWindow(vbNullString, "文件下载") > 0
DoEvents
Loop
Application.Wait now + TimeValue("00:00:03")
SendKeys "^s"
'------------------------------------------------------------------------------
Do Until FindWindow(vbNullString, "另存为") > 0
DoEvents
Loop
Application.Wait now + TimeValue("00:00:03")
SaveName = ThisWorkbook.path & "\CheckYZG\" & "对账单_" & cifcname & "_" & Format(now(), "yyyymmddhhmmss") & ".pdf"
SendKeys SaveName
SendKeys "%s"
'======================================================================
'IE.Quit '关闭ie
'或:Shell ("C:\Program Files\Internet Explorer\IEXPLORE.exe about:blank")
ex:
Application.Wait now + TimeValue("00:00:02") '关闭弹出ie窗口
Czpmxhwnd = FindWindow(vbNullString, Czpmxname & " - Windows Internet Explorer") '根据窗口标题查找,找到后返回句柄
If Czpmxhwnd <> 0 Then
Debug.Print "已经找到指定弹出ie窗口并将关闭之"
aA = SetForegroundWindow(Czpmxhwnd) '将网页调到前台
Application.Wait now + TimeValue("00:00:01") '' 程序休息
SendKeys "%{F4}"
'SendKeys "{ENTER}", True
End If
'退出原ie窗口
IE.Quit
Application.Wait now + TimeValue("00:00:02") '' 程序休息
SendKeys "{ENTER}", True
Shell ("C:\Program Files\Internet Explorer\IEXPLORE.exe about:blank")
Set IE = Nothing
'打开pdf下载文件目录
'Application.Wait now + TimeValue("00:00:03")
Shell "explorer.exe /n,/e," & ThisWorkbook.path & "\CheckYZG\", vbMaximizedFocus
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
[/quote]
大侠,可以帮我写一下,照片上传那部分代码吗????谢谢了
模块内容:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function SetForegroundWindow Lib "user32" (ByVal HWnd As Long) As Long
Declare Function ClientToScreen Lib "user32" (ByVal HWnd As Long, lpPoint As POINTAPI) As Long
Type POINTAPI
x As Long
y As Long
End Type
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Private Const MOUSEEVENTF_RIGHTDOWN = &H8 ' right button down
Private Const MOUSEEVENTF_RIGHTUP = &H10 ' right button up
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 ' middle button down
Private Const MOUSEEVENTF_MIDDLEUP = &H40 ' middle button up
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
'============================================
Sub 客户信息查询()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LinkX$, AccountNo$
Dim IE As Object
Dim file
Dim doc As Object 'MSHTML.HTMLDocument
Dim txt As String
Dim i&, j&, k&, H&, fgh$
Dim t1$, t2$, t3$, a, b, c, d
Dim webs, webs2, webs3, webs4, webs5, dmt, dmt1, dmt2, usrno
Dim strText$, Strtext1, Strtext2
Dim strname$, str, str1$, str1b$, str2$, str2b$, str3$, str4$, str5$, str6$, str7$, str8$, str9$, str12$, str13$, arr, arr1, arr2, arr3, arr4, arr5, Item&, URL, Url1&
Dim S0, S1, S2, S3, S4, S5, S6, S7, S8
Dim str10$, str11$, ShellApp As Object, SaveName$, ZipFolder$, TargetFile$
Dim v() As String, myjs, BRR
Dim cifno$, cifcname$, ResultLink$
Dim dj_x As Long, dj_y As Long, dj_num&, pdf_x As Long, pdf_y As Long
Dim dWinFolder As New ShellWindows, t
Dim objIE As Object, myHWND
Dim Czpmxurl As String, Czpmxname As String
Dim Czpmxhwnd As Long, aA '窗口句柄
'删除IE的Cache缓存,非常重要!
Call DeleteCacheURLList
'--------------------------------------------------------------------------------------------------------MIS登录
'webs = ThisWorkbook.Sheets("Para1").Cells(221, 2).Value
Set IE = CreateObject("InternetExplorer.Application")
Do
For Each objIE In dWinFolder
If InStr(1, objIE.LocationURL, "customer.php?action=customerdetail&cifno=") > 0 Then
Czpmxname = objIE.LocationName '标题
Czpmxurl = objIE.LocationURL '链接
Exit Do '通过链接objIE.LocationURL包含的关键字查询,或用objIE.LocationName即窗口标题包含的关键字来查询
End If
Next
DoEvents
Loop
'此处借用的老师提供链接示例中的代码,非常感谢!
IE.Document.parentwindow.Eval "javascript:window.opener=null;window.open('','_self');window.close();" '在原ie窗口中打开
Set IE = objIE '转换ie窗口控制权终于成功了
Do Until IE.ReadyState = 4 And IE.Busy = False
DoEvents
Loop
Set dmt = IE.Document
'Debug.Print dmt.body.innerhtml
'------------------------------------------------------------已成功取得弹出ie窗口页面innerhtml
For i = 0 To dmt.Links.Length - 1
If dmt.Links(i).innertext = "综合账单" Then
Debug.Print "Links(i) i=" & i
dmt.Links(i).Click
DoEvents
Exit For
End If
Next
Czpmxhwnd = FindWindow(vbNullString, Czpmxname & " - Windows Internet Explorer") '根据窗口标题查找,找到后返回句柄
If Czpmxhwnd <> 0 Then
Debug.Print "已经找到指定弹出ie窗口并将关闭之"
aA = SetForegroundWindow(Czpmxhwnd) '将网页调到前台
Application.Wait now + TimeValue("00:00:01") '' 程序休息
SendKeys "%{F4}"
'SendKeys "{ENTER}", True
End If