DenSyo
Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
'скрипт открывает в выбранной папке все файлы CSV и XLS и пересохраняет их в XLSX
'Excel.Workbooks.Add XlWBATemplate values
Const xlWBATWorksheet = -4167
'Excel.Workbooks.QueryTables.Add constants
Const xlDelimited = 1
Const xlFixedWidth = 2
Const xlInsertDeleteCells = 1
Const xlTextQualifierDoubleQuote = 1
Dim objShell: Set objShell = CreateObject("Wscript.Shell")
Dim objFolder, objBrowFolder, objFSO, FileItem, objExcel, wbr, wsr
Dim startRow: startRow = 1 ' читать CSV с первой строки
Dim fieldNames: fieldNames = True ' CSV имеет имена полей
Dim codePage: codePage = CLng(objShell.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\CodePage\ACP"))
Dim RegionalDelimiter: RegionalDelimiter = objShell.RegRead("HKCU\Control Panel\International\sList")
Dim SemicolonDelimiter: If RegionalDelimiter = ";" Then SemicolonDelimiter = True Else SemicolonDelimiter = False
Dim CommaDelimiter: If RegionalDelimiter = "," Then CommaDelimiter = True Else CommaDelimiter = False
Dim SpaceDelimiter: If RegionalDelimiter = " " Then SpaceDelimiter = True Else SpaceDelimiter = False
Dim TabDelimiter: If RegionalDelimiter = Chr(9) Then TabDelimiter = True Else TabDelimiter = False
Dim OtherDelimiter: If SemicolonDelimiter Or CommaDelimiter Or SpaceDelimiter Or TabDelimiter Then OtherDelimiter = "" Else OtherDelimiter = RegionalDelimiter
Dim ConsecutiveDelimiter: ConsecutiveDelimiter = False
Dim TextQualifier: TextQualifier = xlTextQualifierDoubleQuote
Dim fileFixedWidth: fileFixedWidth = False
Dim fileDelimited: fileDelimited = True
Dim widthArr, typesArr
Dim doErase: doErase = False
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set objBrowFolder = objShell.BrowseForFolder(0, "Select folder for convert files", 0, "")
Set objFolder = objFSO.GetFolder(objBrowFolder.Self.Path)
If Err.Number = 0 Then
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Or objExcel Is Nothing Then Set objExcel = WScript.CreateObject("Excel.Application")
On Error GoTo 0
objExcel.Visible = False
objExcel.Application.DisplayAlerts = False
If MsgBox("Конвертировать все файлы в " & objFolder & " ?", vbYesNo, "Convert all files?") = vbYes Then
If MsgBox("Удалить все исходные файлы после конвертации ?", vbYesNo, "Delete all converted files?") = vbYes Then doErase = True
For Each FileItem In objFolder.Files
If LCase(objFSO.GetExtensionName(FileItem)) = "csv" Then
Set wbr = objExcel.WorkBooks.Add(xlWBATWorksheet)
Set wsr = wbr.Sheets(1)
With wsr.QueryTables.Add("TEXT;" & FileItem.Path, wsr.Range("$A$1"))
.Name = FileItem.Name
.FieldNames = fieldNames
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = codePage
.TextFileStartRow = startRow
If fileFixedWidth Then .TextFileParseType = xlFixedWidth Else .TextFileParseType = xlDelimited
.TextFileTextQualifier = TextQualifier
.TextFileConsecutiveDelimiter = ConsecutiveDelimiter
.TextFileTabDelimiter = TabDelimiter
.TextFileSemicolonDelimiter = SemicolonDelimiter
.TextFileCommaDelimiter = CommaDelimiter
.TextFileSpaceDelimiter = SpaceDelimiter
If OtherDelimiter <> "" Then .TextFileOtherDelimiter = OtherDelimiter
If IsArray(typesArr) Then .TextFileColumnDataTypes = typesArr
If fileFixedWidth And IsArray(widthArr) Then .TextFileFixedColumnWidths = widthArr
.TextFileTrailingMinusNumbers = True
.Refresh False
End With
wbr.SaveAs FileItem.ParentFolder & "\" & objFSO.GetBaseName(FileItem) & ".xlsx", 51
wbr.Close False
Set wbr = Nothing
If doErase Then objFSO.DeleteFile FileItem.Path, True
ElseIf LCase(objFSO.GetExtensionName(FileItem)) = "xls" Then
Set wbr = objExcel.WorkBooks.Open(FileItem.Path)
wbr.SaveAs FileItem.ParentFolder & "\" & objFSO.GetBaseName(FileItem) & ".xlsx", 51
wbr.Close False
Set wbr = Nothing
If doErase Then objFSO.DeleteFile FileItem.Path, True
End If
Next
MsgBox "Конвертирование закончено", vbOKOnly, "Convert finished"
End If
objExcel.Application.DisplayAlerts = True
objExcel.Visible = True
End If |
Всего записей: 218 | Зарегистр. 19-01-2008 | Отправлено: 07:15 20-09-2019 | Исправлено: DenSyo, 07:18 20-09-2019 |
|
