Интересный пример, позволяющий получить атрибуты любого тэга, хотя конечно, реализация немного кривая, но он работает :)
Код
'Для работы требуется файл index.html, находящийся в одной папке с программой.
'На форме также нужно разместить TextBox с Name = "editbox", ListBox с Name = "List1" и CommandButton с Name = "cmd_getattributes"
'Запустите пример, установите курсор на любой элемент HTML в текстовом поле и нажмите на кнопку. В ListBox должны появиться атрибуты выбранного элемента.
'made by Alexander Triantafyllou
'Bsc Information Technology and Telecommunications
'University of Athens Greece
Dim editbox_ba() As Byte
Dim editbox_len As Long
' this holds the attribute names
Public tatname As New Collection
'this holds the attribute values
Public tatval As New Collection
'this holds the position where the attribute name starts
Public tatnamepos As New Collection
'this holds the position where the attribute value starts
Public tatvalpos As New Collection
Public tindex As Long
Public tnamepos As Long
Public htcol As New Collection
Dim kol(93) As String
'apothikeyei ta dedomena poy briskei i get_nodes_by_tname
Public htnodname As New Collection
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
' apothikeyei tis theseis ton images mesa sto document
Public imgsposcol As New Collection
'apothikeyei ta onomata names toy ekastote tag poy eksetazoyme sto
'sygekrimeno editbox
Public curtagnamecol As New Collection
Public Sub getattributes(ByVal spos As Long, Optional ByVal skip_tagnum As Boolean)
'WAS NOT ON ERROR
On Error GoTo errorhandler
Dim htmlword_ba() As Byte
' Put the textbox's string into a byte array '
'this is only needed every time the textbox is being changed
editbox_len = Len(Form1.editbox.Text)
ReDim editbox_ba(editbox_len)
CopyMemory editbox_ba(0), ByVal Form1.editbox.Text, editbox_len
'----------------------------------------------------------
Dim atcol As New Collection
'-----------------------------SBINOYME OLA TA PALIA ----------------------------------------------------
Do While tatname.Count >= 1
tatname.Remove 1
Loop
Do While tatval.Count >= 1
tatval.Remove 1
Loop
Do While tatvalpos.Count >= 1
tatvalpos.Remove 1
Loop
Do While tatnamepos.Count >= 1
tatnamepos.Remove 1
Loop
'----------------------TELOS SBINOYME PALIA-----------------------------------------------
If spos <> 0 Then
'BRISKOYME TAG ATTRIBUTES KAI TA BAZOYME STIS COLLECTIONS
' we find tag attributes and we put them in the collections
' if it is tag then parse else do not
If Not skip_tagnum Then tagnum = gettagnum(spos)
If tagnum <> 888 Or skip_tagnum Then
found = False
' the following code does this instrrev but much more faster using a char byte array
'startpos = InStrRev(Form1.EditBox.Text, "<", spos)
startpos = spos - 1
Do While startpos >= 0
If editbox_ba(startpos) = 60 Then
startpos = startpos + 1
Exit Do
Else
startpos = startpos - 1
End If
Loop
If startpos = -1 Then startpos = 0
'startpos2 = InStr(spos + 1, Form1.EditBox.Text, "<") 'Form1.editbox.Find("<", spos + 1) + 1 '
startpos2 = spos
Dim found_startpos2 As Boolean
Do While startpos2 < editbox_len
If editbox_ba(startpos2) = 60 Then
found_startpos2 = True
startpos2 = startpos2 + 1
Exit Do
Else
startpos2 = startpos2 + 1
End If
Loop
If Not found_startpos2 Then startpos2 = 0
'endpos = InStrRev(Form1.editbox.Text, ">", spos)
endpos = spos - 1
Do While endpos >= 0
If editbox_ba(endpos) = 62 Then
endpos = endpos + 1
Exit Do
Else
endpos = endpos - 1
End If
Loop
If endpos = -1 Then endpos = 0
'endpos2 = InStr(spos, Form1.editbox.Text, ">") 'Form1.editbox.Find(">", spos) + 1 '
endpos2 = spos - 1
Dim found_endpos2 As Boolean
Do While endpos2 < editbox_len
If editbox_ba(endpos2) = 62 Then
found_endpos2 = True
endpos2 = endpos2 + 1
Exit Do
Else
endpos2 = endpos2 + 1
End If
Loop
If Not found_endpos2 Then endpos2 = 0
epos = endpos2
If startpos2 <> 0 And endpos2 <> 0 _
And startpos2 < endpos2 Then
epos = startpos2
ElseIf endpos2 = 0 And startpos2 <> 0 Then
epos = startpos2
ElseIf endpos2 = 0 And startpos2 = 0 Then
epos = editbox_len 'Len(Form1.editbox.Text)
End If
'startpos shows the position of <
'epos shows the end of tag
' to startpos deixnei sti thesi toy <
' to epos deixnei sto telos toy tag
'code to get the attributes that have been already been set and put them in the collections
' kodikas gia na briskei ta properties poy exoyme
' idi orisei kai na ta bazei katallila
' sto collection
htmlwordlen = epos - startpos + 1
htmlword$ = Space$(htmlwordlen)
CopyMemory ByVal htmlword$, editbox_ba(startpos - 1), htmlwordlen
'htmlword = Mid$(Form1.editbox.Text, startpos, epos - startpos + 1)
'htmlwordlen = Len(htmlword)
ReDim htmlword_ba(htmlwordlen)
CopyMemory htmlword_ba(0), ByVal htmlword, htmlwordlen
'eqpos = InStr(1, htmlword, "=") 'Form1.editbox.Find("=", 1) + 1 '
eqpos = 0
Dim found_eqpos As Boolean
Do While eqpos < htmlwordlen
If htmlword_ba(eqpos) = 61 Then
found_eqpos = True
eqpos = eqpos + 1
Exit Do
Else
eqpos = eqpos + 1
End If
Loop
If Not found_eqpos Then eqpos = 0
Do While eqpos <> 0
'ARXI BRISKOYME TO ATTRIBUTE NAME----------------------------------------------------------------
'Start:We find the attribute name
'we found a = now we skip the spaces before the = sign
'BRIKAME TO = TORA KANOYME SKIP TA KENA PRIN TO =
'psaxnoyme gia kena prin to = kai ta agnooyme
k = 1
'testch = Mid$(htmlword, eqpos - k, 1)
Do While htmlword_ba(eqpos - k - 1) = 32 And eqpos - k > 0 'testch = " " And eqpos - k > 0
k = k + 1
'testch = Mid$(htmlword, eqpos - k, 1)
Loop
atendpos = eqpos - k
L = 1
'testch = Mid$(htmlword, atendpos - 1, 1)
Do While htmlword_ba(atendpos - L - 1) <> 32 And atendpos - L > 0 'testch <> " " And atendpos - L > 0
L = L + 1
'testch = Mid$(htmlword, atendpos - L, 1)
Loop
atstpos = atendpos - L + 1
'attribname = Mid$(htmlword, atstpos, atendpos - atstpos + 1)
attribname$ = Space$(atendpos - atstpos + 1)
CopyMemory ByVal attribname$, htmlword_ba(atstpos - 1), (atendpos - atstpos + 1)
'TELOS BRISKOYME ATTRIBUTE NAME --------------------------------------------------------
'End of finding attribute name
'Start of :Finding attribute value
'ARXI BRISKOYME ATTRIBUTE VALUE -----------------------------------------------------------------
' brikame to attribute name tora prospathoyme na
' broyme tin timi toy attribute
' We skip spaces after =
' AGNOOYME TA KENA META TO =
k = 1
'testch = Mid$(htmlword, eqpos + k, 1)
Do While htmlword_ba(eqpos + k - 1) = 32 And eqpos + k <= htmlwordlen 'testch = " " And eqpos + k <= htmlwordlen
k = k + 1
'testch = Mid$(htmlword, eqpos + k, 1)
Loop
valspos = eqpos + k
L = 1
testch = htmlword_ba(valspos + L - 1) 'Chr$(htmlword_ba(valspos + L - 1)) ''Mid$(htmlword, valspos + L, 1)
testch2 = htmlword_ba(valspos - 1) 'Chr$(htmlword_ba(valspos - 1)) 'Mid$(htmlword, valspos, 1)
' ean brikame eisagogika tote i timi tha einai
'mexri ekei poy teleionoyn ta eisagogika
Dim found_valendpos As Boolean
If testch2 = 34 Then ' """"
' valendpos = InStr(valspos + 1, htmlword, """") 'Form1.editbox.Find("""", valspos + 1) + 1 '
valendpos = valspos
Do While valendpos < htmlwordlen
If htmlword_ba(valendpos) = 34 Then
valendpos = valendpos + 1
found_valendpos = True
Exit Do
Else
valendpos = valendpos + 1
End If
Loop
If Not found_valendpos Then valendpos = 0
valspos = valspos + 1
valendpos = valendpos - 1
If valendpos = -1 Then
valendpos = htmlwordlen
End If
ElseIf testch2 = 39 Then ' "'"
' valendpos = InStr(valspos + 1, htmlword, "'") 'Form1.editbox.Find("'", valspos + 1) + 1 '
valendpos = valspos
Do While valendpos < htmlwordlen
If htmlword_ba(valendpos) = 39 Then
valendpos = valendpos + 1
found_valendpos = True
Exit Do
Else
valendpos = valendpos + 1
End If
Loop
If Not found_valendpos Then valendpos = 0
valspos = valspos + 1
valendpos = valendpos - 1
If valendpos = -1 Then
valendpos = htmlwordlen
End If
Else
Do While htmlword_ba(valspos + L - 1) <> 32 And htmlword_ba(valspos + L - 1) <> 60 And htmlword_ba(valspos + L - 1) <> 62 And valspos + L <= htmlwordlen
L = L + 1
'testch <> " " And testch <> ">" And testch <> "<" And valspos + L <= htmlwordlen
' L = L + 1
'testch = Mid$(htmlword, valspos + L, 1)
Loop
valendpos = valspos + L - 1
End If ' testch2=" or '
'BRIKAME TI THESI TOY TELOYS TO ATTRIBUTE VALUE
'attribval = Mid$(htmlword, valspos, valendpos - valspos + 1)
attribval$ = Space$(valendpos - valspos + 1)
CopyMemory ByVal attribval$, htmlword_ba(valspos - 1), (valendpos - valspos + 1)
tatname.Add attribname
tatval.Add attribval
tatnamepos.Add startpos + atstpos - 2
tatvalpos.Add startpos + valspos - 2
'eqpos = InStr(eqpos + 1, htmlword, "=") 'Form1.editbox.Find("=", eqpos + 1) + 1 '
found_eqpos = False
eqpos = valendpos
Do While eqpos < htmlwordlen
If htmlword_ba(eqpos) = 61 Then
found_eqpos = True
Exit Do
Else
eqpos = eqpos + 1
End If
Loop
If Not found_eqpos Then
eqpos = 0
Else
eqpos = eqpos + 1
End If
Loop
End If
End If
Exit Sub
errorhandler:
End Sub
Public Function gettagnum(ByVal startpos As Long) As Integer
Dim spos As Long
Dim epos As Long
Dim k As Long
On Error GoTo errorhandler
Dim tagval As String
'spos = InStrRev(Form1.editbox.Text, "<", startpos)
spos = startpos - 1
Do While spos >= 0
If editbox_ba(spos) = 60 Then
Exit Do
Else
spos = spos - 1
End If
Loop
spos = spos + 1
epos = startpos - 1
'epos = InStrRev(Form1.editbox.Text, ">", startpos)
Do While epos >= 0
If editbox_ba(epos) = 62 Then
Exit Do
Else
epos = epos - 1
End If
Loop
epos = epos + 1
If (spos = 0) Or (epos <> 0 And spos <> 0 And spos < epos) Then
gettagnum = 888
Exit Function
End If
spos = spos + 1
k = 1 ' 61="=" 13=vbcr 62=">" 10=vblf 32=" "
Do While editbox_ba(spos - 1 + k) <> 61 And editbox_ba(spos - 1 + k) <> 13 _
And editbox_ba(spos - 1 + k) <> 62 And editbox_ba(spos - 1 + k) <> 10 And editbox_ba(spos - 1 + k) <> 32
k = k + 1
Loop
tagval$ = Space$(k)
CopyMemory ByVal tagval$, editbox_ba(spos - 1), k
tagnum = findtag(tagval)
gettagnum = tagnum
Exit Function
Exit Function
errorhandler:
tindex = 888
tnamepos = -1
gettagnum = 888
End Function
Private Sub cmd_getattributes_Click()
getattributes editbox.SelStart, False
List1.Clear
For k = 1 To tatval.Count
List1.AddItem CStr(tatname(k)) + " (Position : " + CStr(tatnamepos(k)) + " ) with value =" + CStr(tatval(k)) + " (Position: " + CStr(tatvalpos(k)) + " )"
Next k
End Sub
Private Sub Form_Load()
kol(0) = "a"
kol(1) = "abbr"
kol(2) = "acronym"
kol(3) = "address"
kol(4) = "applet"
kol(5) = "area"
kol(6) = "b"
kol(7) = "base"
kol(8) = "basefont"
kol(9) = "bdo"
kol(10) = "big"
kol(11) = "blockquote"
kol(12) = "body"
kol(13) = "br"
kol(14) = "button"
kol(15) = "caption"
kol(16) = "center"
kol(17) = "cite"
kol(18) = "code"
kol(19) = "col"
kol(20) = "colgroup"
kol(21) = "dd"
kol(22) = "del"
kol(23) = "dfn"
kol(24) = "dir"
kol(25) = "div"
kol(26) = "dl"
kol(27) = "dt"
kol(28) = "em"
kol(29) = "fieldset"
kol(30) = "font"
kol(31) = "form"
kol(32) = "frame"
kol(33) = "frameset"
kol(34) = "h1"
kol(35) = "h2"
kol(36) = "h3"
kol(37) = "h4"
kol(38) = "h5"
kol(39) = "h6"
kol(40) = "head"
kol(41) = "hr"
kol(42) = "html"
kol(43) = "i"
kol(44) = "iframe"
kol(45) = "ilayer"
kol(46) = "img"
kol(47) = "input"
kol(48) = "ins"
kol(49) = "isindex"
kol(50) = "kbd"
kol(51) = "label"
kol(52) = "legend"
kol(53) = "li"
kol(54) = "link"
kol(55) = "map"
kol(56) = "menu"
kol(57) = "meta"
kol(58) = "noframes"
kol(59) = "noscript"
kol(60) = "object"
kol(61) = "ol"
kol(62) = "optgroup"
kol(63) = "option"
kol(64) = "p"
kol(65) = "param"
kol(66) = "plaintext"
kol(67) = "pre"
kol(68) = "q"
kol(69) = "s"
kol(70) = "samp"
kol(71) = "script"
kol(72) = "select"
kol(73) = "small"
kol(74) = "span"
kol(75) = "strike"
kol(76) = "strong"
kol(77) = "style"
kol(78) = "sub"
kol(79) = "sup"
kol(80) = "table"
kol(81) = "tbody"
kol(82) = "td"
kol(83) = "textarea"
kol(84) = "tfoot"
kol(85) = "th"
kol(86) = "thead"
kol(87) = "title"
kol(88) = "tr"
kol(89) = "tt"
kol(90) = "u"
kol(91) = "ul"
kol(92) = "var"
kol(93) = "!--"
Dim intf As Integer
intf = FreeFile
Open App.Path + "\index.html" For Input As #intf
Do While Not EOF(intf)
Line Input #intf, kokostr
editbox.Text = editbox.Text + kokostr + vbNewLine
Loop
Close #intf
End Sub
Public Function findtag(ByVal seektag As String) As Integer
L = 0
Do While found = False And L < UBound(kol)
If StrComp(seektag, kol(L), vbTextCompare) = 0 Then
findtag = L
Exit Function
Else
L = L + 1
End If
Loop
'if we did not find the tag we return the number 888
If found = False Or seektag = "" Then
findtag = 888
End If
End Function
Язык Visual Basic 6.0 является устаревшим. Многие примеры, размещенные на нашем сайте, были созданы еще во времена Windows 98 и могут не работать в современных операционных системах.
Если у вас возникнут какие-либо проблемы или вопросы, вы можете обратиться за помощью на наш форум.
Добавлять комментарии могут только зарегистрированные пользователи сайта.
Если у Вас уже есть учетная запись на Kbyte.Ru, пройдите процедуру авторизации.
Если Вы еще не зарегистрированы на Kbyte.Ru - зарегистрируйтесь.