1 (изменено: Poltergeyst, 2016-01-23 04:50:41)

Тема: LangMF 9.0; JScript.NET; OOo Basic: хранение файлов в базе данных

Без гарантий! Используете на свой страх и риск.
Скрипт предназначен для управления файловой базой данных в формате Access. Пользуясь пунктами меню "Файл" можно создавать новую базу, открывать соединение с уже созданной БД, добавлять и извлекать файлы. Добавление группы файлов, также, происходит при перетаскивании значков файлов из проводника на форму. Если файл является изображением (gif,jpg,jpeg,bmp,png), то выбор пункта списка(одиночный щелчок) выводит изображение в область просмотра. Двойной щелчок по списку выводит контекстное меню, позволяющее обновлять, извлекать или удалять заданный файл из БД.
Формат таблицы хранения файлов: CREATE TABLE filestore(i long, name varchar, crc varchar, file longbinary)

Потребуется установленный LangMF 9.0.
OC WinXP

f_access.mf


<#Module=FileBaseAccess>

    '-----------------------------------------------------------------------------------
    Public ADODBRst
    Public ADODBConn 
    Public ADODBStream
    '-----------------------------------------------------------------------------------
    Public Const adOpenDynamic = 2
    Public Const adOpenStatic = 3

    Public Const adLockBatchOptimistic = 4
    Public Const adLockReadOnly = 1

    Public Const adTypeBinary = 1

    Public Const adAffectCurrent = 1
    Public Const adSaveCreateOverWrite = 2

    Public Const adUseServer = 2
    '-----------------------------------------------------------------------------------
    Public Const ODBC_ADD_DSN = 1
    Public Const ODBC_CONFIG_DSN = 2
    Public Const ODBC_REMOVE_DSN = 3
    Public Const ODBC_ADD_SYS_DSN = 4
    Public Const ODBC_CONFIG_SYS_DSN = 5
    Public Const ODBC_REMOVE_SYS_DSN = 6
    Public Const ODBC_REMOVE_DEFAULT_DSN = 7

    '-----------------------------------------------------------------------------------
    Public Const WS_BORDER = &H00800000
    Public Const WS_CHILD = &H40000000
    Public Const WS_OVERLAPPED = 0
    Public Const WS_OVERLAPPEDWINDOW = &H00CF0000
    Public Const WS_VISIBLE = &H10000000

    Public Const SB_SETTEXTA = &H0401
    Public Const SB_SETTEXTW = &H040B
    Public Const SB_GETTEXTA = &H0402
    Public Const SB_GETTEXTW = &H040D
    Public Const SB_GETTEXTLENGTHA = &H0403
    Public Const SB_GETTEXTLENGTHW = &H040C

    Public Const SB_SETPARTS = &H0404
    Public Const SB_GETPARTS = &H0406
    Public Const SB_GETBORDERS = &H0407
    Public Const SB_SETMINHEIGHT = &H0408
    Public Const SB_SIMPLE = &H0409
    Public Const SB_GETRECT = &H040A


    Public Const SBT_OWNERDRAW = &H1000
    Public Const SBT_NOBORDERS = &H0100
    Public Const SBT_POPOUT = &H0200
    Public Const SBT_RTLREADING = &H0400

    '-----------------------------------------------------------------------------------
    Public hBar
    Public oCns
    Public sDBQCur
    Public sPwdCur
    Public bImg
    Public oPic
    Public IsImg
    

'[Создание формы]
'-------------------------------------------------------------------------------------------
Sub Load(cmdstr)

    IsImg = False
    Set oCns = new CNSTR
    
    Set ADODBConn = CreateObject("ADODB.Connection")
    Set ADODBRst = CreateObject("ADODB.Recordset")
    Set ADODBStream = CreateObject("ADODB.Stream")
    ADODBConn.CursorLocation = adUseServer
    DoEvents

    '/Установка параметров формы/
    '----------------------------------------------------------------------------------        
    With Form
        
        .AutoRedraw = True
        .ScaleMode = 3
        .Caption = "Файловая БД Access [LangMF 9.0](no_enc)"
        .Width = 800 * vbPx
        .Height    = 550 * vbPy
        .Style.MinButton = True
        .Style.MaxButton = True
        .Style.SizeBorder= True
        '-------------------------------------------------------------------------
        .Add "List", 1, "move2 -3, 0.005,-10,,200, 0.95, 1","BorderStyle = 1"
        .Add "CImage", 1, "Left=10","Top=10","BorderStyle=0", "Stretch = True"
        '-------------------------------------------------------------------------
        .Menu.Add 1, "Файл", "Menu1"
        .Menu.SubMenu("Menu1").Add 1, "Создать БД"
        .Menu.SubMenu("Menu1").Add 2, "Открыть БД"
        .Menu.SubMenu("Menu1").Add 3, "Добавить файл"
        .Menu.SubMenu("Menu1").Add 4, "Извлечь файл"
        .Menu.SubMenu("Menu1").Add 5, "Сжать БД"
        .Menu.SubMenu("Menu1").Add 6, "Выход"
        .Menu.Show

        .Menu.SubMenu("Menu1").State(3, &H1) = True
        .Menu.SubMenu("Menu1").State(4, &H1) = True
        .Menu.SubMenu("Menu1").State(5, &H1) = True

        .Menu.Add 2, "", "Menu2"
        .Menu.SubMenu("Menu2").PopUp = True
        .Menu.SubMenu("Menu2").Add 7, "Извлечь файл"
        .Menu.SubMenu("Menu2").Add 8, "Обновить файл"
        .Menu.SubMenu("Menu2").Add 9, "Удалить файл"

        
        .List(1).Visible = False

        .CImage(1).Picture = Nothing
        .CImage(1).Visible = False

        For Each Control In .Controls
            On Error Resume Next
                Control.Appearance = 0
                Control.FontName = "Tahoma"        
                Control.FontSize = 10
                Control.FontBold = True

        Next

        '-------------------------------------------------------------------------
        hBar = CreateStatusBar()
        DoEvents
        
        .Visible = True    
        '-------------------------------------------------------------------------
    End With
        
    DoEvents
End Sub

'[Создание БД Access]
'-------------------------------------------------------------------------------------------
Sub CreateDB()
    
    Dim sDBQ1
    Dim sPwd1
    Dim sPwd2

    'Диалог выбора нового файла базы данных
    '------------------------------------------------------------------------------------
    sDBQ1 = Sys.CDlg.ShowSave("Access database files (*.mdb)|*.mdb", _
                                  "Создать файл БД Access:", _
                                  Sys.Path, "mdb", Form.hWnd, 1, 1, "filebase_noenc.mdb")

    If Len(sDBQ1) = 0 Then Exit Sub
    If Sys.File.IsDirFile(sDBQ1) Then
        MsgBox "БД уже существует, укажите новое имя.", vbExclamation Or vbSystemModal,"Error"
        Exit Sub
    End If

    Err.Clear
    On Error Resume Next

    'Отключение предыдущего соединения
    '------------------------------------------------------------------------------------    
    If ADODBConn.State <> 0 Then 
        ADODBConn.Close()
        DoEvents
        GrayForm()
        DoEvents        
    End If

    '/Генерация файла БД/
    '------------------------------------------------------------------------------------
    hRes = Sys.DynApi.CallFunction(    "ODBCCP32.DLL", _
                                        "SQLConfigDataSource", _
                                        0, _
                                        ODBC_ADD_DSN, _
                                        "Microsoft Access Driver (*.mdb)", _
                                        "CREATE_DB=""" & sDBQ1 & """" & Chr(0))

    If Not Sys.File.IsDirFile(sDBQ1) Or hRes = 0 Then    
        MsgBox "Ошибка создания файла БД", vbExclamation Or vbSystemModal,"Error"
        Exit Sub
    End If

    '/Создание таблицы хранения файлов/
    '------------------------------------------------------------------------------------
    Set ADODBConn1     = CreateObject("ADODB.Connection")
    DoEvents

    ADODBConn1.Open oCns.ConnString(sDBQ1)
    DoEvents

    ADODBConn1.Execute "CREATE TABLE filestore(i long, name varchar, crc varchar, file longbinary)"
    DoEvents

    ADODBConn1.Close()
    DoEvents
    Set ADODBConn1 = Nothing
    
    res = SendMsg(hBar, SB_SETTEXTW, 0, "Выберите базу данных Access...")
    
    If Err.Number<>0 Then GetConnError():Exit Sub
    MsgBox "Создана БД " & sDBQ1 & ".", vbInformation Or vbSystemModal,"Reply"

End Sub

'[Сжатие БД]
'--------------------------------------------------------------------------------------------
Sub CompactDB()

    Dim sDBQShort

    'Отключение соединения
    '------------------------------------------------------------------------------------
    If ADODBConn.State <> 0 Then 
        ADODBConn.Close
        DoEvents
        GrayForm()
        DoEvents
        res = SendMsg(hBar, SB_SETTEXTW, 0, "Сжатие БД " & Sys.File.GetFName(stDBQ) & "...")
    End If
    '------------------------------------------------------------------------------------
    sDBQShort = Sys.File.ShortName(sDBQCur)
    hRes = Sys.DynApi.CallFunction("ODBCCP32.DLL", _
                                       "SQLConfigDataSource", _
                                       0, _
                                       ODBC_CONFIG_SYS_DSN, _
                                       "Microsoft Access Driver (*.mdb)", _
                                       "COMPACT_DB=" & sDBQShort & Chr(32) & sDBQShort & Chr(0))

    If hRes = 0 Then    
        MsgBox "Ошибка сжатия файла БД", vbExclamation Or vbSystemModal,"Error"
        Exit Sub
    End If
    MsgBox "Сжата БД: " & sDBQCur & ".", vbInformation Or vbSystemModal,"Reply"
    ConnectDB False

End Sub

'[Подключение к уже существующей БД]
'--------------------------------------------------------------------------------------------
Sub ConnectDB(q)
    
    '/Запрос на параметры открываемой БД/    
    '------------------------------------------------------------------------------------    
    If q Then

        sDBQCur = Sys.CDlg.ShowOpen("Access database files (*.mdb)|*.mdb", _
                                            "Открыть БД Access:", _
                                            Sys.Path, "mdb", Form.hWnd, 1, 1, "")
        If Len(sDBQCur) = 0 Then Exit Sub
    End If

    '------------------------------------------------------------------------------------    
    Err.Clear
    On Error Resume Next

    GrayForm()
    DoEvents
    
    If ADODBConn.State <> 0 Then ADODBConn.Close()
    DoEvents
    
    ADODBConn.Open oCns.ConnString(sDBQCur)
    DoEvents

    If Err.Number<>0 Then GetConnError():Exit Sub

    Form.List(1).Visible = True    
    Form.Menu.SubMenu("Menu1").State(3, &H1) = False
    Form.Menu.SubMenu("Menu1").State(4, &H1) = False
    Form.Menu.SubMenu("Menu1").State(5, &H1) = False
    res = SendMsg(hBar, SB_SETTEXTW, 0, "Выбрана БД: " & sDBQCur)

    ViewDB()

    MsgBox "Открыта БД " & sDBQCur & ".", vbInformation Or vbSystemModal,"Reply"

End Sub


'[Добавление файла  в БД]
'--------------------------------------------------------------------------------------------
Sub AddFile2DB(xColl)

    Dim lMax
    Dim uSRC32
    Dim sFile

    Err.Clear
    On Error Resume Next

    
    '/Установить максимальный индекс записи для соблюдения уникальности набора/
    '--------------------------------------------------------------------------        
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents
        
    ADODBRst.Open "SELECT MAX(filestore.i) FROM filestore", ADODBConn, adOpenStatic, adLockReadOnly
    If IsNull(ADODBRst.Fields(0).Value) Then 
        lMax = 0
    Else
        lMax = CLng(ADODBRst.Fields(0).Value)
    End If    

    ADODBRst.Close()        
    DoEvents


    '/Запись файла в БД/
    '------------------------------------------------------------------------------------        
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents
        
    ADODBRst.Open "filestore", ADODBConn, adOpenStatic, adLockBatchOptimistic
    DoEvents
    
    ADODBStream.Open()
    ADODBStream.Type = adTypeBinary
    '------------------------------------------------------------------------------------
    For i = 1 To xColl.Count
    
        '/Чтение файла в поток/
        '--------------------------------------------------------------------------        
        sFile = CStr(xColl.Item(i))

        ADODBStream.Cancel()
        ADODBStream.LoadFromFile(sFile)
        DoEvents

        ADODBRst.AddNew
        ADODBRst.Fields(0).Value = lMax + i
        ADODBRst.Fields(1).Value = CStr(Sys.File.GetFName(sFile))
        ADODBRst.Fields(2).Value = CStr(Sys.File.CRC32.File(sFile))
        ADODBRst.Fields(3).Value = ADODBStream.Read
        DoEvents        
    
        ADODBRst.UpdateBatch adAffectCurrent
        DoEvents
        

    Next
    '------------------------------------------------------------------------------------    
    ADODBStream.Close()    
    DoEvents
    
    ADODBRst.Close()    
    DoEvents    
    
    If Err.Number<>0 Then GetConnError(): Exit Sub
    ViewDB()
    Form.List(1).ListIndex = Form.List(1).ListCount - 1    

End Sub

'[Извлечение файла из БД]
'--------------------------------------------------------------------------------------------
Sub ExtractFile()
    
    Dim sFile
    Dim crc32

    If Form.List(1).ListIndex = -1 Then Exit Sub

    'Диалог сохранения
    '--------------------------------------------------------------------------
    sFile = Sys.CDlg.ShowSave("All files (*.*)|*.*", _
                                  "Файл для сохранения:", _
                                   Sys.Path, "*.*", Form.hWnd, 2, 1, Form.List(1).Text)

    If Len(sFile) = 0 Then Exit Sub
    '--------------------------------------------------------------------------

    Err.Clear
    On Error Resume Next
    res = SendMsg(hBar, SB_SETTEXTW, 0, "Извлечение файла " & Form.List(1).Text & "...")

    '/Выборка записи и извлечение файла на диск/
    '--------------------------------------------------------------------------
    If ADODBRst.State <> 0 Then ADODBRst.Close()

    ADODBRst.Open "SELECT filestore.crc,filestore.file FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.i=" & Form.List(1).ItemData(Form.List(1).ListIndex), ADODBConn, adOpenStatic, adLockReadOnly
    DoEvents

    crc32 = CStr(ADODBRst.Fields(0).Value)

    ADODBStream.Open()
    ADODBStream.Type = adTypeBinary
    ADODBStream.Write ADODBRst.Fields(1).Value
    ADODBStream.SaveToFile sFile, adSaveCreateOverWrite
    DoEvents    

    ADODBStream.Close()
    DoEvents
    ADODBRst.Close()    
    DoEvents    

    '/Проверка контрольной суммы/
    '--------------------------------------------------------------------------
    If Sys.File.IsDirFile(sFile) Then
 
        If CCur(crc32) = Sys.File.CRC32.File(sFile) Then
            MsgBox "Файл "& sFile &" успешно извлечен.", vbInformation Or vbSystemModal,"Reply"
        Else
            MsgBox "Ошибка контрольной суммы " & sFile, vbExclamation Or vbSystemModal,"Error"
        End If
    End If

    res = SendMsg(hBar, SB_SETTEXTW, 0, "Выбрана БД: " & sDBQCur)
    '--------------------------------------------------------------------------
    If Err.Number <> 0 Then GetConnError(): Exit Sub

End Sub


'[Обновление файла в БД]
'--------------------------------------------------------------------------------------------
Sub UpdateFile()

    Dim sFile
    Dim index
    If Form.List(1).ListIndex = -1 Then Exit Sub
    
    'Диалог выбора файла
    '--------------------------------------------------------------------------    
    sFile = Sys.CDlg.ShowOpen( "All files (*.*)|*.*", _
                                   "Файл для обновления в БД:", _
                                    Sys.Path, "", Form.hWnd, 1, 1,"")

    If Len(sFile) = 0 Then Exit Sub
    '--------------------------------------------------------------------------    
    
    index = Form.List(1).ListIndex    'Запомнить текущее выделение
    

    Err.Clear
    On Error Resume Next

    '/Обновление записи/
    '--------------------------------------------------------------------------        
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents

    ADODBRst.Open "SELECT * FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.i=" & Form.List(1).ItemData(Form.List(1).ListIndex), ADODBConn, adOpenStatic, adLockBatchOptimistic
        

        '/Чтение файла в поток/
        '------------------------------------------------------------------
        ADODBStream.Open()
        ADODBStream.Type = adTypeBinary
        ADODBStream.LoadFromFile(sFile)

        ADODBRst.Update
        ADODBRst.Fields(1).Value = CStr(Sys.File.GetFName(sFile))
        ADODBRst.Fields(2).Value = CStr(Sys.File.CRC32.File(sFile))
        ADODBRst.Fields(3).Value = ADODBStream.Read()
        DoEvents        
    
        ADODBRst.UpdateBatch adAffectCurrent
        DoEvents
        ADODBStream.Close()    
        DoEvents
    
    ADODBRst.Close()        
    DoEvents
    
    If Err.Number<>0 Then GetConnError(): Exit Sub
    ViewDB()    
    Form.List(1).ListIndex = index
    MsgBox "Данные обновлены.", vbInformation Or vbSystemModal,"Reply"

End Sub


'[Удаление файла из БД]
'--------------------------------------------------------------------------------------------
Sub RemoveRecord()

    Dim sFileName

    If Form.List(1).ListIndex = -1 Then Exit Sub
    iAnsw = MsgBox("Удалить запись " & Form.List(1).Text & "?",vbQuestion + vbOKCancel + vbSystemModal, "Reply")
    If iAnsw = vbCancel Then Exit Sub

    Err.Clear
    On Error Resume Next

    '/Удаление записи/
    '--------------------------------------------------------------------------        
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents

    sFileName = Form.List(1).Text

    ADODBRst.Open "DELETE * FROM filestore WHERE filestore.name='" & sFileName & _
                      "' AND filestore.i=" & Form.List(1).ItemData(Form.List(1).ListIndex), ADODBConn, adOpenStatic, adLockBatchOptimistic
        

    DoEvents
    If Err.Number<>0 Then GetConnError(): Exit Sub
    
    Form.List(1).RemoveItem Form.List(1).ListIndex
    Form.List(1).SetFocus

    If bImg Then 
        Form.CImage(1).Picture = Nothing
        Form.CImage(1).Visible = False
    End If

    MsgBox "Запись, содержащая файл [" & sFileName & "] удалена.", vbInformation Or vbSystemModal, "Reply"

End Sub


'[Вывод списка файлов содержащихся в БД]
'--------------------------------------------------------------------------------------------
Sub ViewDB()


    Form.OLEDropMode = 1
    Form.List(1).OLEDropMode = 1
    Form.CImage(1).OLEDropMode = 1

    Err.Clear
    On Error Resume Next
    
    Form.List(1).Clear
    '----------------------------------------------------------------------------
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents
    ADODBRst.Open "SELECT filestore.i, filestore.name FROM filestore", ADODBConn, adOpenStatic, adLockReadOnly
    DoEvents
    If ADODBRst.EOF Then ADODBRst.Close(): Exit Sub

    ADODBRst.MoveFirst
    DoEvents

    While Not ADODBRst.EOF
        Form.List(1).AddItem ADODBRst.Fields(1).Value
        Form.List(1).ItemData(Form.List(1).ListCount-1) = ADODBRst.Fields(0).Value
        ADODBRst.MoveNext
    Wend

    '---------------------------------------------------------------------------
    ADODBRst.Close()
    DoEvents
    
    If Err.Number<>0 Then GetConnError()

End Sub

'[Вывод изображения]
'--------------------------------------------------------------------------------------------
Sub ShowImage(sImgname)

    Err.Clear
    On Error Resume Next

    '/Выборка записи и извлечение файла/
    '--------------------------------------------------------------------------
    If ADODBRst.State <> 0 Then ADODBRst.Close()

    ADODBRst.Open "SELECT filestore.file FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.i=" & Form.List(1).ItemData(Form.List(1).ListIndex), ADODBConn, adOpenStatic, adLockReadOnly
    DoEvents

        Set oPic = Sys.CreateImage()
        oPic.AutoSize = True
        oPic.Picture = Sys.Conv.Str2Image(ADODBRst.Fields(0).Value)

    ADODBRst.Close()    
    DoEvents    


    '--------------------------------------------------------------------------    
    Form.CImage(1).Visible = False
    Form.CImage(1).Picture = oPic
    DoEvents
    IsImg = True
    ResizeImg()
End Sub

'[Подгонка размеров изображения]
'--------------------------------------------------------------------------------------------
Sub ResizeImg()

    Dim a,b,W,H

    If Form.WindowState = 1 Then Exit Sub    'Выйти из процедуры при минимизированном окне

    Form.CImage(1).Visible = False
    W = oPic.Width
    H = oPic.Height
    a = Form.ScaleWidth - 240
    b = Form.ScaleHeight - 68


    '/Отображать небольшие изображения в натуральную величину/
    '--------------------------------------------------------------------------
    If (W < a) And (H < b) Then
        Form.CImage(1).Width = W
        Form.CImage(1).Height = H
        Form.CImage(1).Visible = True
        DoEvents
        ShiftImage a,b
        Exit Sub
    End If

    '/Масштабировать большие изображения/
    '--------------------------------------------------------------------------
    s1 = a/w
    s2 = b/h

    If W > a Then 

        If H*s1>b Then
            'Если предполагаемая высота больше размеров области отображения
            Form.CImage(1).Height = b
            Form.CImage(1).Width = W*s2
            DoEvents
        Else
            Form.CImage(1).Height = H*s1            
            Form.CImage(1).Width = a
            DoEvents
        End If

    ElseIf H > b Then 

        If W*s2>a Then
            'Если предполагаемая ширина больше размеров области отображения
            Form.CImage(1).Height = H*s1
            Form.CImage(1).Width = a
            DoEvents
        Else
            Form.CImage(1).Width = W*s2
            Form.CImage(1).Height = b
            DoEvents
        End If
    
        
    End If
    ShiftImage a,b
    
        
End Sub

'/Сдвиг изображения/
'-------------------------------------------------------------------------------------------
Sub ShiftImage(x1,x2)
    
    Form.CImage(1).Left = (x1 - Form.CImage(1).Width)/2 + 20
    Form.CImage(1).Top = (x2 - Form.CImage(1).Height)/2 + 5
    Form.CImage(1).Visible = True
    DoEvents

End Sub

'/Отключение элементов управления/
'-------------------------------------------------------------------------------------------
Sub GrayForm()

    With Form    
        .List(1).Visible = False    
        .CImage(1).Picture = Nothing
        .CImage(1).Visible = False
        .Menu.SubMenu("Menu1").State(3, &H1) = True
        .Menu.SubMenu("Menu1").State(4, &H1) = True
        .Menu.SubMenu("Menu1").State(5, &H1) = True
        .OLEDropMode = 0
        .List(1).OLEDropMode = 0
        .CImage(1).OLEDropMode = 0
    DoEvents
    End With

End Sub

'/Сообщение об ошибке/
'-------------------------------------------------------------------------------------------    
Sub GetConnError()

        MsgBox     Err.Source & vbCR & _
            Err.Description, _
            vbExclamation Or vbSystemModal, _
            "Произошла ошибка"    
        Err.Clear
            
End Sub

'[Строки подключения]
'--------------------------------------------------------------------------------------------
Class CNSTR
    Private Sub Class_Initialize
    End Sub
    
    Private Sub Class_Terminate
    End Sub
    
    Public Property Get ConnString(stDBQ)
    ConnString = "Driver={Microsoft Access Driver (*.mdb)};" & _    
                     "DBQ=" & stDBQ & ";" & _    
                     "ExtendedAnsiSQL=0;" & _    
                     "FIL=MS Access;" & _            
                     "ImplicitCommitSync=Yes;" & _    
                     "MaxBufferSize=4096;" & _    
                     "MaxScanRows=5;" & _    
                     "PageTimeout=5;" & _    
                     "ReadOnly=0;" & _    
                     "SafeTransactions=0;" & _    
                     "Threads=3;" & _    
                     "UserCommitSync=Yes"
    End Property

    
End Class

'[Посылка сообщения дочернему окну(StatusBar)]
'--------------------------------------------------------------------------------------------
Function SendMsg(hWnd,MsgID,LParam,WParam)
    SendMsg    = Sys.DynApi.CallFunction( _
                    "USER32.DLL", _
                    "SendMessageW", _
                    hWnd, _
                    MsgID, _
                    LParam, _
                    WParam)
    DoEvents
    
End Function

'[Создание строки состояния]
'--------------------------------------------------------------------------------------------
Function CreateStatusBar()
    CreateStatusBar    = Sys.DynApi.CallFunction( _
                    "COMCTL32.DLL", _
                    "CreateStatusWindowW", _
                    WS_OVERLAPPEDWINDOW + WS_VISIBLE + WS_CHILD, _
                    "Выберите базу данных Access...", _
                    Form.hWnd, _
                    0)
    DoEvents
End Function
<#Module>

'[Обработчики событий элементов управления формы]
'-------------------------------------------------------------------------------------------
<#Form=form>
    
    '-----------------------------------------------------------------------------------
    Function Menu1_Click()
        CreateDB()
        Menu1_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu2_Click()
        ConnectDB True
        Menu2_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu3_Click()

        sFile = Sys.CDlg.ShowOpen("All files (*.*)|*.*", _
                                          "Добавление файла в БД:", _
                                          Sys.Path, "", Form.hWnd, 1, 1, "")

        If Len(sFile) = 0 Then Exit Function

        Set x = Sys.NewCollection()
        x.Add CStr(sFile)
        AddFile2DB x

        Menu3_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu4_Click()
        ExtractFile()

        Menu4_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu5_Click()

        Form.CImage(1).Picture = Nothing
        Form.CImage(1).Visible = False

        CompactDB()

        Menu5_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu6_Click()
        Form.UnloadForm()

    End Function

    '-----------------------------------------------------------------------------------
    Function Menu7_Click()
        Menu4_Click()

        Menu7_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu8_Click()
        UpdateFile()

        Menu8_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu9_Click()
        RemoveRecord()

        Menu9_Click = True
    End Function
    
    '------------------------------------------------------------------------------------
    Sub List1_DblClick()
        Form.Menu.SubMenu("Menu2").Show
    End Sub

    '[Перетаскивание группы файлов на список БД]
    '------------------------------------------------------------------------------------
    Sub List1_OLEDragDrop(Data,Effect,Button,Shift,X,Y)
        DropFiles Data        
    End Sub

    Sub CImage1_OLEDragDrop(Data,Effect,Button,Shift,X,Y)
        DropFiles Data    
    End Sub

    Sub Form_OLEDragDrop(Data,Effect,Button,Shift,X,Y)
        DropFiles Data    
    End Sub

    Sub DropFiles(oData)
        iC = oData.Files.Count
        If iC =0 Then Exit Sub
        
        Set x = Sys.NewCollection()
        For i=1 To iC
            x.Add CStr(oData.Files.Item(i))
        Next
        AddFile2DB x
        Form.SetFocus()
    End Sub

    '[Вывод изображения]
    '------------------------------------------------------------------------------------
    Sub List1_Click()

        Dim sFItem
        sFItem = CStr(Form.List(1).Text)
        result=sFItem=~ig/\.gif|\.jpg|\.jpeg|\.bmp|\.png//

        If result Then 
            ShowImage sFItem
            bImg = True
        Else
            Form.CImage(1).Picture = Nothing
            Form.CImage(1).Visible = False
            bImg = False
        End If

    End Sub

    '------------------------------------------------------------------------------------
    Sub Form_Resize()
        
        If Form.ScaleWidth < 250 Then Exit Sub
        If IsImg Then ResizeImg()
        '----------------------------------------------------------------------------
        res = Sys.DynApi.CallFunction( _
                    "USER32.DLL", _
                    "MoveWindow", _
                    hBar, _
                    0, _
                    Form.ScaleHeight, _
                    Form.ScaleWidth, _
                    0, _
                    True)
        DoEvents
        '----------------------------------------------------------------------------        
        Sys.Gdi.Gradient Form, Array(Array(0,0,&HFF,&HFF,&HFF), Array(Form.ScaleWidth, Form.ScaleHeight, &H52, &HA3, &HA3))
        DoEvents
        
    End Sub
    '------------------------------------------------------------------------------------
    Sub Form_Load()
        
        
    End Sub

    '[Завершение работы]
    '-----------------------------------------------------------------------------------
    Sub Form_Unload()
        
        If ADODBRst.State <> 0 Then ADODBRst.Close()
        DoEvents
        If ADODBConn.State <> 0 Then ADODBConn.Close()
        DoEvents
        
        Set ADODBConn = Nothing
        Set ADODBRst = Nothing
        Set ADODBStream = Nothing

        EndMF
        DoEvents
    End Sub

<#Form>


Аналогичный пример для файловой базы Excel. Файл кодируется в текстовый формат base64, после чего помещается в таблицу в текстовом виде, фрагментируясь при необходимости. При извлечении файла происходит обратное преобразование. Ограничение на размер файла - 2Мб. Удаление файлов для файловой базы Excel не поддерживается.
Формат таблицы хранения файлов: CREATE TABLE filestore(i long, name varchar, crc varchar, chunk1 longtext, ..., chunk32 longtext)

Потребуется установленный LangMF 9.0.
OC WinXP

f_excel.mf


<#Module=FileBaseExcel>

    '-----------------------------------------------------------------------------------
    Public ADODBRst
    Public ADODBConn 
    '-----------------------------------------------------------------------------------
    Public Const adOpenDynamic = 2
    Public Const adOpenStatic = 3

    Public Const adLockBatchOptimistic = 4
    Public Const adLockReadOnly = 1

    Public Const adTypeBinary = 1
    Public Const adTypeText = 2

    Public Const adAffectCurrent = 1
    Public Const adSaveCreateOverWrite = 2

    Public Const adUseServer = 2
    '-----------------------------------------------------------------------------------
    Public Const ODBC_ADD_DSN = 1
    Public Const ODBC_CONFIG_DSN = 2
    Public Const ODBC_REMOVE_DSN = 3
    Public Const ODBC_ADD_SYS_DSN = 4
    Public Const ODBC_CONFIG_SYS_DSN = 5
    Public Const ODBC_REMOVE_SYS_DSN = 6
    Public Const ODBC_REMOVE_DEFAULT_DSN = 7

    '-----------------------------------------------------------------------------------
    Public Const WS_BORDER = &H00800000
    Public Const WS_CHILD = &H40000000
    Public Const WS_OVERLAPPED = 0
    Public Const WS_OVERLAPPEDWINDOW = &H00CF0000
    Public Const WS_VISIBLE = &H10000000

    Public Const SB_SETTEXTA = &H0401
    Public Const SB_SETTEXTW = &H040B
    Public Const SB_GETTEXTA = &H0402
    Public Const SB_GETTEXTW = &H040D
    Public Const SB_GETTEXTLENGTHA = &H0403
    Public Const SB_GETTEXTLENGTHW = &H040C

    Public Const SB_SETPARTS = &H0404
    Public Const SB_GETPARTS = &H0406
    Public Const SB_GETBORDERS = &H0407
    Public Const SB_SETMINHEIGHT = &H0408
    Public Const SB_SIMPLE = &H0409
    Public Const SB_GETRECT = &H040A


    Public Const SBT_OWNERDRAW = &H1000
    Public Const SBT_NOBORDERS = &H0100
    Public Const SBT_POPOUT = &H0200
    Public Const SBT_RTLREADING = &H0400

    Public Const MAX_FILESIZE = 2097120
    '-----------------------------------------------------------------------------------
    Public hBar
    Public oCns
    Public sDBQCur
    Public sPwdCur
    Public bImg
    Public oPic
    Public IsImg
    

'[Создание формы]
'-------------------------------------------------------------------------------------------
Sub Load(cmdstr)

    IsImg = False
    Set oCns = new CNSTR
    
    Set ADODBConn = CreateObject("ADODB.Connection")
    Set ADODBRst = CreateObject("ADODB.Recordset")
    
    ADODBConn.CursorLocation = adUseServer
    ADODBConn.Mode = 3
    DoEvents

    '/Установка параметров формы/
    '----------------------------------------------------------------------------------        
    With Form
        
        .AutoRedraw = True
        .ScaleMode = 3
        .Caption = "Файловая БД Excel [LangMF 9.0]"
        .Width = 800 * vbPx
        .Height    = 550 * vbPy
        .Style.MinButton = True
        .Style.MaxButton = True
        .Style.SizeBorder= True
        '-------------------------------------------------------------------------
        .Add "List", 1, "move2 -3, 0.005,-10,,200, 0.95, 1","BorderStyle = 1"
        .Add "CImage", 1, "Left=10","Top=10","BorderStyle=0", "Stretch = True"
        '-------------------------------------------------------------------------
        .Menu.Add 1, "Файл", "Menu1"
        .Menu.SubMenu("Menu1").Add 1, "Создать БД"
        .Menu.SubMenu("Menu1").Add 2, "Открыть БД"
        .Menu.SubMenu("Menu1").Add 3, "Добавить файл"
        .Menu.SubMenu("Menu1").Add 4, "Извлечь файл"
        .Menu.SubMenu("Menu1").Add 5, "Выход"
        .Menu.Show

        .Menu.SubMenu("Menu1").State(3, &H1) = True
        .Menu.SubMenu("Menu1").State(4, &H1) = True
        

        .Menu.Add 2, "", "Menu2"
        .Menu.SubMenu("Menu2").PopUp = True
        .Menu.SubMenu("Menu2").Add 7, "Извлечь файл"
        .Menu.SubMenu("Menu2").Add 8, "Обновить файл"


        .List(1).Visible = False

        .CImage(1).Picture = Nothing
        .CImage(1).Visible = False

        For Each Control In .Controls
            On Error Resume Next
                Control.Appearance = 0
                Control.FontName = "Tahoma"        
                Control.FontSize = 10
                Control.FontBold = True

        Next

        '-------------------------------------------------------------------------
        hBar = CreateStatusBar()
        DoEvents
        
        .Visible = True    
        '-------------------------------------------------------------------------
    End With
    DoEvents

End Sub

'[Создание БД формата Excel]
'-------------------------------------------------------------------------------------------
Sub CreateDB()
    
    Dim sDBQ1
    Dim i
    Dim sStr
    
    'Диалог выбора файла БД
    '------------------------------------------------------------------------------------
    sDBQ1 = Sys.CDlg.ShowSave("Excel database files (*.xls)|*.xls", _
                                  "Создать файл БД Excel:", _
                                  Sys.Path, "xls", Form.hWnd, 1, 1, "filebase.xls")
    If Len(sDBQ1) = 0 Then Exit Sub
    If Sys.File.IsDirFile(sDBQ1) Then
        MsgBox "БД уже существует, укажите новое имя.", vbExclamation Or vbSystemModal,"Error"
        Exit Sub
    End If

    'Отключение предыдущего соединения
    '------------------------------------------------------------------------------------    
    If ADODBConn.State <> 0 Then 
        ADODBConn.Close()
        DoEvents
        GrayForm()
        DoEvents        
    End If

    Err.Clear
    On Error Resume Next
    '------------------------------------------------------------------------------------
    Set ADODBConn1     = CreateObject("ADODB.Connection")
    ADODBConn1.CursorLocation = adUseServer
    ADODBConn1.Mode = 3
    DoEvents
    
    ADODBConn1.ConnectionString = oCns.ConnString(sDBQ1)
    ADODBConn1.Open() 
    DoEvents

    'Ограничения на длину данных в одной ячейке 65535 байт
    '------------------------------------------------------------------------------------
    sStr=""
    For i=1 To 31
        sStr =     sStr & "chunk" & i & Chr(32) & "longtext, "
    Next
    sStr =     sStr & "chunk" & i & Chr(32) & "longtext)"

    ADODBConn1.Execute "CREATE TABLE filestore(i long, name varchar, crc varchar, " & sStr    
    DoEvents
    
    ADODBConn1.Close()
    DoEvents
    Set ADODBConn1 = Nothing

    res = SendMsg(hBar, SB_SETTEXTW, 0, "Выберите базу данных Excel...")

    If Err.Number <> 0 Then GetConnError():Exit Sub
    MsgBox "Создана БД " & sDBQ1 & ".", vbInformation Or vbSystemModal,"Reply"

End Sub

'[Подключение к уже существующей БД]
'--------------------------------------------------------------------------------------------
Sub ConnectDB()
    
    'Диалог открытия файла
    '------------------------------------------------------------------------------------    
    sDBQCur = Sys.CDlg.ShowOpen("Excel files (*.xls)|*.xls", _
                                    "Открыть БД Excel:", _
                                     Sys.Path, "xls", Form.hWnd, 1, 1, "")
    If Len(sDBQCur) = 0 Then Exit Sub
    '------------------------------------------------------------------------------------    
    
    Err.Clear
    On Error Resume Next

    GrayForm()
    DoEvents
    
    If ADODBConn.State <> 0 Then ADODBConn.Close()
    DoEvents
    
    ADODBConn.ConnectionString = oCns.ConnString(sDBQCur)
    ADODBConn.Open() 
    DoEvents
    If Err.Number<>0 Then GetConnError():Exit Sub

    Form.List(1).Visible = True    
    Form.Menu.SubMenu("Menu1").State(3, &H1) = False
    Form.Menu.SubMenu("Menu1").State(4, &H1) = False
    DoEvents
    res = SendMsg(hBar, SB_SETTEXTW, 0, "Выбрана БД: " & sDBQCur)
    DoEvents

    ViewDB()

    MsgBox "Открыта БД " & sDBQCur & ".", vbInformation Or vbSystemModal,"Reply"

End Sub

'[Вывод списка файлов содержащихся в БД]
'--------------------------------------------------------------------------------------------
Sub ViewDB()


    Form.OLEDropMode = 1
    Form.List(1).OLEDropMode = 1
    Form.CImage(1).OLEDropMode = 1

    Err.Clear
    On Error Resume Next
    
    Form.List(1).Clear
    '----------------------------------------------------------------------------
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents
    ADODBRst.Open "SELECT filestore.i, filestore.name FROM filestore", ADODBConn, adOpenStatic, adLockReadOnly
    DoEvents
    If ADODBRst.EOF Then ADODBRst.Close(): Exit Sub

    ADODBRst.MoveFirst()
    DoEvents

    While Not ADODBRst.EOF
        Form.List(1).AddItem ADODBRst.Fields(1).Value
        Form.List(1).ItemData(Form.List(1).ListCount-1) = ADODBRst.Fields(0).Value
        ADODBRst.MoveNext
        DoEvents
    Wend

    '---------------------------------------------------------------------------
    ADODBRst.Close()
    DoEvents

    If Err.Number<>0 Then GetConnError()

End Sub

'[Добавление файла  в БД]
'--------------------------------------------------------------------------------------------
Sub AddFile2DB(sFile)

    Dim ADODBStream
    Dim oScr

    Dim lCount
    Dim j

    '/Проверка размера файла/
    '--------------------------------------------------------------------------        
    Set oScr = CreateObject("Scripting.FileSystemObject")
    If oScr.GetFile(sFile).Size > MAX_FILESIZE Then
        MsgBox "Размер файла превышает ограничение " & MAX_FILESIZE & " байт", vbSystemModal + vbExclamation, "Операция отменена"
        Set oScr = Nothing    
        Exit Sub
    End If
    Set oScr = Nothing
    '--------------------------------------------------------------------------        

    Err.Clear
    On Error Resume Next

    Set ADODBStream = CreateObject("ADODB.Stream")
    
    '/Подсчет количества записей/
    '--------------------------------------------------------------------------        
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents
        
    ADODBRst.Open "SELECT COUNT(filestore.i) FROM filestore", ADODBConn, adOpenStatic, adLockReadOnly
    DoEvents
    
    If IsNull(ADODBRst.Fields(0).Value) Then 
        lCount = 0
    Else
        lCount = CLng(ADODBRst.Fields(0).Value)
    End If    
    ADODBRst.Close()        
    DoEvents

    '/Запись файла в БД/
    '------------------------------------------------------------------------------------        
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents
        
    ADODBRst.Open "filestore", ADODBConn, adOpenStatic, adLockBatchOptimistic
    DoEvents
    
    '------------------------------------------------------------------------------------
    ADODBStream.Open
    ADODBStream.Type = adTypeText
    ADODBStream.WriteText Sys.Conv.EncodeBase64(Sys.Conv.File2Str(sFile))
    DoEvents

    
        ADODBRst.AddNew
        ADODBRst.Fields(0).Value = lCount + 1
        ADODBRst.Fields(1).Value = CStr(Sys.File.GetFName(sFile))
        ADODBRst.Fields(2).Value = CStr(Sys.File.CRC32.File(sFile))
        DoEvents
        '----------------------------------------------------------------------------
        j=0
        ADODBStream.Position = 0
        While Not ADODBStream.EOS
            ADODBRst.Fields(3+j).Value = ADODBStream.ReadText(65535)
            DoEvents
            j = j + 1
        Wend        
        '----------------------------------------------------------------------------    
        ADODBRst.UpdateBatch adAffectCurrent
        DoEvents
        
    
    ADODBStream.Close()
    DoEvents
    
    ADODBRst.Close()    
    DoEvents    
    '------------------------------------------------------------------------------------
    If Err.Number<>0 Then GetConnError(): Exit Sub

    ViewDB()

    Form.List(1).ListIndex = Form.List(1).ListCount - 1    
    DoEvents

End Sub

'[Извлечение файла из БД]
'--------------------------------------------------------------------------------------------
Sub ExtractFile()
    
    Dim ADODBStream
    Dim sFile
    Dim crc32

    If Form.List(1).ListIndex = -1 Then Exit Sub
    
    'Диалог сохранения файла
    '------------------------------------------------------------------------------------
    sFile = Sys.CDlg.ShowSave("All files (*.*)|*.*", _
                                  "Файл для сохранения:", _
                                  Sys.Path, "*.*", Form.hWnd, 2, 1, Form.List(1).Text)

    If Len(sFile) = 0 Then Exit Sub
    '------------------------------------------------------------------------------------

    Err.Clear
    On Error Resume Next
    Set ADODBStream = CreateObject("ADODB.Stream")

    res = SendMsg(hBar, SB_SETTEXTW, 0, "Извлечение файла " & Form.List(1).Text & "...")
    DoEvents

    '/Выборка записи и извлечение файла/
    '------------------------------------------------------------------------------------
    If ADODBRst.State <> 0 Then ADODBRst.Close()

    ADODBRst.Open "SELECT * FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.i=" & CLng(Form.List(1).ItemData(Form.List(1).ListIndex)), ADODBConn, adOpenStatic, adLockReadOnly
    DoEvents

    crc32 = ADODBRst.Fields(2).Value

        'Чтение частей файла из таблицы
        '------------------------------------------------------------------
        ADODBStream.Open()
        ADODBStream.Type = adTypeText    
        DoEvents
    
        j=0
        While ADODBRst.Fields(3+j).ActualSize<>0
            ADODBStream.WriteText(ADODBRst.Fields(3+j).Value)
            DoEvents
            j = j + 1
        Wend        

    
        ADODBStream.Position = 0    
        Sys.Conv.Str2File Sys.Conv.DecodeBase64(ADODBStream.ReadText), sFile
        DoEvents    

        ADODBStream.Close()
        DoEvents    
        '-------------------------------------------------------------------

    ADODBRst.Close()    
    DoEvents    

    Set ADODBStream = Nothing
    '------------------------------------------------------------------------------------
    Sys.Sleep(100)
    
    '/Проверка контрольной суммы/
    '------------------------------------------------------------------------------------
    If Sys.File.IsDirFile(sFile) Then
 
        If CCur(crc32) = Sys.File.CRC32.File(sFile) Then
            MsgBox "Файл "& sFile &" успешно извлечен.", vbInformation Or vbSystemModal,"Reply"
        Else
            MsgBox "Ошибка контрольной суммы " & sFile, vbExclamation Or vbSystemModal,"Error"
        End If
    End If

    res = SendMsg(hBar, SB_SETTEXTW, 0, "Выбрана БД: " & sDBQCur)
    '------------------------------------------------------------------------------------
    If Err.Number <> 0 Then GetConnError(): Exit Sub

End Sub

'[Обновление файла в БД]
'--------------------------------------------------------------------------------------------
Sub UpdateFile()

    Dim ADODBStream
    Dim sFile
    Dim index

    If Form.List(1).ListIndex = -1 Then Exit Sub

    'Диалог выбора файла
    '------------------------------------------------------------------------------------
    sFile = Sys.CDlg.ShowOpen("All files (*.*)|*.*", _
                                  "Файл для обновления в БД:", _
                                  Sys.Path, "", form.hWnd, 1, 1, "")

    If Len(sFile) = 0 Then Exit Sub
    '------------------------------------------------------------------------------------

    Err.Clear
    On Error Resume Next
    Set ADODBStream = CreateObject("ADODB.Stream")

    index = Form.List(1).ListIndex    'Запомнить текущее выделение

    '/Запись base64 шифрованного файла в поля БД/
    '------------------------------------------------------------------------------------
    If ADODBRst.State <> 0 Then ADODBRst.Close()
    DoEvents

    ADODBRst.Open "SELECT * FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.i=" & CLng(Form.List(1).ItemData(Form.List(1).ListIndex)), ADODBConn, adOpenDynamic, adLockBatchOptimistic
        
    ADODBStream.Open()
    ADODBStream.Type = adTypeText
    ADODBStream.WriteText Sys.Conv.EncodeBase64(Sys.Conv.File2Str(sFile))
        
    ADODBRst.Update()
    ADODBRst.Fields(1).Value = CStr(Sys.File.GetFName(sFile))
    ADODBRst.Fields(2).Value = CStr(Sys.File.CRC32.File(sFile))

        j = 0
        ADODBStream.Position = 0
        While Not ADODBStream.EOS
            ADODBRst.Fields(3+j).Value = ADODBStream.ReadText(65535)
            DoEvents
            j = j + 1
        Wend        

        While j<32
            ADODBRst.Fields(3+j).Value = ""
            DoEvents
            j = j + 1
        Wend        
    
    ADODBRst.UpdateBatch adAffectCurrent
    DoEvents
        
    ADODBStream.Close()
    DoEvents
    
    ADODBRst.Close()        
    DoEvents
    
    Set ADODBStream = Nothing
    '------------------------------------------------------------------------------------
    If Err.Number<>0 Then GetConnError(): Exit Sub

    ViewDB()    

    Form.List(1).ListIndex = index
    MsgBox "Данные обновлены.", vbInformation Or vbSystemModal,"Reply"

End Sub

'[Вывод изображения]
'--------------------------------------------------------------------------------------------
Sub ShowImage(sImgname)

    Dim ADODBStream
    
    Err.Clear
    On Error Resume Next
    
    Set ADODBStream = CreateObject("ADODB.Stream")

    '/Выборка записи и извлечение файла/
    '--------------------------------------------------------------------------
    If ADODBRst.State <> 0 Then ADODBRst.Close()

    ADODBRst.Open "SELECT * FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.i=" & CLng(Form.List(1).ItemData(Form.List(1).ListIndex)), ADODBConn, adOpenStatic, adLockReadOnly
    DoEvents

    'Чтение частей файла из таблицы
    '--------------------------------------------------------------------------    
    ADODBStream.Open()
    ADODBStream.Type = adTypeText    
    DoEvents
    
        j=0
        While ADODBRst.Fields(3+j).ActualSize<>0
            ADODBStream.WriteText(ADODBRst.Fields(3+j).Value)
            DoEvents
            j = j + 1
        Wend        
        ADODBStream.Position = 0    
    
    'Восстановление изображения
    '--------------------------------------------------------------------------        
    Set oPic = Sys.CreateImage()
    oPic.AutoSize = True
    oPic.Picture = Sys.Conv.Str2Image(Sys.Conv.DecodeBase64(ADODBStream.ReadText))
    DoEvents

    ADODBStream.Close()    
    DoEvents

    ADODBRst.Close()    
    DoEvents    
    
    Set ADODBStream = Nothing
    '--------------------------------------------------------------------------    
    Form.CImage(1).Visible = False
    Form.CImage(1).Picture = oPic
    DoEvents
    IsImg = True
    ResizeImg()

End Sub

'[Подгонка размеров изображения]
'--------------------------------------------------------------------------------------------
Sub ResizeImg()

    Dim a,b,W,H

    If Form.WindowState = 1 Then Exit Sub    'Выйти из процедуры при минимизированном окне

    Form.CImage(1).Visible = False
    W = oPic.Width
    H = oPic.Height
    a = Form.ScaleWidth - 240
    b = Form.ScaleHeight - 68


    '/Отображать небольшие изображения в натуральную величину/
    '--------------------------------------------------------------------------
    If (W < a) And (H < b) Then
        Form.CImage(1).Width = W
        Form.CImage(1).Height = H
        Form.CImage(1).Visible = True
        DoEvents
        ShiftImage a,b
        Exit Sub
    End If

    '/Масштабировать большие изображения/
    '--------------------------------------------------------------------------
    s1 = a/w
    s2 = b/h

    If W > a Then 

        If H*s1>b Then
            'Если предполагаемая высота больше размеров области отображения
            Form.CImage(1).Height = b
            Form.CImage(1).Width = W*s2
            DoEvents
        Else
            Form.CImage(1).Height = H*s1            
            Form.CImage(1).Width = a
            DoEvents
        End If

    ElseIf H > b Then 

        If W*s2>a Then
            'Если предполагаемая ширина больше размеров области отображения
            Form.CImage(1).Height = H*s1
            Form.CImage(1).Width = a
            DoEvents
        Else
            Form.CImage(1).Width = W*s2
            Form.CImage(1).Height = b
            DoEvents
        End If
    
        
    End If
    ShiftImage a,b
    
        
End Sub

'/Сдвиг изображения/
'-------------------------------------------------------------------------------------------
Sub ShiftImage(x1,x2)
    
    Form.CImage(1).Left = (x1 - Form.CImage(1).Width)/2 + 20
    Form.CImage(1).Top = (x2 - Form.CImage(1).Height)/2 + 5
    Form.CImage(1).Visible = True
    DoEvents

End Sub

'/Отключение элементов управления/
'-------------------------------------------------------------------------------------------
Sub GrayForm()

    With Form    
        .List(1).Visible = False    
        .CImage(1).Picture = Nothing
        .CImage(1).Visible = False
        .Menu.SubMenu("Menu1").State(3, &H1) = True
        .Menu.SubMenu("Menu1").State(4, &H1) = True
        .OLEDropMode = 0
        .List(1).OLEDropMode = 0
        .CImage(1).OLEDropMode = 0
        DoEvents
    End With

End Sub

'/Сообщение об ошибке/
'-------------------------------------------------------------------------------------------    
Sub GetConnError()

        MsgBox     Err.Source & vbCR & _
            Err.Description, _
            vbExclamation Or vbSystemModal, _
            "Произошла ошибка"    
        Err.Clear
            
End Sub

'[Строки подключения]
'--------------------------------------------------------------------------------------------
Class CNSTR
    Private Sub Class_Initialize
    End Sub
    
    Private Sub Class_Terminate
    End Sub
    
    Public Property Get ConnString(stDBQ)
    ConnString = "Driver={Microsoft Excel Driver (*.xls)};" & _    
                     "DBQ=" & stDBQ & ";" & _
                     "FileType=Excel;" & _    
                     "ReadOnly=0;"
            
    End Property

    
End Class

'[Посылка сообщения дочернему окну(StatusBar)]
'--------------------------------------------------------------------------------------------
Function SendMsg(hWnd,MsgID,LParam,WParam)
    SendMsg    = Sys.DynApi.CallFunction( _
                    "USER32.DLL", _
                    "SendMessageW", _
                    hWnd, _
                    MsgID, _
                    LParam, _
                    WParam)
    DoEvents
    
End Function

'[Создание строки состояния]
'--------------------------------------------------------------------------------------------
Function CreateStatusBar()
    CreateStatusBar    = Sys.DynApi.CallFunction( _
                    "COMCTL32.DLL", _
                    "CreateStatusWindowW", _
                    WS_OVERLAPPEDWINDOW + WS_VISIBLE + WS_CHILD, _
                    "Выберите базу данных Excel...", _
                    Form.hWnd, _
                    0)
    DoEvents
End Function

<#Module>

'[Обработчики событий элементов управления формы]
'-------------------------------------------------------------------------------------------
<#Form=form>
    
    '-----------------------------------------------------------------------------------
    Function Menu1_Click()
        CreateDB()
        Menu1_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu2_Click()
        ConnectDB()
        Menu2_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu3_Click()

        Dim sF
        sF = Sys.CDlg.ShowOpen( "All files (*.*)|*.*", _
                    "Добавление файла в БД:", _
                    Sys.Path, "", Form.hWnd, 1, 1, "")
        If Len(sF) = 0 Then Exit Function
        AddFile2DB(sF)

        Menu3_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu4_Click()
        ExtractFile()

        Menu4_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu5_Click()
        Form.UnloadForm()

    End Function

    '-----------------------------------------------------------------------------------
    Function Menu7_Click()
        Menu4_Click()

        Menu7_Click = True
    End Function

    '-----------------------------------------------------------------------------------
    Function Menu8_Click()
        UpdateFile()

        Menu8_Click = True
    End Function

    '------------------------------------------------------------------------------------
    Sub List1_DblClick()
        Form.Menu.SubMenu("Menu2").Show
    End Sub

    '[Перетаскивание файла на список БД]
    '------------------------------------------------------------------------------------
    Sub List1_OLEDragDrop(Data,Effect,Button,Shift,X,Y)
        DropFiles Data        
    End Sub

    Sub CImage1_OLEDragDrop(Data,Effect,Button,Shift,X,Y)
        DropFiles Data    
    End Sub

    Sub Form_OLEDragDrop(Data,Effect,Button,Shift,X,Y)
        DropFiles Data    
    End Sub

    Sub DropFiles(oData)

        Dim iC

        iC = oData.Files.Count
        If iC = 0 Then Exit Sub

        AddFile2DB CStr(oData.Files.Item(1))
        DoEvents

        Form.SetFocus()
        DoEvents
    End Sub

    '[Вывод изображения]
    '------------------------------------------------------------------------------------
    Sub List1_Click()

        Dim sFItem
        sFItem = CStr(Form.List(1).Text)
        result=sFItem=~ig/\.gif|\.jpg|\.jpeg|\.bmp|\.png//

        If result Then 
            ShowImage sFItem
            bImg = True
        Else
            Form.CImage(1).Picture = Nothing
            Form.CImage(1).Visible = False
            bImg = False
        End If

    End Sub

    '------------------------------------------------------------------------------------
    Sub Form_Resize()
        
        If Form.ScaleWidth < 250 Then Exit Sub
        If IsImg Then ResizeImg()
        '----------------------------------------------------------------------------
        res = Sys.DynApi.CallFunction( _
                    "USER32.DLL", _
                    "MoveWindow", _
                    hBar, _
                    0, _
                    Form.ScaleHeight, _
                    Form.ScaleWidth, _
                    0, _
                    True)
        DoEvents
        '----------------------------------------------------------------------------        
        Sys.Gdi.Gradient Form, Array(Array(0,0,&HFF,&HFF,&HFF), Array(Form.ScaleWidth, Form.ScaleHeight, &H9D, &H4A, &H81))
        DoEvents
        
    End Sub
    '------------------------------------------------------------------------------------
    Sub Form_Load()
        
        
    End Sub

    '[Завершение работы]
    '-----------------------------------------------------------------------------------
    Sub Form_Unload()
        
        If ADODBRst.State <> 0 Then ADODBRst.Close()
        DoEvents
        If ADODBConn.State <> 0 Then ADODBConn.Close()
        DoEvents
        
        Set ADODBConn = Nothing
        Set ADODBRst = Nothing
        

        EndMF
        DoEvents
    End Sub
<#Form>

2 (изменено: Poltergeyst, 2015-05-24 22:13:38)

Re: LangMF 9.0; JScript.NET; OOo Basic: хранение файлов в базе данных

Реализация похожей идеи на JScript.NET.

Приложение JScript.NET предназначено для работы с базой данных графических изображений формата Access. Откройте новое изображение используя кнопку [Открыть изображение]. Добавьте файл изображения в базу даных нажав кнопку [Сохранить]. Чтобы просмотреть изображение из базы, выберите его имя из списка. Чтобы восстановить изображение в файл нажмите [Восстановить]. Чтобы удалить изображение из базы нажмите [Удалить]. 

Файл базы данных [IMAGEDB.mdb] должен находится в одном каталоге со приложением [IMGDB.exe].

NET Framework v2.0.50727
OC WinME/XP

Чтобы получить исполняемый модуль откомпиллируйте файл IMGDB.JS примерно следующей командой:  C:\WINDOWS\Microsoft.NET\Framework\v2.0.50727\jsc.exe /target:winexe C:\...\IMGDB.JS


База данных Access 4.0 [IMAGEDB.mdb] содержит единственную таблицу STORE:
_____________________________________
Столбец |Назначение            |Тип данных
_____________________________________
i1           |Индекс файла         |LONG 
i2           |Имя файла              |VARCHAR
i3           |Файл изображения  |LONGTEXT
_____________________________________

Команда SQL для создания таблицы: CREATE TABLE STORE(i1 LONG,i2 VARCHAR,i3 LONGTEXT)

Post's attachments

imgdbn11n.zip 23.98 kb, 237 downloads since 2010-01-19 

You don't have the permssions to download the attachments of this post.

3 (изменено: Poltergeyst, 2015-05-28 23:34:03)

Re: LangMF 9.0; JScript.NET; OOo Basic: хранение файлов в базе данных

Решение из той же серии для Open Office 2.x - управление небольшой файловой базой данных с помощью связанной формы документа Open Office Writer. Размер добавляемого файла ограничен 2Мб.

Open Office 2.x
OC WinXP

Post's attachments

oobindata.zip 15.58 kb, 4 downloads since 2015-05-28 

You don't have the permssions to download the attachments of this post.