Benutzer:Erodeist/Calc2WikiTable

Calc2WikiTable ist ein BASIC-Makro für OpenOffice.org Version 2.4. Es wurde vorrangig für den Datenaustausch zwischen Calc Spreadsheet-Tabellen und Wikipedia-Tabellen entwickelt. Benutzung für Artikelbearbeitungen wird momentan nicht empfohlen.

Einschränkungen

• Dies ist eine Alpha-Version (0.2).

Installation

1. In OpenOffice.org Calc muß ein neues Makro-Modul in einer Bibliothek erstellt werden. Der Name für das Modul ist frei wählbar (Empfehlung: „Calc2WikiTable“).
2. Das neue Modul muß zur Bearbeitung geöffnet werden.
3. Der gesamte nachfolgende Quellcode wird per Copy&Paste eingefügt.
4. Ab sofort steht die Funktionalität über die Funktion „Main“ zur Verfügung.

Gebrauchs-Anleitung

1. In Calc den gewünschten Zellbereich auswählen (zusammenhängendes Rechteck).
2. Das Makro starten. Im sich öffnenden Eingabefeld können Parameter für die Konvertierung festgelegt werden. Mit OK bestätigen.
3. Ein neues Writer Dokument wird geöffnet, in das die Wikipedia-Tabelle „geschrieben“ wird.
4. Fertig.

Quellcode

' ========== Calc2WikiTable ====================================================
' Software : BASIC-Macro for OpenOffice.org (version 2.x or later)
' Purpose  : Converts a Calc spreadsheet into a Wikipedia table
' Version  : 0.2 (2008-12-12)
' Author(s): Erodeist
' <http://de.wikipedia.org/wiki/Benutzer:Erodeist/Calc2WikiTable>
' ------------------------------------------------------------------------------
' USAGE
' 1. Select in OOo.Calc a single rectangular range of cells for conversion.
' 2. Execute this macro. You will be asked for conversion parameters.
'    Supported parameters are:
'    C - caption, the SpreadSheet's name is used
'    H - header, for cells in first row
'        Automatically suggested, if first cell has bigger/bolder font
'    W - wikitable, outputs 'class="wikitable"'
'    S - sortable columns, outputs 'class="sortable"'
'        should be used with the H-parameter
'    F - format text (bold, italic)
'    L - links (Hyperlinks in cells)
'    A - align cells, outputs 'style="text-align:..."'
'        Numbers will be right-aligned
'    O - one line per row
' 3. Verify/modify the results in the created OOo.Writer document.
' 4. Copy the produced code from OOo.Writer into your Wikipedia table.
' ------------------------------------------------------------------------------
' LICENSE
' Calc2WikiTable, BASIC-Macro for OpenOffice.org
' Copyright (c) 2008 Erodeist
' 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 3 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, see <http://www.gnu.org/licenses/>.
' ------------------------------------------------------------------------------

Option Explicit
' ---------- WIKI SETTINGS ----------
' Note: Quotes (") in Strings must be escaped by another Quote
Const WIKI_HEADCLASS  = "hintergrundfarbe5" ' style class for header
Const WIKI_HEADSTYLE  = "" ' inline style for header
Const WIKI_EMPTYCELL  = "" ' for empty cells, "&nbsp;" or ""
Const WIKI_ALIGNRIGHT  = "style=""text-align:right"""
Const WIKI_ALIGNCENTER = "style=""text-align:center"""
Const WIKI_BASEURL    = "http://de.wikipedia.org/"
Const WIKI_WIKIURL    = "http://de.wikipedia.org/wiki/"
Const WIKI_REDLINK1   = "http://de.wikipedia.org/w/index.php?title="
Const WIKI_REDLINK2   = "&action=edit&redlink=1"
'Const WIKI_ALIGNRIGHT  = "align=""right"""  ' deprecated
'Const WIKI_ALIGNCENTER = "align=""center""" ' deprecated
' ---------- OOo.WRITER ---------- 
Const WRITER_FONTNAME = "Courier New"
Const WRITER_FONTSIZE = 10.0
' ---------- i18n ----------
Const MSG_MACRO  = "Calc2WikiTable - OOo.table -> Wikipedia.table"
Const MSG_ERROR  = "Calc2WikiTable: Error"
Const MSG_PARAM1 = "This macro converts selected table cells into Wikipedia format. "
Const MSG_PARAM2 = "Enter conversion parameters:  [C]aption  [H]eader "
Const MSG_PARAM3 = "[W]ikitable  [S]ortable  [A]lign  [O]ne line/row  [F]ormats  [L]inks "
Const PARAM_CAPTION  = "C", PARAM_HEADER = "H", PARAM_WIKITABLE = "W" ' see MSG_PARAMx
Const PARAM_SORTABLE = "S", PARAM_ALIGN  = "A", PARAM_ONELINE   = "O" ' see MSG_PARAMx
Const PARAM_FORMATS  = "F", PARAM_LINKS  = "L" ' see MSG_PARAMx
Const ERR_INVALIDDOCUMENT = "Not a Spreadsheet Document. "
Const ERR_MULTICELLRANGE  = "Can't convert multiple Cell Ranges. "
' ------------------------------------------------------------------------------

Sub Main
Dim docCalc As Object, oSheet As Object
Dim cra As New com.sun.star.table.CellRangeAddress ' As Variant
Dim iRow As Long, iCol As Long
Dim oCell As Object, sCell As String ' cell object, text
Dim sDelimiter As String ' for TH/TD output
Dim cchTable As Long, cchCell As Long, cchCellMax As Long ' examination
Dim sFlags As String ' user parameters
Dim fWikitable As Boolean, fMini As Boolean, fAligned As Boolean ' flags
Dim fCaption As Boolean, fHeading As Boolean, fSortable As Boolean ' flags
Dim fFormats As Boolean, fLinks As Boolean ' flags

	' check component and selection
	If Not ThisComponent.supportsService("com.sun.star.sheet.SpreadsheetDocument") Then
		MsgBox(ERR_INVALIDDOCUMENT, 16, MSG_ERROR) : Exit Sub
	ElseIf ThisComponent.CurrentSelection.supportsService("com.sun.star.sheet.SheetCellRanges") Then
		MsgBox(ERR_MULTICELLRANGE, 16, MSG_ERROR) : Exit Sub
	End If
	
	' access stuff and selection range
	docCalc = ThisComponent	
	oSheet = docCalc.CurrentSelection.SpreadSheet
	cra = docCalc.CurrentSelection.RangeAddress
	If (cra.EndColumn >= 255) Or (cra.EndRow = 65535) Then
		' user selected all
		cra = GetUsedRangeAddress(oSheet)
	End If
	
	' collect "optimal" conversion parameters
'	sFlags = PARAM_CAPTION
	' check for heading
	If oSheet.Rows.Count > 1 Then
		Dim oCell2 As Object
		oCell = oSheet.getCellByPosition(cra.StartColumn, cra.StartRow)
		oCell2 = oSheet.getCellByPosition(cra.StartColumn, cra.StartRow + 1)
		If oCell.CharHeight > oCell2.CharHeight Then
			sFlags = sFlags & PARAM_HEADER
		ElseIf oCell.CharWeight > oCell2.CharWeight Then
			sFlags = sFlags & PARAM_HEADER
		End If
	End If
	sFlags = sFlags & PARAM_WIKITABLE & PARAM_FORMATS & PARAM_LINKS
	
	' check string sizes (whether to use PARAM_ONELINE)
	For iRow = cra.StartRow To cra.EndRow
		For iCol = cra.StartColumn To cra.EndColumn
			cchCell = Len(oSheet.getCellByPosition(iCol, iRow).String)
			If cchCell > cchCellMax Then cchCellMax = cchCell
			cchTable = cchTable + cchCell
		Next iCol
	Next iRow
	If ((cchTable / (cra.EndRow - cra.StartRow + 1)) < 80) And (cchCellMax < 40) Then
		sFlags = sFlags & PARAM_ONELINE
	End If
	
	' ask user for final conversion parameters
	sFlags = InputBox(MSG_PARAM1 & Chr(13) & MSG_PARAM2 & Chr(13) & MSG_PARAM3, _
			MSG_MACRO, sFlags)
	If Len(sFlags) = 0 Then
		Exit Sub ' user cancelled
	Else
		fCaption   = InStr(1, sFlags, PARAM_CAPTION, 1)
		fHeading   = InStr(1, sFlags, PARAM_HEADER, 1)
		fSortable  = InStr(1, sFlags, PARAM_SORTABLE, 1)
		fWikitable = InStr(1, sFlags, PARAM_WIKITABLE, 1)
		fMini      = InStr(1, sFlags, PARAM_ONELINE, 1)
		fAligned   = InStr(1, sFlags, PARAM_ALIGN, 1)
		fFormats   = InStr(1, sFlags, PARAM_FORMATS, 1)
		fLinks     = InStr(1, sFlags, PARAM_LINKS, 1)
	End If
	'fHeading = fWikitable Or fSortable
	
	Dim docWriter As Object, oText As Object, oCursor As Object, vDummy()
	Dim PAR_BREAK As Integer ' = com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK

	' initalize Writer objects
	docWriter = StarDesktop.LoadComponentFromURL("private:factory/swriter", "_blank", 0, vDummy)
	oText = docWriter.Text
	oCursor = oText.createTextCursor()
	' select all and apply font
	With oCursor
		.gotoEnd(False)
		.gotoStart(True)
		.CharFontName = WRITER_FONTNAME
		.CharHeight = WRITER_FONTSIZE
	End With
	PAR_BREAK = com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK

	' open the table
	oText.insertString(oCursor, "{|", False)
	If fWikitable And fSortable Then
		oText.insertString(oCursor, " class=""wikitable sortable""", False)
	ElseIf fWikitable Then
		oText.insertString(oCursor, " class=""wikitable""", False)
	ElseIf fSortable Then
		oText.insertString(oCursor, " class=""sortable""", False)
	End If
	oText.insertControlCharacter(oCursor, PAR_BREAK, False)
	
	' insert caption
	If fCaption Then
		oText.insertString(oCursor, "|+ " & oSheet.Name, False)
		oText.insertControlCharacter(oCursor, PAR_BREAK, False)
	End If
	
	' loop through rows
	For iRow = cra.StartRow To cra.EndRow
		If (iRow = cra.StartRow) And fHeading Then
			' use column headers
			oText.insertString(oCursor, "|-", False)
			If Len(WIKI_HEADCLASS) Then
				oText.insertString(oCursor," class=""" & WIKI_HEADCLASS & """", False)
			End If
			If Len(WIKI_HEADSTYLE) Then
				oText.insertString(oCursor," style=""" & WIKI_HEADSTYLE & """", False)
			End If
			oText.insertControlCharacter(oCursor, PAR_BREAK, False)
			sDelimiter = "!"
		Else
			sDelimiter = "|"
		End If
		
		' loop through columns
		For iCol = cra.StartColumn To cra.EndColumn
			' get cell and text
			oCell = oSheet.getCellByPosition(iCol, iRow)
			sCell = WikiCellString(oCell, _
					fFormats And ((iRow > cra.StartRow) Or (fHeading = False)), _
					fLinks)
			If Len(sCell) = 0 Then sCell = WIKI_EMPTYCELL
			
			' get cell formatting
			If (iRow > cra.StartRow) Or (fHeading = False) Then
				' check alignment
				If fAligned Then
					Select Case oCell.HoriJustify
						Case com.sun.star.table.CellHoriJustify.LEFT
							' no style required
						Case com.sun.star.table.CellHoriJustify.RIGHT
							sCell = WIKI_ALIGNRIGHT & " | " & sCell
						Case com.sun.star.table.CellHoriJustify.CENTER
							sCell = WIKI_ALIGNCENTER & " | " & sCell
						Case com.sun.star.table.CellHoriJustify.STANDARD
							If IsNumeric(oCell.String) Then
								sCell = WIKI_ALIGNRIGHT & " | " & sCell
							End If
					End Select
				End If
			End If
			
			' signal new wiki cell
			If (iCol = cra.StartColumn) Or (fMini = False) Then
				sCell = sDelimiter & " " & sCell
			Else
				sCell = " " & sDelimiter & sDelimiter & " " & sCell
			End If
			' insert cell text
			oText.insertString(oCursor, sCell, False)
			If (fMini = False) Then
				oText.insertControlCharacter(oCursor, PAR_BREAK, False)
			End If
		Next iCol
		
		' row done, 1-line-per-row needs newline
		If (fMini) Then
			oText.insertControlCharacter(oCursor, PAR_BREAK, False)
		End If
		' signal next row, if necessary
		If (iRow < cra.EndRow) Then
			oText.insertString(oCursor, "|-", False)
			oText.insertControlCharacter(oCursor, PAR_BREAK, False)
		End If
	Next iRow
	
	' close the table
	oText.insertString(oCursor, "|}", False)
	oText.insertControlCharacter(oCursor, PAR_BREAK, False)

End Sub

' Returns a RangeAddress structure bounding all used cells in a sheet.
' As New com.sun.star.table.CellRangeAddress
Function GetUsedRangeAddress(oSheet As Object) As Variant
Dim oCursor As Object
	oCursor = oSheet.createCursor()
	oCursor.GotoStartOfUsedArea(False)
	oCursor.GotoEndOfUsedArea(True)
	GetUsedRangeAddress = oCursor.RangeAddress
End Function

' Returns a cell's content with CharFormats and Links.
' No Paragraph Format applied
Function WikiCellString(oCell As Object, fFormat As Boolean, fLinks As Boolean) As String
Dim TextElement As Object
Dim TextPortion As Object
Dim Enum1 As Object
Dim Enum2 As Object
Dim sCell As String, sPart As String

	Enum1 = oCell.createEnumeration()
	' loop over "paragraphs"
	Do While Enum1.hasMoreElements()
		TextElement = Enum1.nextElement
		If TextElement.supportsService("com.sun.star.text.Paragraph") Then
			Enum2 = TextElement.createEnumeration
			' loop over portions
			Do While Enum2.hasMoreElements
				TextPortion = Enum2.nextElement
				Select Case TextPortion.TextPortionType
					Case "TextField"
						If fLinks Then
							sPart = WikiLink(TextPortion.TextField.URL, _
									TextPortion.TextField.Representation)
						Else
							sPart = WikiText(TextPortion.TextField.Representation)
						End If
					Case "Text"
						sPart = WikiText(TextPortion.String)
					Case Else
						MsgBox("TextPortionType = '" & TextPortion.TextPortionType & "'")
				End Select
				If fFormat Then ' apply character formatting
					If  TextPortion.CharWeight = com.sun.star.awt.FontWeight.BOLD Then
						sPart = "'''" & sPart & "'''"
					End If
					If TextPortion.CharPosture = com.sun.star.awt.FontSlant.ITALIC Then
						sPart = "''" & sPart & "''"
					End If
					If TextPortion.CharStrikeout = com.sun.star.awt.FontStrikeout.SINGLE Then
						sPart = "<s>" & sPart & "</s>"
					End If
					If TextPortion.CharUnderline = com.sun.star.awt.FontUnderline.SINGLE Then
						sPart = "<u>" & sPart & "</u>"
					End If
					If TextPortion.CharFontPitch = com.sun.star.awt.FontPitch.FIXED Then
						' <code></code>
					End If
				End If
				sCell = sCell & sPart
			Loop
		End If
	Loop
	' return string
	WikiCellString = sCell
End Function

' Returns a normalized string, problem characters encoded/dropped.
' Linebreaks are replaced by <br>.
Function WikiText(s As String) As String
Dim iPos As Long, aCode As Integer, aNext As Integer  ' input char position and aCode
Dim sOut As String, iOut As Long  ' output buffer and position
Dim fWasSpace As Boolean ' keep track of spaces
	
	sOut = Space(Len(s)) ' output buffer
	iPos = 1 : iOut = 1  ' start 1-based
'	fWasSpace = True     ' no leading space
	
	Do While iPos <= Len(s)
		aCode = Asc(Mid(s, iPos, 1)) ' get char aCode
		Select Case aCode
			Case 0 To 8, 11 To 12, 14 To 31
				' ignore
			Case 9, 32 ' TAB, SPC
				If Not fWasSpace Then
					Mid(sOut, iOut, 1, " "): iOut = iOut + 1
					fWasSpace = True
				End If
			Case 10, 13 ' LF CR
				sOut = sOut & Space(3) ' enlarge buffer
				Mid(sOut, iOut, 6, "<br>"): iOut = iOut + 4
				fWasSpace = False
				If iPos < Len(s) Then
					aNext = Asc(Mid(s, iPos + 1, 1))
					If (aNext = 10) Or (aNext = 13) And (aNext <> aCode) Then iPos = iPos + 1
				End If
			Case 124 ' PIPE |
				sOut = sOut & Space(5) ' enlarge buffer
				Mid(sOut, iOut, 6, "&#124;"): iOut = iOut + 6
				fWasSpace = False
			Case 160 ' NBSP
				sOut = sOut & Space(5) ' enlarge buffer
				Mid(sOut, iOut, 6, "&nbsp;"): iOut = iOut + 6
				fWasSpace = False
			Case Else
				Mid(sOut, iOut, 1, Chr(aCode)): iOut = iOut + 1
				fWasSpace = False
		End Select		
		iPos = iPos + 1 ' next character
	Loop
'	If fWasSpace Then iOut = iOut - 1 ' remove trailing space
	
	' return new string
	If iOut > 0 Then WikiText = Left(sOut, iOut - 1)
End Function

' Returns a Wikipedia Link (internal or external)
Function WikiLink(sURL As String, sText As String) As String
Dim iPos As Long, sTmp As String
	If InStr(1, sURL, WIKI_BASEURL) = 1 Then
		If InStr(1, sURL, WIKI_WIKIURL) = 1 Then
			sTmp = Mid$(sURL, Len(WIKI_WIKIURL) + 1)
		ElseIf InStr(1, sURL, WIKI_REDLINK1) = 1 Then
			iPos = InStr(Len(WIKI_REDLINK1) + 1, sURL, WIKI_REDLINK2)
			sTmp = Mid$(sURL, Len(WIKI_REDLINK1) + 1, iPos - Len(WIKI_REDLINK1) - 1)
		End If
	End If
	If Len(sTmp) Then
		For iPos = 1 To Len(sTmp)
			If Mid(sTmp, iPos, 1) = "_" Then Mid(sTmp, iPos, 1, " ")
		Next iPos
		If sText = sTmp Then
			WikiLink = "[[" & sText & "]]"
		ElseIf Len(sText) = 0 Then
			WikiLink = "[[" & sTmp & "]]"
		Else
			WikiLink = "[[" & sTmp & "|" & sText & "]]"
		End If	
	Else
		If (sText = sURL) Or (Len(sText) = 0) Then
			WikiLink = "[" & sURL & "]"
		Else
			WikiLink = "[" & sURL & " " & sText & "]"
		End If
	End If
End Function
' ---------- END OF SCRIPT ----------

ChangeLog

2008-12-12 Version 0.2 (Alpha)

* Unterstützt mehrere Formatierungen und Links innerhalb einer Zelle.

2008-12-10 Version 0.1 (Alpha)

[1]