使用vba从html组合框填充excel用户表单组合框

问题描述 投票：0回答：3

我有一个用户表单，我希望 html 选项值填充 Excel 组合框。基本上我想复制这些值并稍后传递它们。

我所拥有的东西是从不同的帖子中拼凑在一起的，但似乎没有任何效果。 

Dim appIE As InternetExplorerMedium
Dim nam As Object
Dim sel As Object

Set appIE = New InternetExplorerMedium
sURL = "site infor goes here"
With appIE
    .navigate sURL
    .Visible = True
End With
Do While appIE.Busy Or appIE.readyState <> 4
    DoEvents
Loop
For Each f In IE.document.getElementsByTagName("select")
    If f = "suppliercode" Then
        For Each fOption In IE.document.getElementsByTagName("option")
            With Me.SupplierSite.AddItem(f.Option)
            End With
        Next fOption
    End If
Next f

ALSO TRIED:
Set Doc = IE.document.forms("NewReleaseQueueForm1")
For Each sel In Doc.getElementsByTagName("select")(0).Value
If sel.Name = "suppliercode" Then
'loop through and add each option to Me.SupplierSite
For Each opt In IE.document.forms("NewReleaseQueueForm1").getElementsByTagName("option")(0).Value
Me.SupplierSite.AddItem sel.Value
Next opt
End If
Next sel

HTML 示例：

<form id="NewReleaseQueueForm1" method="post" name="NewReleaseQueueForm1">
    <table cellpadding="4">
        <tr>
            <th valign="top">Supplier Site</th>
            <td valign="top">
                <select multiple name="suppliercode" size="5">
                    <option selected value="Any">
                        &lt;Any&gt;
                    </option>
                    <option value="T488C">
                        T488C
                    </option>
                </select>
            </td>
            <td></td>
html vba excel combobox web-scraping
3个回答
0
投票

请将以下 HTML 代码放入记事本中并另存为 HTML 文件。 在 MSIE 中打开该文件

然后打开一个新的干净工作簿并将下面的宏代码粘贴到标准模块中。 确保您的网页已在 MSIE 中打开。 转到编辑器并将光标放在“StartHere()”子例程内的某个位置。 按 PF5 运行它。 将打开一个用户表单，其中包含所有打开的浏览器页面的名称。 选择标题为“测试获取选择选项”的选项。 将出现一个消息框，表明该页面已成功放入 Excel 对象中。 然后检查您的工作表，看看它是否列出了 A 列中的四个选项。

如果有效，则清除sheet1并打开您的网页。 再次尝试该宏，看看 9it 是否适用于您的页面。

HTML：代码

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> <html lang="en"> 
<head> 
<meta http-equiv="content-type" content="text/html; charset=utf-8"> 
<title>Test Get Select Options</title> 
</head> 
<body> 

<form id="NewReleaseQueueForm1" method="post" name="NewReleaseQueueForm1">
    <table cellpadding="4">
        <tr>
            <th valign="top">Supplier Site</th>
            <td valign="top">
                <select multiple name="suppliercode" size="5">
                    <option selected value="Any">
                        &lt;Any&gt;
                    </option>
                    <option value="T488C">
                        T488C
                    </option>
                    <option value="R488C">
                        R488C
                    </option>
                    <option value="C488C">
                        C488C
                    </option>
                    <option value="Z488C">
                        Z488C
                    </option>
                </select>
            </td>
            <td></td>
       </tr>
   </table>
</form>
</body> 
</html>

宏代码：

Global myDoc As HTMLDocument
Global IE As Object
Sub StartHere()
    On Error Resume Next
        ThisWorkbook.VBProject.References.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 0, 0    'Microsoft Scripting Runtime
        ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 0, 0    'Microsoft Extensability for VBA
        ThisWorkbook.VBProject.References.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 0, 0    'Microsoft Forms
        ThisWorkbook.VBProject.References.AddFromGuid "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", 0, 0    'Microsoft MSHTML
        ThisWorkbook.VBProject.References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 0, 0    'Microsoft Internet Controls
    On Error GoTo 0
Call nextSub
End Sub
Sub nextSub()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.codemodule
        Dim LineNum As Long
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("Module1")
        Set CodeMod = VBComp.codemodule
        LineNum = 1
        CodeMod.insertlines 1, "Global myDoc As HTMLDocument"
        CodeMod.insertlines 2, "Global IE As Object"
        Call getOpenBrowserCreateForm
End Sub
Sub removeCode()
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents("Module1")
        Set CodeMod = VBComp.codemodule
        LineNum = 1
    For i = 34 To 4 Step -1
            CodeMod.DeleteLines i
    Next i
End Sub
Public myDoc As HTMLDocument
Public IE As Object


Sub getOpenBrowserCreateForm()
Dim myForm As Object
Dim NewFrame As MSForms.Frame
Dim NewButton As MSForms.CommandButton, newButton2 As MSForms.CommandButton
'Dim NewComboBox As MSForms.ComboBox
Dim NewListBox As MSForms.ListBox
'Dim NewTextBox As MSForms.TextBox
'Dim NewLabel As MSForms.Label
'Dim NewOptionButton As MSForms.OptionButton
'Dim NewCheckBox As MSForms.CheckBox
Dim x As Integer
Dim Line As Integer

'This is to stop screen flashing while creating form
Application.VBE.MainWindow.Visible = False

On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\mshtml.tlb"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\ieframe.dll"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\system32\FM20.DLL"
On Error GoTo 0
Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3)

'Create the User Form
With myForm
    .Properties("Caption") = "Select Open Web Site"
    .Properties("Width") = 326
    .Properties("Height") = 280
End With

'Create ListBox
Set NewListBox = myForm.designer.Controls.Add("Forms.listbox.1")
With NewListBox
    .Name = "ListBox1"
    .Top = 12
    .Left = 12
    .Width = 297
    .Height = 207.8
    .Font.Size = 9
    .Font.Name = "Tahoma"
    .BorderStyle = fmBorderStyleOpaque
    .SpecialEffect = fmSpecialEffectSunken
End With

'Create CommandButton1 Create
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
    .Name = "CommandButton1"
    .Caption = "Select"
    .Accelerator = "M"
    .Top = 228
    .Left = 234
    .Width = 72
    .Height = 24
    .Font.Size = 9
    .Font.Name = "Tahoma"
    .BackStyle = fmBackStyleOpaque
End With

'Create CommandButton2 Create
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
    .Name = "CommandButton2"
    .Caption = "Cancel"
    .Accelerator = "M"
    .Top = 228
    .Left = 144
    .Width = 72
    .Height = 24
    .Font.Size = 9
    .Font.Name = "Tahoma"
    .BackStyle = fmBackStyleOpaque
End With

'add code for form module
myForm.codemodule.insertlines 1, "Private Sub CommandButton1_Click()"
myForm.codemodule.insertlines 2, "Dim urlLocation As String"
myForm.codemodule.insertlines 3, ""
myForm.codemodule.insertlines 4, "''////////////////////////////////////////////////////////////////////"
myForm.codemodule.insertlines 5, "''  This part gets all open web pages qand displays them on the form for user to choose"
myForm.codemodule.insertlines 6, "''"
myForm.codemodule.insertlines 7, "    Set objIterator = CreateObject(" & Chr(34) & "Shell.Application" & Chr(34) & ")"
myForm.codemodule.insertlines 8, "    For X = 0 To objIterator.Windows.Count"
myForm.codemodule.insertlines 9, "        On Error Resume Next"
myForm.codemodule.insertlines 10, "        current_title = objIterator.Windows(X).Document.Title"
myForm.codemodule.insertlines 11, "        current_url = objIterator.Windows(X).Document.Location"
myForm.codemodule.insertlines 12, "    "
myForm.codemodule.insertlines 13, "        If current_title = ListBox1.Value Then 'is this my webpage?"
myForm.codemodule.insertlines 14, "        "
myForm.codemodule.insertlines 15, "            Set IE = objIterator.Windows(X)"
myForm.codemodule.insertlines 16, "            MsgBox " & Chr(34) & "IE was properly set" & Chr(34) & ""
myForm.codemodule.insertlines 17, "            "
myForm.codemodule.insertlines 18, "             Boolean_indicator = True"
myForm.codemodule.insertlines 19, "            Exit For"
myForm.codemodule.insertlines 20, "        End If"
myForm.codemodule.insertlines 21, "    Next"
myForm.codemodule.insertlines 22, "    Set objIterator = Nothing"
myForm.codemodule.insertlines 23, "    Set myDoc = IE.Document"
myForm.codemodule.insertlines 24, "Return"
myForm.codemodule.insertlines 25, "Unload Me"
myForm.codemodule.insertlines 26, ""
myForm.codemodule.insertlines 27, "End Sub"
myForm.codemodule.insertlines 28, ""
myForm.codemodule.insertlines 29, ""
myForm.codemodule.insertlines 30, "Private Sub CommandButton2_Click()"
myForm.codemodule.insertlines 31, " Unload Me"
myForm.codemodule.insertlines 32, "End Sub"
myForm.codemodule.insertlines 33, ""
myForm.codemodule.insertlines 34, ""
myForm.codemodule.insertlines 35, "Private Sub UserForm_Activate()"
myForm.codemodule.insertlines 36, "    Dim myArray1() As String, tempNumb As Integer"
myForm.codemodule.insertlines 37, "    "
myForm.codemodule.insertlines 38, "    "
myForm.codemodule.insertlines 39, "    i = 2"
myForm.codemodule.insertlines 40, "    tempNumb = 1"
myForm.codemodule.insertlines 41, "    "
myForm.codemodule.insertlines 42, "    ReDim myArray1(1 To 1)"
myForm.codemodule.insertlines 43, "   "
myForm.codemodule.insertlines 44, "    Set objShell = CreateObject(" & Chr(34) & "Shell.Application" & Chr(34) & ")"
myForm.codemodule.insertlines 45, "    Set objAllWindows = objShell.Windows"
myForm.codemodule.insertlines 46, "    "
myForm.codemodule.insertlines 47, "    "
myForm.codemodule.insertlines 48, "    For Each ow In objAllWindows"
myForm.codemodule.insertlines 49, "        If (InStr(1, ow," & Chr(34) & "Internet Explorer" & Chr(34) & ", vbTextCompare)) Then"
myForm.codemodule.insertlines 50, "            myArray1(tempNumb) = ow.Document.Title"
myForm.codemodule.insertlines 51, "            tempNumb = tempNumb + 1"
myForm.codemodule.insertlines 52, "            If Not ow.Document.Title = " & Chr(34) & "" & Chr(34) & " Then"
myForm.codemodule.insertlines 53, "                ReDim Preserve myArray1(1 To tempNumb)"
myForm.codemodule.insertlines 54, "            Else"
myForm.codemodule.insertlines 55, "                Exit For"
myForm.codemodule.insertlines 56, "            End If"
myForm.codemodule.insertlines 57, "        End If"
myForm.codemodule.insertlines 58, "    Next"
myForm.codemodule.insertlines 59, "     "
myForm.codemodule.insertlines 60, "    Me.ListBox1.List = myArray1"
myForm.codemodule.insertlines 61, "End Sub"
myForm.codemodule.insertlines 62, ""
'Show the form
VBA.UserForms.Add(myForm.Name).Show

'Delete the form (Optional)
Application.VBE.MainWindow.Visible = True

ThisWorkbook.VBProject.VBComponents.Remove myForm

'   IE is now set to the user's choice and you can add code here to interact with it
'   myDoc is now set to IE.Document also
'
'
'

Dim drp As HTMLFormElement

Set drp = myDoc.getelementsbyname("suppliercode")(0)



Dim walekuj As Long
walekuj = myDoc.forms.Length
 MsgBox walekuj

'we get the option values into our worksheet

For x = 0 To 3
 Cells(x + 1, 1) = drp.Item(x).innerText
 Next x

'Now we select the option value of our choice

drp.selectedIndex = 2

' we free memory

Set IE = Nothing
 Application.StatusBar = ""
End Sub
0
投票

只需通过 VB 编辑器“工具”-“参考文献”自行将参考文献添加到干净的工作簿中即可。 它们是“Microsoft 脚本运行时”、“Microsoft Forms”、“Microsoft MSHTML”和“Microsoft Internet Controls”。 然后将以下代码添加到模块中并运行 getOpenBrowserCreateForm()。 它已经为我工作了很多年了

Global myDoc As HTMLDocument
Global IE As Object


Sub getOpenBrowserCreateForm()
Dim myForm As Object
Dim NewFrame As MSForms.Frame
Dim NewButton As MSForms.CommandButton, newButton2 As MSForms.CommandButton
'Dim NewComboBox As MSForms.ComboBox
Dim NewListBox As MSForms.ListBox
'Dim NewTextBox As MSForms.TextBox
'Dim NewLabel As MSForms.Label
'Dim NewOptionButton As MSForms.OptionButton
'Dim NewCheckBox As MSForms.CheckBox
Dim x As Integer
Dim Line As Integer

'This is to stop screen flashing while creating form
Application.VBE.MainWindow.Visible = False

On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\mshtml.tlb"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\ieframe.dll"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\system32\FM20.DLL"
On Error GoTo 0
Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3)

'Create the User Form
With myForm
    .Properties("Caption") = "Select Open Web Site"
    .Properties("Width") = 326
    .Properties("Height") = 280
End With

'Create ListBox
Set NewListBox = myForm.designer.Controls.Add("Forms.listbox.1")
With NewListBox
    .Name = "ListBox1"
    .Top = 12
    .Left = 12
    .Width = 297
    .Height = 207.8
    .Font.Size = 9
    .Font.Name = "Tahoma"
    .BorderStyle = fmBorderStyleOpaque
    .SpecialEffect = fmSpecialEffectSunken
End With

'Create CommandButton1 Create
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
    .Name = "CommandButton1"
    .Caption = "Select"
    .Accelerator = "M"
    .Top = 228
    .Left = 234
    .Width = 72
    .Height = 24
    .Font.Size = 9
    .Font.Name = "Tahoma"
    .BackStyle = fmBackStyleOpaque
End With

'Create CommandButton2 Create
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
    .Name = "CommandButton2"
    .Caption = "Cancel"
    .Accelerator = "M"
    .Top = 228
    .Left = 144
    .Width = 72
    .Height = 24
    .Font.Size = 9
    .Font.Name = "Tahoma"
    .BackStyle = fmBackStyleOpaque
End With

'add code for form module
myForm.codemodule.insertlines 1, "Private Sub CommandButton1_Click()"
myForm.codemodule.insertlines 2, "Dim urlLocation As String"
myForm.codemodule.insertlines 3, ""
myForm.codemodule.insertlines 4, "''////////////////////////////////////////////////////////////////////"
myForm.codemodule.insertlines 5, "''  This part gets all open web pages qand displays them on the form for user to choose"
myForm.codemodule.insertlines 6, "''"
myForm.codemodule.insertlines 7, "    Set objIterator = CreateObject(" & Chr(34) & "Shell.Application" & Chr(34) & ")"
myForm.codemodule.insertlines 8, "    For X = 0 To objIterator.Windows.Count"
myForm.codemodule.insertlines 9, "        On Error Resume Next"
myForm.codemodule.insertlines 10, "        current_title = objIterator.Windows(X).Document.Title"
myForm.codemodule.insertlines 11, "        current_url = objIterator.Windows(X).Document.Location"
myForm.codemodule.insertlines 12, "    "
myForm.codemodule.insertlines 13, "        If current_title = ListBox1.Value Then 'is this my webpage?"
myForm.codemodule.insertlines 14, "        "
myForm.codemodule.insertlines 15, "            Set IE = objIterator.Windows(X)"
myForm.codemodule.insertlines 16, "            MsgBox " & Chr(34) & "IE was properly set" & Chr(34) & ""
myForm.codemodule.insertlines 17, "            "
myForm.codemodule.insertlines 18, "             Boolean_indicator = True"
myForm.codemodule.insertlines 19, "            Exit For"
myForm.codemodule.insertlines 20, "        End If"
myForm.codemodule.insertlines 21, "    Next"
myForm.codemodule.insertlines 22, "    Set objIterator = Nothing"
myForm.codemodule.insertlines 23, "    Set myDoc = IE.Document"
myForm.codemodule.insertlines 24, "Return"
myForm.codemodule.insertlines 25, "Unload Me"
myForm.codemodule.insertlines 26, ""
myForm.codemodule.insertlines 27, "End Sub"
myForm.codemodule.insertlines 28, ""
myForm.codemodule.insertlines 29, ""
myForm.codemodule.insertlines 30, "Private Sub CommandButton2_Click()"
myForm.codemodule.insertlines 31, " Unload Me"
myForm.codemodule.insertlines 32, "End Sub"
myForm.codemodule.insertlines 33, ""
myForm.codemodule.insertlines 34, ""
myForm.codemodule.insertlines 35, "Private Sub UserForm_Activate()"
myForm.codemodule.insertlines 36, "    Dim myArray1() As String, tempNumb As Integer"
myForm.codemodule.insertlines 37, "    "
myForm.codemodule.insertlines 38, "    "
myForm.codemodule.insertlines 39, "    i = 2"
myForm.codemodule.insertlines 40, "    tempNumb = 1"
myForm.codemodule.insertlines 41, "    "
myForm.codemodule.insertlines 42, "    ReDim myArray1(1 To 1)"
myForm.codemodule.insertlines 43, "   "
myForm.codemodule.insertlines 44, "    Set objShell = CreateObject(" & Chr(34) & "Shell.Application" & Chr(34) & ")"
myForm.codemodule.insertlines 45, "    Set objAllWindows = objShell.Windows"
myForm.codemodule.insertlines 46, "    "
myForm.codemodule.insertlines 47, "    "
myForm.codemodule.insertlines 48, "    For Each ow In objAllWindows"
myForm.codemodule.insertlines 49, "        If (InStr(1, ow," & Chr(34) & "Internet Explorer" & Chr(34) & ", vbTextCompare)) Then"
myForm.codemodule.insertlines 50, "            myArray1(tempNumb) = ow.Document.Title"
myForm.codemodule.insertlines 51, "            tempNumb = tempNumb + 1"
myForm.codemodule.insertlines 52, "            If Not ow.Document.Title = " & Chr(34) & "" & Chr(34) & " Then"
myForm.codemodule.insertlines 53, "                ReDim Preserve myArray1(1 To tempNumb)"
myForm.codemodule.insertlines 54, "            Else"
myForm.codemodule.insertlines 55, "                Exit For"
myForm.codemodule.insertlines 56, "            End If"
myForm.codemodule.insertlines 57, "        End If"
myForm.codemodule.insertlines 58, "    Next"
myForm.codemodule.insertlines 59, "     "
myForm.codemodule.insertlines 60, "    Me.ListBox1.List = myArray1"
myForm.codemodule.insertlines 61, "End Sub"
myForm.codemodule.insertlines 62, ""
'Show the form
VBA.UserForms.Add(myForm.Name).Show

'Delete the form (Optional)
Application.VBE.MainWindow.Visible = True

ThisWorkbook.VBProject.VBComponents.Remove myForm

'   IE is now set to the user's choice and you can add code here to interact with it
'   myDoc is now set to IE.Document also
'
'
'

Dim drp As HTMLFormElement

Set drp = myDoc.getelementsbyname("suppliercode")(0)



Dim walekuj As Long
walekuj = myDoc.forms.Length
 MsgBox walekuj

'we get the option values into our worksheet

For x = 0 To 3
 Cells(x + 1, 1) = drp.Item(x).innerText
 Next x

'Now we select the option value of our choice

drp.selectedIndex = 2

' we free memory

Set IE = Nothing
 Application.StatusBar = ""
End Sub
0
投票
Set IE = IE.document.frames(1).document
Dim supls As Object
Dim suplsDrop As Object
 Set suplsDrop = IE.getElementsByTagName("OPTION")
 For Each supls In IE.getElementsByTagName("SELECT")
  If supls.Name = "suppliercode" Then
 For Each suplsDrop In supls
  With Me.SupplierSite
  .AddItem suplsDrop.Value
  End With
Next suplsDrop
End If
Next supls
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.