|
По умолчанию, в ООо Base 2.4 pro мы можем вставлять и удалять картинки (двойным щелчком левой кнопки мыши или в контекстном меню правой кнопки мыши). Но иногда хочется и сохранять имеющиеся в базе картинки на диск. В этом нам помогут макросы. Это четвёртая статья из цикла База данных за пять минут. Начало см. здесь
Создание макроса Самостоятельное создание макроса для новичка процесс также довольно сложный. Поэтому вы можете скопировать данный код и вставить в модуль ООBasic: 'Сохранение картинок 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 В этом примере для вставки я использовал стандартную функцию вставки картинки (двойным щелчком мыши). Для использования нестандартной функции надо раскомментировать код, идущий после If oResult.wasNull() Then В этом примере использовался вызов дополнительный функций. Их код также требуется включить (скопировать и вставить) в модуль Basic. ChooseAFile()
'Функция вызывает диалог выбора файла
REM sInPath specifies the initial directory. If the initial directory
REM is not specified, then the user's default work directory is used.
REM The selected file is returned as a URL.
Function ChooseAFile(sFilters(), bOpen As Boolean, Optional sInPath As String) As String
Dim oDialog As Object
Dim sPath As String
Dim oSFA As Object
Dim s As String
Dim i As Integer 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 ChooseADirectory()
'Функция вызывает диалог выбора каталога REM sInPath specifies the initial directory. If the initial directory REM is not specified, then the user's default work directory is used. REM The selected directory is returned as a URL. Function ChooseADirectory(Optional sInPath As String) As String Dim oDialog As Object Dim oSFA As Object Dim s As String 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 GetWorkDir()
'Функция возвращает путь
Function GetWorkDir() As String
Dim oPathSettings
oPathSettings = CreateUnoService("com.sun.star.util.PathSettings")
GetWorkDir() = oPathSettings.Work
End Function
FindComponentWithURL()
'Функция возвращает объект, связанный с нужным нам файлом Function FindComponentWithURL(sName$, bLoadIfNotFound As Boolean) as Object Dim oDocs as Object' Enumeration of the loaded components. Dim oDoc as Object' A single enumerated component. Dim sDocURL as String ' URL of the component that we are checking. 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 FValue()'Функция убирает запрещённые символы в названии файла или каталога Function FValue(sValue As String) As String '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 FOpenForm()'Процедура вызывает нужную нам форму из базы данных VideoBase Sub FOpenForm(sSource as String) 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
Выполнение макроса надо подвязать к событию "Отпускание клавиши мыши" у всех графических полей вашей формы. Отладка макросаЕсли вы скопировали приведённый здесь код, то отлаживать его не надо —- всё уже отлажено. Если вы его изменили и что-то не работает, обратитесь к документации по OpenOffice.org Basic. Использование макросаИспользование простое: один щелчок левой кнопки мыши вызывает этот макрос.
Макрос работает так: если поле с картинкой пустое, программа предложит вам выбрать графический файл для вставки (с помощью макроса или стандартной функции). Если поле содержит картинку, вы сможете выбрать каталог, где будет создан новый каталог с названием фильма для сохранения. После этого в выбранном каталоге будет лежать файл картинки. Название картинки соответствует названию поля, в котором эта картинка хранится. |
Готовый вариант (с разнесённым интерфейсом, экспортом картинок и тремя записями в каждой таблице) можно скачать: база: 
Для корректной работы готовой базы зарегистрируйте её в OpenOffice.org в качестве источника данных VideoBase (Сервис - Параметры - База данных OpenOffice.org - Базы данных)
см. также