<head>
<meta http-equiv="content-type" content="text/html; charset=windows-1251">
<hta:application id="hta" applicationname="AlcDeclList"
contextmenu="yes"
innerborder="no"
maximizebutton="yes"
minimizebutton="yes"
navigable="yes"
scroll="no"
scrollflat="yes"
selection="no"
showintaskbar="yes"
singleinstance="no"
sysmenu="yes"
version="1.0"
windowstate="normal"
>
<title>Поставщики</title>
<style>
Body {
background-color: buttonface;
font-family: Arial;
font-size: 14;
cursor: arrow;
}
</style>
<script language="vbscript">
Function Fill_Dict_TextBox() 'Вызов диалога
dim objDic
Set objDic = CreateObject("Scripting.Dictionary")
objDic.Add "Description", "Заполните реквизиты поставщика"
objDic.Add "OwID", ListView1.SelectedItem.Text
objDic.Add "BtnFinish", True
Set Fill_Dict_TextBox = objDic
set objDic = Nothing
End Function
Sub Window_Onload 'Заполнение заголовков
ListView1.ColumnHeaders.Add , , "Id", 35
ListView1.ColumnHeaders.Add , , "Наименование", 170
ListView1.ColumnHeaders.Add , , "Серия", 70
ListView1.ColumnHeaders.Add , , "Номер", 70
ListView1.ColumnHeaders.Add , , "Дата", 90
ListView1.ColumnHeaders.Add , , "Кем выдана", 140
ListView1.ColumnHeaders.Add , , "Субьект РФ", 100
ListView1.ColumnHeaders.Add , , "Код страны", 90
self.Focus()
End Sub
Sub ListView1_KeyPress(Key) 'Недопиленый кусок для поиска по первой букве наименования
FndIt = Chr(key)
end Sub
Sub ListView1_ColumnClick(ColumnHeader) ' Сортировка по содержимому столбца
Location.Reload(True)
With ListView1
.Sorted = False
.SortKey = ColumnHeader.Index - 1
If .SortOrder = 0 Then
.SortOrder = 1
Else
.SortOrder = 0
End If
.Sorted = True
End With
End Sub
Sub AddItem(ID, Name, Serial, Number, Dat, Kv, Subekt, Kod) ' Добавление данных
With ListView1.ListItems.Add(, , ID)
With .ListSubItems
.Add ,, Name
.Add ,, Serial
.Add ,, Number
.Add ,, dat
.Add ,, Kv
.Add ,, Subekt
.Add ,, Kod
End With
End With
End Sub
Sub ListView1_DblClick() 'Реакция на двойной клик
'msgbox ListView1.SelectedItem.Text
varReturn = window.ShowModalDialog("OwForm.hta", Fill_Dict_TextBox, "dialogHeight:300px;dialogWidth:400px")
ListView1.ListItems.Clear()
call ReadSQLdata 'Вызов чтения из БД. Нужен чтобы обновить содержимое таблицы перезаполняя её.
' Тут то собака зарыта. Если бы получилось затолкать измененные данные в ListView, но не выходит.
end sub
</script>
<body scroll="NO" style="text-align: center">
<OBJECT ID="ListView1" WIDTH=800 HEIGHT=450
CLASSID="CLSID:BDD1F04B-858B-11D1-B16A-00C0F0283628">
<PARAM NAME="_ExtentX" VALUE="21167">
<PARAM NAME="_ExtentY" VALUE="13229">
<PARAM NAME="SortKey" VALUE="1">
<PARAM NAME="View" VALUE="3">
<PARAM NAME="LabelEdit" VALUE="1">
<PARAM NAME="Sorted" VALUE="-1">
<PARAM NAME="LabelWrap" VALUE="-1">
<PARAM NAME="HideSelection" VALUE="-1">
<PARAM NAME="OLEDragMode" VALUE="1">
<PARAM NAME="OLEDropMode" VALUE="1">
<PARAM NAME="AllowReorder" VALUE="-1">
<PARAM NAME="FullRowSelect" VALUE="1">
<PARAM NAME="GridLines" VALUE="-1">
<PARAM NAME="HoverSelection" VALUE="-1">
<PARAM NAME="_Version" VALUE="393217">
<PARAM NAME="ForeColor" VALUE="-2147483640">
<PARAM NAME="BackColor" VALUE="-2147483643">
<PARAM NAME="Appearance" VALUE="0">
<PARAM NAME="OLEDragMode" VALUE="1">
<PARAM NAME="OLEDropMode" VALUE="1">
<PARAM NAME="NumItems" VALUE="0">
</OBJECT>
<script language="vbscript">
call ReadSQLdata
Sub ReadSQLdata
Set IBConn = CreateObject("ADODB.Connection")
Set WshShell = CreateObject("WScript.Shell")
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(WshShell.CurrentDirectory)
Set objFolderItem = objFolder.Self
Set DBConn = CreateObject("ADODB.Connection")
Set objFS = CreateObject("Scripting.FileSystemObject")
Path = objFolderItem.Path + "\"
strFilePath = Path+"fb.ini" ' База данных Firebird
Set objTS = objFS.OpenTextFile(strFilePath, 1)
objTS.SkipLine
objTS.SkipLine
'===================================
Udlread=objTS.Readline ' Читаем параметры подключения
IBConn.Open(Udlread)
strFilePath = Path+"OWqery.sql"
Set SQLf = objFS.OpenTextFile(strFilePath, 1)
SQLstr = SQLf.ReadAll ' Читаем файл с запросом
Set objRecordset = IBConn.Execute(SQLstr) ' Выполняется запрос
'===================================
Dim Qery (10)
While Not objRecordset.EOF
For i=1 To objRecordset.Fields.Count
If IsNull( objRecordset.Fields(i-1).Value) Then
Qery(i) = ""
Else
Qery(i) = Cstr(objRecordset.Fields(i-1).Value)
End If
Next
Call Additem (Qery(1), Qery(2), Qery(3), Qery(4), Qery(5), Qery(6), Qery(7), Qery(8))'Запрос возвращает 8 элементов, которые мы пишем в таблицу
objRecordset.MoveNext
Wend
end sub
</script>
</body>
</html>
Такой вот код.
