epublishing/ePublishing/Album.xba

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Album" script:language="StarBasic" script:moduleType="normal">Sub albumMark6
End Sub

Sub rotatePageButton
	Dim curPageStyleName As String
	Dim pageStyles As Object
	Dim pageStyle As Object
	curPageStyleName = getCurPageStyleName()
	pageStyles = ThisComponent.StyleFamilies.getByName(&quot;PageStyles&quot;)
	pageStyle = pageStyles.getByName(curPageStyleName)
	If pageStyle.IsLandScape Then
		undoPageAlbum
	Else 
		makePageAlbum
	EndIf
End Sub

Sub makePageAlbum
	Dim curPageStyleName As String
	&apos;saveVersion(&quot;Перед выполнением макроса повоорта страницы в альбомную ориентацию&quot;)
	curPageStyleName = getCurPageStyleName()
	findBestAnchor()
	If checkPageSettings(curPageStyleName) Then
		MsgBox getTranslation(&quot;albumRotationCheckPageSettings&quot;)
		Exit Sub
	EndIf
	rotatePageClockwise(curPageStyleName)	
End Sub

Sub findBestAnchor()
	Dim curPageStyleName As String
	Dim oViewCursor As Object
	Dim oTextCursor As Object
	curPageStyleName = getCurPageStyleName()
	oViewCursor = ThisComponent.CurrentController.getViewCursor()
	oViewCursor.jumpToStartOfPage()
	oTextCursor = oViewCursor.Text.createTextCursorByRange(oViewCursor.End)
	If NOT oTextCursor.isStartOfParagraph Then
		oTextCursor.goToNextParagraph(false)
		oViewCursor.goToRange(oTextCursor,false)
	EndIf
	If	curPageStyleName = getCurPageStyleName() Then
		Exit Sub
	EndIf
	MsgBox getTranslation(&quot;unrecoverableError&quot;)
End Sub

Sub undoPageAlbum
	Dim curPageStyleName As String
	curPageStyleName = getCurPageStyleName()
	applyPortraitPageStyle(curPageStyleName)
End Sub

sub	applyPortraitPageStyle(pageStyleName As String)
	Dim pageStyles As Object
	Dim pageStyle As Object
	Dim oViewCursor As Object
	oViewCursor = ThisComponent.CurrentController.getViewCursor()
	pageStyles = ThisComponent.StyleFamilies.getByName(&quot;PageStyles&quot;)
	pageStyle = pageStyles.getByName(pageStyleName)
	If NOT pageStyle.IsLandScape Then
		MsgBox getTranslation(&quot;albumRotationPageIsAlreadyAlbum&quot;)
		Exit sub
	EndIf
	If pageStyles.hasByName(&quot;portrait_&quot; &amp; pageStyleName) Then
		replacePageStyleByPortrait(pageStyleName)
		removeAlbumFrames(pageStyleName)
	Else
		MsgBox getTranslation(&quot;albumRotationBackupStyleNotFound1&quot;) &amp; &quot; portrait_&quot; &amp; pageStyleName &amp; &quot; &quot; &amp; getTranslation(&quot;albumRotationBackupStyleNotFound2&quot;)
	EndIf
	
End Sub

Sub replacePageStyleByPortrait(pageStyleName As String)
	Dim pageStyles As Object
	Dim pageStyle As Object
	Dim oldPageStyle As Object
	Dim textEnumeration As Object
	Dim enumerationElement As Object
	Dim i As Integer
	pageStyles = ThisComponent.StyleFamilies.getByName(&quot;PageStyles&quot;)
	oldPageStyle = pageStyles.getByName(pageStyleName)
	For i = 0 To pageStyles.getCount() - 1 
		pageStyle = pageStyles.getByIndex(i)
		If pageStyle.FollowStyle = pageStyleName Then
			pageStyle.FollowStyle = &quot;portrait_&quot; &amp; pageStyleName
		EndIf
		If pageStyle.getName() = &quot;portrait_&quot; &amp; pageStyleName Then
			pageStyle.FollowStyle = oldPageStyle.FollowStyle
		EndIf
	Next i
	pageStyle = pageStyles.getByName(&quot;portrait_&quot; &amp; pageStyleName)
	pageStyle.Hidden = false
	pageStyle.FollowStyle = oldPageStyle.FollowStyle
	
	&apos;Replace in direct formatting
	textEnumeration = ThisComponent.Text.createEnumeration
	While textEnumeration.hasMoreElements
		enumerationElement = textEnumeration.nextElement
		If enumerationElement.pageDescName = pageStyleName Then
			enumerationElement.pageDescName = &quot;portrait_&quot; &amp; pageStyleName
		EndIf
	Wend
	
	&apos;Replace album style by portrait
	If oldPageStyle.IsUserDefined() Then
		pageStyles.removeByName(pageStyleName)
		pageStyles.getByName(&quot;portrait_&quot; &amp; pageStyleName).setName(pageStyleName)
	EndIf
	
End Sub


Sub removeAlbumFrames(pageStyleName As String)
	Dim drawPagesEnum As Object
	Dim drawPage As Object
	drawPagesEnum = ThisComponent.DrawPage.CreateEnumeration()
	While drawPagesEnum.hasMoreElements()
		drawPage = drawPagesEnum.nextElement()
		If drawPage.getName() = &quot;header_&quot; &amp; pageStyleName Or drawPage.getName() = &quot;footer_&quot; &amp; pageStyleName Then
			drawPage.dispose()
		EndIf
	Wend 
End Sub

sub savePortraitPageStyle(pageStyleName As String)
	createPageStyleByExample(&quot;portrait_&quot; &amp; pageStyleName)
	hidePageStyle(&quot;portrait_&quot; &amp; pageStyleName)
End Sub

Sub hidePageStyle(pageStyleName As String)
    &apos;Globalscope.BasicLibraries.LoadLibrary(&quot;MRILib&quot;)
	Dim pageStyles As Object
	Dim pageStyle As Object
	pageStyles = ThisComponent.StyleFamilies.getByName(&quot;PageStyles&quot;)
	pageStyle = pageStyles.getByName(pageStyleName)
    pageStyle.Hidden = true
End Sub

Sub rotatePageClockwise(pageStyleName As String)
	Dim pageStyles As Object
	Dim pageStyle As Object
	Dim tmpDimension As Long 
	Dim frame As Object
	Dim frameName As String
	Dim oViewCursor As Object
	Dim pageNumber As Long
	Dim headerFrameW As Long
	Dim headerFrameH As Long
	Dim headerFrameYOffset As Long
	Dim headerFrameXOffset As Long
	Dim footerFrameW As Long
	Dim footerFrameH As Long
	Dim footerFrameYOffset As Long
	Dim footerFrameXOffset As Long
	Dim textElement As Object
	oViewCursor = ThisComponent.CurrentController.getViewCursor()
	pageNumber = oViewCursor.getPage()
	pageStyles = ThisComponent.StyleFamilies.getByName(&quot;PageStyles&quot;)
	pageStyle = pageStyles.getByName(pageStyleName)
	If pageStyle.IsLandScape Then
		MsgBox getTranslation(&quot;albumRotationPageIsAlreadyAlbum&quot;)
		Exit sub
	EndIf
	If NOT pageStyle.IsUserDefined() Then
		pageStyleName = &quot;new&quot; &amp; pageStyleName
		createPageStyleByExample(pageStyleName)
		oViewCursor.pageDescName = pageStyleName
		pageStyle = pageStyles.getByName(pageStyleName)
	EndIf
	savePortraitPageStyle(pageStyleName)
	If pageStyle.HeaderIsOn Then
		headerFrameW = pageStyle.HeaderHeight - pageStyle.HeaderBodyDistance
		headerFrameH = pageStyle.Width - pageStyle.HeaderLeftMargin - pageStyle.HeaderRightMargin - pageStyle.LeftMargin - pageStyle.RightMargin
		headerFrameYOffset =  pageStyle.HeaderLeftMargin +  pageStyle.LeftMargin
		headerFrameXOffset =  pageStyle.Height - pageStyle.TopMargin - (pageStyle.HeaderHeight - pageStyle.HeaderBodyDistance)
	EndIf
	
	If pageStyle.FooterIsOn Then
		footerFrameW = pageStyle.FooterHeight - pageStyle.FooterBodyDistance
		footerFrameH = pageStyle.Width - pageStyle.FooterLeftMargin - pageStyle.FooterRightMargin - pageStyle.LeftMargin - pageStyle.RightMargin
		footerFrameYOffset =  pageStyle.FooterLeftMargin +  pageStyle.LeftMargin
		footerFrameXOffset =  pageStyle.BottomMargin
	EndIf
	
	rotatePageClockwiseMargins(pageStyle)
	rotatePageOrientation(pageStyle)
		
	If pageStyle.HeaderIsOn Then
		If NOT pageStyle.FirstIsShared Then
			textElement = pageStyle.HeaderTextFirst
		ElseIf NOT pageStyle.HeaderIsShared Then
			If pageNumber Mod 2 = 1 Then
				textElement = pageStyle.HeaderTextRight
			Else
				textElement = pageStyle.HeaderTextLeft
			EndIf		
		Else 
			textElement = pageStyle.HeaderText
		EndIf
		frameName = &quot;header_&quot; &amp; pageStyleName
		copyTextToFrame(textElement,headerFrameXOffset,headerFrameYOffset,headerFrameW,headerFrameH,frameName)
	EndIf
	
	If pageStyle.FooterIsOn Then
		If NOT pageStyle.FirstIsShared Then
			textElement = pageStyle.FooterTextFirst
		ElseIf NOT pageStyle.FooterIsShared Then
			If pageNumber Mod 2 = 1 Then
				textElement = pageStyle.FooterTextRight
			Else
				textElement = pageStyle.FooterTextLeft
			EndIf		
		Else 
			textElement = pageStyle.FooterText
		EndIf
		frameName = &quot;footer_&quot; &amp; pageStyleName
		copyTextToFrame(textElement,footerFrameXOffset,footerFrameYOffset,footerFrameW,footerFrameH,frameName)
	EndIf

	removePageHeader(pageStyle)
	removePageFooter(pageStyle)

End Sub

Sub rotatePageClockwiseMargins(pageStyle)
	Dim tmpDimension As Long 
	tmpDimension = pageStyle.LeftMargin
	If pageStyle.FooterIsOn Then
		pageStyle.LeftMargin = pageStyle.BottomMargin + pageStyle.FooterHeight
	Else
		pageStyle.LeftMargin = pageStyle.BottomMargin
	EndIf
	pageStyle.BottomMargin = pageStyle.RightMargin
	If pageStyle.HeaderIsOn Then
		pageStyle.RightMargin = pageStyle.TopMargin + pageStyle.HeaderHeight
	Else
		pageStyle.RightMargin = pageStyle.TopMargin
	EndIf
	pageStyle.TopMargin = tmpDimension
End Sub

Sub rotatePageOrientation(pageStyle)
	Dim tmpDimension As Long 
	tmpDimension = pageStyle.Height
	pageStyle.Height = pageStyle.Width
	pageStyle.Width = tmpDimension
	pageStyle.IsLandscape = Not pageStyle.IsLandscape
End Sub

Function checkPageSettings(pageStyleName As String) As Boolean
	Dim pageStyles As Object
	Dim pageStyle As Object
	checkPageSettings = false
	
	pageStyles = ThisComponent.StyleFamilies.getByName(&quot;PageStyles&quot;)
	pageStyle = pageStyles.getByName(pageStyleName)	
	If pageStyle.HeaderIsOn Then
		If pageStyle.HeaderIsDynamicHeight Then
			checkPageSettings = true
			pageStyle.HeaderIsDynamicHeight = false
			MsgBox getTranslation(&quot;albumRotationDynamicHeaderHeight&quot;)
		EndIf
		If pageStyle.HeaderDynamicSpacing Then
			checkPageSettings = true
			pageStyle.HeaderDynamicSpacing = false
			MsgBox getTranslation(&quot;albumRotationDynamicHeaderOffset&quot;)
		EndIf
	EndIf
	If pageStyle.FooterIsOn Then
		If pageStyle.FooterIsDynamicHeight Then
			checkPageSettings = true
			pageStyle.FooterIsDynamicHeight = false
			MsgBox getTranslation(&quot;albumRotationDynamicFooterHeight&quot;)
		EndIf
		If pageStyle.FooterDynamicSpacing Then
			checkPageSettings = true
			pageStyle.FooterDynamicSpacing = false
			MsgBox getTranslation(&quot;albumRotationDynamicFooterOffset&quot;)
		EndIf
	EndIf
	&apos;Workaround to force Writer reread new page settings
	If checkPageSettings Then
		pageStyle.FirstIsShared = true
		pageStyle.FirstIsShared = false
		pageStyle.FirstIsShared = true
	EndIf
End Function


Sub copyTextToFrame(textElement As Object,frameXOffset As Long,frameYOffset As Long,frameW As Long,frameH As Long,frameName As String)
	Dim oViewCursor As Object
	Dim initialCursorPosition As Object
	Dim frame As Object
	Dim enumeration As Object
	Dim firstElement As Boolean
	Dim element As Object
	Dim cellNames() As String
	Dim firstCellAnchor As Object
	Dim lastCellAnchor As Object
	
	oViewCursor = ThisComponent.CurrentController.getViewCursor()
	initialCursorPosition = oViewCursor.Text.createTextCursorByRange(oViewCursor.End)
	frame = createFrame(frameXOffset,frameYOffset,frameW,frameH,frameName)
	enumeration = textElement.CreateEnumeration()
	firstElement = true
	While enumeration.hasMoreElements
		element = enumeration.nextElement()
		If element.supportsService(&quot;com.sun.star.text.TextTable&quot;) Then
		 	cellNames = element.getCellNames()
		 	element.IsWidthRelative = false
		 	firstCellAnchor = element.getCellByName(cellNames(LBound(cellNames))).getStart()
		 	lastCellAnchor = element.getCellByName(cellNames(UBound(cellNames))).getEnd()
		 	oViewCursor.goToRange(firstCellAnchor,false)
			oViewCursor.goToRange(lastCellAnchor,true)
			unoCopy()
			oViewCursor.goToRange(frame.Text.End,false)
			unoPaste()
			If firstElement Then
				frame.Text.CreateEnumeration().nextElement.dispose()
			EndIf
		ElseIf  element.supportsService(&quot;com.sun.star.text.Paragraph&quot;) Then
			oViewCursor.goToRange(element,false)
			unoCopy()
			oViewCursor.goToRange(frame.Text.End,false)
			unoPaste()
		EndIf
		firstElement = false
	Wend
	oViewCursor.goToRange(initialCursorPosition,false)
End Sub

Sub removePageHeader(pageStyle As Object)
	pageStyle.headerIsOn = false
End Sub

Sub removePageFooter(pageStyle As Object)
	pageStyle.FooterIsOn = false
End Sub

Function getCurPageStyleName() As String
	dim curPageStyleName as String 
	dim oViewCursor as Object
	dim oTextCursor as Object
	oViewCursor = ThisComponent.CurrentController.getViewCursor()
	If Not oViewCursor.isAtEndOfLine() And Not oViewCursor.isAtStartOfLine()  Then
		oViewCursor.goToStartOfLine(false)
	EndIf
	oTextCursor = oViewCursor.Text.createTextCursorByRange(oViewCursor)
	If oTextCursor.isStartOfParagraph() Then
		getCurPageStyleName = oViewCursor.PageStyleName
		Exit Function
	EndIf
	If oTextCursor.isEndOfParagraph() Then
		getCurPageStyleName = oViewCursor.PageStyleName
		Exit Function
	EndIf
	oViewCursor.Text.insertControlCharacter(oViewCursor.End,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False)
	oViewCursor.paraOrphans = 0
	oViewCursor.paraWidows = 0
	oTextCursor = oViewCursor.Text.createTextCursorByRange(oViewCursor)
	oTextCursor.goRight(1,false)
	oViewCursor.goToRange(oTextCursor,false)
	getCurPageStyleName = oViewCursor.pageStyleName
	oViewCursor.goLeft(1,false)
	backspace()
End Function

Sub unoCopy
	dim document   as object
	dim dispatcher as object
	document   = ThisComponent.CurrentController.Frame
	dispatcher = createUnoService(&quot;com.sun.star.frame.DispatchHelper&quot;)
	dispatcher.executeDispatch(document, &quot;.uno:Copy&quot;, &quot;&quot;, 0, Array())
End Sub

sub unoPaste
	dim document   as object
	dim dispatcher as object
	document   = ThisComponent.CurrentController.Frame
	dispatcher = createUnoService(&quot;com.sun.star.frame.DispatchHelper&quot;)
	dispatcher.executeDispatch(document, &quot;.uno:Paste&quot;, &quot;&quot;, 0, Array())
end sub

Function createFrame(posX As Long,posY As Long,width As Long,height As Long,frameName As String) As Object
	Dim oViewCursor as Object
	Dim oTextCursor as Object
	Dim oText As Object
	Dim frame As Object
	Dim border As Object
	oViewCursor = ThisComponent.CurrentController.getViewCursor()
	oText = oViewCursor.Text
	oTextCursor = oText.createTextCursorByRange(oViewCursor.End)
	frame = ThisComponent.createInstance(&quot;com.sun.star.text.TextFrame&quot;)
	frame.AnchorType = 2
	frame.Height = height
	frame.Width = width
	frame.PageToggle = false
	frame.BorderDistance = 0
	frame.HoriOrient = 0
	frame.HoriOrientRelation = 7
	frame.HoriOrientPosition= posX
	frame.VertOrient = 0
	frame.VertOrientRelation = 7
	frame.VertOrientPosition = posY
	oText.insertTextContent(oTextCursor.Start, frame, false)
	frame.FrameIsAutomaticHeight = false
	border = frame.bottomBorder
	border.OuterLineWidth = 0
	border.LineWidth = 0
	frame.bottomBorder = border
	frame.topBorder = border
	frame.leftBorder = border
	frame.rightBorder = border
	frame.WritingMode = 2
	frame.PositionProtected = true
	frame.Name = frameName
	createFrame = frame
End Function
</script:module>