von Frieder D. » Mo, 12.03.2012 15:13
Hallo,
hoffentlich bist du noch an einer Lösung interessiert.
Wie man die URLs aus den Textfeldern einer Zelle bekommt steht in
OpenOffice.org Macros Explained von Andrew Pitonyak, Kapittel 15.11. URLs in Calc suchen .
Ich habe dir mahl ein Makro geschrieben, mit dem du deine Tabelle in eine ordentliche Form bringst, und das die Links ausließt.
Ich denke nicht, dass das mit VBA-Code funktioniert.
Hier der Code:
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
Und hier das Dokument mit eingebauten Makros:
Gruß Frieder
Hallo,
hoffentlich bist du noch an einer Lösung interessiert.
Wie man die URLs aus den Textfeldern einer Zelle bekommt steht in [url=http://www.uni-due.de/~abi070/ooo.html]OpenOffice.org Macros Explained[/url] von Andrew Pitonyak, Kapittel 15.11. URLs in Calc suchen .
Ich habe dir mahl ein Makro geschrieben, mit dem du deine Tabelle in eine ordentliche Form bringst, und das die Links ausließt.
Ich denke nicht, dass das mit VBA-Code funktioniert.
Hier der Code:
[code]
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[/code]
Und hier das Dokument mit eingebauten Makros:
[attachment=0]Kontaktliste2.ods[/attachment]
Gruß Frieder