UptadeRunlight(Html Marquee Element) in vb6-CSDN博客

本文链接：https://blog.csdn.net/wgsnet/article/details/3225329

本文介绍了一个VBScript程序，用于读取并更新HTML文件中的跑马灯（Marquee）元素内容。通过解析HTML文件，程序能够定位到跑马灯元素，并替换其显示文本。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

'可读取更新HTML里跑马灯（Marquee节点）

'UptadeRunlight(Html Marquee Element) in vb6

'By wgscd 2008/11/7

'HTTP://www.blog.csdn.net/wgsnet

'QQ:153964481
Dim oldAllstring As String
Dim oldMarquee, newMarquee
Dim htmlfile As String

Private Sub Command1_Click()
On Error Resume Next

resetFile

MsgBox "更新成功"
Unload Me

End Sub

Private Sub Form_Load()
On Error Resume Next

htmlfile = App.Path & "/" & FindFile(App.Path, ".html")
oldAllstring = readFile(htmlfile)
Me.Text1.Text = oldAllstring
oldMarquee = TestRegExp(oldAllstring)

addMarqueeToControl

''resetFile oldAllstring, oldMarquee

''MsgBox oldMarquee

End Sub
'<marquee id="marquee1" direction="up" scrollAmount=2 scrolldelay="4" style="font-size: 26pt; color: #FFFF00; font-weight: bold" width="590px" height="70px">wgscd 你好啊！！test
'
'test
'ooooooooooo </marquee>

Sub addMarqueeToControl()

Dim i As Integer

For i = 0 To UBound(oldMarquee) - 1
     TextMarquee(i).Visible = True

        Dim str, MarqueeStartP
           str = oldMarquee(i)
           MarqueeStartP = InStr(str, "px"">") + 4
           str = Mid(str, MarqueeStartP, Len(str) - MarqueeStartP - 9)
           ''MsgBox str
           ''TextMarquee(i).Text = oldMarquee(i)
           TextMarquee(i).Text = str

Next

End Sub

Sub resetFile()

Dim i As Integer
ReDim newMarquee(UBound(oldMarquee))

    For i = 0 To UBound(oldMarquee) - 1

        Dim str, MarqueeStartP
           str = oldMarquee(i)
           MarqueeStartP = InStr(str, "px"">") + 4
           str = Mid(str, MarqueeStartP, Len(str) - MarqueeStartP - 9)

           newMarquee(i) = Replace(oldMarquee(i), str, Me.TextMarquee(i).Text)

           ''MsgBox newMarquee(i)

           ''MsgBox str
           ''TextMarquee(i).Text = oldMarquee(i)
           ''TextMarquee(i).Text = str

Next

For i = 0 To UBound(oldMarquee) - 1


       oldAllstring = Replace(oldAllstring, oldMarquee(i), newMarquee(i))

Next

'' Me.Text1.Text = oldAllstring

writeFile htmlfile, oldAllstring

End Sub

Function TestRegExp(ByVal myString As String) As String()
        Dim objMatch, colMatches, RetStr
                 Dim objregexp As RegExp
                Set objregexp = New RegExp
                objregexp.Global = True
                objregexp.Pattern = "<marquee id=""marquee[^<]*</marquee>"
                Set colMatches = objregexp.Execute(myString)
                Dim i As Integer
                Dim strs() As String
                ReDim strs(colMatches.Count)
                ''MsgBox colMatches.Count
                  For Each objMatch In colMatches
                       ''RetStr = RetStr & objMatch.Value & vbNewLine
                      '' MsgBox objMatch.Value
                       strs(i) = objMatch.Value
                       i = i + 1
                  Next

                 ''RetStr = objregexp.Replace(myString, "$1 from $2 where $1 in( select top " & Text1.Text & " $1 from $2)""")
                  'MsgBox RetStr

            '' oldMarquee = strs
       TestRegExp = strs

End Function

Function readFile(ByVal strfilePath As String) As String
       On Error Resume Next
        Dim fsoTest As New FileSystemObject, f As TextStream

        Dim str As String
        Set f = fsoTest.OpenTextFile(strfilePath, ForReading)
    If Not f.AtEndOfStream Then
        str = f.ReadAll
        readFile = str
    Else
        readFile = ""
    End If
        f.Close
        Set f = Nothing

End Function

Function writeFile(ByVal strFile As String, ByVal strVal As String) As Boolean
        On Error GoTo er
        Dim fso As New FileSystemObject, f As TextStream
        Set f = fso.CreateTextFile(strFile, True)
        f.Write (strVal)
        f.Close
        Set f = Nothing
        writeFile = True
        Exit Function
er:

        writeFile = False

        Exit Function

End Function

Function FindFile(ByVal FoderPath As String, ByVal searchFileExtention As String) As String ''searchFileExtention=".XXX"
Dim strFileName As String
Dim objFso As FileSystemObject
Dim objFiles As Files
Dim objFile As File

Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.GetFolder(FoderPath).Files

If objFiles.Count = 0 Then
MsgBox "找不到html模板文件！", vbInformation, "提示"
Unload Me

GoTo Err
End If

   For Each objFile In objFiles
    strFileName = objFile.Name

    If Right(strFileName, 5) = searchFileExtention Then ''".XXX"
    ''List1.AddItem strFileName
     FindFile = strFileName ''只要第一个

     Exit Function

     ''MsgBox strFileName

    End If
      '' MsgBox strFileName

   Next

Err:
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing

Exit Function
End Function