Костыль №1 Перевод DBF в XLS

Решил поделиться своими костылями 🙂 Очень часто приходиться писать маленькие программки (костыли), которые выполняют какую-то рутинную работу.

И так костыль №1. Появилась задача перевести кучу dbf файлов в xls с последующим редактированием. Конечно существуют программы, которые перекодируют dbf в xls, но они платные и не позволяют производить редактирования внутри файла. Поэтому выбор мой пал на Open Office и встроенный Basic.

Данный макрос берет файлы dbf из папки C:\TEMP\detail\ и кладет XLS в C:\TEMP\detail\XLS\ . Вы можете поправить на свои пути.

Sub Main

Dim NextFile As String
NextFile = Dir("C:\TEMP\detail\*.dbf", 0)

While NextFile <> ""

cDbfFileToOpen = "C:\TEMP\detail\" + NextFile
cXlsFileToSave = "C:\TEMP\detail\XLS\" + NextFile
ResultString = InStr(1, cXlsFileToSave, "dbf")
Mid(cXlsFileToSave, ResultString, 3, "XLS")

'Открываем DBF
cURLDBF = ConvertToURL( cDbfFileToOpen )
oCalcDoc = StarDesktop.loadComponentFromURL( cURLDBF, "_blank", 0, _
Array( MakePropertyValue( "FilterName", "dBase" ),_
MakePropertyValue( "FilterOptions", "30" )) )

'Удаляем 2 первых столбца
Sheet = oCalcDoc.Sheets(0)
Sheet.Columns.removeByIndex(0, 2)

'Удаляем еще 4 столбца
Sheet.Columns.removeByIndex(1, 2)
Sheet.Columns.removeByIndex(3, 1)
Sheet.Columns.removeByIndex(6, 1)

'Изменяем формат столбцов 7 и 8
Dim NumberFormats As Object
Dim NumberFormatString As String
Dim NumberFormatId As Long
Dim LocalSettings As New com.sun.star.lang.Locale

LocalSettings.Language = "ru"
LocalSettings.Country = "ru"

NumberFormats = oCalcDoc.NumberFormats
NumberFormatString = "# ##0,00 [$руб.-419];[RED]-# ##0,00 [$руб.-419]"

NumberFormatId = NumberFormats.addNew(NumberFormatString, LocalSettings)

Col = Sheet.Columns(7)
Col.NumberFormat = NumberFormatId
Col.OptimalWidth = True
'Выравнивание столбца по центру
Col.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER

Col = Sheet.Columns(8)
Col.NumberFormat = NumberFormatId
Col.OptimalWidth = True

'Изменяем название столбцов
Cell = Sheet.getCellByPosition(0, 0)
Cell.String = "Первый столбец"

Cell = Sheet.getCellByPosition(1, 0)
Cell.String = "Второй"

Cell = Sheet.getCellByPosition(2, 0)
Cell.String = "Третий"

Cell = Sheet.getCellByPosition(3, 0)
Cell.String = "Четвертый"

Cell = Sheet.getCellByPosition(4, 0)
Cell.String = "Пятый"

Cell = Sheet.getCellByPosition(5, 0)
Cell.String = "Шестой"

Cell = Sheet.getCellByPosition(6, 0)
Cell.String = "Седьмой"

Cell = Sheet.getCellByPosition(7, 0)
Cell.String = "Восьмой"

'Выставляем оптимальную ширину столбцов
For I = 0 To 7
Col = Sheet.Columns(I)
Col.OptimalWidth = True
Next I

Col = Sheet.Columns(2)
Col.Width = 5000

'Сохраняем в XLS
cURLXLS = ConvertToURL( cXlsFileToSave )
oCalcDoc.storeToURL( cURLXLS, _
Array( MakePropertyValue( "FilterName", "MS Excel 97" ) ) )

oCalcDoc.close( True )

NextFile = Dir
Wend

End Sub

Function MakePropertyValue( Optional cName As String, Optional uValue ) As com.sun.star.beans.PropertyValue
Dim oPropertyValue As New com.sun.star.beans.PropertyValue
If Not IsMissing( cName ) Then
oPropertyValue.Name = cName
EndIf
If Not IsMissing( uValue ) Then
oPropertyValue.Value = uValue
EndIf
MakePropertyValue() = oPropertyValue
End Function