1 (изменено: Poltergeyst, 2019-11-05 17:16:01)

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

Без гарантий. Используете на свой страх и риск.
Скрипт предназначен для управления файловой базой данных в формате 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
	

	'/Установка параметров формы/
	'----------------------------------------------------------------------------------		
	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()
		
		
		.Visible = True	
		DoEvents
		'-------------------------------------------------------------------------
	End With
		
	
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()
		
		GrayForm()
				
	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")
	

	ADODBConn1.Open oCns.ConnString(sDBQ1)
	ADODBConn1.Execute "CREATE TABLE filestore(i long, name varchar, crc varchar, file longbinary)"
	ADODBConn1.Close()
	
	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
		
		GrayForm()
		
		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()
	
	
	If ADODBConn.State <> 0 Then ADODBConn.Close()
	ADODBConn.Open oCns.ConnString(sDBQCur)
	
	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()
	
		
	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()		
	
	'/Запись файла в БД/
	'------------------------------------------------------------------------------------		
	If ADODBRst.State <> 0 Then ADODBRst.Close()
	ADODBRst.Open "filestore", ADODBConn, adOpenStatic, adLockBatchOptimistic
	
	ADODBStream.Open()
	ADODBStream.Type = adTypeBinary
	'------------------------------------------------------------------------------------
	For i = 1 To xColl.Count
	
		'/Чтение файла в поток/
		'--------------------------------------------------------------------------		
		sFile = CStr(xColl.Item(i))

		ADODBStream.Cancel()
		ADODBStream.LoadFromFile(sFile)
		

		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
		ADODBRst.UpdateBatch adAffectCurrent
		
	Next
	'------------------------------------------------------------------------------------	
	ADODBStream.Close()	
	ADODBRst.Close()	
		
	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
	

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

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

	'/Проверка контрольной суммы/
	'--------------------------------------------------------------------------
	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()
	

	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()
				
	
		ADODBRst.UpdateBatch adAffectCurrent
		ADODBStream.Close()	
		ADODBRst.Close()		
	
	
	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()
	

	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
		

	
	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()
	
	ADODBRst.Open "SELECT filestore.i, filestore.name FROM filestore", ADODBConn, adOpenStatic, adLockReadOnly
	
	If ADODBRst.EOF Then ADODBRst.Close(): Exit Sub

	ADODBRst.MoveFirst
	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
		DoEvents
		ADODBRst.MoveNext
	Wend
	'---------------------------------------------------------------------------
	ADODBRst.Close()
	
	
	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
	

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

	ADODBRst.Close()	
	'--------------------------------------------------------------------------	
	Form.CImage(1).Visible = False
	Form.CImage(1).Picture = oPic
	
	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
		
		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
			
		Else
			Form.CImage(1).Height = H*s1			
			Form.CImage(1).Width = a
			
		End If

	ElseIf H > b Then 

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

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
	
	End With
	DoEvents
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)
	
	
End Function

'[Создание строки состояния]
'--------------------------------------------------------------------------------------------
Function CreateStatusBar()

	CreateStatusBar	= Sys.DynApi.CallFunction( _
					"COMCTL32.DLL", _
					"CreateStatusWindowW", _
					WS_OVERLAPPEDWINDOW + WS_VISIBLE + WS_CHILD, _
					"Выберите базу данных Access...", _
					Form.hWnd, _
					0)
	
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)
		
		'----------------------------------------------------------------------------		
		Sys.Gdi.Gradient Form, Array(Array(0,0,&HFF,&HFF,&HFF), Array(Form.ScaleWidth, Form.ScaleHeight, &H52, &HA3, &HA3))
		
		
	End Sub
	'------------------------------------------------------------------------------------
	Sub Form_Load()
		
		
	End Sub

	'[Завершение работы]
	'-----------------------------------------------------------------------------------
	Sub Form_Unload()
		
		If ADODBRst.State <> 0 Then ADODBRst.Close()
		If ADODBConn.State <> 0 Then ADODBConn.Close()
		
		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
	

	'/Установка параметров формы/
	'----------------------------------------------------------------------------------		
	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()
		
		.Visible = True	
		DoEvents
		'-------------------------------------------------------------------------
	End With
	

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()
		
		GrayForm()
				
	End If

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

	'Ограничения на длину данных в одной ячейке 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	
	
	ADODBConn1.Close()
	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()
	
	If ADODBConn.State <> 0 Then ADODBConn.Close()
	ADODBConn.ConnectionString = oCns.ConnString(sDBQCur)
	ADODBConn.Open() 
	
	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
	
	res = SendMsg(hBar, SB_SETTEXTW, 0, "Выбрана БД: " & sDBQCur)
	

	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()
	
	ADODBRst.Open "SELECT filestore.i, filestore.name FROM filestore", ADODBConn, adOpenStatic, adLockReadOnly
	
	If ADODBRst.EOF Then ADODBRst.Close(): Exit Sub

	ADODBRst.MoveFirst()
	

	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
		DoEvents
		ADODBRst.MoveNext
		
	Wend

	'---------------------------------------------------------------------------
	ADODBRst.Close()
	
	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()
	
	ADODBRst.Open "SELECT COUNT(filestore.i) FROM filestore", ADODBConn, adOpenStatic, adLockReadOnly
	
	If IsNull(ADODBRst.Fields(0).Value) Then 
		lCount = 0
	Else
		lCount = CLng(ADODBRst.Fields(0).Value)
	End If	
	ADODBRst.Close()		
	

	'/Запись файла в БД/
	'------------------------------------------------------------------------------------		
	If ADODBRst.State <> 0 Then ADODBRst.Close()
	
		
	ADODBRst.Open "filestore", ADODBConn, adOpenStatic, adLockBatchOptimistic
	
	
	'------------------------------------------------------------------------------------
	ADODBStream.Open
	ADODBStream.Type = adTypeText
	ADODBStream.WriteText Sys.Conv.EncodeBase64(Sys.Conv.File2Str(sFile))
	
		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))
		
		'----------------------------------------------------------------------------
		j=0
		ADODBStream.Position = 0
		While Not ADODBStream.EOS
			ADODBRst.Fields(3+j).Value = ADODBStream.ReadText(65535)
			
			j = j + 1
		Wend		
		'----------------------------------------------------------------------------	
		ADODBRst.UpdateBatch adAffectCurrent
		
		
	
	ADODBStream.Close()
	ADODBRst.Close()	
		
	'------------------------------------------------------------------------------------
	If Err.Number<>0 Then GetConnError(): Exit Sub

	ViewDB()

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

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 & "...")
	

	'/Выборка записи и извлечение файла/
	'------------------------------------------------------------------------------------
	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
	

	crc32 = ADODBRst.Fields(2).Value

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

	
		ADODBStream.Position = 0	
		Sys.Conv.Str2File Sys.Conv.DecodeBase64(ADODBStream.ReadText), sFile
			
		ADODBStream.Close()
		'-------------------------------------------------------------------

	ADODBRst.Close()	
	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()
	

	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)
			j = j + 1
		Wend		

		While j<32
			ADODBRst.Fields(3+j).Value = ""
			j = j + 1
		Wend		
	
	ADODBRst.UpdateBatch adAffectCurrent
	ADODBStream.Close()
	ADODBRst.Close()		
	
	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
	

	'Чтение частей файла из таблицы
	'--------------------------------------------------------------------------	
	ADODBStream.Open()
	ADODBStream.Type = adTypeText	
	
	
		j=0
		While ADODBRst.Fields(3+j).ActualSize<>0
			ADODBStream.WriteText(ADODBRst.Fields(3+j).Value)
			
			j = j + 1
		Wend		
		ADODBStream.Position = 0	
	
	'Восстановление изображения
	'--------------------------------------------------------------------------		
	Set oPic = Sys.CreateImage()
	oPic.AutoSize = True
	oPic.Picture = Sys.Conv.Str2Image(Sys.Conv.DecodeBase64(ADODBStream.ReadText))
	
	ADODBStream.Close()	
	ADODBRst.Close()	
		
	
	Set ADODBStream = Nothing
	'--------------------------------------------------------------------------	
	Form.CImage(1).Visible = False
	Form.CImage(1).Picture = oPic
	
	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
		
		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
			
		Else
			Form.CImage(1).Height = H*s1			
			Form.CImage(1).Width = a
			
		End If

	ElseIf H > b Then 

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

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
		
	End With
	DoEvents
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)
	
	
End Function

'[Создание строки состояния]
'--------------------------------------------------------------------------------------------
Function CreateStatusBar()

	CreateStatusBar	= Sys.DynApi.CallFunction( _
					"COMCTL32.DLL", _
					"CreateStatusWindowW", _
					WS_OVERLAPPEDWINDOW + WS_VISIBLE + WS_CHILD, _
					"Выберите базу данных Excel...", _
					Form.hWnd, _
					0)
	
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))
		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)
		
		'----------------------------------------------------------------------------		
		Sys.Gdi.Gradient Form, Array(Array(0,0,&HFF,&HFF,&HFF), Array(Form.ScaleWidth, Form.ScaleHeight, &H9D, &H4A, &H81))
		
		
	End Sub
	'------------------------------------------------------------------------------------
	Sub Form_Load()
		
		
	End Sub

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

<#Form>

2 (изменено: Poltergeyst, 2019-11-05 02:28:50)

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

Реализация похожей идеи на 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 24.01 kb, file has never been downloaded. 

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