Quelle  Internet.xba   Sprache: unbekannt

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<!--
 * This file is part of the LibreOffice project.
 *
 * This Source Code Form is subject to the terms of the Mozilla Public
 * License, v. 2.0. If a copy of the MPL was not distributed with this
 * file, You can obtain one at http://mozilla.org/MPL/2.0/.
 *
 * This file incorporates work covered by the following license notice:
 *
 *   Licensed to the Apache Software Foundation (ASF) under one or more
 *   contributor license agreements. See the NOTICE file distributed
 *   with this work for additional information regarding copyright
 *   ownership. The ASF licenses this file to you under the Apache
 *   License, Version 2.0 (the "License"); you may not use this file
 *   except in compliance with the License. You may obtain a copy of
 *   the License at http://www.apache.org/licenses/LICENSE-2.0 .
-->
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Internet" script:language="StarBasic">REM  *****  BASIC  *****
Option Explicit
Public sNewSheetName as String

Function CheckHistoryControls()
Dim bLocGoOn as Boolean
Dim Firstdate as Date
Dim LastDate as Date
 LastDate = CDateFromUNODate(StockRatesModel.txtEndDate.Date)
 FirstDate = CDateFromUNODate(StockRatesModel.txtStartDate.Date)
 bLocGoOn = FirstDate <> 0 And LastDate <> 0
 If bLocGoOn Then
  If FirstDate >= LastDate Then
   Msgbox(sMsgStartDatebeforeEndDate,16, sProductname)
   bLocGoOn = False
  End If
 End If
 CheckHistoryControls = bLocGoon
End Function

 
Sub InsertCompanyHistory()
Dim StockName as String
Dim CurRow as Integer
Dim sMsgInternetError as String
Dim CurRate as Double
Dim oCell as Object
Dim sStockID as String
Dim ChartSource as String 
 If CheckHistoryControls() Then
  StartDate = CDateFromUNODate(StockRatesModel.txtStartDate.Date)
  EndDate = CDateFromUNODate(StockRatesModel.txtEndDate.Date)
  DlgStockRates.EndExecute()
  If StockRatesModel.optDaily.State = 1 Then
   sInterval = "d"
   iStep = 1
  ElseIf StockRatesModel.optWeekly.State = 1 Then
   sInterval = "w"
   iStep = 7
   StartDate = StartDate - WeekDay(StartDate) + 2
   EndDate = EndDate - WeekDay(EndDate) + 2
  End If
  iEndDay = Day(EndDate)
  iEndMonth = Month(EndDate)
  iEndYear = Year(EndDate)
  iStartDay = Day(StartDate)
  iStartMonth = Month(StartDate)
  iStartYear = Year(StartDate)
'  oDocument.AddActionLock()
  UnprotectSheets(oSheets)
  InitializeStatusline("", 10, 1)
  oBackGroundSheet = oSheets.GetbyName("Background") 
  StockName = DlgStockRates.GetControl("lstStockNames").GetSelectedItem()
  CurRow = GetStockRowIndex(Stockname)
  sStockID = oFirstSheet.GetCellByPosition(SBCOLUMNID1, CurRow).String
  ChartSource = ReplaceString(HistoryChartSource, sStockID, "<StockID>")
  ChartSource = ReplaceString(ChartSource, iStartDay, "<StartDay>")
  ChartSource = ReplaceString(ChartSource, cStr(iStartMonth-1), "<StartMonth>")
  ChartSource = ReplaceString(ChartSource, iStartYear, "<StartYear>") 
  ChartSource = ReplaceString(ChartSource, iEndDay, "<EndDay>")
  ChartSource = ReplaceString(ChartSource, cStr(iEndMonth-1), "<EndMonth>")
  ChartSource = ReplaceString(ChartSource, iEndYear, "<EndYear>")
  ChartSource = ReplaceString(ChartSource, sInterval, "<interval>")
  oStatusLine.SetValue(2)
  If GetCurrentRate(ChartSource, CurRate, 1) Then
   oStatusLine.SetValue(8)
   UpdateValue(StockName, Today, CurRate)
   oStatusLine.SetValue(9)
   UpdateChart(StockName)
   oStatusLine.SetValue(10)
  Else
   sMsgInternetError = Stockname & ": " & sNoInternetDataAvailable & chr(13) & sCheckInternetSettings
   Msgbox(sMsgInternetError, 16, sProductname)
  End If
  ProtectSheets(oSheets)
  oStatusLine.End
  If oSheets.HasbyName(sNewSheetName) Then
   oController.ActiveSheet = oSheets.GetByName(sNewSheetName)
  End If
'  oDocument.RemoveActionLock() 
 End If
End Sub



Sub InternetUpdate()
Dim i as Integer
Dim StocksCount as Integer
Dim iStartRow as Integer
Dim sUrl as String
Dim StockName as String  
Dim CurRate as Double
Dim oCell as Object
Dim sMsgInternetError as String
Dim sStockID as String
Dim ChartSource as String
' oDocument.AddActionLock()
 Initialize(True)
 UnprotectSheets(oSheets)
 StocksCount = GetStocksCount(iStartRow)
 InitializeStatusline("", StocksCount + 1, 1)
 Today = CDate(Date)
 For i = iStartRow + 1 To iStartRow + StocksCount
  StockName = oFirstSheet.GetCellbyPosition(SBCOLUMNNAME1, i).String
  sStockID = oFirstSheet.GetCellByPosition(SBCOLUMNID1, i).String
  ChartSource = ReplaceString(sCurChartSource, sStockID, "<StockID>")
  If GetCurrentRate(ChartSource, CurRate, 0) Then
   InsertCurrentValue(CurRate, i, Now)  
  Else
   sMsgInternetError = Stockname & ": " & sNoInternetDataAvailable & chr(13) & sCheckInternetSettings
   Msgbox(sMsgInternetError, 16, sProductname)
  End If
  oStatusline.SetValue(i - iStartRow + 1)
 Next
 ProtectSheets(oSheets)
 oStatusLine.End
' oDocument.RemoveActionLock
End Sub



Function GetCurrentRate(sUrl as String, fValue As Double, iValueRow as Integer) as Boolean
Dim sFilter As String
Dim sOptions As String
Dim oLinkSheet As Object
Dim sDate as String
 If oSheets.hasByName("Link") Then 
  oLinkSheet = oSheets.getByName("Link")
 Else
  oLinkSheet = oDocument.createInstance("com.sun.star.sheet.Spreadsheet")
  oSheets.insertByName("Link", oLinkSheet)
  oLinkSheet.IsVisible = False
 End If
 
 sFilter = "Text - txt - csv (StarCalc)"
 sOptions = sCurSeparator & ",34,SYSTEM,1,1/10/2/10/3/10/4/10/5/10/6/10/7/10/8/10/9/10"
 
 oLinkSheet.LinkMode = com.sun.star.sheet.SheetLinkMode.NONE
 oLinkSheet.link(sUrl, "", sFilter, sOptions, 1 )
 fValue = oLinkSheet.getCellByPosition(iValueCol, iValueRow).Value
 If fValue = 0 Then
  Dim sValue as String
  sValue = oLinkSheet.getCellByPosition(1, iValueRow).String
  sValue = ReplaceString(sValue, ".",",")
  fValue = Val(sValue)
 End If
 GetCurrentRate = fValue <> 0
End Function



Sub UpdateValue(ByVal sName As String, fDate As Double, fValue As Double )
Dim oSheet As Object
Dim iColumn As Long
Dim iRow As Long
Dim i as Long
Dim oCell As Object
Dim LastDate as Date
Dim bLeaveLoop as Boolean
Dim RemoveCount as Long
Dim iLastRow as Long
Dim iLastLinkRow as Long
Dim dDate as Date
Dim CurDate as Date
Dim oLinkSheet as Object
Dim StartIndex as Long
Dim iCellValue as Long
 ' Insert Sheet with Company - Chart
 sName = CheckNewSheetname(oSheets, sName)
 If NOT oSheets.hasByName(sName) Then
  oSheets.CopybyName("Background", sName, oSheets.Count)
  oSheet = oSheets.getByName(sName)
  iCurRow = SBSTARTROW
  iMaxRow = iCurRow
  oCell = oSheet.getCellByPosition(SBDATECOLUMN, iCurRow)
  oCell.Value = fDate
 End If
 sNewSheetName = sName
 oLinkSheet = oSheets.GetByName("Link")
 oSheet = oSheets.getByName(sName)
 iLastRow = GetLastUsedRow(oSheet)- 2
 iLastLinkRow = GetLastUsedRow(oLinkSheet)
 iCurRow = iLastRow
 bLeaveLoop = False
 RemoveCount = 0
 ' Delete all Cells in Date Area
 Do
  oCell = oSheet.GetCellbyPosition(SBDATECOLUMN,iCurRow)
  If oCell.CellStyle = sColumnHeader Then
   bLeaveLoop = True
   StartIndex = iCurRow
   iCurRow = iCurRow + 1
  Else
   RemoveCount = RemoveCount + 1
   iCurRow = iCurRow - 1
  End If
 Loop Until bLeaveLoop 
 If RemoveCount > 1 Then
  oSheet.Rows.RemoveByIndex(iCurRow, RemoveCount-1)
 End If
 For i = 1 To iLastLinkRow
  oCell = oSheet.GetCellbyPosition(SBDATECOLUMN,iCurRow)
  iCellValue = oLinkSheet.GetCellByPosition(0,i).Value
  If iCellValue > 0 Then
   oCell.SetValue(oLinkSheet.GetCellByPosition(0,i).Value)
  Else
   oCell.SetValue(StringToDate(oLinkSheet.GetCellByPosition(0,i).String))
  End If
  oCell = oSheet.GetCellbyPosition(SBVALUECOLUMN,iCurRow)
  oCell.SetValue(oLinkSheet.GetCellByPosition(4,i).Value)
  If i < iLastLinkRow Then
   iCurRow = iCurRow + 1
   oSheet.Rows.InsertByIndex(iCurRow,1)
  End If
 Next i
 iMaxRow = iCurRow
End Sub


Function StringToDate(DateString as String) as Date
Dim ShortMonths(11)
Dim DateList() as String
Dim MaxIndex as Integer
Dim i as Integer
 ShortMonths(0) = "Jan"
 ShortMonths(1) = "Feb"
 ShortMonths(2) = "Mar"
 ShortMonths(3) = "Apr"
 ShortMonths(4) = "May"
 ShortMonths(5) = "Jun"
 ShortMonths(6) = "Jul"
 ShortMonths(7) = "Aug"
 ShortMonths(8) = "Sep"
 ShortMonths(9) = "Oct"
 ShortMonths(10) = "Nov"
 ShortMonths(11) = "Dec"
 For i = 0 To 11
  DateString = ReplaceString(DateString,CStr(i+1),ShortMonths(i))
 Next i
 DateString = ReplaceString(DateString, ".", "-")
 StringToDate = CDate(DateString) 
End Function


Sub UpdateChart(sName As String)
Dim oSheet As Object
Dim oCell As Object, oCursor As Object
Dim oChartRange As Object
Dim oEmbeddedChart As Object, oCharts As Object
Dim oChart As Object, oDiagram As Object
Dim oYAxis As Object, oXAxis As Object
Dim fMin As Double, fMax As Double
Dim nDateFormat As Long
Dim aPos As Variant
Dim aSize As Variant
Dim oContainerChart as Object
Dim mRangeAddresses(0) as New com.sun.star.table.CellRangeAddress
 mRangeAddresses(0).Sheet = GetSheetIndex(oSheets, sNewSheetName)
 mRangeAddresses(0).StartColumn = SBDATECOLUMN 
 mRangeAddresses(0).StartRow = SBSTARTROW-1
 mRangeAddresses(0).EndColumn = SBVALUECOLUMN
 mRangeAddresses(0).EndRow = iMaxRow
  
 oSheet = oDocument.Sheets.getByName(sNewSheetName)
 oCharts = oSheet.Charts
 
 If Not oCharts.hasElements Then
  oSheet.GetCellbyPosition(2,2).SetString(sName)
  oChartRange = oSheet.getCellRangeByPosition(SBDATECOLUMN,6,5,SBSTARTROW-3)
  aPos = oChartRange.Position
  aSize = oChartRange.Size
  
  Dim oRectangleShape As New com.sun.star.awt.Rectangle
  oRectangleShape.X = aPos.X
  oRectangleShape.Y = aPos.Y
  oRectangleShape.Width = aSize.Width
  oRectangleShape.Height = aSize.Height
  oCharts.addNewByName(sName, oRectangleShape, mRangeAddresses(), True, False)
  oContainerChart = oCharts.getByName(sName)
  oChart = oContainerChart.EmbeddedObject
  oChart.Title.String = ""
  oChart.HasLegend = False
  oChart.diagram = oChart.createInstance("com.sun.star.chart.XYDiagram")
  oDiagram = oChart.Diagram
  oDiagram.DataRowSource = com.sun.star.chart.ChartDataRowSource.COLUMNS
  oChart.Area.LineStyle = com.sun.star.drawing.LineStyle.SOLID
  oXAxis = oDiagram.XAxis
  oXAxis.TextBreak = False
  nDateFormat = oXAxis.NumberFormats.getStandardFormat(com.sun.star.util.NumberFormat.DATE, oDocLocale)

  oYAxis = oDiagram.getYAxis()
  oYAxis.AutoOrigin = True
 Else
  oChart = oCharts(0)
  oChart.Ranges = mRangeAddresses()
  oChart.HasRowHeaders = False
  oEmbeddedChart = oChart.EmbeddedObject
  oDiagram = oEmbeddedChart.Diagram
  oXAxis = oDiagram.XAxis
 End If
 oXAxis.AutoStepMain = False
 oXAxis.AutoStepHelp = False
 oXAxis.StepMain = iStep
 oXAxis.StepHelp = iStep
 fMin = oSheet.getCellByPosition(SBDATECOLUMN,SBSTARTROW).Value
 fMax = oSheet.getCellByPosition(SBDATECOLUMN,iMaxRow).Value
 oXAxis.Min = fMin
 oXAxis.Max = fMax
 oXAxis.AutoMin = False
 oXAxis.AutoMax = False
End Sub


Sub CalculateChartafterSplit(SheetName, NewNumber, OldNumber, NoteText, SplitDate)
Dim oSheet as Object
Dim i as Integer
Dim oValueCell as Object
Dim oDateCell as Object
Dim bLeaveLoop as Boolean
 If oSheets.HasbyName(SheetName) Then
  oSheet = oSheets.GetbyName(SheetName)
  i = 0
  bLeaveLoop = False
  Do
   oValueCell = oSheet.GetCellbyPosition(SBVALUECOLUMN, SBSTARTROW + i)
   If oValueCell.CellStyle = CurrCellStyle Then
    SplitCellValue(oSheet, OldNumber, NewNumber, SBVALUECOLUMN, SBSTARTROW + i, "")  
    i = i + 1
   Else
    bLeaveLoop = True
   End If
  Loop Until bLeaveLoop
  oDateCell = oSheet.GetCellbyPosition(SBDATECOLUMN, SBSTARTROW + i-1)
  oDateCell.Annotation.SetString(NoteText)
 End If
End Sub
</script:module>