Mam problem z jednym makrem którego niestety nie mogę przekonwertować na libreoffice. Makro jest napisane przez informatyków w firmie z którą współpracuję i niestety nie mam możliwości z nimi się skontaktować. Makro to jest niezbędne do prawidłowego zaksięgowania kwot w banku a zależy mi aby używać go w libreoffice a nie w excelu. Pracuję na Kubuntu 11.10 o ile ma to jakieś znaczenie.
Zaznaczam, że makro działało w wersji libreoffice3,6 natomiast wysypuje się w wersji 4.1. Makro to zapisuje dane do pliku o rozszerzeniu csv. Problem pojawia się przy nadaniu nazwy pliku.
Kod: Zaznacz cały
Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Option Explicit
Const SEPARATOR_POL As String = ","
Const SEPARATOR_NAZ As String = "_"
Const FORMAT_DATY As String = "YYYYMMDD"
Const FORMAT_CZASU As String = "HHMMSS"
Const FORMAT_KWOTY As String = "0.00"
Public Sub ZapiszDaneJakoCSV()
On Local Error GoTo ZapiszDaneJakoCSV_ErrH
Dim mess As String
Dim nazwaPliku As String
Dim np As Long
Dim r As Long, i As Long
Dim linia As String, wartoscJakoString As String
Dim sk As Long
If ActiveWorkbook.ActiveSheet.Range("B2").Value = "" Then mess = mess & vbCrLf & " - brak numeru agenta"
If ActiveWorkbook.ActiveSheet.Range("C2").Value = "" Then mess = mess & vbCrLf & " - brak kwoty wpłaty zbiorczej"
If ActiveWorkbook.ActiveSheet.Range("D2").Value = "" Then mess = mess & vbCrLf & " - brak daty dokonania wpłaty zbiorczej"
If ActiveWorkbook.ActiveSheet.Range("G12").Value <> "" Then mess = mess & vbCrLf & " - niespełniony warunek zgodności kwoty zbiorczej z sumą kwot transakcji!"
For r = 4 To 1000
If ((ActiveWorkbook.ActiveSheet.Cells(r, 1) <> "") Or (ActiveWorkbook.ActiveSheet.Cells(r, 2) <> "") Or (ActiveWorkbook.ActiveSheet.Cells(r, 3) <> "") Or (ActiveWorkbook.ActiveSheet.Cells(r, 4) <> "")) And Not ((ActiveWorkbook.ActiveSheet.Cells(r, 1) <> "") And (ActiveWorkbook.ActiveSheet.Cells(r, 2) <> "") And (ActiveWorkbook.ActiveSheet.Cells(r, 3) <> "") And (ActiveWorkbook.ActiveSheet.Cells(r, 4) <> "")) Then mess = mess & vbCrLf & " - niekompletne dane w wierszu " & CStr(r)
Next r
If mess <> "" Then
MsgBox "Przed zapisaniem pliku proszę poprawić następujące błędy:" & vbCrLf & mess, vbOKOnly + vbExclamation, "Błąd"
Exit Sub
End If
nazwaPliku = Application.GetSaveAsFilename(ActiveWorkbook.ActiveSheet.Cells(2, 2) & SEPARATOR_NAZ & Format(ActiveWorkbook.ActiveSheet.Cells(2, 4), FORMAT_DATY) & SEPARATOR_NAZ & (ActiveWorkbook.ActiveSheet.Cells(2, 19)) & "PLN" & SEPARATOR_NAZ & Format(Date, FORMAT_DATY) & SEPARATOR_NAZ & Format(Time(), FORMAT_CZASU), "Pliki z wartościami rozdzielanymi przecinkami (*.csv), *.csv", 0, "Wskaż gdzie i pod jaką nazwą zapisać plik")
np = FreeFile
Open nazwaPliku For Output As np
Print #np, ActiveWorkbook.ActiveSheet.Cells(2, 1) & SEPARATOR_POL & ActiveWorkbook.ActiveSheet.Cells(2, 2) & SEPARATOR_POL & KropkaWKwocie(Format$(ActiveWorkbook.ActiveSheet.Cells(2, 3), FORMAT_KWOTY)) & SEPARATOR_POL & Format$(ActiveWorkbook.ActiveSheet.Cells(2, 4), FORMAT_DATY)
sk = 13
wartoscJakoString = CStr(ActiveWorkbook.ActiveSheet.Cells(2, 1))
For i = 1 To Len(wartoscJakoString)
sk = sk + Asc(Mid$(wartoscJakoString, i, 1))
Next i
wartoscJakoString = CStr(ActiveWorkbook.ActiveSheet.Cells(2, 2))
For i = 1 To Len(wartoscJakoString)
sk = sk + Asc(Mid$(wartoscJakoString, i, 1))
Next i
wartoscJakoString = KropkaWKwocie(Format$(ActiveWorkbook.ActiveSheet.Cells(2, 3), FORMAT_KWOTY))
For i = 1 To Len(wartoscJakoString)
sk = sk + Asc(Mid$(wartoscJakoString, i, 1))
Next i
wartoscJakoString = Format$(ActiveWorkbook.ActiveSheet.Cells(2, 4), FORMAT_DATY)
For i = 1 To Len(wartoscJakoString)
sk = sk + Asc(Mid$(wartoscJakoString, i, 1))
Next i
For r = 4 To 1000
If ActiveWorkbook.ActiveSheet.Cells(r, 1) & SEPARATOR_POL & ActiveWorkbook.ActiveSheet.Cells(r, 2) & SEPARATOR_POL & ActiveWorkbook.ActiveSheet.Cells(r, 3) & SEPARATOR_POL & ActiveWorkbook.ActiveSheet.Cells(r, 4) <> SEPARATOR_POL & SEPARATOR_POL & SEPARATOR_POL Then
linia = ActiveWorkbook.ActiveSheet.Cells(r, 1) & SEPARATOR_POL & ActiveWorkbook.ActiveSheet.Cells(r, 2) & SEPARATOR_POL & KropkaWKwocie(Format$(ActiveWorkbook.ActiveSheet.Cells(r, 3), FORMAT_KWOTY)) & SEPARATOR_POL & Format$(ActiveWorkbook.ActiveSheet.Cells(r, 4), FORMAT_DATY)
Print #np, linia
wartoscJakoString = CStr(ActiveWorkbook.ActiveSheet.Cells(r, 1))
For i = 1 To Len(wartoscJakoString)
sk = sk + Asc(Mid$(wartoscJakoString, i, 1))
Next i
wartoscJakoString = CStr(ActiveWorkbook.ActiveSheet.Cells(r, 2))
For i = 1 To Len(wartoscJakoString)
sk = sk + Asc(Mid$(wartoscJakoString, i, 1))
Next i
wartoscJakoString = KropkaWKwocie(Format$(ActiveWorkbook.ActiveSheet.Cells(r, 3), FORMAT_KWOTY))
For i = 1 To Len(wartoscJakoString)
sk = sk + Asc(Mid$(wartoscJakoString, i, 1))
Next i
wartoscJakoString = Format$(ActiveWorkbook.ActiveSheet.Cells(r, 4), FORMAT_DATY)
For i = 1 To Len(wartoscJakoString)
sk = sk + Asc(Mid$(wartoscJakoString, i, 1))
Next i
End If
Next r
Print #np, CStr(sk)
Close np
ActiveWorkbook.Saved = True
MsgBox "Dziękujemy, dane zostały pomyślnie zapisane do pliku " & nazwaPliku & vbCrLf & "Prosimy o przesłanie tego pliku do Banku według uzgodnionej procedury.", vbInformation + vbOKOnly
Exit Sub
ZapiszDaneJakoCSV_ErrH:
Close
MsgBox "Zapis danych do pliku " & nazwaPliku & " nie powiódł się!" & vbCrLf & "Proszę sprawdzić czy na dysku jest wystarczająca ilość wolnego miejsca oraz czy nie jest zabezpieczony przed zapisem.", vbExclamation + vbOKOnly
End Sub
Public Function KropkaWKwocie(ByVal kwota As String) As String
Dim pozycjaPrzecinka As Long
Mid(kwota, Len(kwota) - 2, 1) = "."
KropkaWKwocie = kwota
End Function