Keskustelu: Koodit: LibreOffice Basic .NET yhdistelmä

REM Module1:
REM  *****  BASIC  *****

' Komponentit:
' Valintaikkuna (Dialog1)
' Ohjausobjektit
' ListBox (ListBox1)
' Sido Objektin tilaa muutettu -> LstBoxStateChange tapahtumaan
' Tallenna projektisi

' Valitse valikkoriviltä: Työkalut -> Mukauta
' Valitse vasemmalta ylhäältä välilehti: Valikot
' Valitse oikealta ylhäältä: Rajaus alasvetolaatikko, valitse projektisi nimi.
' Valise sen alta: Kohde ja klikkaa oikealla pikku täppää (kolme viivaa alekkain)
' Klikkaa: Lisää, Kirjoita ylimpään tekstiruutuun Uusi valikko 1 tillalle:
' DaoBase ja klikkaa OK.
' Valitse vasemmalta ylhäältä Luokka alasvetolaatikko ja valitse laatikosta
' makro, odota ja valitse projektisi nimi. Laajenna alla olevan alasvetolaatikon
' listassa puu jossa lukee projektisi nimi. Tuplaklikkaa StarToWork jolloin se
' ilmestyy oikealle alempaan laatikkoon (Assigned Commands)
' Valitse StartToWork. Klikkaa alhaalta Muuta nappia -> Nimeä uudelleen
' kirjoita: Create/Write, klikkaa OK nappia
' Tees sama uudelleen ja valitse ja valitse ReadDaoBase, tuplaklikkaa, klikkaa OK
' nappia vasemmalla alhaalla ja tallenna projektisi.
' Valitse valikkoriviltä: Työkalut -> Mukauta -> valitse 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
' jälleen projektisi.

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

Option VBASupport 1
Private DBEngine As Object
Private Const dbFixedField	 = 1
Private Const dbLong = 4
Private Const dbText	= 10
Private Const dbLongVarBinary = 11
Private Const dbAutoIncrField = 16
Private Const dbOpenDynaset = 2
Private Const dbOpenTable = 1
Private oListenerTop As Object
Private oController As Object
Private oDoc As Object
Private localFile As String
Private dbFile As String
Private Records() As String
Global oDlg As Object
Private oList As Object
Private CreateRunning As Boolean
Private ReadRunning As Boolean
Private oListenerTop As Object

Sub StartToWork

	If CreateRunning Then Exit Sub
	CreateRunning = True

	oDoc = ThisComponent
	oController = ThisComponent.CurrentController
	oDoc.lockControllers

	Dim filepicker As Object
	filepicker = createUnoService("com.sun.star.ui.dialogs.FilePicker")
	filepicker.setDisplayDirectory(Left(thisComponent.URL, InStrReverse(thisComponent.URL, "/") - 1))
	filepicker.appendFilter("Images (*.jpg; *.png; *.gif; *.bmp; *.tiff)", "*.jpg;*.jpeg;*.png;*.gif;*.bmp;*.tiff")
	filepicker.appendFilter("RTF (*.rtf)", "*.rtf")
	filepicker.appendFilter("ZIP (*.zip)", "*.zip")
	filepicker.setCurrentFilter("Images (*.jpg; *.png; *.gif; *.bmp; *.tiff)")

	If filepicker.Execute = com.sun.star.ui.dialogs.ExecutableDialogResults.OK Then
		sFileArray = filepicker.getFiles()
        localFile = ConvertFromUrl(sFileArray(0))
    Else
    	MsgBox "Canceled by the user","48","System"
    	CreateRunning = False : Exit Sub
    End If

	dbFile = Replace(localFile, Left(localFile, InStrReverse(localFile, "\")), "")

	thisComponent.Store
	BuildDialog

	Dim sURL$, basePath$, dbPath$

	sURL = ConvertFromUrl(thisComponent.URL)
	basePath = Left(sURL, InStrRev(sURL, "\"))
    dbPath = basePath & "DaoBase.accdb"

    Dim existst As Boolean
    existst = False

	Dim DBEngine As Object
	Set DBEngine = CreateObject("DAO.DBEngine.120")
	If Dir(dbPath) <> "" Then
    	existst = True: Goto jump
    End If

	Dim sLang As String
    sLang = ";LANGID=0x0409;CP=1252;COUNTRY=0"
	DBEngine.CreateDatabase dbPath, sLang

Jump:

	Dim db As Object
	Set db = DBEngine.OpenDatabase(dbPath)

	IF existst Then Goto jump2

	Dim tdf As Object
	Set tdf = db.CreateTableDef("TABLE1")

	Dim fld As Object

	With tdf
    	Set fld = .CreateField("ID", 4)
    	fld.Attributes = dbAutoIncrField
    	.Fields.Append fld
    	Dim idx As DAO.Index
    	Set idx = .CreateIndex("PrimaryKey")
    	idx.Primary = True
    	idx.Unique = True
    	idx.Fields.Append idx.CreateField("ID")
    	.Indexes.Append idx
    	Set fld = .CreateField("File", dbText)
    	fld.Required = True
		.Fields.Append fld
    	Set fld = .CreateField("Data", dbLongVarBinary)
    	fld.Required = False
    	.Fields.Append fld
	End With

	db.TableDefs.Append tdf

jump2:

	strSQL = "Select ID, File, Data From TABLE1"
	Dim rs As Object
	Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
	If Not rs.EOF Then rs.MoveLast
	rs.AddNew
	rs.Fields.Item("File").Value = dbFile
	rs.Update
	rs.Close

	If Not IsNull(tdf) Then Set tdf = Nothing
    db.Close : Set db = Nothing
	Set DBEngine = Nothing

	Dim myNetBlob As Object, result As String
    myNetBlob = CreateObject("NetOleBlob.helper")
    result = myNetBlob.WriteBlob(dbPath, "TABLE1", "Data", localFile)
	CreateRunning = False

End Sub

Sub ReadDaoBase

	Dim sURL$, basePath$, rtfPath$, dbPath$
	sURL = ConvertFromUrl(thisComponent.URL)
	basePath = Left(sURL, InStrRev(sURL, "\"))
	oDoc = ThisComponent
	oController = ThisComponent.CurrentController
	oDoc.lockControllers
    If ThisComponent.hasLocation() Then ThisComponent.store()
    ThisComponent.setModified(False)

    dbPath = basePath & "DaoBase.accdb"

    If Dir(dbPath) <> "" Then
 		BuildDialog
		Dim lTicks As Long
		lTick = GetSystemTicks()
 		DoEvents
		Do
			If GetSystemTicks() > lTick + 500 Then Exit Do
		Loop
		CenterDialog
		oListenerTop = createUnoListener("TopListen_", "com.sun.star.awt.XTopWindowListener")
		oDlg.addTopWindowlistener(oListenerTop)
		ReadFromDb
    Else
    	yesno = MsgBox("File: " & dbPath & " does no exists." & chr(10) _
    	& "             Do you want to create a new database file?", vbYesNo, "DaoBase")
    	Select Case yesno
    		Case 6
    			CreateRunning = False : StartToWork
    		Case Else
				CreateRunning = False : Exit Sub
    	End Select
    End If

End Sub

Sub ReadFromDb

	If ReadRunning Then Exit Sub
	ReadRunning = True

	Dim sURL$, basePath$,  dbPath$
	sURL = ConvertFromUrl(thisComponent.URL)
	basePath = Left(sURL, InStrRev(sURL, "\"))

    dbPath = basePath & "DaoBase.accdb"
	dbfName = dbFile

	If Dir(dbPath) = "" Then
    	MsgBox "File : " & dbPath & " cannot be found" : Exit Sub
    End If

    Dim DBEngine As object
	Set DBEngine = CreateObject("DAO.DBEngine.120")

	Dim db As Object
	Set db = DBEngine.OpenDatabase(dbPath)
	Dim strSQL As String
	strSQL = "SELECT File FROM TABLE1"

    Dim rs As Object, i As Long, rCount As Long
	Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
	If Not rs.BOF Then rs.MoveFirst
	rCount = rs.RecordCount

	If rCount > -1 Then
		ReDim Records()
		Dim lst As String : lst = Chr(10)
		rs.MoveFirst
		For i = 0 To rCount + 1
			lst =  lst & rs.Fields.Item("File").Value
			If i <= rCount Then lst = lst & Chr(10)
			If rs.EOF Then Exit For
			rs.MoveNext
		Next i
		Records = Split(lst, Chr(10)) : lst = ""
	Else
		MsgBox "There is no records in database", "48", "System"
		Exit Sub
	End If

	rs.Close : Set rs = Nothing
	db.Close : Set db =  Nothing
	oList.Model.StringItemList = Records
	oDlg.execute()

	ReadRunning = False
	CreateRunning = False

End Sub

Sub BuildDialog

	DialogLibraries.LoadLibrary("Standard")
	oDlg = CreateUnoDialog(DialogLibraries.Standard.Dialog1)
	oList = oDlg.getControl("ListBox1")

End Sub

Sub CenterDialog

	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 = oDlg.Model.Width
	oSize.Height = oDlg.Model.Height
	factor = oSize.Width / oDlg.convertSizeToPixel(oSize, com.sun.star.util.MeasureUnit.APPFONT).Width

	With oDlg.Model
		.PositionX = (factor * oTopWindowPosSize.Width - .Width) / 2
		.PositionY = (factor * oTopWindowPosSize.Height - .Height) / 1.75
	End With

End Sub

Sub TopListen_windowOpened
End Sub

Sub TopListen_windowClosed
 	oDlg.dispose
End Sub
Sub TopListen_windowMinimized
End Sub
Sub TopListen_windowClosing
	Running = False
	ReadRunning = False
	oDlg.removeTopWindowListener(oListenerTop)
	oListenerTop = Nothing
	oDlg.endexecute
End Sub
Sub TopListen_windowNormalized
End Sub
Sub TopListen_windowActivated
End Sub
Sub TopListen_windowDeactivated
End Sub
Sub TopListen_disposing
End Sub

Sub LstBoxStateChange(oEvent)

	If oEvent.Source.SelectedItems(0) <> "" Then
	sURL = ConvertFromUrl(thisComponent.URL)
	basePath = Left(sURL, InStrRev(sURL, "\"))
    dbPath = basePath & "DaoBase.accdb"
	Dim dbfName As String, sql As String
	dbfName = oEvent.Source.SelectedItems(0)
	Set DBEngine = CreateObject("DAO.DBEngine.120")
	Set db = DBEngine.OpenDatabase(dbPath)

	sql = "SELECT File, Data FROM TABLE1 Where File = '" & dbfName & "';"

	Dim rs As Object
	Set rs = db.OpenRecordset(sql , dbOpenDynaset)

	If Not rs.BOF Then rs.MoveFirst

	Dim fName As String, ext As String, pos
	fName = rs.Fields.Item("File").Value

	sURL = ConvertFromUrl(thisComponent.URL)
	basePath = Left(sURL, InStrRev(sURL, "\"))
	filePath = basePath & fName

	ext = Replace(fName, Left(fName,  InStrReverse(fName, ".") -1), "")
	Dim fName2 As String
	fName2 = Replace(fName, ext, "")
	fName2 = fName2 & "2" & ext
	Dim sFilePath As String
	sFilePath = Replace(filePath, fName, fName2)
	If Dir(sFilePath) <> "" Then Kill sFilePath
	Do While Dir(sFilePath) <> "" : Loop
	On Error Goto ErrorHandler

	Dim oInstream As Object, fileBytes() As Byte
	oInstream = com.sun.star.io.SequenceInputStream.createStreamFromSequence(rs.Fields.Item("Data").Value)
	oInstream.readBytes(fileBytes, oInstream.getLength())
	oInstream = Nothing
	Dim sfa As Object, oOut As Object
	sfa = createUnoService("com.sun.star.ucb.SimpleFileAccess")
	oOut = sfa.openFileWrite(sFilePath)
	oOut.writeBytes(fileBytes)
	rs.Close : Set rs = Nothing
	db.Close : Set db = Nothing
	Set DBEngine = Nothing

	Do While(sFilePath) = "" : Loop
	Dim oShellExe As Object
	oShellExec = CreateUnoService("com.sun.star.system.SystemShellExecute")
	oShellExec.execute(sFilePath, "", 0)
	oShellExec = Nothing
	Exit Sub

 ErrorHandler:
 	MsgBox Err.Description
 	Err.Clear
	End If

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
	ThisComponent.setModified(False)
End Sub
REM NO WARRANTY 😎