Keskustelu: Koodit: Näin naapurissa

REM  *****  BASIC  *****

Option VBASupport 1

Global bSetBox As Boolean

Private _company As String

Property Get companyName As String
    companyName = _company
End Property

Property Let companyName(value As String)
    _company = value
End Property

Private _lrow As Long

Property Get swapStart As Long
    swapStart =  _lrow
End Property

Property Let swapStart(value As Long)
     _lrow = value
End Property

Sub GetStocks 'Sidonta: Työkalut > Mukauta > Tapahtumat > Avaa asiakirja

    companyName = "":  swapStart = 0
    ImportStocks 1, "https://www.di.se/bors/aktier/?data%5Bcountry%5D=SE&data=&field=name&desc=false"
    ImportStocks 2, "https://www.di.se/bors/aktier/?data%5Bcountry%5D=SE&data=&field=name&desc=true"

End Sub

Sub ImportStocks(qcnt As Integer, qUrl As String)

    Dim URL As String
    Dim response As String
    Dim pos As Long
    Dim oServiceManager As Object
    Dim oSimpleFileAccess As Object
    Dim oInputStream As Object
    Dim oTextInputStream As Object
    Dim oSFA As Object, oInText As Object

    URL =  qUrl

    oServiceManager = GetProcessServiceManager()
    oSimpleFileAccess = oServiceManager.createInstance("com.sun.star.ucb.SimpleFileAccess")
    oSFA =  createUNOService("com.sun.star.ucb.SimpleFileAccess")
    oInText = createUNOService("com.sun.star.io.TextInputStream")
    oInputStream = oSimpleFileAccess.openFileRead(URL)
    oInText.setInputStream(oInputStream)

    Do While Not oInText.isEOF()
        line = oInText.readLine()
        response = response & line & Chr(10)
    Loop

    oInputStream.closeInput()
    oInText = Nothing
    oInputStream = Nothing
    oInText = Nothing
    oSimpleFileAccess = nothing
    oServiceManager = Nothing

    pos = InStr(response, "js_search-result-link" + Chr(34) + " title=")

    If pos > 0 Then
        pos = pos + Len("js_search-result-link" + Chr(34) + " title=")
        response = Replace(response, Left(response, pos - 1), "")
        pos = InStr(response, "Hämtar mer data...")
        If pos > 0 Then
            response = Left(response, pos - 1)
        End If
    End If

    response = Replace(response, "href=" + chr(34) + "/bors/aktier/", "")
    response = Replace(response, "</td><td class=" + chr(34) + "i-t__c--p" + chr(34) + ">", "|")
    response = Replace(response, "</a></td><td>", "|")
    response = Replace(response, "</td><td>", "|")
    response = Replace(response,  "<a class=" + chr(34) +"js_search-result-link" + chr(34) + " title=", "|")
    response = Replace(response, "<td class=" + Chr(34) + "i-t__c--m" + chr(34) + ">", "")
    response = Replace(response, "<td class=" + Chr(34) + "i-t__c--n" + chr(34) + ">", "")
    response = Replace(response, "</td></tr><tr id=" +chr(34) + "ins_", "|")
    response = Replace(response, "</td>", "|")
    response = Replace(response, "/" + chr(34) + ">", "|")
    response = Replace(response, "amp;", "")

    Dim apu() As String, tmp As String
    Dim apos As Integer, lpos As Integer
    apu() = Split(response, "|")

    For i = Lbound(apu) to Ubound(apu)
        If Instr(apu(i), ">") = 0 and InStr(apu(i), chr(34)) = 0  Then
            apos = inStr(apu(i), "-")
            lpos = InStrRev(apu(i), "-")
            If apos > 0 and lpos > 0 and apos <>  lpos Then
                dnotadd = true
            Else
                dnotadd = False
            End If
            If Not dnotadd Then
                apu(i) = Ltrim(apu(i))
                apu(i) = Rtrim(apu(i))
                tmp =  tmp +  "|" + Trim(apu(i))
            End If
        End If
    Next i

    response = Right(tmp, Len(tmp) - 1)
    tmp = ""
    Erase apu()

    Dim oSheet as Object
    Dim oCell as Object
    Dim oDoc As object

    Dim tempArray() As String
    tempArray() = Split(response, "|")

     response = ""

    Dim nColor
    nColor = RGB(238, 238, 238)

    Dim ncol,  nrow, cnt, last
    ncol = 0
    nrow = 1

    coef = 0
    cnt = 0
    last = Ubound(tempArray) + 1

    oDoc = ThisComponent
    oSheet = ThisComponent.CurrentController.getActiveSheet()

    If qcnt = 2 Then
        Dim oCursor As Object
        oCursor = oSheet.createCursor()
        oCursor.gotoEndOfUsedArea(False)
        LastRow = oCursor.RangeAddress.EndRow
        nrow = nrow + LastRow
        swapStart = nrow
        oCursor = Nothing
        oCell = oSheet.getCellByPosition(0, nrow)
    End If

    Dim oController As Object
    oController = ThisComponent.CurrentController

    If Ubound(tempArray) > 0 Then

        oDoc.lockControllers

        Do while cnt < last

            if cnt = 180 Then
                cnt = 538
            End If
            If cnt = 700  Then
                cnt = 1040
            End If

            If cnt = 1220 Then
                cnt = 1578
            End if

            If ncol = 9 then
                ncol = 0
                nrow = nrow + 1
            End If

            If qcnt = 2 And tempArray(cnt) = companyName Then  Exit Do
            oCell = oSheet.getCellByPosition(ncol, nrow)
            oCell.setString(tempArray(cnt))

            If Not  IsRowOdd(nrow) Then
                oCell.CellBackColor =  nColor
            End if
            ncol = ncol + 1
            If cnt = 1919 Then
                Exit Do
            End IF
            cnt = cnt + 1

        Loop

        If qcnt = 1 Then
            oCell = oSheet.getCellByPosition(0, nrow)
            companyName = oCell.getString()
         End If

        oCell = oSheet.getCellByPosition(0, 0)
        oController.select(oCell)

    End If

    If qcnt = 2 Then SwapRows oSheet

    Erase tempArray()

    oCursor = oSheet.createCursor()
    oCursor.gotoEndOfUsedArea(True)

    lastRow = oCursor.RangeAddress.EndRow
    For i = 1 To lastRow
        For j = 1 to 2
            oCell = oSheet.getCellByPosition(j, i)
            If InStr(oCell.getString, "-") > 0 Then
                oCell.CharColor = RGB(0, 0, 255)
            ElseIf  InStr(oCell.getString, "+") > 0 Then
                oCell.CharColor = RGB(0, 255, 0)
            End If
        Next j
    Next i

    oCursor = oSheet.createCursor()
    oCursor.gotoEndOfUsedArea(True)
    lastRow = oCursor.RangeAddress.EndRow
    For i = 1 To lastRow
        For j = 2 To 3
            oCell = oSheet.getCellByPosition(j, i)
            If InStr(oCell.getString, "-") > 0 Then
                oCell.CharColor = RGB(0, 0, 255)
            ElseIf  InStr(oCell.getString, "+") > 0 Then
                oCell.CharColor = RGB(0, 255, 0)
            End If
        Next j
    Next i

    oCursor = Nothing
    oCell = oSheet.getCellByPosition(0, nrow)
    oCell = Nothing

    oDoc.unlockControllers

    If qcnt = 1 Then oSheet.Name = "Stockholm Börsen " & Format(GetStockholmDateTime(), "yyyy-mm-dd")
    If qcnt = 2 Then CheckExchange
    oSheet = Nothing

    ThisComponent.setModified(False)

End Sub

Function IsRowOdd(nRow As Integer) As Boolean

    IsRowOdd = (nRow Mod 2 <> 0)

End Function

Sub CheckExchange()

    Dim stockholmTime As Date
    Dim stockholmDate As Date
    Dim updatedDate As Date

    stockholmTime= GetStockholmDateTime()
    stockholmDate = DateValue(stockholmTime)

    Select Case WeekDay(stockholmTime, vbMonday)
        Case 6, 7
            ShowMessage 1, "Börsen är stängd"
        Case Else
            If IsBetween(stockholmTime) Then
                ShowMessage 2, "Börsen är öppen"
            Else
                ShowMessage 1, "Börsen är stängd"
            End If
    End Select

    Dim oSheet As Object
    oSheet = ThisComponent.CurrentController.getActiveSheet()

    If WeekDay(stockholmTime, vbMonday) = 6 Then
        updatedDate = stockholmDate - 1
        oSheet.Name = oSheet.Name &  " (Uppdaterad " & Format(updatedDate, "yyyy-mm-dd") & ")"
    ElseIf WeekDay(stockholmTime, vbMonday) = 7 Then
        updatedDate = stockholmDate - 2
        oSheet.Name = oSheet.Name &  " (Uppdaterad " & Format(updatedDate, "yyyy-mm-dd") & ")"
    End If

    oSheet = Nothing

End Sub

Function GetStockholmDateTime() As Date

    Dim oSimple As Object
    Dim oStream As Object
    Dim oText As Object
    Dim sJSON As String
    Dim dt As String

    oSimple = createUnoService("com.sun.star.ucb.SimpleFileAccess")
    oStream = oSimple.openFileRead("https://timeapi.io/api/Time/current/zone?timeZone=Europe/Stockholm")

    oText = createUnoService("com.sun.star.io.TextInputStream")
    oText.setInputStream(oStream)

    sJSON = ""
    Do While Not oText.isEOF()
        sJSON = sJSON & oText.readLine()
    Loop

    oStream.closeInput()
    dt = Mid(sJSON, InStr(sJSON, """dateTime"":") + 12, 26)
    GetStockholmDateTime = CDate(Left(dt, 19))

End Function

Function IsBetween(stockholmTime As Date) As Boolean

    Dim currentTime As Date
    Dim startTime As Date
    Dim endTime As Date
    currentTime = TimeValue(stockholmTime)
    startTime = TimeValue("09:00:00")
    endTime = TimeValue("17:00:00")

    IsBetween = (currentTime >= startTime And currentTime <= endTime)

End Function

Sub SwapRows(ByVAl oSheet)

    Dim oCursor As Object
    oCursor = oSheet.createCursor()
    oCursor.gotoEndOfUsedArea(False)
    Dim lRow As Long
    lRow = oCursor.RangeAddress.EndRow
    Dim nRows As Long :  nRows = lRow - swapStart
    Dim oCell as Object
    Dim strTemp As String
    Dim tmpArray(nRows) As String
    Dim cnt As Integer : cnt = 0

    For i = swapStart to lRow
        strTemp = ""
        For j = 0 To 8
            oCell = oSheet.getCellByPosition(j, i)
            strTemp = strTemp & oCell.getString(j, i)
            If j < 8 Then strTemp = strTemp & "|"
            If j = 8 then tmpArray(cnt) = strTemp
        Next j
        cnt = cnt + 1
    Next i


    Dim temp2Array() As String
    cnt = swapStart

    For i =  Ubound(tmpArray) to Lbound(tmpArray) Step -1
        temp2Array() = Split(tmpArray(i), "|")
        For j =  Lbound(temp2Array) to Ubound(temp2Array)
                oCell = oSheet.getCellByPosition(j, cnt)
                oCell.setString(temp2Array(j))
        Next j
        cnt = cnt + 1
        Erase temp2Array
    Next i

End Sub

Sub ShowMessage(choice As Integer, msgstr As String)

    If bSetBox Then Exit Sub
    If Not bSetBox Then bSetBox = True

    Dim oToolkit As Object, oParent As Object
    Dim oWinDesc As New com.sun.star.awt.WindowDescriptor
    Dim oWindow As Object

    oToolkit = CreateUnoService("com.sun.star.awt.Toolkit")
    oParent = ThisComponent.CurrentController.Frame.ContainerWindow

    Dim oCC As Object, oPosSize As Object
    Dim boxW As Long, boxH As Long
    Dim centerX As Long, centerY As Long

    oCC = ThisComponent.getCurrentController()
    oPosSize = oCC.ComponentWindow.getPosSize()

    boxW = 250
    boxH = 50
    centerX = (oPosSize.Width - boxW) / 2
    centerY = (oPosSize.Height - boxH) / 2

    With oWinDesc
        .Type = com.sun.star.awt.WindowClass.SIMPLE
        .WindowServiceName = "floatingwindow"
        .ParentIndex = -1
        .Parent = oParent
        .Bounds = CreateUnoStruct("com.sun.star.awt.Rectangle")
        .Bounds.X = centerX
        .Bounds.Y = centerY
        .Bounds.Width = boxW
        .Bounds.Height = boxH
        .WindowAttributes = com.sun.star.awt.WindowAttribute.SHOW
    End With

    oWindow = oToolkit.createWindow(oWinDesc)
    oWindow.setBackground(&HFFFFFF)
    Dim oTextDesc As New com.sun.star.awt.WindowDescriptor
    Dim oTextWindow As Object

    With oTextDesc
        .Type = com.sun.star.awt.WindowClass.SIMPLE
        .WindowServiceName = "fixedtext"
        .ParentIndex = -1
        .Parent = oWindow
        .Bounds = CreateUnoStruct("com.sun.star.awt.Rectangle")
        .Bounds.X = 0
        .Bounds.Y = (boxH - 26) / 2
        .Bounds.Width = boxW
        .Bounds.Height = 26
        .WindowAttributes = 1 + 4
    End With

    oTextWindow = oToolkit.createWindow(oTextDesc)
    oTextWindow.setText(msgstr)

    Dim oFontDesc As New com.sun.star.awt.FontDescriptor
    With oFontDesc
        .Name = "Arial"
        .Height = 12
        .Weight = com.sun.star.awt.FontWeight.BOLD
    End With

    oTextWindow.setProperty("FontDescriptor", oFontDesc)
    Select Case choice
        Case 0
            oTextWindow.setProperty("TextColor", RGB(0, 0, 0))
        Case 1
            oTextWindow.setProperty("TextColor", RGB(0, 0, 255))
        Case 2
            oTextWindow.setProperty("TextColor", RGB(0, 255, 0))
        'Case etc
        Case Else
    End Select

    oTextWindow.setProperty("Align", 1)

    oWindow.setVisible(True)
    oTextWindow.setVisible(True)

    Dim startTicks :startTicks = getSystemTicks

    Do While getSystemTicks < startTicks + 2000 : Loop

    oTextWindow.dispose
    oWindow.dispose()

    bSetBox = False

End Sub

Sub OnClose 'Sidonta: Työkalut > Mukauta > Tapahtumat > Näkymää ollaan sulkemassa
    ThisComponent.setModified(False)
End Sub