Тема: HTA: Frame в качестве панели инструментов
Здравствуйте, уважаемые коллеги.
На досуге написал HTA для учета коллекции видео, чем хочу с вами поделиться. Предпосылкой стало отсутствие информированности детей на предмет наличия того или иного мультфильма в их домашней коллекции. Считаю интересным моментом использование фрейма в качестве панели инструментов. Кроме того, начинающих кодеров могут заинтересовать методы работы с XML, файловой системой, визуальными фильтрами Alpha и AlphaImageLoader, и пр.

Сначала я переписал названия всех мультфильмов в TXT-файл, и лишь спустя некоторое время решил в качестве базы использовать файл XML, поэтому пришлось прочитать данные из TXT и закинуть их в XML, для чего я использовал следующий скрипт:
Const TxtFile = "data.txt"
Const XMLFileName = "data.xml"
Dim dataArray()
ReadTXT
WriteXML
MsgBox "Обновление файла " & XMLFileName & " завершено", vbInformation
Sub ReadTXT()
Dim fso, objFile, i
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(TxtFile) Then
Set objFile = fso.OpenTextFile(TxtFile)
i = 0
Do Until objFile.AtEndOfStream
ReDim Preserve dataArray(i)
dataArray(i) = Trim(objFile.ReadLine)
i = i + 1
Loop
Set objFile = Nothing
Else
MsgBox "Файл " & sTxtFile & " не найден", vbCritical, "Ошибка"
WScript.Quit
End If
Set fso = Nothing
End Sub
Sub WriteXML()
Dim xmlDoc, objNewNode, i
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
If xmlDoc.Load(XMLFileName) Then
If xmlDoc.DocumentElement.hasChildNodes Then
Do While xmlDoc.DocumentElement.childNodes.length >= 1
xmlDoc.DocumentElement.removeChild(xmlDoc.DocumentElement.firstChild )
Loop
End If
xmlDoc.DocumentElement.setAttribute "date", Now()
For i = 0 To UBound(dataArray)
Set objNewNode = xmlDoc.createElement("film")
With objNewNode
.setAttribute "name", dataArray(i)
.setAttribute "year", "?"
.setAttribute "date", FormatDateTime(Now(),ddmmyyyyhhmmss)
.setAttribute "id", i
End With
xmlDoc.DocumentElement.AppendChild(objNewNode)
Set objNewNode = Nothing
Next
xmlDoc.Save(XMLFileName)
Else
MsgBox "Ошибка загрузки файла " & XMLFileName, vbExclamation
WScript.Quit
End If
Set xmlDoc = Nothing
End SubЗатем нарисовал основное окно, состоящее из HTA и двух HTML:
<html>
<head>
<title>VideoLib</title>
<HTA:APPLICATION
ID = "VideoLib"
APPLICATIONNAME="VideoLib"
SINGLEINSTANCE="yes"
MAXIMIZEBUTTON="no"
SELECTION="no"
Icon = "daffodil.ico"
Version = "1.0">
</HTA:APPLICATION>
</head>
<script language="VBScript" src="VideoLib.vbs"></script>
<frameset rows="120,*">
<frame id="menufrm" src="Menu.html" name="topFrame" scrolling="no" noresize>
<frame id="mainfrm" src="Main.html" name="mainFrame">
</frameset>
</html>
<html>
<link href="VideoLib.css" rel="stylesheet" type="text/css" />
<body>
<div>
<span id="add"></span>
<span id="del"></span>
<span id="save"></span>
<span id="search"></span>
<input id="find" type="text" size="41">
<span id="help"></span>
<span id="about"></span>
<span id="tip">Кнопки:<br/>
- Добавить - добавляем новую строку в список<br/>
- Удалить - отмечаем строку на удаление<br/>
- Сохранить - сохраняем изменения в XML-файле<br/>
- Поиск - ищем строку в наименовании<br/>
Редактируем данные в ячейках над заголовками столбцов<br/>
Сортируем данные нажатием на заголовки столбцов
</span>
<span id="tip1">
VideoLib - приложение<br/>для учета коллекции видео<br/>
Автор: Анатолий Демидович<br/>
<a href="http://da440dil.narod.ru/">http://da440dil.narod.ru</a>
</span>
</div>
<div id="inp">
<input id="film" type="text" size="64">
<input id="year" type="text" size="4">
<span id="flcount"></span>
</div>
<div>
<table border="1" cols="3" cellpadding="2" width="555px">
<tr align="center">
<td id="fname" width="75%">Наименование</td>
<td id="fyear" width="10%">Год</td>
<td id="fdate" width="15%">Дата</td>
</tr>
</table>
</div>
</body>
</html>
<html>
<link href="VideoLib.css" rel="stylesheet" type="text/css" />
<body>
<div id="flinfo"></div>
</body>
</html>Растусовал и нарядил элементы с помощью CSS:
body{
font:bold 12 sans-serif;
color:#fff;
background-color: #4169e1;
}
table {
font:bold 12 sans-serif;
}
#find { margin: 0px 0px 11px 8px; }
#inp { margin-bottom: 2px; }
#flcount{
border: 4px ridge;
font:bold 14 sans-serif;
margin: 1px 1px 2px 1px;
padding: 2px 4px 2px 4px;
}
/* Кнопки */
#add, #save, #del, #search, #help, #about {
height:40px;
width:40px;
margin: 0px 3px 3px 3px;
cursor:hand;
}
#add { filter:progid:DXImageTransform.Microsoft.AlphaImageLoader(src="add.png",sizingMethod="scale"); }
#save { filter:progid:DXImageTransform.Microsoft.AlphaImageLoader(src="save.png",sizingMethod="scale"); }
#del { filter:progid:DXImageTransform.Microsoft.AlphaImageLoader(src="del.png",sizingMethod="scale"); }
#search { filter:progid:DXImageTransform.Microsoft.AlphaImageLoader(src="search.png",sizingMethod="scale"); }
#help { filter:progid:DXImageTransform.Microsoft.AlphaImageLoader(src="help.png",sizingMethod="scale"); }
#about { filter:progid:DXImageTransform.Microsoft.AlphaImageLoader(src="about.png",sizingMethod="scale"); }
/* Всплывающие подсказки */
#tip , #tip1{
display:none;
position:absolute;
background:#fafafa;
border:1px solid #ccc;
color:#000;
padding:3px;
font-size:12px;
font-style:italic;
filter:progid:DXImageTransform.Microsoft.Alpha(opacity=80);
}
#tip{
top:2px;
left:106px;
width:371px;
}
#tip1{
top:10px;
left:306px;
width:220px;
text-align:center;
}
a{ text-decoration:none; }Добавил png-картинки, скрипт:
Const XMLFileName = "data.xml"
Const TableStart = "<table id=""tbl"" border=""1"" cols=""3"" cellpadding=""2"">"
Const TableEnd = "</table>"
Const cColor = "#ff9933"
Dim arrInfo()
Dim curNode 'текущий узел
Dim strHTML
Dim fSort 'флаг сортировки
Dim intLastID
Sub Window_OnLoad()
With Window
.ResizeTo 600, 500
.MoveTo (Screen.Width \ 2) - 320, (Screen.Height \ 2) - 280
End With
GetInfo 'получаем информацию в массив
ShowInfo 'отображаем информацию в окне
SetEH 'устанавливаем обработчики событий
End Sub
'получаем инфу
Sub GetInfo()
Dim xmlDoc, i, z
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
If xmlDoc.Load(XMLFileName) Then
If xmlDoc.DocumentElement.hasChildNodes Then
z = xmlDoc.DocumentElement.childNodes.Length - 1
For i = 0 To z
Redim Preserve arrInfo(4,i)
With xmlDoc.DocumentElement.childNodes(i)
arrInfo(0,i) = .GetAttribute("name")
arrInfo(1,i) = .GetAttribute("year")
arrInfo(2,i) = .GetAttribute("date")
arrInfo(3,i) = .GetAttribute("id")
End With
Next
intLastID = xmlDoc.DocumentElement.childNodes(z).GetAttribute("id")
End If
Else
MsgBox "Ошибка загрузки файла " & XMLFileName, vbExclamation
End If
Set xmlDoc = Nothing
End Sub
'закидываем инфу в окно
Sub ShowInfo()
If Not IsArray(arrInfo) Then Exit Sub
strHTML = vbNullString
For i = 0 To UBound(arrInfo,2)
strHTML = strHTML & "<tr id=""flm-" & i & """><td width=""75%"">" & arrInfo(0,i) & _
"</td><td width=""10%"">" & arrInfo(1,i) & "</td><td width=""15%"">" & _
DateValue(arrInfo(2,i)) & "</td></tr>"
Next
mainfrm.flinfo.InnerHTML = TableStart & strHTML & TableEnd
With menufrm
.flcount.InnerHTML = "Итого: " & UBound(arrInfo,2) + 1
.film.Value = vbNullString
.year.Value = vbNullString
End With
SetColor
End Sub
'обработчики событий
Sub SetEH()
'сортировка
menufrm.fname.onmousedown = GetRef("SortInfo")
menufrm.fyear.onmousedown = GetRef("SortInfo")
menufrm.fdate.onmousedown = GetRef("SortInfo")
'выбор строки
For Each childNode In mainfrm.flinfo.childNodes
childNode.onmousedown = GetRef("SetInfo")
Next
'изменение значения
menufrm.film.onchange = GetRef("ChangeInfo")
menufrm.year.onchange = GetRef("ChangeInfo")
'добавление строки
menufrm.add.onclick = GetRef("AddInfo")
'удаление строки
menufrm.del.onclick = GetRef("DelInfo")
'сохранение информации в файле XML
menufrm.save.onclick = GetRef("SaveInfo")
'поиск информации
menufrm.search.onclick = GetRef("SearchInfo")
'кнопки Enter
menufrm.find.onkeydown = GetRef("SearchInfoOnKey")
menufrm.film.onkeydown = GetRef("ChangeInfoOnKey")
menufrm.year.onkeydown = GetRef("ChangeInfoOnKey")
'подсказки
menufrm.help.onmouseover = GetRef("ShowTip")
menufrm.help.onmouseout = GetRef("HideTip")
menufrm.about.onmouseover = GetRef("ShowAbout")
menufrm.about.onmouseout = GetRef("HideAbout")
'ссылка
menufrm.about.onclick = GetRef("OnClickRef")
End Sub
'сортируем информацию в окне
Sub SortInfo()
'выбираем по какому полю сортировать
If menufrm.event.srcElement.id = "fname" Then
SortArray arrInfo,2,0
ElseIf menufrm.event.srcElement.id = "fyear" Then
SortArray arrInfo,2,1
Else
SortArray arrInfo,2,2
End If
ShowInfo 'отображаем
SetEH 'устанавливаем обработчики
End Sub
'сортировка массива методом пузырька
Sub SortArray(arr,r,q)
Dim m, n 'счетчики
Dim b() 'буфер
Dim f 'флаг
If IsArray(arr) Then
Redim b(UBound(arr))
fSort = Not fSort 'меняем флаг сортировки
For m = 0 To UBound(arr,r)-1
f = True
For n = 0 To UBound(arr,r)-1
If fSort Then
If arr(q,n) > arr(q,n+1) Then
f = SortFinish(b,n,arr)
End If
Else
If arr(q,n) < arr(q,n+1) Then
f = SortFinish(b,n,arr)
End If
End If
Next
If f Then Exit For
Next
End If
End Sub
'собственно сортировка
Function SortFinish(b,n,arr)
Dim z
For z = 0 To UBound(arr)
b(z) = arr(z,n)
arr(z,n) = arr(z,n+1)
arr(z,n+1) = b(z)
SortFinish = False
Next
End Function
'выбор строки
Sub SetInfo()
On Error Resume Next
Const bColor = "#4169e1"
Const iColor = "#0000ff"
If Not IsEmpty(curNode) Then
If curNode.bgcolor <> cColor Then curNode.bgcolor = bColor
End If
With mainfrm.event.srcElement
Set curNode = .parentNode
If IsEmpty(arrInfo(4,Mid(curNode.id,5))) Then .parentNode.bgcolor = iColor
End With
With curNode
menufrm.film.Value = arrInfo(0,Mid(.id,5))
menufrm.year.Value = arrInfo(1,Mid(.id,5))
End With
End Sub
'редактируем информацию
Sub ChangeInfo()
On Error Resume Next
Dim z
With menufrm.event.srcElement
If .id = "film" Then
z = 0
Else
z = 1
End If
curNode.childNodes(z).innerHTML = .Value
arrInfo(z,Mid(curNode.id,5)) = .Value
'меняем дату редактирования
arrInfo(2,Mid(curNode.id,5)) = Now()
'ставим флаг - редактировать
If arrInfo(4,Mid(curNode.id,5)) <> 1 Then arrInfo(4,Mid(curNode.id,5)) = 0
End With
curNode.bgcolor = cColor
End Sub
'добавляем информацию
Sub AddInfo()
Dim i
i = UBound(arrInfo,2) + 1
Redim Preserve arrInfo(4,i)
arrInfo(0,i) = "Новый"
arrInfo(1,i) = "?"
arrInfo(2,i) = Now()
intLastID = intLastID + 1 'увеличиваем значение последнего ID
arrInfo(3,i) = intLastID
arrInfo(4,i) = 1 'ставим флаг - добавить
strHTML = strHTML & "<tr id=""flm-" & i & """><td width=""75%"">" & arrInfo(0,i) & _
"</td><td width=""10%"">" & arrInfo(1,i) & "</td><td width=""15%"">" & _
DateValue(arrInfo(2,i)) & "</td></tr>"
mainfrm.flinfo.InnerHTML = TableStart & strHTML & TableEnd
With menufrm
.film.Value = arrInfo(0,i)
.year.Value = arrInfo(1,i)
End With
'сортируем по убыванию даты создания
fSort = False
SortArray arrInfo,2,2
ShowInfo 'цвет выставляется здесь
SetEH
End Sub
'устанавливаем цвет строк
Sub SetColor()
Dim colElem, i
Set colElem = mainfrm.tbl.getElementsByTagName("tr")
For i = 0 To colElem.Length-1
'если значение не сохранено в базе
If Not IsEmpty(arrInfo(4,i)) Then colElem(i).bgcolor = cColor
Next
Set colElem = Nothing
End Sub
'удаляем информацию
Sub DelInfo()
With curNode
.childNodes(0).innerHTML = "Удален"
.bgcolor = cColor
'ставим флаг - удалить
arrInfo(4,Mid(.id,5)) = 2
End With
End Sub
'сохраняем информацию
Sub SaveInfo()
Dim xmlDoc, objNewNode, objEditNode, i
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
If xmlDoc.Load(XMLFileName) Then
xmlDoc.documentElement.setAttribute "dt", Now()
For i = 0 To UBound(arrInfo,2)
If Not IsEmpty(arrInfo(4,i)) Then 'если данные изменились
If arrInfo(4,i) = 0 Then 'редактируем
Set objEditNode = xmlDoc.selectSingleNode("//film[@id='" & arrInfo(3,i) &"']")
For j = 0 To 3
objEditNode.Attributes(j).Text = arrInfo(j,i)
Next
Set objEditNode = Nothing
ElseIf arrInfo(4,i) = 1 Then 'добавляем
Set objNewNode = xmlDoc.createElement("film")
With objNewNode
.setAttribute "name", arrInfo(0,i)
.setAttribute "year", arrInfo(1,i)
.setAttribute "date", FormatDateTime(Now(),ddmmyyyyhhmmss)
.setAttribute "id", arrInfo(3,i)
End With
xmlDoc.documentElement.AppendChild(objNewNode)
Set objNewNode = Nothing
ElseIf arrInfo(4,i) = 2 Then 'удаляем
xmlDoc.documentElement.removeChild(xmlDoc.selectSingleNode("//film[@id='" & arrInfo(3,i) &"']"))
End If
End If
Next
xmlDoc.Save(XMLFileName)
Else
MsgBox "Ошибка загрузки файла " & XMLFileName, vbExclamation
End If
Set xmlDoc = Nothing
Erase arrInfo
GetInfo
ShowInfo
SetEH
End Sub
'поиск информации
Sub SearchInfo()
Dim strInput, regEx, i, j, s
If menufrm.find.value = vbNullString Then
MsgBox "Введите строку",vbInformation
Else
strInput = menufrm.find.value
'используем регулярное выражение
Set regEx = New RegExp
With regEx
.Global = True
.IgnoreCase = True
.Pattern = strInput
End With
For i = 0 To UBound(arrInfo,2)
If regEx.Test(arrInfo(0,i)) Then
j = j + 1
s = s & "- " & arrInfo(0,i) & vbCrLf
End If
Next
Set regEx = Nothing
If j Then
MsgBox "Совпадения найдены" & vbCrLf & "Количество: " & j & vbCrLf & s, vbInformation
Else
MsgBox "Совпадений не найдено", vbInformation
End If
End If
End Sub
'нажатие на Enter в строке поиска
Sub SearchInfoOnKey()
If menufrm.event.keyCode=13 Then SearchInfo
End Sub
'нажатие на Enter в ячейках при изменении информации
Sub ChangeInfoOnKey()
If menufrm.event.keyCode=13 Then ChangeInfo
End Sub
'показывываем Help
Sub ShowTip()
menufrm.tip.style.display = "block"
End Sub
'прячем Help
Sub HideTip()
menufrm.tip.style.display = "none"
End Sub
'показываем About
Sub ShowAbout()
menufrm.tip1.style.display = "block"
End Sub
'прячем About
Sub HideAbout()
menufrm.tip1.style.display = "none"
End Sub
'ссылка
Sub OnClickRef()
CreateObject("WScript.Shell").Run "iexplore.exe http://da440dil.narod.ru/about.html"
End SubВ итоге получилось то, что получилось (на скриншотах выше).
Не безупречно, на что свободного времени хватило
. Может использованные приемы кому-нибудь пригодятся.
Скачать можно здесь.

