Konwersja makr z VBA do StarBasic

Użytkowanie arkusza kalkulacyjnego

Konwersja makr z VBA do StarBasic

Postprzez Husar » Śr kwi 10, 2013 10:54 am

Witam,
znalazłem sobie skoroszyt w Excel'u, który pobiera kursy walut NBP. Jako niewolnik CHF-ów :-) bardzo mi się przyda ten skoroszyt w Calc. Mam problem z konwersją z VBA do StarBasic'a. Z góry dziękuję za pomoc. Dołączam oryginalny skoroszyt.

A to makra:

Kod: Zaznacz cały   Rozszerz widokZwiń widok
Option Explicit
Sub Waluty()
Dim rName As Name
Dim ost, i As Long
Dim tabela, nrTabeli As String
Dim data_tabeli As Date
Dim Index
Dim zapyt As QueryTable

If Worksheets("Kursy").Range("A2").Value = Date Then Exit Sub
Worksheets("Kursy").Range("K7") = "Czekaj !!! Pobieram dane"

Application.ScreenUpdating = False
pobierz_dir ' pobieram spis tabel kursów

ost = Worksheets("Dir").Range("A65536").End(xlUp).Row


For i = 1 To ost
    tabela = Worksheets("Dir").Cells(i, 1)
    data_tabeli = DateSerial(Val("20" & Mid(tabela, 6, 2)), Val(Mid(tabela, 8, 2)), Val(Mid(tabela, 10, 2)))
  If Left(tabela, 1) = "a" And data_tabeli > #1/1/2010# Then
  ' ograniczę lekko zakres, żeby nie ściągać za długo - można powyżej wpisać inną datę
  ' pierwsza tabela na NBP w formacie jakie akceptuje to makro jest z 04.05.2004
    Index = Application.Match(tabela, Worksheets("Kursy").Range("B:B"), 0) ' sprawdzam czy pobrałem już takie tabele
        If IsError(Index) Then ' jeżeli nie
       
        nrTabeli = Mid(tabela, 2, 3) & "/" & UCase(Left(tabela, 1)) & "/NBP/" & ("20" & Mid(tabela, 6, 2))
       
        With Worksheets("Waluty")
        .Select
        .Columns("A:F").Clear
        .Range("A1") = data_tabeli
        .Range("B1") = tabela 'oryginalny
        .Range("C1") = nrTabeli ' przekształcony
       
        End With
        With Worksheets("Waluty").QueryTables.Add(Connection:= _
                "URL;http://www.nbp.pl/Kursy/TabArch.aspx?n=" & tabela, Destination:=Range("A2"))
                .Name = "Kursy" & tabela
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlOverwriteCells
                .SavePassword = False
                .SaveData = False
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlSpecifiedTables
                .WebFormatting = xlWebFormattingNone
                .WebTables = "2"
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With
    UpdateCell
    End If
  End If
Next

For Each rName In ActiveWorkbook.Names
    rName.Delete
Next rName

For Each zapyt In Worksheets("Waluty").QueryTables
zapyt.Delete
Next

Worksheets("Kursy").Select
With Worksheets("Kursy").Range("A1:J" & Worksheets("Kursy").Range("A65536").End(xlUp).Row)

.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End With
Application.ScreenUpdating = True
Worksheets("Kursy").Range("K7") = ""
End Sub


Kod: Zaznacz cały   Rozszerz widokZwiń widok
Sub UpdateCell()

'Niniejsza procedura UpdateCell jest wykonana przez Tajana - ja tylko  dostosowałem do swoich potrzeb :)
'Tajan - Mam nadzieję, że się nie gniewasz

Dim data As Double
Dim poz
Dim kwer As Worksheet
Dim zest As Worksheet
Dim kol As Long
Dim wiersz As Long
Dim tabo, tabl As String

Set kwer = ThisWorkbook.Worksheets("Waluty")
Set zest = ThisWorkbook.Worksheets("Kursy")

data = Range("A1") ' data tabeli
tabo = Range("B1") ' nazwa oryginalna tabeli w NBP
tabl = Range("C1") ' nazwa przetworzona tabeli
With zest
    poz = Application.Match(data, .Range("A:A"), 0)
    If IsError(poz) Then
       poz = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End If
    kol = 4
    .Cells(poz, "A") = CDate(data)
    .Cells(poz, "B") = tabo
    .Cells(poz, "C") = tabl
   
    Do While .Cells(1, kol) <> ""
       wiersz = Application.Match(.Cells(1, kol), kwer.Range("B:B"), 0)
       .Cells(poz, kol) = kwer.Cells(wiersz, "C")
       kol = kol + 1
    Loop
End With
   
End Sub


Kod: Zaznacz cały   Rozszerz widokZwiń widok
Sub pobierz_dir()
With Worksheets("Dir")
.Select
.Columns(1).Delete
End With
    With Worksheets("Dir").QueryTables.Add(Connection:= _
        "URL;http://www.nbp.pl/kursy/xml/dir.txt", Destination:=Range("A1"))
        .Name = "dir-kursy"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub


Kod: Zaznacz cały   Rozszerz widokZwiń widok
Sub usun()
If MsgBox("Czy na pewno chcesz usunąć wszystkie dane ?", vbInformation + vbYesNo) <> vbYes Then Exit Sub
ost = [A65536].End(xlUp).Row
If ost > 2 Then
Range("A2:I" & ost).ClearContents
End If
End Sub
Pozdrawiam
Roman

LibreOffice Wersja 4.1.3., Windows 7 + Ubuntu 13.10 (od niedawna)
Husar
 
Posty: 33
Dołączył(a): Śr mar 06, 2013 3:48 am

Re: Konwersja makr z VBA do StarBasic

Postprzez belstar » Śr kwi 10, 2013 11:16 am

viewtopic.php?f=9&t=1769
Po małym zmodyfikowaniu:
Kod: Zaznacz cały   Rozszerz widokZwiń widok
Sub getNBP_kurs
   Dim Properties(1) As New com.sun.star.beans.PropertyValue
   
   Properties(0).Name = "Hidden"' to możesz wyrzucić
   Properties(0).Value = False '  to możesz wyrzucić
   ' i indeks 1 zmienić na 0 we wszystkich wystąpieniach zmiennej Properties()
   Properties(1).Name = "FilterName"
   Properties(1).Value = "Text"

   StarDesktop.LoadComponentFromUrl("http://www.nbp.pl/kursy/xml/dir.txt", "_blank", 0, Properties())
End Sub
LibreOffice 3.6.3.2 Ubuntu 12.04 LTS
belstar
 
Posty: 356
Dołączył(a): Cz mar 17, 2011 9:08 am

Re: Konwersja makr z VBA do StarBasic

Postprzez belstar » Śr kwi 10, 2013 8:32 pm

Ponieważ nie analizowałem kodu dogłębnie, wpisałem adres taki jaki mi wpadł pierwsze w oko, a on pobiera ci tylko nazwy tabel kursów walut. I tu chcę nadrobić swoje niedopatrzenie, mając jednocześnie kilka pytań:
Czy interesuje ciebie zawsze kurs z dnia uruchomienia makra?
Cy musi to być konwersja 1:1?
W oryginalnej wersji są trzy arkusze (kursy, dir i Waluty), czy ma tak pozostać, czy wystarczy jeden z walutami?
LibreOffice 3.6.3.2 Ubuntu 12.04 LTS
belstar
 
Posty: 356
Dołączył(a): Cz mar 17, 2011 9:08 am

Re: Konwersja makr z VBA do StarBasic

Postprzez Husar » Cz kwi 11, 2013 12:52 am

W tej chwili interesują mnie kursy z ostatnich 30 dni (dodaje sobie wykresy) i inne waluty niż w tym skoroszycie. Obserwuję horyzont miesięczny i wybieram moment zakupu waluty w kantorze internetowym. Konwersja 1:1 miałaby znaczenie jedynie poznawcze, ale szczerze mówiąc VBA też kiepsko znam.
Pozdrawiam
Roman

LibreOffice Wersja 4.1.3., Windows 7 + Ubuntu 13.10 (od niedawna)
Husar
 
Posty: 33
Dołączył(a): Śr mar 06, 2013 3:48 am

Re: Konwersja makr z VBA do StarBasic

Postprzez belstar » N kwi 14, 2013 11:02 pm

Konwersja skończona, niestety nie jest to 1:1
Załączniki
kursyWalut.ods
(88.75 KiB) Pobrane 73 razy
LibreOffice 3.6.3.2 Ubuntu 12.04 LTS
belstar
 
Posty: 356
Dołączył(a): Cz mar 17, 2011 9:08 am

Re: Konwersja makr z VBA do StarBasic

Postprzez Husar » Pn kwi 15, 2013 7:26 pm

Dziękuję za pracę nad makrem.
Przeglądając arkusz Dane_do_Statystyk zauważyłem coś takiego:
http://scr.hu/0dal/nespg

A po uruchomieniu makra Waluty() wyskakuje następujący komunikat:
http://scr.hu/0dal/tlnr3
Pozdrawiam
Roman

LibreOffice Wersja 4.1.3., Windows 7 + Ubuntu 13.10 (od niedawna)
Husar
 
Posty: 33
Dołączył(a): Śr mar 06, 2013 3:48 am

Re: Konwersja makr z VBA do StarBasic

Postprzez belstar » Pn kwi 15, 2013 8:07 pm

Chodzi ci o błąd w sortowaniu?
Zauważyłem to już wcześniej i w komentarzu do odpowiedzialnego za tą czynność kodu wpisałem że coś jest nie tak.

Co do wyjątku to u mnie, zaraz po przeczytaniu twojego postu, otworzyłem dokument, uruchomiłem makro i wszystko jest dobrze (dowód: załącznik z dzisiejszym notowaniem), także nie man pojęcia co u ciebie jest nie tak. Uruchom procedurę krokowo, ustaw czujkę na zmienną (w tym wypadku url) i obserwuj co jest grane.
Załączniki
Złe_Sortowanie.jpg
Złe_Sortowanie.jpg (23.42 KiB) Przeglądane 949 razy
LibreOffice 3.6.3.2 Ubuntu 12.04 LTS
belstar
 
Posty: 356
Dołączył(a): Cz mar 17, 2011 9:08 am

Re: Konwersja makr z VBA do StarBasic

Postprzez Husar » Pn kwi 15, 2013 9:20 pm

Nie wiem czy dobrze to zrobiłem. Zaznaczyłem słowo url i wstawiłem czujkę. Uruchomiłem krokowo procedurę i takie coś się pojawiło:

http://scr.hu/0dal/ilj7i
Pozdrawiam
Roman

LibreOffice Wersja 4.1.3., Windows 7 + Ubuntu 13.10 (od niedawna)
Husar
 
Posty: 33
Dołączył(a): Śr mar 06, 2013 3:48 am

Re: Konwersja makr z VBA do StarBasic

Postprzez belstar » Pn kwi 15, 2013 9:57 pm

Strzałka pokazuje ci linie kodu która się wykona po naciśnięciu Shift+F8.
Na dole w oknie czujki sprawdź jaką wartość zawiera zmienna. Ważne też jest z którego miejsca procedury Waluty() zostałeś przeniesiony do procedury getNBP_kurs(). Zasada jest taka:
1 Pobranie spisu tabel (url z końcówką dir.txt)
Kod: Zaznacz cały   Rozszerz widokZwiń widok
SpisTabel = getNBP_kurs("http://www.nbp.pl/kursy/xml/dir.txt", "Dir")

2 Wpisanie wszystkich tabel do skoroszytu DIR po wyodrębnieniu dat itp
Kod: Zaznacz cały   Rozszerz widokZwiń widok
for i = 0 to Ubound(SpisTabel)
      If Left(SpisTabel(i)(0), 1) = "a" Then
         tabela = SpisTabel(i)(0)
         data_tabeli = DateSerial(Val("20" & Mid(tabela, 6, 2)), Val(Mid(tabela, 8, 2)), Val(Mid(tabela, 10, 2)))
         nrTabeli = Mid(tabela, 2, 3) & "/" & UCase(Left(tabela, 1)) & "/NBP/" & ("20" & Mid(tabela, 6, 2))
         If  data_tabeli > DateValue("1/1/2012") Then
            gdzie =  getCountA(oSheetDir, "A")
            Index = getMatch(oSheetDir, str(data_tabeli), "A1:A10000", 0)
            If isEmpty(Index)  then
               oSheetDir.getCellByPosition(0, gdzie).String = data_tabeli
               oSheetDir.getCellByPosition(1, gdzie).String = tabela
               oSheetDir.getCellByPosition(2, gdzie).String = nrTabeli
               oSheetDir.getCellByPosition(3, gdzie).value = data_tabeli
            End If
         End If
      End If
   Next

3 Sortowanie
Kod: Zaznacz cały   Rozszerz widokZwiń widok
   oRange = oSheetDir.getCellRangeByName("A1:D500")
   aSortFields(0).Field = 3
   aSortFields(0).SortAscending = False         
   aSortDesc(0).Name = "SortFields"
   aSortDesc(0).Value = aSortFields()
   oRange.Sort(aSortDesc())

4 Pobranie kursów walut
Kod: Zaznacz cały   Rozszerz widokZwiń widok
   gdzie =  getCountA(oSheetDir, "A")
   daty_tabel = oSheetDir.getCellRangeByName("A1:A" & Trim(Str(gdzie))).getDataArray
   Tabele = oSheetDir.getCellRangeByName("B1:B" & Trim(Str(gdzie))).getDataArray
   For i = 0 to gdzie - 1
      Index = getMatch(oSheetDaneStatys, daty_tabel(i)(0), "A1:A10000", 0)   
      If isEmpty(Index)  then
         
         Url = "http://www.nbp.pl/Kursy/TabArch.aspx?n=" & Tabele(i)(0)
         Pobrane = getNBP_kurs(Url, "")
         temp = getCountA(oSheetDaneStatys, "B")
         oSheetDaneStatys.getCellByPosition(0, temp).String = daty_tabel(i)(0)
         oSheetDaneStatys.getCellByPosition(38, temp).Formula = "=VALUE(A" & Trim(Str(Temp + 1)) & ")"'val(daty_tabel(i)(0))
         for j = 1 to Ubound(Pobrane) + 1
            oSheetDaneStatys.getCellByPosition(j, temp).String = Pobrane(j - 1)(0)
         next
      End If
   next

i na końcu znów sortowanie, które coś zawodzi.

Tak więc funkcja getNBP_kurs jest wywoływana dwa razy (przy założeniu że pobieramy tylko dane z jednego dnia)
Pierwszy raz pobiera nazwy tabel (wywołanie z argumentem obowiązkowym adres WWW i stringiem DIR)
Kod: Zaznacz cały   Rozszerz widokZwiń widok
getNBP_kurs("http://www.nbp.pl/kursy/xml/dir.txt", "Dir")

W tej części zostanie otworzony ukryty skoroszyt calca z podanego adresu (po imporcie tekstu do calca).
Wykonane będzie pobranie z kolumny a wszystkich danych (nazwy tabel)
Kod: Zaznacz cały   Rozszerz widokZwiń widok
Dane = quotes.Sheets(0).getCellRangeByName("A1:A" & Trim(Str(LastRow("Arkusz1", quotes) + 1))).getDataArray

Drugi raz kiedy już będzie pobierany konkretny dokument z dnia notowania
Kod: Zaznacz cały   Rozszerz widokZwiń widok
Url = "http://www.nbp.pl/Kursy/TabArch.aspx?n=" & Tabele(i)(0)
Pobrane = getNBP_kurs(Url, "")

Wykonywany jest wtedy inny fragment kodu
Kod: Zaznacz cały   Rozszerz widokZwiń widok
quotes = StarDesktop.LoadComponentFromUrl(url, "_blank", 0, Properties())

quotes.getTextTables.getByName("Tabela2").getColumns.removeByIndex(0, 2)
quotes.getTextTables.getByName("Tabela2").getRows.removeByIndex(0, 1)
Dane = quotes.getTextTables.getByName("Tabela2").getDataArray

Później dane są wstawiane do arkusza Dane_do_Statystyk

Mam nadzieję że wyjaśniłem wszystko prosto.

Pozdrawiam
LibreOffice 3.6.3.2 Ubuntu 12.04 LTS
belstar
 
Posty: 356
Dołączył(a): Cz mar 17, 2011 9:08 am

Re: Konwersja makr z VBA do StarBasic

Postprzez Jan_J » Pn kwi 15, 2013 11:19 pm

@ Husar
1. czy nie uruchamiasz przypadkiem getNBP_kurs() zamiast Waluty()? To pierwsze potrzebuje argumentów, to drugie mu ich dostarcza w wywołaniu.
2. weź proszę wklejaj obrazki na forum zamiast na zewnętrzny serwis. Będą zintegrowane z tekstem. I lepsze będą png albo gif niż jpeg, bo bez zakłóceń. Tak wiem, "wszyscy" robią zrzuty ekranu w jpeg, ale to nie jest właściwe. Co można przeczytać we "wszystkich" książkach i serwisach o formatach graficznych.

@ belstar
W moich testach (LO 4.0.0.3 Portable / W7 Pro) funkcję Waluty() uruchamiam z narzędzia/makro/... .
getNBP_kurs jest wywoływany w wierszu 23 -- z opcjonalnym parametrem "Dir". Zdalny URL otwiera się w ramce Writera a nie Calca, więc obiekt quotes nie ma komponentu Sheets -- i krach w wierszu 95. Co prawda niby masz zabezpieczenie przez ArkuszDir -- ale nie spełnia swojej roli.
// Może trzeba by założyć odpowiedni filtr wejściowy (bodajże "StarCalc (Text - txt - csv)" albo podobnie), co by się w Calcu otwierał?.


@ sortowanie
...
JJ
LO 4.1 ∙ AOO 4.0.1 ∙ Python (2.[67]|3.3) ∙ Unicode 6.2 ∙ LATEX 2ε ∙ XML ∙ Unix tools ∙ Linux (2.6|3.x) ∙ Fedora 19 ∙ CentOS 6.5 ∙ SUSE 13.1
Jan_J
 
Posty: 1954
Dołączył(a): Pt maja 22, 2009 1:20 pm
Lokalizacja: Wrocław

Re: Konwersja makr z VBA do StarBasic

Postprzez belstar » Wt kwi 16, 2013 12:41 am

Jan_J napisał(a):W moich testach (LO 4.0.0.3 Portable / W7 Pro) funkcję Waluty() uruchamiam z narzędzia/makro/... .
getNBP_kurs jest wywoływany w wierszu 23 -- z opcjonalnym parametrem "Dir". Zdalny URL otwiera się w ramce Writera a nie Calca, więc obiekt quotes nie ma komponentu Sheets -- i krach w wierszu 95. Co prawda niby masz zabezpieczenie przez ArkuszDir -- ale nie spełnia swojej roli.
// Może trzeba by założyć odpowiedni filtr wejściowy (bodajże "StarCalc (Text - txt - csv)" albo podobnie), co by się w Calcu otwierał?.


Racja, to też w arkuszu z instrukcją jest napisane żeby testować to to.

Zamieszczam poprawioną funkcje getNBP_kurs
Kod: Zaznacz cały   Rozszerz widokZwiń widok
Function getNBP_kurs(url As String, optional ArkuszDir As String)
   Dim Properties(1) As New com.sun.star.beans.PropertyValue
   Dim quotes
   Dim Dane
   
   Properties(0).Name = "Hidden"
   Properties(0).Value = true
   
   If ArkuszDir = "Dir" Then
      Properties(1).Name = "FilterName"
      Properties(1).Value = "Text - txt - csv (StarCalc)"
   Else
      Properties(1).Name = "FilterName"
      Properties(1).Value = "Text (StarWriter/Web)"
   End if

   quotes = StarDesktop.LoadComponentFromUrl(url, "_blank", 0, Properties())
   If ArkuszDir = "" then
      quotes.getTextTables.getByName("Tabela2").getColumns.removeByIndex(0, 2)
      quotes.getTextTables.getByName("Tabela2").getRows.removeByIndex(0, 1)
      Dane = quotes.getTextTables.getByName("Tabela2").getDataArray
   Else
      Dane = quotes.Sheets(0).getCellRangeByName("A1:A" & Trim(Str(LastRow("Arkusz1", quotes) + 1))).getDataArray
   End If
   quotes.close(true)
   getNBP_kurs = Dane
End Function

Zainteresowani niech podmienią i testują.

Dla wyjaśnienia najpierw ma być otwarty dokument calca, następne wywołanie writer/web.
LibreOffice 3.6.3.2 Ubuntu 12.04 LTS
belstar
 
Posty: 356
Dołączył(a): Cz mar 17, 2011 9:08 am

Re: Konwersja makr z VBA do StarBasic

Postprzez Husar » Wt kwi 16, 2013 7:48 pm

Jan_J napisał(a):@ Husar
1. czy nie uruchamiasz przypadkiem getNBP_kurs() zamiast Waluty()? To pierwsze potrzebuje argumentów, to drugie mu ich dostarcza w wywołaniu.
2. I lepsze będą png albo gif niż jpeg, bo bez zakłóceń.

Ad. 1. Uruchamiałem Waluty(). Jak będę miał chwilę, to przyjrzę się uważniej.
Ad. 2. sorry, po 10h na kursie nie zwróciłem uwagi jakiego formatu są zrzuty. "Chciałem dobrze a wyszło jak zawsze" :-) :knock:
Pozdrawiam
Roman

LibreOffice Wersja 4.1.3., Windows 7 + Ubuntu 13.10 (od niedawna)
Husar
 
Posty: 33
Dołączył(a): Śr mar 06, 2013 3:48 am


Powrót do Calc

Kto przegląda forum

Użytkownicy przeglądający ten dział: Brak zidentyfikowanych użytkowników i 2 gości