REM  *****  BASIC  *****
option explicit
option VBASupport 1 ' for InStrRev

Sub createPDFForm
	dim doc
	doc = StarDesktop.currentComponent
	if not doc.hasLocation then
		saveAs (doc)
		if not doc.hasLocation then exit sub
	else
		' make sure it's saved
		doc.storeAsURL (doc.location, Array())
	endif
	Dim url, args(0) as new com.sun.star.beans.PropertyValue
	url = doc.location
	args(0).Name = "AsTemplate"
	args(0).Value = true
	doc = StarDesktop.loadComponentFromURL (url, "_blank", 0, args)	
	if isNull(doc) then exit sub
	makeForm doc
	fillTable doc
	url = Left(url, InStrRev(url, "." ) ) & "pdf" ' thanks to http://stackoverflow.com/questions/917672/change-filename-extension-in-basic-for-openoffice-macro
	args(0).Name = "FilterName"
	args(0).Value = "writer_pdf_Export"
	doc.storeToURL (url, args)
	' close doc per http://wiki.services.openoffice.org/wiki/Documentation/DevGuide/OfficeDev/Closing_Documents
	if doc.supportsService ("com.star.util.XCloseable") then
		doc.close True
	else
		doc.dispose
	end if
	' display the new PDF (the OLE bridge is documented at http://wiki.services.openoffice.org/wiki/Documentation/DevGuide/ProUNO/Bridge/Using_Automation_Objects_from_UNO
	' Wscript.Shell.Run is documented at http://msdn.microsoft.com/en-us/library/d5fk67ky(VS.85).aspx
	createUnoService("com.sun.star.bridge.oleautomation.Factory").createInstance("Wscript.Shell").run url
End Sub

sub saveAs (doc)
	dim document, dispatcher
	document   = doc.CurrentController.Frame
	dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
	dim args1(0) as new com.sun.star.beans.PropertyValue
	args1(0).Name = "FilterName"
	args1(0).Value = "writer8"
	dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1())
end sub

sub makeForm (doc)
' turn static forms into real forms ("[]" becomes a checkbox; "[x]" becomes a pre-checked checkbox; "____" becomes an edit field of the same length
	Dim search
	search = doc.createSearchDescriptor
	search.searchString = "\[ *]" ' empty checkboxes
	search.searchRegularExpression = true
	dim result
	result = doc.findAll(search)
	dim i
	for i = 0 to result.count-1
		createCheckbox result.getByIndex(i), False, doc
	next i
	search.searchString = "\[[^\]]*]" ' checkboxes with something in them
	result = doc.findAll(search)
	for i = 0 to result.count-1
		createCheckbox result.getByIndex(i), True, doc
	next i
	search.searchString = "_+" ' underlines need to be replaced with text boxes
	result = doc.findAll(search)
	for i = 0 to result.count-1
		createTextframe result.getByIndex(i), doc
	next i
end sub

sub createCheckbox (rng as com.sun.star.text.TextRange, checked as boolean, doc) as com.sun.drawing.ControlShape
' returns an inline checkbox to be used with insertTextContent
	' need to create two objects and associate them (http://api.openoffice.org/servlets/ReadMsg?list=dev&msgNo=20684)
	dim checkModel, checkbox
	checkModel = doc.createInstance("com.sun.star.form.component.CheckBox")
	checkbox = doc.createInstance("com.sun.star.drawing.ControlShape")
	checkModel.label = ""
	if (checked) then checkModel.state = 1
	checkModel.visualEffect = com.sun.star.awt.VisualEffect.FLAT
	Dim sz as New com.sun.star.awt.Size
	sz.height = 320 ' hard-wired is ugly, but checkboxes are fixed in size (/qa.openoffice.org/issues/show_bug?id=26593)
	sz.width  = 320
	checkbox.size = sz ' can't just do checkShape.size.height = 320 because structs are always copied (wiki.services.openoffice.org/wiki/Documentation/DevGuide/ProUNO/Basic/Mapping_of_Structs)
	checkbox.vertOrient = com.sun.star.text.VertOrientation.TOP
	checkbox.control = checkModel
	rng.Text.insertTextContent(rng, checkbox, True)
end sub

sub createTextframe (rng as com.sun.star.text.TextRange, doc)
' simulate an underlined textbox by putting it in a frame with a bottom border
	dim textframe
	textframe = doc.createInstance("com.sun.star.text.TextFrame")
	textframe.anchorType = com.sun.star.text.TextContentAnchorType.AS_CHARACTER
	Dim sz as New com.sun.star.awt.Size
	sz.height = rng.charHeight * 2540/72 - 50 ' convert points to dekamicrons and adjust to let it fit the line
	sz.width  = rng.charHeight * len(rng.string) * 2540/144 ' underline is about one en, half of charHeight
	textframe.size = sz
	textframe.TopMargin = 0
	textframe.BottomMargin = 0
	textframe.LeftMargin = 0
	textframe.RightMargin = 0
	textframe.BorderDistance = 0
	textframe.HoriOrient = com.sun.star.text.HoriOrientation.NONE
	textframe.VertOrient = com.sun.star.text.VertOrientation.LINE_TOP
	dim border as New com.sun.star.table.BorderLine
	border = textframe.bottomBorder
	border.outerLineWidth = 50
	textframe.bottomBorder = border
	border.outerLineWidth = 0
	textframe.topBorder = border
	textframe.leftBorder = border
	textframe.rightBorder = border
	dim textbox, textModel, fontDescriptor
	textModel = doc.createInstance("com.sun.star.form.component.TextField")
	textbox = doc.createInstance("com.sun.star.drawing.ControlShape")
	textModel.border = 0 ' no border
	fontDescriptor = textModel.fontDescriptor
	fontDescriptor.name = rng.CharFontName
	fontDescriptor.height = rng.CharHeight-1 ' slightly smaller to fit over the underline
	textModel.fontDescriptor = fontDescriptor
	textbox.size = sz
	textbox.vertOrient = com.sun.star.text.VertOrientation.TOP
	textbox.control = textModel
	rng.text.insertTextContent(rng, textframe, True)
	' can't create a text cursor before the frame is inserted in the text	
	textframe.insertTextContent(textframe.createTextCursor, textbox, True)
end sub



sub fillTable (doc)
	Dim tables, table, tableIndex
	Dim rows, cols, rowindex, colIndex
	Dim cell
		 
	tables = doc.getTextTables()
	For tableIndex = 0 to tables.count - 1
		table = tables(tableIndex)	 
		rows = table.getRows
		cols = table.getColumns
		For rowIndex = 1 To rows.count: For colIndex = 1 To cols.count
			cell = table.getCellByName( Chr(Asc("A") - 1 + colIndex) & rowIndex)
			if len(cell.string) = 0 then
			' only fill empty cells
				dim textbox, textModel, fontDescriptor, textRng
				if colIndex = 0 then
					'I initially had the first column as a checkbox for Do Not Substitute, but I don't like it.
					textModel = doc.createInstance("com.sun.star.form.component.CheckBox")
					textModel.label = " "
				else
					textModel = doc.createInstance("com.sun.star.form.component.TextField")
					textModel.border = 0 ' no border
					fontDescriptor = textModel.fontDescriptor ' copy the relevant font info. ranges don't use FontDescriptors, so I can't just do
					textRng = cell.createTextCursor           ' textModel.fontDescriptor = textRng.fontDescriptor
					fontDescriptor.name = textRng.CharFontName
					fontDescriptor.height = textRng.CharHeight-1 ' a bit smaller to show the descenders
					textModel.fontDescriptor = fontDescriptor
				end if
				textbox = doc.createInstance("com.sun.star.drawing.ControlShape")
				textbox.vertOrient = com.sun.star.text.VertOrientation.NONE
				textbox.vertOrientPosition = 60 ' odd inconsistency: positive numbers are below baseline here, but above baseline in Position dialog box
				textbox.control = textModel
				cell.insertTextContent(cell, textbox, false)
				Dim sz as New com.sun.star.awt.Size
				sz.height = cell.start.charHeight * 2540/72 ' points to dekamicrons
				sz.width  = colwidth(table, colIndex-1)-150
				textbox.size = sz
			end if
		Next colIndex : Next rowIndex
	Next tableIndex
end sub

function colwidth (table, index) ' index is 0-based
	' need the table to be oriented (http://api.openoffice.org/servlets/ReadMsg?list=dev&msgNo=12552) 
	table.horiOrient = com.sun.star.text.HoriOrientation.LEFT_AND_WIDTH
	' tricks from http://wiki.services.openoffice.org/wiki/API/Samples/Java/Writer/TextTable
	dim n
	n = table.columns.count
	if index >= n then
		colwidth = 0
	elseif n = 1 then ' single column table
		colwidth = table.width
	else
		dim ratio as double
		ratio = table.width / table.tableColumnRelativeSum
		dim pos
		pos = table.tableColumnSeparators
		if index = 0 then
			colwidth = pos(0).position * ratio
		elseif index = n-1 then ' last column
			colwidth = (table.tableColumnRelativeSum - pos (ubound(pos)).position) * ratio
		else
			colwidth = (pos(index).position - pos(index-1).position) * ratio
		end if
	end if
end function

sub splitParagraphs
' separates paragraphs in tables into separate rows (only in column D) (Useful for text pasted into tables that should be on separate lines)
	dim doc
	doc = StarDesktop.currentComponent
	Dim tables, table, tableIndex
	Dim rows, rowindex
	Dim cell
		 
	tables = doc.getTextTables()
	For tableIndex = 0 to tables.count - 1
		table = tables(tableIndex)	 
		rows = table.getRows
		For rowIndex = 1 To rows.count
			cell = table.getCellByName("D" & rowIndex)
			if not isNull (cell) then splitParagraph cell.text, table, rowIndex, doc
		Next rowIndex
	Next tableIndex
end sub

sub splitParagraph (t, table, rowIndex, doc)
	dim paras, para, controller, clip, cell, n ' n is number of paragraphs inserted
	n = 0
	controller = doc.currentController
	paras = t.createEnumeration
	' leave the first paragraph (the instructions) untouched
	if paras.hasMoreElements then para = paras.nextElement
	While paras.hasMoreElements
		n = n + 1
		para = paras.nextElement
		controller.select (para)
		clip = controller.transferable
		cell = table.getCellByName ("D" & (rowIndex + n))
		if len(cell.string) <> 0 then
			' add a new row at the right place and delete the penultimate one (any contents will be lost)
			' the last row is the "Physician Signature" line; don't delete that
			table.rows.insertByIndex (rowIndex+n-1, 1)
			table.rows.removeByIndex (table.rows.count-2, 1)
			cell = table.getCellByName ("D" & (rowIndex + n))
		end if
		controller.select (cell)
		controller.insertTransferable clip
		para.dispose
	Wend
end sub