Keskustelu: Koodit: LibreOffice SlideShows in Basic

' Valitse valikkoriviltä: Työkalut -> Mukauta -> Tapahtumat välilehti,
' valitse listasta Asiakirjaa ollaan sulkemassa. Klikkaa Makro nappia.
' Valitse vasemmalla (Kirjasto), laajenna projektsi nimi puuu -> laajenna
' Standard, klikkaa Module1, Valitse OnClose -> klikkaa alhaalla OK ja tallenna
' projektisi.

' Module1
REM  *****  BASIC  *****
REM Lisenssi: DWYFW (tee mitä v***** ikinä haluat)

Option VBASupport 1
Option Compatible

Private oDlg As Object
Private Delay As Long
Private oDoc As Object

Private fstrArray() As String
Private Const vbUnicode = 64
Private Const vbFromUnicode = 128
Private oFocusListener As Object
Private oAdjustmentListener As Object
Private oActionListener As Object
Private oTopListener As Object
Private AllowExitFor As Boolean
Private FocusGained As Boolean
Private GoToLoop As Boolean
Private ExitLoop As Boolean

Sub WriteReadFileBytes

	ThisComponent.store
	ThisComponent.setModified(False)
	Dim basePath As String
	basePath = Left(thisComponent.Url, InStrReverse(thisComponent.Url, "/"))
	basePath = ConvertFromUrl(basePath)

	If Dir(basePath & "imgdata.dat") = "" Then
		If Dir(basePath & "*.jpg") = "" Then
			MsgBox "No .jpg image files or imgdata.dat file found", "48", "System"
			Exit Sub
		End If
	End If
	oDoc = thisComponent
	oDoc.lockControllers
	If Dir(basePath & "imgdata.dat") <> "" Then Goto jump
	Redim fstrArray()
	Dim params As String : params = "/c copy /b " & basePath & Chr(42) & ".jpg " & basePath & "imgdata.dat"
	Dim oShellExec As Object
	oShellExec = CreateUnoService("com.sun.star.system.SystemShellExecute")
	oShellExec.execute("cmd.exe", params, 1)

	ITicks = GetSystemTicks()

	DoEvents
	Do
		If Dir(basePath & "imgdata.dat") <> "" Then Exit Do
		IF GetSytemTicks() > ITicks + 3000 Then ' Increase the value if needed
			MsgBox "The system file: imgdata.dat not found. Timeout", "48","System"
			Exit Sub
		End If
	Loop

	oShellExec = Nothing

	If Dir(basePath & "*.jpg") <> "" Then
		Dim f As String
		f = Dir(basePath & "*.jpg")
		Do While f <> ""
    		Kill basePath & f
    		f = Dir()
		Loop
	End If

jump:

	Dim sfa As Object : sfa = createUnoService("com.sun.star.ucb.SimpleFileAccess")
	Dim oStream As Object : oStream = sfa.openFileRead(basePath & "imgdata.dat")
	Dim fileBytes() As Byte
	oStream.readBytes(fileBytes, oStream.getLength)
	oStream.closeInput()
	oStream = Nothing
	ReDim fstrArray()
	Dim fstr As String
	fstr = DumpBytes(fileBytes)

	fstr = Replace(fstr, "ÿØÿà", "SpliterMarks" & "ÿØÿà")
	fstrArray = Split(fstr, "SpliterMarks") : fstr = ""
	BuildUI

End Sub

Sub BuildUI

    Dim oDialogModel As Object
    Dim oDialog As Object
    Dim oImageModel As Object
    Dim oImage As Object
 	Dim oSpinModel As Object
    Dim oSpin As Object
    Dim oSpinLblModel As Object
    Dim oSpinLbl As Object
	Dim oLblModel As Object
    Dim oLbl As Object
	Dim oBtnModel As Object
	Dim oBtn As Object
    Dim oControl As Object

    oDialogModel = CreateUnoService("com.sun.star.awt.UnoControlDialogModel")
    oDialogModel.Width = 150
    oDialogModel.Height = 140
    oDialogModel.BackGroundColor = RGB(225,225,225)

    oDialog = CreateUnoService("com.sun.star.awt.UnoControlDialog")
    oDialog.setModel(oDialogModel)
	oDlg = oDialog : oDlg.Title = "SlideShow in Basic"
	oTopListener = createUnoListener("TopListen_", "com.sun.star.awt.XTopWindowListener")
	oDlg.addTopWindowlistener(oTopListener )

    oImageModel = oDialogModel.createInstance("com.sun.star.awt.UnoControlImageControlModel")
    oImageModel.Name = "Img1"
    oImageModel.PositionX = 5
    oImageModel.PositionY = 5
    oImageModel.Width = 140
    oImageModel.Height = 110
    oImageModel.ScaleMode = 1
    oImageModel.BackGroundColor = RGB(0,0,0)
    oImageModel.TabStop = False
    oDialogModel.insertByName("Img1", oImageModel)

    oSpinModel = oDialogModel.createInstance("com.sun.star.awt.UnoControlSpinButtonModel")
    oSpinModel.Name = "oSpin1"
	oSpinModel.PositionX = 135
	oSpinModel.PositionY = 122
	oSpinModel.Width = 10
	oSpinModel.Height = 12
	oSpinModel.SpinValue = 1
	oSpinModel.SpinValueMin = 1
	oSpinModel.SpinValueMax = 25
	oSpinModel.SpinIncrement = 1
    oSpinModel.SpinIncrement = 1
    oSpinModel.Orientation = 1
	oSpinModel.Border = 1
	oSpinModel.Tabindex = 1
	oSpinModel.TabStop = True
	oSpinModel.Repeat = False
	oDialogModel.insertByName("oSpin1", oSpinModel)
	oControl = oDialog.getControl("oSpin1")
	AddAdjustmentListenerToControl oControl
	AddFocusListenerToControl oControl
	oControl = Nothing

	oSpinLblModel = oDialogModel.createInstance("com.sun.star.awt.UnoControlFixedTextModel")
	oSpinLblModel.Name = "oSpinLbl1"
	oSpinLblModel.PositionX = 125
	oSpinLblModel.PositionY = 122
	oSpinLblModel.Width = 10
	oSpinLblModel.Height = 12
	oSpinLblModel.Align = 1
	oSpinLblModel.VerticalAlign = 1
	oSpinLblModel.Border = 2
	oSpinLblModel.Label = 1
	oSpinLblModel.BackGroundColor = RGB(255, 255, 255)
	oDialogModel.insertByName("oSpinLbl1", oSpinLblModel)

	oBtnModel = oDialog.Model.createInstance("com.sun.star.awt.UnoControlButtonModel")
	oBtnModel.Name = "oBtn1"
	oBtnModel.PositionX = 62
	oBtnModel.PositionY = 120
	oBtnModel.Width = 35
	oBtnModel.Height = 14
	oBtnModel.Label = "Pause"
	oBtnModel.TabIndex = 2
	oBtnModel.TabStop = True
	oDialogModel.insertByName("oBtn1", oBtnModel)
	oControl = oDialog.getControl("oBtn1")
	AddActionListenerToControl oControl
	oControl = Nothing

	oLblModel = oDialogModel.createInstance("com.sun.star.awt.UnoControlFixedTextModel")
	oLblModel.Name = "oLbl1"
	oLblModel.PositionX = 104
	oLblModel.PositionY = 119
	oLblModel.Width = 20
	oLblModel.Height = 16
	oLblModel.Align = 2
	oLblModel.VerticalAlign = 1
	oLblModel.TabStop = False
	oLblModel.FontName = "Segoe UI Light"
	oLblModel.FontHeight = 7
	oLblModel.FontWeight = com.sun.star.awt.FontWeight.NORMAL
	oLblModel.FontSlant = com.sun.star.awt.FontSlant.NONE
	oLblModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE
	oLblModel.MultiLine = True
	oLblModel.Step = 0
	oLblModel.Label = "Slide" & Chr(10) & "Delay"
	oLblModel.Border = 0
	oLblModel.VerticalAlign = 1
	oDialogModel.insertByName("oLbl1", oLblModel)

    oDialog.createPeer(CreateUnoService("com.sun.star.awt.Toolkit"), Null)

    On Error Resume Next
	Dim oSize As New com.sun.star.awt.Size, factor As Double
	Dim oCC, oComponentWindow, oTopWindowPosSize
	oCC = ThisComponent.getCurrentController()
	oComponentWindow = oCC.ComponentWindow
	oTopWindowPosSize = oComponentWindow.Toolkit.ActiveTopWindow.getPosSize()

	oSize.Width = oDialog.Model.Width
	oSize.Height = oDialog.Model.Height
	factor = oSize.Width / oDialog.convertSizeToPixel(oSize, com.sun.star.util.MeasureUnit.APPFONT).Width

	With oDialog.Model
		.PositionX = (factor * oTopWindowPosSize.Width - .Width) / 2 ' Change these if needed
		.PositionY = (factor * oTopWindowPosSize.Height - .Height) / 1.75
	End With

	If Err <> 0 Then Err.Clear
	Delay = 1000
	AllowExitFor= False
	FocusGained = False
	oDlg.getControl("oSpin1").setFocus
    oDlg.execute
	oDlg.dispose

End Sub

Sub TopListen_windowOpened
End Sub

Sub TopListen_windowClosed

	oAdjustmentListener = Nothing
	oActionListener = Nothing
	oTopListener = Nothing
	GoToLoop = False
	ExitLoop = False
	Dim ctls As Object
	ctls = oDlg.getControls()
	For i = Lbound(ctls) To Ubound(ctls)
		oDlg.Model.removeByName(ctls(i).Model.Name)
	Next i

	ReDim fstrArray()

End Sub

Sub TopListen_windowMinimized
End Sub
Sub TopListen_windowClosing
	RemoveFocusListenerFromControl oDlg.getControl("oSpin1")
	RemoveAdjustmentListenerFromControl oDlg.getControl("oSpin1")
	RemoveActionListenerFromControl oDlg.getControl("oBtn1")
	AllowExitFor = True
	ExitLoop = True
	oDlg.endexecute
End Sub
Sub TopListen_windowNormalized
End Sub
Sub TopListen_windowActivated
End Sub
Sub TopListen_windowDeactivated
	oDlg.removeTopWindowlistener(oTopListener)
End Sub

Sub TopListen_disposing
End Sub

Sub SlideShow

	Dim strBytes() As Variant
	Dim props(0) As New com.sun.star.beans.PropertyValue
	AllowExitFor = False

jumpback:
	If AllowExitFor Then Exit Sub

	For i = 1 To Ubound(fstrArray) + 1
		If AllowExitFor Then Exit Sub
		If i > Ubound(fstrArray) Then GoTo jumpback
		ReDim strBytes()
		strBytes = StrConv(fstrArray(i), vbFromUnicode)
		Dim oInstream As Object
		oInstream = com.sun.star.io.SequenceInputStream.createStreamFromSequence(strBytes)

		Dim oProvider As Object
		Dim oImgObj As Object
		Dim oImgControl As Object
		Redim props(0)
		oProvider = CreateUnoService("com.sun.star.graphic.GraphicProvider")
		props(0).Name="InputStream" : props(0).Value = oInstream
		oImgObj = oProvider.queryGraphic(props)
		oInstream.CloseInput()
		oInstream = Nothing
		oImgControl = oDlg.getControl("Img1")
		oImgControl.Model.Graphic = oImgObj
		oImgObj = Nothing
		oProvider = Nothing

		If Not AllowExitFor And Not GoToLoop Then
			Wait Delay
		Else
			Exit Sub
		End If

		If GoToLoop Then
			Do
				If ExitLoop Then Exit Do
			Loop
		End If

	Next i

End Sub

Function DumpBytes(inBytes As Variant) As Variant

	Dim aBytes(Ubound(inBytes)) As Byte
    aBytes = inBytes

    Dim i As Long, val As Long, sResult As String

    For i = Lbound(aBytes) To Ubound(aBytes)
    	val = (aBytes(i) And &HFF)
		sResult = sResult & Chr(val)
	Next i

	Erase aBytes
	DumpBytes = sResult
	sResult = ""

End Function

Sub AddActionListenerToControl(oControl As Object)
	oActionlistener = CreateUnoListener("ButtonAction_", "com.sun.star.awt.XActionListener")
	oControl.addActionListener(oActionlistener)
End Sub

Sub RemoveActionListenerFromControl(oControl As Object)
	oControl.removeActionListener(oActionlistener)
End Sub

Sub AddAdjustmentListenerToControl(oControl As Object)
	oAdjustmentListener = CreateUnoListener("Adjustment_","com.sun.star.awt.XAdjustmentListener")
	oControl.addAdjustmentListener(oAdjustmentListener)
End Sub

Sub RemoveAdjustmentListenerFromControl(oControl As Object)
	oControl.removeAdjustmentListener(oAdjustmentListener)
End Sub

Sub ButtonAction_actionPerformed(oEvent)

    If oEvent.Source.Model.Label = "Pause" Then
    	oEvent.Source.Model.Label = "Continue"
    	GoToLoop = True
    	ExitLoop = False
    	Exit Sub
    ElseIf oEvent.Source.Model.Label = "Continue" Then
    	oEvent.Source.Model.Label = "Pause"
    	ExitLoop = True
    	GoToLoop = False
    End If

End Sub

Sub Adjustment_adjustmentValueChanged(oEvent)
	oDlg.getControl("oSpinLbl1").Model.Label = oEvent.Value
	Delay = oEvent.Value * 1000
End Sub

Sub AddFocusListenerToControl(oControl As Object)
	oFocusListener = CreateUnoListener("FocusListener_","com.sun.star.awt.XFocusListener")
	oControl.addFocusListener(oFocusListener)
End Sub

Sub RemoveFocusListenerFromControl(oControl As Object)
	oControl.removeFocusListener(oFocusListener)
End Sub

Sub FocusListener_focusGained(oEvent)

	If Not FocusGained Then
		FocusGained = True
		Delay = 1000
		SlideShow
	End If

End Sub

Sub FocusListener_focusLost(oEvent)
End Sub

Sub  FocusListener_disposing : End Sub
Sub Adjustment_disposing : End Sub
Sub ButtonAction_disposing : End Sub

Function InStrReverse(sText As String, search As String) As Long

	If sText = "" Or search = "" Or Len(search) > Len(sText) Then
    	InStrReverse = 0
    	Exit Function
	End If

	Dim i As Long

	For i = Len(sText) To 1 Step -1
		If Mid(sText, i, Len(search)) = search Then
			InStrReverse = i : Exit Function
		End If
	Next i

End Function

Sub OnClose
	AllowExitFor = True
	ThisComponent.store
	ThisComponent.setModified(False)
	Redim fstrArray()
End Sub

REM NO WARRANTY 😎