【VB】简易的山东灯塔党建答题程序源码

firef0x · 发表于 2018-5-8 11:36

本帖最后由 firef0x 于 2018-5-8 11:48 编辑

该程序发布在https://www.52pojie.cn/thread-688246-1-1.html
兑现程序发布最初的承诺，在活动结束之后放出程序源码。
之所以在活动结束之后才放出，主要是避免出题方有针对性的修改网站程序，其次防止在活动期间被人利用以牟利（虽然只是很简单一个小程序，但是某些钱实在好赚，不展开说了）。
本源码是第一个版本的程序源码，其后的历次更新均在此基础上修改而来，逐步加入和调整了模糊查询，剩下的就是易用性的改进，程序工作原理并没有什么变化。
昨天对程序进行了一定的修改以适应5月份的“模拟答题”（正式答题会报错，程序发布帖有更新后的完整程序），大家可以在此基础上测试。
除了API操作，其它操作我尽量作了注释，方便大家理解程序工作原理。
很简单的东西，大神轻喷。
程序使用Win7 Ultimate 64bit（Win10 Pro 64bit）+ VB6.0 with SP6开发

以下是程序代码：

Part0.程序窗口
引用Microsoft ActiveX Data Objects 2.8 Library、Microsoft HTML Object Library
插入mdl一个
窗体设置：
CommandButton两个：cmdGet、cmdGO
TextBox两个：txthWnd、txtTitle
ListBox一个：lstAnswer

Part1.窗体代码

[Visual Basic] 纯文本查看 复制代码

Option Explicit

Private Sub cmdGo_Click()
'自动答题过程

    Dim x
    Dim i As Integer
    Dim n As Integer
    Dim strTextGet As String
    Dim strAnswer As String
    Dim tmpString As String
    Dim tmpstringArray() As String
    Dim MultiFlag As Boolean
    
    i = 0
    
    For Each x In hDoc.getElementsByClassName("w_fz18")     '使用getElementsByClassName方法取得ClassName为w_fz18的Nodes集，并进行枚举
    
    strTextGet = Replace(x.innerText, " ", "")      '去掉空格，这里只考虑了半角空格一种情况，可以根据需要去掉全角空格或Chr(9)Tab占位符
    
        Select Case i       'Nodes集8个为一个循环，第3个（Index为2）是题干，第4-7个（Index为3-6）为各选项
        
            Case 2
            
                strAnswer = FindAnswer(strTextGet)      '根据题干取得答案文本
                lstAnswer.AddItem CStr(lstAnswer.ListCount + 1) & "、" & strAnswer
                
            Case 3 To 6     '判断页面上的选项并作答
            
                    tmpString = Right(strTextGet, Len(strTextGet) - 2)
                    
                    If InStr(1, strAnswer, " ") > 0 Then        '判断多选，真为多选（字符串中包含空格），假为单选
                    
                        Erase tmpstringArray
                        MultiFlag = False
                        tmpstringArray = Split(strAnswer, " ")      '分离多选答案
                        
                            For n = 0 To UBound(tmpstringArray)
                                If tmpstringArray(n) = tmpString Then MultiFlag = True      '比对并标记
                            Next
                            
                        If MultiFlag Then x.parentNode.firstChild.Click     '判断标记，如符合便点击选项前的Check或Option
                    Else
                    
                        If strAnswer = tmpString Then x.parentNode.firstChild.Click     '判断单选答案，如正确便点击选项前的Check
                        
                    End If
                    
        End Select

        If i < 7 Then i = i + 1 Else i = 0      '判断Node顺序，累加或重置顺序号
    
    Next
    
    cmdGo.Enabled = False
    
End Sub

Private Sub cmdGet_Click()

    Set hDoc = Nothing
    txthWnd.Text = ""
    txtTitle.Text = ""
    lstAnswer.Clear
    
    Call getWeb     '获取句柄并生成iHTMLDocuments对象
    
    If Val(txthWnd.Text) > 0 Then
        txtTitle.Text = hDoc.Title
        cmdGo.Enabled = True
    End If
    
End Sub

Function FindAnswer(tText As String) As String
'根据题目取得答案

    Dim Cn As New ADODB.Connection
    Dim Rs As New ADODB.Recordset
    
    Dim i As Integer
    Dim SQLStr As String
    Dim strOutput As String
    Dim strTmp() As String
    
    '建立ADODB连接并打开
    Set Cn = New ADODB.Connection
    Cn.ConnectionString = "Provider=MSDataShape;Data Source=" & App.Path & "\test.mdb;Data Provider=Microsoft.Jet.OLEDB.4.0"
    Cn.Open
    
    '定义SQL命令字符串，这里只是用了绝对比较方法，可以通过 like + % 的方式变为模糊查找（后期即是如此）
    SQLStr = "select * from test where Question='" & tText & "'"
    
    '执行SQL语句并返回一个RecordSet对象，因为题库的关系这里的RecordSet只有一条记录，如使用模糊查找，应注意多条记录对应的答案会不同，所以需要通过调整模糊查找的关键词实现返回的记录为唯一值
    Rs.Open SQLStr, Cn
    
    If Not (Rs.EOF) Then
    
        strOutput = Rs(6)       '字段“Answer”为答案，其Index为6
        
            If Len(strOutput) > 1 Then      '判断多选，真为多选，假为单选
            
                strTmp = Split(strOutput, ",")      '分离多选答案
                strOutput = ""

                For i = 0 To UBound(strTmp)
                    strTmp(i) = Replace(Rs(setFieldIndex(strTmp(i))), " ", "")      '根据答案选项取得答案文本
                Next
                
                strOutput = Join(strTmp)    '将答案文本组合为单个字符串，答案之间以" "（空格）分隔
                
            Else
            
                strOutput = Rs(setFieldIndex(strOutput))         '根据答案选项取得答案文本
                
            End If
            
    End If

    Rs.Close
    Cn.Close
    Set Rs = Nothing
    Set Cn = Nothing
    
    FindAnswer = strOutput
    
End Function

Function setFieldIndex(indexS As String) As Integer
'根据选项字母取得Fields的Index值

    setFieldIndex = Switch(indexS = "A", 2, indexS = "B", 3, indexS = "C", 4, indexS = "D", 5)
    
End Function

Private Sub lstAnswer_Click()
'点击列表项后将列表的Tooltips更改为点击项的文本

    lstAnswer.ToolTipText = lstAnswer.Text
    
End Sub

Part2.模块代码

[Visual Basic] 纯文本查看 复制代码

Option Explicit

Public hDoc As IHTMLDocument

Private Type UUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As UUID, ByVal wParam As Long, ppvObject As Any) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long

Private Function GenerateiHTMLObject(ByVal hWnd As Long) As IHTMLDocument

  Dim ID     As UUID
  Dim lngReg As Long
  Dim lngHnD As Long
  
  lngHnD = RegisterWindowMessage("WM_HTML_GETOBJECT")
  
  With ID
  
    .Data1 = &H626FC520
    .Data2 = &HA41E
    .Data3 = &H11CF
    .Data4(0) = &HA7
    .Data4(1) = &H31
    .Data4(2) = &H0
    .Data4(3) = &HA0
    .Data4(4) = &HC9
    .Data4(5) = &H8
    .Data4(6) = &H26
    .Data4(7) = &H37
    
  End With
  
  Call SendMessageTimeout(hWnd, lngHnD, 0, 0, &H2, 2000, lngReg)
  Call ZeroMemory(ID, Len(ID))
  Call ObjectFromLresult(lngReg, ID, 0, GenerateiHTMLObject)
  
End Function

Public Sub getWeb()
'获取句柄并生成iHTMLDocument对象

 Dim lngFindWn As Long
 Dim tmpHwnd As Long
   
    lngFindWn = FindWindow("IEFrame", vbNullString)     '使用FindWindow API查找IEFrame子窗口，由于该子窗口仅存在于IE浏览器中，故本程序并不支持其它浏览器
    
    '根据IEFrame的窗口结构逐层查找包含HTML DOM对象的子窗口，取得其句柄
    tmpHwnd = FindWindowEx(lngFindWn, 0, "Frame Tab", vbNullString)
    If tmpHwnd > 0 Then lngFindWn = tmpHwnd Else MsgBox "Frame Tab"
    
    tmpHwnd = FindWindowEx(lngFindWn, 0, "TabWindowClass", vbNullString)
    If tmpHwnd > 0 Then lngFindWn = tmpHwnd Else MsgBox "TabWindowClass"
    
    tmpHwnd = FindWindowEx(lngFindWn, 0, "Shell DocObject View", vbNullString)
    If tmpHwnd > 0 Then lngFindWn = tmpHwnd Else MsgBox "Shell DocObject View"
    
    tmpHwnd = FindWindowEx(lngFindWn, 0, "Internet Explorer_Server", vbNullString)
    If tmpHwnd > 0 Then lngFindWn = tmpHwnd Else MsgBox "Internet Explorer_Server"
    
    If tmpHwnd > 0 Then
        frmMain.txthWnd = lngFindWn
        Set hDoc = GenerateiHTMLObject(lngFindWn)       '根据查找到的句柄生成iHTMLDocument对象
    End If
    
End Sub

Filler源码.zip (4.77 KB, 下载次数: 285)

firef0x · 发表于 2018-5-8 17:29

本帖最后由 firef0x 于 2018-5-8 17:45 编辑

下面我们再来谈谈关于HTML的分析。
这是我截取的灯塔党建页面其中一题的HTML，为了方便查看我调整了一下格式，更醒目。
（其中部分span标签被程序员打成了sapn，这个bug从始至终存在，呵呵哒。。。我这里偏不改它[/手动滑稽]，反正对我们使用没什么影响）

[HTML] 纯文本查看 复制代码

<li>
        <h1>
                <span>
                        <i class="W_num_i w_fz18">
                                1
                        </i>
                </span>
                .
                <span class="w_colred w_fz18 w_boderti">
                        单选题
                </span>
                <span class="w_fz18">
                        我们的哲学社会科学有没有中国特色，归根到底要看有没有主体性、（）。
                </span>
        </h1>
        
        <div class="W_ml45" answer="A" subjecttype="0">
                <label>
                        <input name="ra_1" type="radio" value="A" goright="A" ids="undefined">
                        <sapn class="W_ml10 W_col W_pointer w_fz18">
                                A.原创性
                        </sapn>
                </label>
        </div>
        
        <div class="W_ml45" answer="A" subjecttype="0">
                <label>
                        <input name="ra_1" type="radio" value="B" goright="A" ids="undefined">
                        <sapn class="W_ml10 W_col W_pointer w_fz18">
                                B.自觉性
                        </sapn>
                </label>
        </div>
        
        <div class="W_ml45" answer="A" subjecttype="0">
                <label>
                        <input name="ra_1" type="radio" value="C" goright="A" ids="undefined">
                        <sapn class="W_ml10 W_col W_pointer w_fz18">
                                C.本体性
                        </sapn>
                </label>
        </div>
        
        <div class="W_ml45" answer="A" subjecttype="0">
                <label>
                        <input name="ra_1" type="radio" value="D" goright="A" ids="undefined">
                        <sapn class="W_ml10 W_col W_pointer w_fz18">
                                D.民族性
                        </sapn>
                </label>
        </div>
        
        <div class="w_right W_ml45 w_fz18" style="display: none;">
        </div>
</li>

我们可以看到，所有出现在页面中的文本都使用了span标签，其中使用css样式表规定了样式，所有的题目和选项都有w_fz18这个类名
所以我们提取页面文字使用GetElementsByClassName这个方法，ClassName当然就是我们观察出来的w_fz18
在一道题目内包含w_fz18的Nodes一共8个，所以程序查找判断是8组为一个循环。

我们提取到的每个Node实际上是

[HTML] 纯文本查看 复制代码

<sapn class="W_ml10 W_col W_pointer w_fz18">C.本体性</sapn>

这样的HTML代码构成的对象。
Node其中一个属性InnerHTML就是取得这一段HTML代码，而InnerText则是标签之间所有文本内容，所以我们用InnerText属性来获取题目/答案的文本
有了文本就可以进行分析查找判断了，在程序中使用Right(len-2)的方式去掉前面的C.字母项
当确定一个Node就是我们所查找到的正确答案之后，我们要对其进行点选操作，就需要对选项之前的Checkbox或者Radio进行定位，所以我们来分析一下单个选项：

[HTML] 纯文本查看 复制代码

        <div class="W_ml45" answer="A" subjecttype="0">
                <label>
                        <input name="ra_1" type="radio" value="C" goright="A" ids="undefined">
                        <sapn class="W_ml10 W_col W_pointer w_fz18">
                                C.本体性
                        </sapn>
                </label>
        </div>

在这里可以看到，定义Radio的<Input>Node和我们提取到的<span>Node是并列关系，而他们的父Node（parentNode）是<label>，<Input>是<label>下面第一个子Node（firstChild）
所以定位到Radio的<Input>Node，再发送个Click事件给它，就完成了模拟点击的动作
即<span>.parentNode.firstChild.Click。

乖小江江 · 发表于 2018-5-8 11:38

必须支持大佬，谢谢

乖小江江 · 发表于 2018-5-8 11:38

貌似我沙发和凳子都占了，超开心，谢谢大佬了

qqqwww0078 · 发表于 2018-5-8 11:50

楼上的你是来水经验的吧？

wushaominkk · 发表于 2018-5-8 11:52

代码写的很漂亮!感谢分享原创源码

直抒胸臆 · 发表于 2018-5-8 12:05

感谢分享……

苏紫方璇 · 发表于 2018-5-8 13:04

感谢分享，我们单位也有类似的答题，只实现了半自动显示答案，学习下楼主自动化的思路

firef0x · 发表于 2018-5-8 14:53

本帖最后由 firef0x 于 2018-5-8 15:19 编辑

苏紫方璇发表于 2018-5-8 13:04
感谢分享，我们单位也有类似的答题，只实现了半自动显示答案，学习下楼主自动化的思路

自动化的思路要配合HTML来看，这一部分偷了个懒没有做。。。。。有空了补个说明在上面。

可以自动登录的全自动化操作也要结合HTML来看，也不复杂
比如取得HTML DOM的标题，或者是取得IEFrame子窗口的URL，然后判断当前页面是登录页面还是操作页面
根据页面编写对应的过程就行。如果是多帐号连续操作记得加一个登出的过程。。。。

xfgd0823 · 发表于 2018-5-8 15:11

感谢楼主无私分享，共同学习，共同进步。

帐号		自动登录	找回密码
密码			注册[Register]

[其他原创] 【VB】简易的山东灯塔党建答题程序源码

免费评分