LibreOffice-Forum

Code: Alles auswählen

REM  *****  BASIC  *****
'Copyright (c) 2011 Frieder Delor, Mailto: delorfr@googlemail.com
'This Module contains Some Lines from Winfried Rohr
'Copyright (c) 2007 Winfried Rohr, re-Solutions Software Test Engineering
'mailto: ooo@re-solutions.de  Untere Zahlbacher Strasse 18, D-55131 Mainz
 
'This program is free software; you can redistribute it and/or modify it under 
'the terms of the GNU General Public License as published by the Free Software
'Foundation; either version 2 of the License, or (at your option) any later 
'version.

'This program is distributed in the hope that it will be useful, but WITHOUT 
'ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
'FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.

'You should have received a copy of the GNU General Public License along with 
'this program; if not, write to the Free Software Foundation, Inc., 59 Temple 
'Place, Suite 330, Boston, MA 02111-1307 USA
' ========================================================================
Option Explicit

sub import_CSV
Dim sBlattName As String
Dim oSheets As Object
Dim oDoc as Object
  oDoc = ThisComponent
  oSheets = oDoc.Sheets
  oDoc.addActionLock 
  oDoc.LockControllers
  sBlattName ="Rohtabelle"
'  insertCSV2Calc (sBlattName )
  If Not insertCSV2Calc2(sBlattName) Then
    MsgBox "Oh. Mist. Ende.", 0, "Fehler"
    Exit Sub
  End If


  oDoc.Sheets.insertNewByName("sheetDummy" ,0)'ist nur dazu da, die Farbe der letzten Tabelle richtig anzuzeigen
  oDoc.getSheets.removeByName("sheetDummy")


  oDoc.UnlockControllers 
  oDoc.removeActionLock
End Sub
'------------------------------------
' Main routine
' the Sub "insertCSV2Calc" is originally from Winfried Rohr, with a few changes from me.

' ========================================================================
Function insertCSV2Calc2 ( sBlattName As String) As Boolean 'Optional
Dim oImport2Calc As Object , oFileDialog As Object
Dim oNeuBlatt As Object  
Dim oCSV  As Object
Dim sDir$ ,sUrl$
Dim iiSpalten as Long
Dim iiZeilen as Long
Dim oQuellBlatt As Object, oQuellBereich AS Object ,  oZielBereich As Object
Dim alleDaten
Dim oDoc as Object
'sBlattName="Rohtabelle2"
  oDoc = ThisComponent
  oImport2Calc = StarDesktop.getCurrentComponent().getCurrentController().getModel()
  ' laden von Hilfsfunktionen
  GlobalScope.BasicLibraries.LoadLibrary( "Tools" )
  
  ' Dateidialog zur Auswahl des CSV
  oFileDialog = _
    CreateUnoService( "com.sun.star.ui.dialogs.FilePicker" )
  With oFileDialog
     .setDisplayDirectory(GetWorkDir)
    .appendFilter( "Textdatei (TAB getrennt)", "*.csv" )
    .Title = "CSV-Datei zum Import wählen"
  End With 

  ' wenn ausgewählt und mit OK geschlossen
  If oFileDialog.execute() = _
    com.sun.star.ui.dialogs.ExecutableDialogResults.OK then
    ' ausgewählter Dateiname
    sUrl = oFileDialog.Files(0)
    If oDoc.Sheets().hasByName( sBlattName ) then 
      oDoc.getSheets.removeByName( sBlattName )
    End If
    '  anlegen nach letztem Blatt
    If oDoc.Sheets().getCount() < 255 then
      oDoc.Sheets().insertNewByName( sBlattName , _
        oDoc.Sheets().getCount() )
    Else
      MsgBox _
        "Beende das Makro: Max. Tabellenanzahl." & CHR(10) _
        & CHR(10) & "Erklärung:" _
        & CHR(10) & "Diese Calc-Datei hat die maximale Anzahl an Tabellen" _
        & CHR(10) & "Deshalb importiere ich die Daten nicht" _
        & CHR(10) & " das Makro wird nun beendet." _
        , 48 ,  "Fehler "
      Exit Function		 
    End If
        
    ' Objekt für das neue Blatt     
    oNeuBlatt = oDoc.Sheets().getByName( sBlattName )
    'On Error Resume Next
    oNeuBlatt.tabColor = RGB(100,125,255)
    ' Filter festlegen
    Dim FileProperties(2) As New com.sun.star.beans.PropertyValue
    FileProperties(0).Name = "FilterName"
    FileProperties(0).Value ="Text - txt - csv (StarCalc)"
    FileProperties(1).Name = "FilterOptions"
    ' FilterOptions 
    FileProperties(1).Value ="59/44,34,22,1,1/1/2/1/3/1/4/1" 
    '"Westeuropa(iso-8859-15/EURO)"=22
    ' Funktioniert bei mir nur als Wert, nicht als String.
    FileProperties(2).Name = "Hidden"
    FileProperties(2).Value = True
    ' Datei öffnen
    oCSV = _
      StarDesktop.loadComponentFromURL( _
      sUrl, "_blank", 0, FileProperties())
        
    ' Bereich der Daten ermitteln
    oQuellBlatt = oCSV.Sheets( 0 ) 
    iiSpalten = _
      getLastUsedColumn( oQuellBlatt ) 
    iiZeilen = _
      getLastUsedRow( oQuellBlatt )  
        
    ' alle Daten als Array rausziehen
    oQuellBereich = _
      oQuellBlatt.getCellRangeByPosition( _
      0, 0, iiSpalten, iiZeilen )
        
    alleDaten = _
      oQuellBereich.getDataArray()
        
    ' Zielbereich in gleicher Grösse festlegen 
    oZielBereich = _
      oNeuBlatt.getCellRangeByPosition( _
      0, 0, iiSpalten, iiZeilen )
    ' Datenarray reinschreiben
    oZielBereich.setDataArray( alleDaten() ) 
    'Hochkomma entfernen:  
    dim oRange as object, oReplaceDescriptor as object
    oRange= oNeuBlatt.getCellrangeByPosition(0,0,iiSpalten,iiZeilen)
    oReplaceDescriptor = oRange.createReplaceDescriptor()
	oReplaceDescriptor.SearchString = "^."
	oReplaceDescriptor.ReplaceString = "&"
	oReplaceDescriptor.SearchRegularExpression = True
	oRange.ReplaceAll( oReplaceDescriptor )
    ' CSV-Datei schliessen  
    oCSV.close( TRUE )
    insertCSV2Calc2 = True
  End If      
End Function 
'------------------------------------------------------
Function GetWorkDir() As String
  Dim oPathSettings
  oPathSettings = CreateUnoService("com.sun.star.util.PathSettings")
  GetWorkDir() = oPathSettings.Work
End Function
'-----------------------------------------------------------
REM Returns the number of the last Row of a continuous data range in a sheet.
Function GetLastUsedRow(oSheet as Object) As Integer 
  Dim oCell
  Dim oCursor
  Dim aAddress
  
  oCell = oSheet.getCellByPosition(0, 0)
  oCursor = oSheet.createCursorByRange(oCell)
  oCursor.gotoEndOfUsedArea(True)
  aAddress = oCursor.RangeAddress
  GetLastUsedRow = aAddress.EndRow
End Function
REM Returns the number of the last column of a continuous data range in a sheet.
Function GetLastUsedColumn(oSheet as Object) As Long
  Dim oCell
  Dim oCursor
  Dim aAddress

  oCell = oSheet.getCellByPosition(0, 0)
  oCursor = oSheet.createCursorByRange(oCell)
  oCursor.gotoEndOfUsedArea(True)
  aAddress = oCursor.RangeAddress
  GetLastUsedColumn = aAddress.EndColumn
End Function