REM ***** BASIC ***** Option Explicit Public sNewSheetName as String Function CheckHistoryControls() Dim bLocGoOn as Boolean Dim Firstdate as Date Dim LastDate as Date LastDate = CDateFromISO(StockRatesModel.txtEndDate.Date) FirstDate = CDateFromISO(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 Dim oCell as Object Dim sStockID as String Dim ChartSource as String If CheckHistoryControls() Then StartDate = CDateFromISO(StockRatesModel.txtStartDate.Date) EndDate = CDateFromISO(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 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, iValueCol 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(1, iValueCol).Value If fValue = 0 Then Dim sValue as String sValue = oLinkSheet.getCellByPosition(1, iValueCol).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 Integer Dim oCell As Object Dim LastDate as Date Dim bLeaveLoop as Boolean Dim RemoveCount as Integer Dim iLastRow as Integer Dim iLastLinkRow as Integer Dim dDate as Date Dim CurDate as Date Dim oLinkSheet as Object Dim StartIndex as Integer 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 CurDate = EndDate 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.SetValue(CurDate) CurDate = CurDate - iStep 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