OpenOffice.info

Code: Alles auswählen

Function GetAddress(HyperlinkCell As Range)

    GetAddress = Replace _

    (HyperlinkCell.Hyperlinks(1).Address, "mailto:", "")

End Function

Code: Alles auswählen

=LINKS(A2;LÄNGE(A2))

Code: Alles auswählen

Option VBASupport 1

Code: Alles auswählen

REM  *****  BASIC  *****
Public oDoc as Object
Public ofromSheet as object
Public oToSheet as object
'-------------------------------------------------------------------------------
'SchreibtAddresse und Links der selektierte Zeile in Tabelle2
Sub writeSelection
Dim nRow As Long
Dim oSelection
  oDoc=ThisComponent
  ofromSheet= oDoc.Sheets.getByName("Tabelle1")
  oToSheet= oDoc.Sheets.getByName("Tabelle2")
  oSelection= odoc.CurrentSelection
  if  oSelection.supportsService( "com.sun.star.sheet.SheetCellRange") then
    nRow= oSelection.RangeAddress.StartRow
    if oSelection.RangeAddress.Sheet= _
        ofromSheet.getCellByPosition(0,0).RangeAddress.Sheet then
      WriteNewAdress(nRow)
      WriteNewHyperLink(nRow)
    else
      MsgBox "Die auswahl befindet sich auf der falschen Tabelle",16,"Fehler"
    end if
  else 
    MsgBox "Es ist keine Zelle ausgewählt.",16,"Fehler"
  end if
End Sub
'----------------------------------------------------------
'Schreibt Addresse und Linksaller Zeilen in Tabelle2
Sub writeAll
Dim nRow As Long
  oDoc=ThisComponent
  ofromSheet= oDoc.Sheets.getByName("Tabelle1")
  oToSheet= oDoc.Sheets.getByName("Tabelle2")
  For nRow=0 To GetLastUsedRow(ofromSheet)
    WriteNewAdress(nRow)
    WriteNewHyperLink (nRow)
  Next
End Sub
'------------------------------------------------------------------------------------
'Parst die Addresse und schreibt sie in Tabelle2
Sub WriteNewAdress(nRow as Long)
Dim aAdress()
Dim i%
Dim sAdress$, sNR$, sStreet$, sPLZ$, sStadt$
  'Name eintragen
  sName=ofromSheet.getCellByPosition( 0, nRow).String
  oToSheet.getCellByPosition( 0, nRow+1).String=sName
  sAdress=ofromSheet.getCellByPosition( 1, nRow).String
  'Addresse separieren und eintragen
  aAdress()=Split( sAdress,chr(10))
  If  aAdress(0)<>"" Then
    i=1
    Do while IsNumeric (Right (aAdress(0),i))   
     sNR= Right (aAdress(0),i)
     sStreet=Left(aAdress(0),len(aAdress(0))-i)
     i=i+1
    Loop 
    'Straße
    oToSheet.getCellByPosition( 1, nRow+1).String=sStreet
    'Haus NR
    sNR=Trim(sNR)
    oToSheet.getCellByPosition( 2, nRow+1).String= sNR
  End if
  If  Ubound(aAdress())>=1 Then
    'PLZ
    sPLZ=Left(aAdress(1),5)
    oToSheet.getCellByPosition( 3, nRow+1).String= sPLZ
    'Stadt
    sStadt= Right(aAdress(1),Len(aAdress(1))-5)
    oToSheet.getCellByPosition( 4, nRow+1).String= sStadt
  end if
  If Ubound (aAdress())>=2 Then
    'Sdadteil 
    oToSheet.getCellByPosition(5, nRow+1).String= aAdress(2)
  end if 
  
end sub
'----------------------------------------------------------------------------------------------
'hhllt dieLinks und schreibt sie in Tabelle2
Sub WriteNewHyperLink(nRow as Long)
  Dim oCell as Object, oText as Object, oParEnum as Object, oParElement as Object
  Dim oEnum as Object, oElement as Object
  dim i%
  oCell = ofromSheet.getCellByPosition( 3, nRow)
  oParEnum = oCell.getText().createEnumeration()
  'Zugriff auf alle Textfelder in der Zelle
  Do While oParEnum.hasMoreElements()
    oParElement = oParEnum.nextElement()
    oEnum = oParElement.createEnumeration()
    i=0
    'schleife über alle Textfelder in der Zelle
    'und holend der URL
    Do While oEnum.hasMoreElements()
      oElement = oEnum.nextElement()
      If oElement.TextPortionType = "TextField" Then
        i=i+1
        If oElement.TextField.supportsService("com.sun.star.text.TextField.URL") Then
          'Schreiben der URL
          oToSheet.getCellByPosition(5+i, nRow+1).String= oElement.TextField.URL
        End If
      End If
    Loop
  Loop
End Sub 
'----------------------------------------------------------------------------------------------
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 as Object
  Dim oCursor as Object
  Dim aAddress
  
  oCell = oSheet.getCellByPosition(0, 0)
  oCursor = oSheet.createCursorByRange(oCell)
  oCursor.gotoEndOfUsedArea(True)
  aAddress = oCursor.RangeAddress
  GetLastUsedRow = aAddress.EndRow
End Function