Еще один вариант vbs. Можно обработать как отдельный файл, так и папку с файлами.
Код:
InName = "Z:\Soft_Arc\Пример обработки сертификата" ' Путь обрабатываемой папки, если он не передаётся в аргументе
'InName = "Z:\Soft_Arc\Пример обработки сертификата\Петров Иван Иванович.txt" ' Путь обрабатываемого файла, если он не передаётся в аргументе
With WScript.Arguments
If .Count <> 0 Then
InName = .Item(0)
End If
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
Look = 0
If (FSO.FolderExists(InName)) Then Look = 1
If (FSO.FileExists(InName)) Then Look = 2
If Look = 0 Then
MsgBox "Not found:" + vbCrLf + vbCrLf + InName, 16, "Error"
WScript.Quit 1
End If
Ext = "txt" ' Расширение файлов при обработке папки
R1 = "B3" ' Начало заголовка генерируемой таблицы
' Перечисление параметров в заголовке
Param = Array("Имя файла", _
"Серийный номер", _
"СНИЛС", _
"ОГРН", _
"ИНН", _
"Адрес, улица", _
"Электронная почта", _
"Город", _
"Должность", _
"Подразделение", _
"Организация", _
"Имя")
N0 = LBound(Param)
NN = UBound(Param)
Set XL = CreateObject("Excel.Application")
XL.Visible = True
XL.Workbooks.Add
Call HeadLine(XL, R1, Param, N0, NN)
ii = 0
If Look = 2 Then
Call InTable(XL, R1, Param, N0, NN, FSO, InName, ii)
Else
On Error Resume Next
LErr = 0
With FSO.GetFolder(InName)
LErr = Not Err.Number <> 0
If Not LErr Then
MsgBox "Error open folder " + vbCrLf + vbCrLf + InName + vbCrLf + vbCrLf + "Err.Number " + CStr(Err.Number) + vbCrLf + Err.Description, 16, "Error"
WScript.Quit 1
Else
For Each InFile In .Files
If LCase(Ext) = LCase(FSO.GetExtensionName(InFile)) Then Call InTable(XL, R1, Param, N0, NN, FSO, InFile, ii)
Next
End If
End With
On Error GoTo 0
End If
XL.Columns(Replace(XL.Range(R1).Address, "$" + CStr(XL.Range(R1).Row), ":") + Replace(XL.Range(R1).Offset(0, NN - N0).Address, "$" + CStr(XL.Range(R1).Row), "")).EntireColumn.AutoFit
Sub HeadLine(XL, R1, Param, N0, NN) ' ---- Формируем заголовок таблицы
For i = N0 To NN
With XL.Range(R1).Offset(0, i - N0)
.Formula = Param(i)
.HorizontalAlignment = -4108
.VerticalAlignment = -4108
.Font.FontStyle = "полужирный"
.Borders(7).Weight = -4138
.Borders(8).Weight = -4138
.Borders(9).Weight = -4138
.Borders(10).Weight = -4138
End With
Next
End Sub
Sub InTable(XL, R1, Param, N0, NN, FSO, InName, ii) ' ---- Содержимое файла помещаем в строку таблицы
On Error Resume Next
LErr = 0
With FSO.OpenTextFile(InName, 1)
LErr = Not Err.Number <> 0
If Not LErr Then
MsgBox "Error open file " + vbCrLf + vbCrLf + InName + vbCrLf + vbCrLf + "Err.Number " + CStr(Err.Number) + vbCrLf + Err.Description
Exit Sub
Else
InTxt = .ReadAll
LErr = Not Err.Number <> 0
If Not LErr Then
MsgBox "Error read file " + vbCrLf + vbCrLf + InName + vbCrLf + vbCrLf + "Err.Number " + CStr(Err.Number) + vbCrLf + Err.Description
Exit Sub
End If
End If
.Close
End With
On Error GoTo 0
j1 = InStr(1, InTxt, vbCrLf + Param(N0 + 1))
If j1 > 0 Then
j1 = InStr(j1 + 1, InTxt, vbCrLf)
j1 = InStr(j1 + 1, InTxt, vbCrLf) + 2
j2 = InStr(j1, InTxt, vbCrLf)
jj1 = InStr(j2, InTxt, vbCrLf + "Субъект")
jj1 = InStr(jj1 + 1, InTxt, vbCrLf)
jj1 = InStr(jj1 + 1, InTxt, vbCrLf) + 2
jj2 = InStr(jj1, InTxt, vbCrLf + "-------")
ii = ii + 1
With XL.Range(R1)
.Offset(ii, 0) = FSO.GetFileName(InName)
.Offset(ii, 1) = Trim(Mid(InTxt, j1, j2 - j1 + 1))
InTxt = Mid(InTxt, jj1, jj2 - jj1 + 1)
For i = N0 + 2 To NN
j1 = InStr(1, InTxt, Param(i) + ":")
If j1 <> 0 Then
j1 = InStr(j1, InTxt, ":")
j2 = InStr(j1, InTxt, vbCrLf)
.Offset(ii, i - N0) = Mid(InTxt, j1 + 1, j2 - j1)
End If
Next
End With
End If
End Sub
Путь к каталогу или файлу задаётся аргументом скрипта (также можно просто перетянуть папку или файл на скрипт в Проводнике), либо, при отсутствии аргумента, явно в скрипте. Поскольку предназначено для ручной работы — сохранение Рабочей книги оставил Вам на откуп.
Я счёл необходимым добавить в Excel-таблицу поле с именем файла.
|
