В этом задании Я покажу, как сделать поиск в dbf файле и заменить данные согласно этому поиску. Для этого будут применены InputBox и Popup. Все это будет делаться через ADOX, хотя это можно сделать и через ADO. Что удобней это приоритет, который выбираете сами. Строку подключения также можете выбирать, которая удобна.
Здесь, по сути, происходит заданный поиск последовательного доступа. Причем, поиск чем-то немного напоминает поиск данных как в EXCEL, но нет выбора из найденных строк. Просто происходит последовательный выбор найденных данных и замена их данными, которые будут указаны для этого. Также применяется фильтр в определении количества заменяемых данных. Запись можно пропустить и в режиме поиска перейти к другой записи. Можно остановить поиск. Данные для замены могут быть разными и задачи поиска могут быть тоже разными. Этот скрипт - демонстрация поиска и замены данных в dbf файле с использованием приглашений и подачи. Поиск происходит в столбце-колонки st2 и там же происходит замена. Для просмотра файла Я предоставил приложение WDBFVIEW.EXE
Предоставляю файл Adox4A.vbs
По ходу приложу некоторые комментарии.
'*******************************************************************
' Имя: Adox4A.vbs
' Язык: VBScript
' Описание: Поиск и замена в DBF файле
' ADO,ADOX
'*******************************************************************
Set WshShell=WScript.CreateObject("WScript.Shell")
SDefaultDir=WshShell.CurrentDirectory
Set FSO = CreateObject("Scripting.FileSystemObject")
FilDbfIst="_222.dbf"
PosS=InStr(1,FilDbfIst, UCase(".dbf"), 1)
ImFilFilDbf=Mid(FilDbfIst,1,PosS-1)
NameFilSozDBF=SDefaultDir & "\" & FilDbfIst 'Уже есть файл
'========== Проверка файла
If FSO.FileExists(NameFilSozDBF) Then
else
MsgBox "Нет файла "&NameFilSozDBF
WScript.Quit
end if
'========== Проверка файла
Set cat = Createobject("ADOX.Catalog")
'+++++++++++++++++++++++++++++++++++++++++
cat.ActiveConnection = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SDefaultDir & ";" & _
"Extended Properties=dBase IV;"
'+++++
'Можно подключить строку Driver
' cat.ActiveConnection="Driver={Microsoft dBase Driver (*.dbf)};DBQ=" & SDefaultDir & ";Deleted=0;ReadOnly=0;Exclusive=1;"
'+++++
Set oCon = cat.ActiveConnection
oCon.CursorLocation = 3
strSQLdbf="SELECT * FROM " & NameFilSozDBF & " "
Set RS = oCon.Execute(strSQLdbf)
KlFieldsN = RS.Fields.count
KlRecsN=RS.RecordCount
if KlRecsN<=0 then
WScript.Echo("В файле " & NameFilSozDBF & " нет записей")
WScript.Quit
end if
'======================================== Поиск всех данных по выборке
Set RSN=WScript.CreateObject("ADODB.Recordset")
strSQLDbf="SELECT * FROM " & NameFilSozDBF & " "
RSN.open strSQLDbf,oCon,2,2
RSN.Requery
'On Error Resume Next 'Проверка ошибок
NomPozRSN=0 'Начальный номер позиции
RSN.MoveFirst
Do until Trim(st2)<>""
'Применяем InputBox
' Вводим число 45 для поиска и последующей замены
TITLE ="Поиск в поле ST2"
StDn = InputBox("Файл" & vbCrLf & NameFilSozDBF & vbCrLf & "Записей " & KlRecsN & vbCrLf & vbCrLf & "Введите данные для поиска" , TITLE)
if IsEmpty(StDn) then
MsgBox "Вы нажали Отмена!"
' WshShell.Run SDefaultDir & "\WDBFVIEW.exe " & SDefaultDir & "\" & FilDbfIst & " ",1,True
WScript.Quit
end if
'================ Фильтр =========
RSN.filter="[st2]='" & StDn &"'" 'Если поле имеет целое значение то опострофы можно убрать
Kzap=RSN.RecordCount ' кол. отобранных записей
RSN.filter=0 ' Отменяет фильтр
'================ Фильтр =========
if trim(StDn)="" Then
WScript.Echo("Вы не сделали ввод. Продолжение - любая клавиша.")
else
'777777777777777777777777777777777777777777777777777777777
kFn=0 'Количество найденых строк
for i=1 to KlRecsN
if trim(Kzap)=0 then
wscript.echo("Нет таких данных!")
exit for
end if
RSN.Find "[st2] = '" & Trim(StDn) & "'",NomPozRSN, 1, 1
NomPozRSN=RSN.AbsolutePosition
'kkkkkkkkkkkkkkkkkkkkkkkkkkkk
if RSN.fields("st2")=StDn then
kFn=kFn+1
'Применяем InputBox Сделаем замену числа 45 числом 34
TITLE ="Замена в поле ST2 величины " & StDn
StZam = InputBox("Всего данных " & Kzap & vbCrLf& "Строка " & NomPozRSN & vbCrLf& "По счету " & kFn & vbCrLf& "st2=" & StDn & vbCrLf & vbCrLf& "Введите новые данные для замены" , TITLE)
if IsEmpty(StZam) then
MsgBox "Вы нажали отмена поиска!"
exit for
end if
if trim(StZam)="" Then
WScript.Echo("Вы не сделали ввод. Продолжение - любая клавиша.")
exit for
else
St1Dem=RSN.Fields("st1").value
'Применяем Popup. Можно установить время, в течение которого будет отображаться всплывающее окно сообщения. Я не вводил время и если необходимо можете ввести.
'По ходу показываем сопутствующие данные поиска. Делаем свой выбор.
BtnCode = WshShell.Popup("Всего данных " & Kzap & vbCrLf& "Замена " & StDn & " на " & StZam& vbCrLf & "Позиция строки " & NomPozRSN& vbCrLf & "По счету " & kFn& vbCrLf &_
"st2=" & StDn & vbCrLf & St1Dem & vbCrLf & vbCrLf & "Продолжить - повторить?",, "Ваш выбор:", 2 + 32)
'if BtnCode=-1 then 'Прервать по времени максимальной продолжительности отображения окна. Указывается в секундах.
' exit for
'end if
if BtnCode=3 then 'Прервать
exit for
end if
if BtnCode=4 then 'Продолжить
'++++++++++++++++++++++++++++++++++++++ Можно и так
'ImColSt=Cat.Tables(ImFilFilDbf).Columns.Item(2) 'работает
'ImColSt=Cat.Tables(ImFilFilDbf).Columns.Item("ST2") 'работает
'ImColSt=Cat.Tables(ImFilFilDbf).Columns(2).Name 'работает
'ImColSt=Cat.Tables(ImFilFilDbf).Columns(2) 'работает
'for jk=1 to Cat.Tables(ImFilFilDbf).Columns.Count
' if Cat.Tables(ImFilFilDbf).Columns(jk)="ST2" then
' ImColStr=jk
' exit for
' end if
' next
' jk=0
'RSN.Fields(ImColStr).value=StZam
'++++++++++++++++++++++++++++++++++++++
' RSN.Fields(2).value=StZam 'Можно и так
RSN.Fields("st2").value=StZam
RSN.Update
RSN.Requery
WshShell.Run SDefaultDir & "\WDBFVIEW.exe " & SDefaultDir & "\" & FilDbfIst & " ",1,True
end if
if BtnCode=5 then 'Игнорировать
' WScript.Echo("Пропустить")
end if
if Kzap=kFn then
wscript.echo("Поиск и замена закончена!")
exit for
end if
end if
end if
'kkkkkkkkkkkkkkkkkkkkkkkkkkkk
RSN.AbsolutePosition=NomPozRSN
NomPozRSN=RSN.AbsolutePosition
RSN.MoveNext
next
RSN.MoveFirst
NomPozRSN=RSN.AbsolutePosition
RSN.AbsolutePosition=NomPozRSN
'777777777777777777777777777777777777777777777777777777777
end if
Loop
'On Error goto 0
Set RSN = Nothing
RSN.close
Set RS = Nothing
RS.close
WScript.Quit
Остальное как обычно.
Перед запуском скрипта файл _222.dbf сохраните в другом каталоге для повторного применения, если случайно испортите или удалите. Файл WDBFVIEW.exe Я добавлю в эту подборку. Процесс поиска и замены данных в dbf файлов требует времени и зависит от объема файла и мощности компьютера.
Файлы сохранил в архив Занятие4.rar
Пробуйте.
Ссылка на файл https://disk.yandex.ru/d/i4FQljIyl47ASA
Подписывайтесь на мой канал и ставьте лайки.
