Базы данных (Base)

'Сохранение картинок

Sub FPictureExtract(oEvent)
Dim oBaseContext as Object, oDB as Object, oCon as Object
Dim oSimpleFileAccess as Object, oStatement as Object
Dim oResult as Object
Dim sSQL$, s$

'Один раз нажата левая кнопка мыши
If oEvent.ClickCount=1 AND oEvent.Buttons=1 Then
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName("VideoBase")
oCon = oDB.getConnection("", "")
oStatement = oCon.createStatement()

Dim oForm as Object, oData() as Variant, oStream as Object
Dim lNameCol as Long, lLen as Long
Dim sDirName as String, sMedia as String, sRelease as String, sFileURL as String

oForm = oEvent.Source.getModel().getParent()
lNameCol = oForm.findColumn("ONAME")
sDirName = oForm.getString(lNameCol)
lNameCol = oForm.findColumn("MEDIA")
sMedia = oForm.getString(lNameCol)
lNameCol = oForm.findColumn("RELEASE")
sRelease = oForm.getString(lNameCol)

If Len(sDirName)=0 Then MsgBox "Похоже, что у Вас не указано оригинальное название фильма.": Exit Sub

sSQL = "SELECT " & oEvent.Source.Model.DataField & " FROM MAIN WHERE ONAME='" & sDirName & "' AND MEDIA='" & sMedia & "' AND RELEASE='" & sRelease & "'"
oResult = oStatement.executeQuery(sSQL)
If Not IsNull(oResult) Then
oResult.next()
oStream = oResult.getBinaryStream(1)
s = "com.sun.star.ucb.SimpleFileAccess"
oSimpleFileAccess = createUnoService(s)
If oResult.wasNull() Then
'Вставляем картинку, не используя стандартную фукцию (могут быть проблемы с удалением картинки)
' sFileURL = ChooseAFile (GraphicFilters(), True)
' If Len(sFileURL)=0 Then Exit Sub
' oStream = oSimpleFileAccess.openFileRead(sFileURL)
' lLen = oStream.getLength()
' ReDim oData(0 To lLen-1)
' oStream.readBytes(oData(), lLen)
' lNameCol = oForm.findColumn(oEvent.Source.Model.DataField)
' oForm.updateBytes(lNameCol, oData())
' oStream.closeInput()
' MsgBox "Вставлен файл " & ConvertFromURL(sFileURL)
Else
'Извлекаем картинку
sFileURL = ChooseADirectory ("Выберите каталог для сохранения картинки")
If Len(sFileURL)=0 Then Exit Sub
sFileURL = sFileURL & FValue (sDirName) & "/" & oEvent.Source.Model.DataField & ".jpg"
If FileExists(sFileURL) Then sFileURL = ChooseAFile (GraphicFilters(), False, sFileURL)
If sFileURL <> "" Then
oSimpleFileAccess.writeFile(sFileURL, oStream)
MsgBox "Записан файл " & ConvertFromURL(sFileURL)
End If
End If
End If
oCon.close()
oForm.updateRow()
End If
End Sub 

oDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
oSFA = createUnoService("com.sun.star.ucb.SimpleFileAccess")

REM See the TemplateDescription constants to see what other
REM values are supported.
If bOpen Then
i = com.sun.star.ui.dialogs.TemplateDescription.FILEOPEN_SIMPLE
Else
REM When choosing a file that already exists, you will be asked
REM if you want to overwrite the file.
i = com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_SIMPLE
End If
oDialog.initialize(Array(i))

If IsMissing(sInPath) Then
oDialog.setDisplayDirectory(GetWorkDir ())
ElseIf oSFA.Exists(sInPath) Then
oDialog.setDisplayDirectory(sInPath)
Else
s = "Каталог '" & sInPath & "' не найден."
If MsgBox(s, 33, "Error") = 2 Then Exit Function
End If

For i = LBound(sFilters()) To UBound(sFilters()) Step 2
Dim sFilterName$
Dim sFilterValue$
sFilterValue = sFilters(i+1)
sFilterName = sFilterValue & " - " & sFilters(i)
oDialog.appendFilter(sFilterName, sFilterValue)
Next

If oDialog.Execute() = 1 Then
sPath = oDialog.Files(0)
ChooseAFile() = sPath
End If
End Function

Rem You can also use com.sun.star.ui.dialogs.OfficeFolderPicker
oDialog = CreateUnoService("com.sun.star.ui.dialogs.FolderPicker")
oSFA = createUnoService("com.sun.star.ucb.SimpleFileAccess")

If IsMissing(sInPath) Then
oDialog.setDisplayDirectory(GetWorkDir ())
ElseIf oSFA.Exists(sInPath) Then
oDialog.setDisplayDirectory(sInPath)
Else
s = "Каталог '" & sInPath & "' не найден."
If MsgBox(s, 33, "Error") = 2 Then Exit Function
End If

If oDialog.Execute() = 1 Then
ChooseADirectory() = oDialog.getDirectory()
End If
End Function

REM Use some methods from the Tools library.
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If

oDocs = StarDesktop.getComponents().createEnumeration()
Do While oDocs.hasMoreElements()
oDoc = oDocs.nextElement()
sDocURL = GetDocURL(oDoc)

REM Just in case the name contains the full URL.
REM If the name is an empty string, then return an unsaved document.
If sName = sDocURL Then
FindComponentWithURL() = oDoc
Exit Function
End If

REM This will only work if the name contains the file extension.
If FileNameoutofPath(sDocURL, "/") = sName Then
FindComponentWithURL() = oDoc
Exit Function
End If
Loop

REM The document was not found,
REM perhaps the name did not contain a file extension.
oDocs = StarDesktop.getComponents().createEnumeration()
Do While oDocs.hasMoreElements()
oDoc = oDocs.nextElement()
sDocURL = GetDocURL(oDoc)

If GetFileNameWithoutExtension(sDocURL, "/") = sName Then
FindComponentWithURL() = oDoc
Exit Function
End If
Loop

REM The name was still not found, check to see if a document exists
REM with the specified URL.
REM In OOo version 1.x, loadComponentFromURL() returned NULL
REM if the document did not exist. Starting with version 2.x,
REM an illegal argument exception is thrown instead.
If bLoadIfNotFound AND FileExists(sName) Then
oDoc = StarDesktop.loadComponentFromURL(sName, "_blank", 0, Array())
FindComponentWithURL() = oDoc
'Else
' FindComponentWithURL = NULL
End If
End Function

'Microsoft wrote:
'The name must start with either a letter or number.
'It can contain any uppercase or lowercase characters (file
'names aren't case-sensitive) except the following characters:
'quotation mark ("), apostrophe ('), slash (/), backslash (),
'colon (:), and vertical bar (|).
'И я добавил: ? * Chr$(0)

Dim sStr As Variant
Dim iIndex As Integer

If Len(sValue) = 0 Then Exit Function
sStr = Array("""", "'", "/", "", ":", "|", "?", "*", Chr$(0))
For iIndex = 0 To UBound(sStr)
sValue = Replace(sValue, sStr(iIndex), "")
Next iIndex
FValue = Trim(sValue)

End Function

Dim oBase as Object, oCon as Object
Dim oForms as Object

oBase = FindComponentWithURL ("VideoBase", True)

'Определяем oCon через DataSource
oCon = oBase.DataSource.getConnection("", "")

'Ищем зарегистрированную базу данных VideoBase
If IsNULL(oBase) OR IsEmpty(oBase) Then
Print "База данных VideoBase не найдена"
Exit Sub
End If

'Ищем в базе данных форму справочников
If oBase.FormDocuments.hasbyName(sSource) Then
oForms= oBase.FormDocuments
Dim args(1) As New com.sun.star.beans.PropertyValue
args(0).Name = "ActiveConnection"
args(0).Value = oCon
args(1).Name = "OpenMode"
args(1).Value = "open"
oForms.loadComponentFromURL(sSource,"_blank",0,args())
Else
MsgBox "Форма справочников " & sSource & " не найдена.",32,"Ошибка:"
Exit Sub
End If
End Sub