Option Explicit
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001
Const sTitle = "Ошибка"
Const sChar = ":"
'Параметры подключения
Const sDNS1 ="Dsn=Файлы dBASE;dbq="
Const sDEF2 = ";defaultdir="
Const sPARAM3= ";driverid=533;maxbuffersize=2048;pagetimeout=5"
'Путь к папке, содержащей: accounts.dbf, rectranc.dbf, rectranh.dbf
Const sdbPath ="C:\BACKUP"
'Путь к папке, куда выводятся текстовые файлы
Const outPath = "C:\TEMP"
Dim pConn, pNames, pData, errButton, pItem
Dim sQuery, sFile, fso, pWriter, sOut
errButton = vbExclamation +vbOKOnly
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set pConn = CreateObject("ADODB.Connection")
Set pNames = CreateObject("ADODB.Recordset")
On Error Goto 0
Err.Clear
pConn.Open sDNS1 & sdbPath & sDEF2 & sdbPath & sPARAM3
If Err.Number <> 0 Then MsgBox "Ошибка создания подключения", errButton, sTitle: WScript.Quit
pNames.Open "Select accounts.INOUT From accounts Group By accounts.INOUT", _
pConn, adOpenStatic, adLockOptimistic
If Err.Number <> 0 Then MsgBox "Ошибка чтения таблицы accounts", errButton, sTitle: WScript.Quit
If pNames.RecordCount > 0 Then
Do Until pNames.EOF
pItem = CStr(pNames.Fields.Item("INOUT"))
Set pData = CreateObject("ADODB.Recordset")
pData.Open "Select rectranh.HEAD2, rectranc.NFACC, rectranc.NAME, accounts.ENDSUM From accounts, rectranc, rectranh Where (accounts.TNUM = rectranc.TNUM) And (rectranc.CODE = rectranh.CODE) And (accounts.INOUT = '" & _
pItem & "')", pConn, adOpenStatic, adLockOptimistic
If pData.RecordCount > 0 Then
sFile = fso.BuildPath(outPath, pItem & ".txt")
Set pWriter = fso.CreateTextFile(sFile, True)
Do Until pData.EOF
sOut = pData.Fields.Item("HEAD2") & sChar
sOut = sOut & pData.Fields.Item("NFACC") & sChar
sOut = sOut & pData.Fields.Item("ENDSUM") & sChar
sOut = sOut & pData.Fields.Item("NAME")
pWriter.WriteLine sOut
pData.MoveNext
Loop
pWriter.Close
End If
pNames.MoveNext
Loop
pConn.Close
MsgBox "Выполнено"
Else
pConn.Close
MsgBox "Таблица acconts не содержит записей", errButton, sTitle
End If
|
