1 (изменено: Poltergeyst, 2021-09-20 23:15:23)

Тема: LangMF 9/11: хранение файлов в базе данных

Без гарантий. Используете на свой страх и риск.

Скрипт предназначен для управления файловой базой данных в формате Access(ADO). Пользуясь пунктами меню "Файл" можно создавать новую базу, открывать соединение с уже созданной БД, добавлять и извлекать файлы. Добавление группы файлов, также, происходит при перетаскивании значков файлов из проводника на форму. Если файл является изображением (gif, jpg, jpeg, bmp), то выбор пункта списка(одиночный щелчок) выводит изображение в область просмотра. Двойной щелчок по списку выводит контекстное меню, позволяющее обновлять, извлекать или удалять заданный файл из БД.

Формат таблицы хранения файлов: CREATE TABLE filestore(id COUNTER, name varchar, crc varchar, file longbinary).

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

f_access.mf


<#Module=FileBaseAccess_ADO>

	'-----------------------------------------------------------------------------------
	Public objADODBRst
	Public objADODBConn 
	Public objADODBStream
	'-----------------------------------------------------------------------------------
	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 bImg
	Public oPic
	Public IsImg
	

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

	IsImg = False
	Set oCns = new CNSTR
	
	Set objADODBConn = CreateObject("ADODB.Connection")
	Set objADODBRst = CreateObject("ADODB.Recordset")
	Set objADODBStream = CreateObject("ADODB.Stream")
	objADODBConn.CursorLocation = adUseServer
	

	'/Установка параметров формы/
	'----------------------------------------------------------------------------------		
	With Form
		
		.AutoRedraw = True
		.ScaleMode = 3
		.Caption = "Файловая БД Access(ADO)[LangMF 9.0]v2"
		.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.90, 1","FontSize=10"
		.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

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

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

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

	GrayForm()

	Err.Clear
	On Error Resume Next

	'Отключение предыдущего соединения
	'------------------------------------------------------------------------------------	
	If objADODBConn.State <> 0 Then objADODBConn.Close()
		
	'/Генерация файла БД/
	'------------------------------------------------------------------------------------
	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

	'/Создание таблицы хранения файлов/
	'------------------------------------------------------------------------------------
	objADODBConn.Open oCns.ConnString(sDBQ1)

	' Тип данных COUNTER это первичный ключ
	objADODBConn.Execute "CREATE TABLE filestore(id COUNTER, name varchar, crc varchar, file longbinary)"
	'///objADODBConn1.Execute "CREATE TABLE filestore(id COUNTER, name varchar, crc varchar, file longbinary, CONSTRAINT PrimaryKey PRIMARY KEY (id))"///
	objADODBConn.Close()

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

End Sub

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

	Dim sDBQShort

	GrayForm()
	res = SendMsg(hBar, SB_SETTEXTW, 0, "Сжатие БД " & sDBQCur & "...")

	'Отключение соединения
	'------------------------------------------------------------------------------------
	If objADODBConn.State <> 0 Then objADODBConn.Close
		
	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

	'------------------------------------------------------------------------------------	
	GrayForm()

	Err.Clear
	On Error Resume Next

	If objADODBConn.State <> 0 Then objADODBConn.Close()
	objADODBConn.Open oCns.ConnString(sDBQCur)
	
	If Err.Number<>0 Then GetConnError():Exit Sub

	With Form 
		.List(1).Visible = True	
		.Menu.SubMenu("Menu1").State(3, &H1) = False
		.Menu.SubMenu("Menu1").State(4, &H1) = False
		.Menu.SubMenu("Menu1").State(5, &H1) = False
	End With

	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 objADODBRst.State <> 0 Then objADODBRst.Close()
	objADODBRst.Open "filestore", objADODBConn, adOpenStatic, adLockBatchOptimistic
	
	objADODBStream.Type = adTypeBinary
	objADODBStream.Open()
	'------------------------------------------------------------------------------------
	For i = 1 To xColl.Count
	
		'/Чтение файла в поток/
		'--------------------------------------------------------------------------		
		sFile = CStr(xColl.Item(i))

		objADODBStream.Cancel()
		objADODBStream.LoadFromFile(sFile)
		
		With objADODBRst
			.AddNew
			.Fields(1).Value = CStr(Sys.File.GetFName(sFile))
			.Fields(2).Value = CStr(Sys.File.CRC32.File(sFile))
			.Fields(3).Value = objADODBStream.Read
			.UpdateBatch adAffectCurrent
		End With
		
	Next
	'------------------------------------------------------------------------------------	
	objADODBStream.Close()	
	objADODBRst.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 objADODBRst.State <> 0 Then objADODBRst.Close()

	objADODBRst.Open "SELECT filestore.crc,filestore.file FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.id=" & Form.List(1).ItemData(Form.List(1).ListIndex), objADODBConn, adOpenStatic, adLockReadOnly
	
	crc32 = CStr(objADODBRst.Fields(0).Value)
	With objADODBStream
		.Type = adTypeBinary
		.Open()
		.Write objADODBRst.Fields(1).Value
		.SaveToFile sFile, adSaveCreateOverWrite
		.Close()
	End With
	objADODBRst.Close()	

	If Err.Number <> 0 Then GetConnError(): Exit Sub
		
	'/Проверка контрольной суммы/
	'--------------------------------------------------------------------------
	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)

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 objADODBRst.State <> 0 Then objADODBRst.Close()
	
	objADODBRst.Open "SELECT * FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.id=" & Form.List(1).ItemData(Form.List(1).ListIndex), objADODBConn, adOpenStatic, adLockBatchOptimistic
		
		'/Чтение файла в поток/
		'------------------------------------------------------------------
		objADODBStream.Type = adTypeBinary
		objADODBStream.Open()
		objADODBStream.LoadFromFile(sFile)

		With objADODBRst
			.Update
			.Fields(1).Value = CStr(Sys.File.GetFName(sFile))
			.Fields(2).Value = CStr(Sys.File.CRC32.File(sFile))
			.Fields(3).Value = objADODBStream.Read()
			.UpdateBatch adAffectCurrent
		End With
		objADODBStream.Close()	
		objADODBRst.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 objADODBRst.State <> 0 Then objADODBRst.Close()
	
	sFileName = Form.List(1).Text

	objADODBConn.Execute "DELETE * FROM filestore WHERE filestore.name='" & sFileName & _
                      "' AND filestore.id=" & Form.List(1).ItemData(Form.List(1).ListIndex)
		

	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

	Form.List(1).Clear

	Err.Clear
	On Error Resume Next
	'----------------------------------------------------------------------------
	If objADODBRst.State <> 0 Then objADODBRst.Close()
	
	objADODBRst.Open "SELECT filestore.id, filestore.name FROM filestore", objADODBConn, adOpenStatic, adLockReadOnly
	
	With objADODBRst 
		If .EOF Then .Close(): Exit Sub
		.MoveFirst
		While Not .EOF
			Form.List(1).AddItem .Fields(1).Value
			Form.List(1).ItemData(Form.List(1).ListCount-1) = .Fields(0).Value
			DoEvents
			.MoveNext
		Wend
		.Close()
	End With
	If Err.Number<>0 Then GetConnError()

End Sub

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

	Err.Clear
	On Error Resume Next

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

	objADODBRst.Open "SELECT filestore.file FROM filestore WHERE filestore.name='" & Form.List(1).Text & _
                      "' AND filestore.id=" & Form.List(1).ItemData(Form.List(1).ListIndex), objADODBConn, adOpenStatic, adLockReadOnly
	

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

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

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

	Dim a,b,W,H

	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>
	
	'-----------------------------------------------------------------------------------
	Sub Menu1_Click()
		CreateDB()
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Menu2_Click()
		ConnectDB True
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Menu3_Click()

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

		If Len(sFile) = 0 Then Exit Sub

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

	'-----------------------------------------------------------------------------------
	Sub Menu4_Click()
		ExtractFile()
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Menu5_Click()
		CompactDB()
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Menu6_Click()
		Form.UnloadForm()
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Menu7_Click()
		Menu4_Click()
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Menu8_Click()
		UpdateFile()
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Menu9_Click()
		RemoveRecord()
	End Sub
	
	'------------------------------------------------------------------------------------
	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 Form.ScaleHeight < 200 Then Exit Sub
		If Form.WindowState = 1 Then Exit Sub	'Выйти из процедуры при минимизированном окне
		If IsImg Then ResizeImg()
		'----------------------------------------------------------------------------
		res = Sys.DynApi.CallFunction( _
					"USER32.DLL", _
					"MoveWindow", _
					hBar, _
					0, _
					Form.ScaleHeight, _
					Form.ScaleWidth, _
					0, _
					True)
		
	End Sub
	'------------------------------------------------------------------------------------
	Sub Form_Load()
		
		
	End Sub

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

		EndMF
		DoEvents
		
	End Sub

<#Form>

2 (изменено: Poltergeyst, 2021-09-28 21:24:19)

Re: LangMF 9/11: хранение файлов в базе данных

Без гарантий. Используете на свой страх и риск.

Аналогичный пример с использованием Web-интерфейса, использующий формат БД Access предыдущего скрипта. Простой Wsk(Winsock Control)-сервер изображений с базой Access(ADO), с возможностью просмотра/загрузки небольших(jpg, jpeg, gif, png) изображений через Web-интерфейс. Для загрузки изображения в БД используется буфер в памяти. Файл БД Access "base_wsk.mdb" расположен рядом со скриптом. После запуска скрипта нужно открыть заглавную страницу http://127.0.0.1/ в обозревателе. Меню иконки в трее позволяет остановить скрипт.

http://127.0.0.1/1/pic.jpg - формат на ссылку изображения в БД(с сохранением имени файла).
Формат таблицы хранения файлов: CREATE TABLE filestore(id COUNTER, name varchar, crc varchar, file longbinary).

Потребуется установленный LangMF 11
OC Win 7

wsksrv.mf


Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" (ByVal dwInitial As Long, ByVal pData As Long, ByVal iLen As Long) As Long
<#Module=Simple_WSK>

	Public objADODBRst
	Public objADODBConn 
	'-----------------------------------------------------------------------------------
	Public Const adOpenDynamic = 2
	Public Const adOpenStatic = 3

	Public Const adLockBatchOptimistic = 4
	Public Const adLockReadOnly = 1

	Public Const adAffectCurrent = 1
	Public Const adUseServer = 2

	'-----------------------------------------------------------------------------------
	Public Const sckTCPProtocol = 0
	Public Const sckClosed = 0
	'-----------------------------------------------------------------------------------
	Public oCns
	Public sDBQCur
	Public cnt
	Public sUPLOAD

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

	Set oCns = new CNSTR

	'/Буфер приема файла/
	Set sUPLOAD = Sys.NewBuf()
	
	Set objADODBConn = CreateObject("ADODB.Connection")
	Set objADODBRst = CreateObject("ADODB.Recordset")
	objADODBConn.CursorLocation = adUseServer
	
	'/Установка параметров формы/
	'----------------------------------------------------------------------------------		
	With Form

		.Hide
	
		On Error Resume Next
		Set .Tray.TrayIcon = LoadPicture(Sys.Path & "icon.ico")
		On Error GoTo 0

		.Tray.TrayTip = "Simple Wsk Server [mem_buf]"
		.Tray.InTray = True
		
		.Menu.Popup = True
		.Menu.Add 1, "Выбрать БД"
		.Menu.Add 2, "Выход"

		.Add "Wsk",1
		.Add "Wsk",2

		.Add "Wsk",11
		.Add "Wsk",22
	
	End With

	'/WSK для отображения страницы/изобажений/
	'----------------------------------------------------------------------------------
	With Form.Wsk(1)
		.Protocol = sckTCPProtocol
		.LocalPort = 80
		.Listen()
	End With

	With Form.Wsk(2)
		.Protocol = sckTCPProtocol
		.LocalPort = 0
	End With

	'/WSK для загрузки файла изображения в БД/
	'----------------------------------------------------------------------------------
	With Form.Wsk(11)
		.Protocol = sckTCPProtocol
		.LocalPort = 10000
		.Listen()
	End With

	With Form.Wsk(22)
		.Protocol = sckTCPProtocol
		.LocalPort = 0
	End With

	'----------------------------------------------------------------------------------
	ConnectDB False

End Sub

'[Подключение к уже существующей БД]
'-------------------------------------------------------------------------------------------
Sub ConnectDB(q)
	

	'------------------------------------------------------------------------------------	
	If q Then
		'Выбранная БД
		sDBQCur = Sys.CDlg.ShowOpen("Access database files (*.mdb)|*.mdb", _
                                            "Открыть БД Access:","", _
                                            Sys.Path, "mdb", 1, 1)
		If Len(sDBQCur) = 0 Then Exit Sub
	Else
		'Расположенная рядом со скриптом БД
		sDBQCur = Sys.Path & "base_wsk.mdb"
	End If

	'------------------------------------------------------------------------------------	
	Err.Clear
	On Error Resume Next
		If objADODBConn.State <> 0 Then objADODBConn.Close()
		objADODBConn.Open oCns.ConnString(sDBQCur)

	If Err.Number<>0 Then 
		GetConnError()
		Unload Form
		Exit Sub
	End If

	If q Then MsgBox "Обновите заглавную страницу.",vbInformation + vbSystemModal,"Simple Server"

End Sub

'/Сообщение об ошибке/
'-------------------------------------------------------------------------------------------	
Sub GetConnError()
	MsgBox Err.Source & vbCRLF & Err.Description, vbExclamation Or vbSystemModal, "Error"	
	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

	Public Property Get ServHeader()
		ServHeader = 	"HTTP/1.1 200 OK" & vbCRLF & _
				"Cache-Control: no-cache, pre-check=0, post-check=0" & vbCRLF & _
				"Pragma: no-cache" & vbCRLF
	End Property


End Class

'[Отправка изображения браузеру]
'-------------------------------------------------------------------------------------------
Sub SendPicture(sRequest)

		Dim id, name

		'/Индекс в БД/ 
		'---------------------------------------------------------------------------
		Set mts = Sys.RXP.Execute(sRequest,"GET\s+\/([0-9]+)\/(.+)\s+HTTP", True, False)
			id = mts(0).submatches(0)
			name = CStr(mts(0).submatches(1))
			' Избавиться от escape-символов
			name = nameScr.unescapestr(name)

		'/Выборка изображения/ 
		'---------------------------------------------------------------------------
		Err.Clear
		On Error Resume Next

		If objADODBRst.State <> 0 Then objADODBRst.Close()
		objADODBRst.Open "SELECT filestore.file FROM filestore WHERE filestore.name='" & name & _
				 "' AND filestore.id=" & id, objADODBConn, adOpenStatic, adLockReadOnly
		
		If Err.Number<>0 Then GetConnError()
		'---------------------------------------------------------------------------
		Form.Wsk(2).SendData 	oCns.ServHeader & _
					"Content-Type: image/*" & vbCRLF & vbCRLF & Sys.Conv.Buf(objADODBRst.Fields(0).Value, vbString)

		' Важно
		DoEvents
		objADODBRst.Close()	
End Sub

'[Отправка страницы браузеру]
'--------------------------------------------------------------------------------------------
Sub SendIndexPage()

		Dim sDataStr
		
		sDataStr = vbCRLF & "<OPTION VALUE='0'>Выберите пункт списка...</OPTION>" & vbCRLF

		Err.Clear
		On Error Resume Next
		'----------------------------------------------------------------------------
		If objADODBRst.State <> 0 Then objADODBRst.Close()
		Set objADODBRst = objADODBConn.Execute("SELECT filestore.id, filestore.name FROM filestore")

		With objADODBRst
			If Not .EOF Then
				.MoveFirst
				While Not .EOF
					sDataStr = sDataStr & "<OPTION VALUE='" & CStr(.Fields(0).Value) & "'>" & CStr(.Fields(1).Value) & "</OPTION>" & vbCRLF
					.MoveNext
				Wend
			End If
			.Close()
		End With
		If Err.Number<>0 Then GetConnError()

		'----------------------------------------------------------------------------
		Form.Wsk(2).SendData oCns.ServHeader & _
				"Content-Type: text/html" & vbCRLF & vbCRLF & Sys.SHD.ResToStr("1") & sDataStr & Sys.SHD.ResToStr("2")
		' Важно
		DoEvents

End Sub

'[Добавление файла в БД (используется буфер в памяти)]
'--------------------------------------------------------------------------------------------
Sub AddFile2DB()

	Dim sFileName
	Dim sText
	
	Dim lPos1, lPos2
	Dim lSZ
	Dim lCHUNK
	Dim lFILE_SZ

	Dim crc32
	'----------------------------------------
	lCHUNK = 1024
	lSZ = sUPLOAD.Size

	If lCHUNK>lSZ Then lCHUNK = lSZ

	'/Найти начальную позицию файла/
	'------------------------------------------------------------------------------------
	sText = sUPLOAD.PString(0,lCHUNK)
		Set mts = Sys.RXP.Execute(sText,"boundary=(.+)\r\n[\W\w]+filename=""(.+)""\r\n",True,True)
		If mts.Count = 0 Then
			sUPLOAD.Size = 0
			MsgBox "Форма не содержит корректных данных",vbExclamation + vbSystemModal,"Reply"
			Exit Sub
		End If

		sBound = CStr(mts(0).submatches(0))
		sFileName = CStr(mts(0).submatches(1))

	lPos1 = lCHUNK - Len(Sys.RXP.Replace(sText, "[\w\W]+Content-Type.*[\r\n]{1,}","", True, True))

	'/Найти конечную позицию и размер файла/
	'------------------------------------------------------------------------------------
	sText = sUPLOAD.PString(lSZ-lCHUNK, lCHUNK)
	lPos2 = lSZ - lCHUNK + Len(Sys.RXP.Replace(sText, sBound & "[\w\W]+","", True, True)) - 4
	lFILE_SZ = lPos2-lPos1

	' Обновить буфер 
	sUPLOAD.SetData Sys.SHD.ArrayByte(sUPLOAD.PArray(lPos1,lFILE_SZ))	'Byte()

	' crc32
	crc32 = RtlComputeCrc32(0, sUPLOAD.Ptr, lFILE_SZ)
	'/MsgBox "Файл: " & sFileName & vbCRLF & "CRC32: " & Hex(crc32),vbSystemModal Or vbInformation

	'/Запись файла в БД/
	'------------------------------------------------------------------------------------		
	Err.Clear
	On Error Resume Next

	If objADODBRst.State <> 0 Then objADODBRst.Close()
	
	objADODBRst.Open "SELECT * FROM filestore", objADODBConn, adOpenStatic, adLockBatchOptimistic
	
	With objADODBRst
		.AddNew
		.Fields(1).Value = CStr(sFileName)
		.Fields(2).Value = CStr(crc32)
		.Fields(3).Value = sUPLOAD.GetData(vbArray Or vbByte)
		.UpdateBatch adAffectCurrent
	End With
		
	objADODBRst.Close()	
	'------------------------------------------------------------------------------------	
	If Err.Number<>0 Then GetConnError()

	sUPLOAD.Size = 0	'Очистить буфер
	
End Sub

<#Module>

'[Обработчики событий элементов управления формы]
'-------------------------------------------------------------------------------------------
<#Form=Form>

	'/Отправка страницы/изображений обозревателю/ 
	'------------------------------------------------------------------------------------
	Sub Wsk1_ConnectionRequest(RequestID)
		
		If Form.Wsk(2).State = 0 Then 
			Form.Wsk(2).Accept(RequestId)
		Else
			' Принудительно закрыть порт
			Form.Wsk(2).Close()
			Form.Wsk(2).Accept(RequestId)
		End If

	End Sub

	'------------------------------------------------------------------------------------
	Sub Wsk2_DataArrival(lBytes)

		Dim sData
		Dim r
		
		sData = CStr(sData)
		Form.Wsk(2).GetData sData, vbString
		
		'Проверка на соответствие формата адреса изображения
		r = Sys.RXP.Test(sData,"GET\s+\/[0-9]+\/.+\s+HTTP",True,False) 
		If r Then
			Call SendPicture(sData)			
		Else 
			Call SendIndexPage()
		End If

	End Sub

	'/Загрузка файла в БД/
	'------------------------------------------------------------------------------------
	Sub Wsk11_ConnectionRequest(RequestID)
		
		cnt = False
		sUPLOAD.Size = 0

		If Form.Wsk(22).State = 0 Then 
			Form.Wsk(22).Accept(RequestId)
		Else
			' Принудительно закрыть порт
			Form.Wsk(22).Close()
			Form.Wsk(22).Accept(RequestId)
		End If

		'/Закрыть слушающий порт приема файла/
		Form.Wsk(11).Close()
		' Важно
		DoEvents

		'/Приостановить другие запросы, которые могут исходить от обозревателя/
		WaitMs(2000)	
		
		Call AddFile2DB()	

		'/Вернуться на заглавную/
		'----------------------------------------------------------------------------
		Form.Wsk(22).SendData 	oCns.ServHeader & _
					"Content-Type: text/html" & vbCRLF & vbCRLF & Sys.SHD.ResToStr("3")
		
		' Важно
		DoEvents

		cnt = False
		
	End Sub

	'//Асинхронный приемник данных//
	'------------------------------------------------------------------------------------
	Sub Wsk22_DataArrival(lBytes)
		
		Dim sData
		Dim lSZ
		Dim r

		sData = CStr(sData)
		Form.Wsk(22).PeekData sData, vbString
		'Не допустимо DoEvents

		'/Убедиться что данные содержат файл/
		'----------------------------------------------------------------------------
		If Not cnt Then	
			r = Sys.RXP.Test(sData,"boundary=(.+)\r\n",True,True)
			cnt = True
			If Not r Then Exit Sub
		End If

		'/Записать данные в буфер/
		'----------------------------------------------------------------------------
		With sUPLOAD
			lSZ = .Size
			.Size = lSZ + lBytes
			.Offset = lSZ
			.SetData sData
		End With

	End Sub

	'------------------------------------------------------------------------------------
	Sub Wsk2_SendComplete() 
		Form.Wsk(2).Close()
		' Важно
		DoEvents

		'/Открыть слушающий порт приема файла/
		If Form.Wsk(11).State = sckClosed Then 
			
			'/Приостановить другие запросы, которые могут исходить от обозревателя/
			WaitMs(1000)

			Form.Wsk(11).Listen()
		End If
	End Sub

	'------------------------------------------------------------------------------------
	Sub Wsk22_SendComplete() 
		Form.Wsk(22).Close()
		' Важно
		DoEvents
	End Sub

	'------------------------------------------------------------------------------------
	Sub Tray_MouseDown(button)
		If button=2 Then Form.Menu.Show()
	End Sub

	'------------------------------------------------------------------------------------
	Sub Menu1_Click()
		ConnectDB True
	End Sub

	'------------------------------------------------------------------------------------
	Sub Menu2_Click()
		Unload Form
	End Sub

	'------------------------------------------------------------------------------------
	Sub Form_Load()
		
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Form_Unload()
		EndMF
		DoEvents
	End Sub

<#Form>

'-------------------------------------------------------------------------------------------
<#Script=nameScr#>
function unescapestr(sTxt)
{
	return unescape(String(sTxt));
}  
<#Script#>


'[Ресурсы (заглавная страница)]
'/Начало заглавной страницы/
'-------------------------------------------------------------------------------------------
<#res id="1" name="begin" #>
<HTML> 
<HEAD>
<meta http-equiv="Content-Language" content="ru">
<meta http-equiv="Content-Type" content="text/html; charset=windows-1251">
<meta http-equiv="Content-Script-Type" content="text/javascript">
<link rel="icon" href="data:,">
<link rel="shortcut icon" href="#" />
<TITLE>Simple Server</TITLE>

<STYLE type=text/css>
	TD {border:1px solid black;}
</STYLE>
</HEAD>

<BODY>
<TABLE align=center>
<TR align=center>
<TD>
<SELECT ID="fld1" SIZE=1 style="width: 300px" onchange="setimage()">
<#res#>

'[OPTIONS]

'/Конец заглавной страницы/
'-------------------------------------------------------------------------------------------
<#res id="2" name="end" #>
</SELECT>
</TD>
<TD>
<FORM METHOD="post" ENCTYPE="multipart/form-data" ACTION="http://127.0.0.1:10000/">
<INPUT TYPE="FILE" NAME="filesender" SIZE=30 ACCEPT="image/jpeg,image/gif,image/png">
<INPUT TYPE="SUBMIT" NAME="submit1" VALUE="Отправить"/>
<INPUT TYPE="RESET" NAME="reset1" VALUE="Сброс"/>
</FORM>
</TD>
</TR>

<TR align=center>
<TD COLSPAN=2>
<IMG ID="img1"></IMG>
</TD>
</TR>

<SCRIPT>
var obj = document.getElementById("fld1");
var objImg = document.getElementById("img1");
obj.selectedIndex = 0;

function setimage()
{
	var i = obj.selectedIndex;
	if (i==0){return;}

	var id = obj.value;
	var name = escape(obj.item(i).text);

	sURL = String("http://127.0.0.1/" + id + "/" + name);
	//alert(sURL);
	objImg.src = sURL;
}
</SCRIPT>
</BODY>
</HTML>
<#res#>


'/Перенаправление на заглавную/
'-------------------------------------------------------------------------------------------
<#res id="3" name="refer" #>
<HTML> 
<HEAD>
<meta http-equiv="Content-Language" content="ru">
<meta http-equiv="Content-Type" content="text/html; charset=windows-1251">
<meta http-equiv="Content-Script-Type" content="text/javascript">
<A HREf="http://127.0.0.1/">Вернуться</A>
<BODY>
<SCRIPT>
window.location.href="http://127.0.0.1/"
</SCRIPT>
</BODY>
</HTML>
<#res#>

3 (изменено: Poltergeyst, 2021-10-10 12:33:40)

Re: LangMF 9/11: хранение файлов в базе данных

Без гарантий. Используете на свой страх и риск.

Вариант предыдущего скрипта, простой файловый Wsk-сервер с базой Access(ADO), с возможностью прослушивания/загрузки в базу данных mp3 саундтреков используя Web-интерфейс. При загрузке mp3 в БД используется временный файл. Файл БД "base_wsk.mdb" расположен рядом со скриптом.

http://127.0.0.1/1/sound.mp3 - формат на ссылку саундтрека в БД(с сохранением имени файла).
Формат таблицы хранения mp3-файлов: CREATE TABLE filestore(id COUNTER, name varchar, crc varchar, file longbinary).

Потребуется установленный LangMF 11
OC Win 7

wsksrv.mf


Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" (ByVal dwInitial As Long, ByVal pData As Long, ByVal iLen As Long) As Long
<#Module=Simple_WSK>

	Public objADODBRst
	Public objADODBConn 
	'-----------------------------------------------------------------------------------
	Public Const adOpenDynamic = 2
	Public Const adOpenStatic = 3

	Public Const adLockBatchOptimistic = 4
	Public Const adLockReadOnly = 1

	Public Const adAffectCurrent = 1
	Public Const adSaveCreateOverWrite = 2

	Public Const adUseServer = 2

	Public Const adTypeBinary = 1
	Public Const adTypeText = 2

	'-----------------------------------------------------------------------------------
	Public Const sckTCPProtocol = 0
	Public Const sckClosed = 0
	'-----------------------------------------------------------------------------------
	Public oCns
	Public sDBQCur
	Public sTempFile
	Public cnt
	Public oFs
	Public oStream
	

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

	sTempFile = Sys.Path & "upload.txt"
	Set oCns = new CNSTR
	
	Set objADODBConn = CreateObject("ADODB.Connection")
	Set objADODBRst = CreateObject("ADODB.Recordset")
	Set oFs = CreateObject("Scripting.FileSystemObject")
	objADODBConn.CursorLocation = adUseServer
	
	'/Установка параметров формы/
	'----------------------------------------------------------------------------------		
	With Form

		.Hide
	
		On Error Resume Next
		Set .Tray.TrayIcon = LoadPicture(Sys.Path & "icon.ico")
		On Error GoTo 0

		.Tray.TrayTip = "Simple Wsk Server [upload]"
		.Tray.InTray = True
		
		.Menu.Popup = True
		.Menu.Add 1, "Выбрать БД"
		.Menu.Add 2, "Выход"

		.Add "Wsk",1
		.Add "Wsk",2

		.Add "Wsk",11
		.Add "Wsk",22
	
	End With

	'/WSK для отображения страницы/
	'----------------------------------------------------------------------------------
	With Form.Wsk(1)
		.Protocol = sckTCPProtocol
		.LocalPort = 80
		.Listen()
	End With

	With Form.Wsk(2)
		.Protocol = sckTCPProtocol
		.LocalPort = 0
	End With

	'/WSK для загрузки файла в БД/
	'----------------------------------------------------------------------------------
	With Form.Wsk(11)
		.Protocol = sckTCPProtocol
		.LocalPort = 10000
		.Listen()
	End With

	With Form.Wsk(22)
		.Protocol = sckTCPProtocol
		.LocalPort = 0
	End With

	'----------------------------------------------------------------------------------
	ConnectDB False

End Sub

'[Подключение к уже существующей БД]
'-------------------------------------------------------------------------------------------
Sub ConnectDB(q)
	

	'------------------------------------------------------------------------------------	
	If q Then
		'Выбранная БД
		sDBQCur = Sys.CDlg.ShowOpen("Access database files (*.mdb)|*.mdb", _
                                            "Открыть БД Access:","", _
                                            Sys.Path, "mdb", 1, 1)
		If Len(sDBQCur) = 0 Then Exit Sub
	Else
		'Расположенная рядом со скриптом БД
		sDBQCur = Sys.Path & "base_wsk.mdb"
	End If

	'------------------------------------------------------------------------------------	
	Err.Clear
	On Error Resume Next
		If objADODBConn.State <> 0 Then objADODBConn.Close()
		objADODBConn.Open oCns.ConnString(sDBQCur)

	If Err.Number<>0 Then 
		GetConnError()
		Unload Form
		Exit Sub
	End If

	If q Then MsgBox "Обновите заглавную страницу.",vbInformation + vbSystemModal,"Simple Server"

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

	Public Property Get ServHeader()
		ServHeader = 	"HTTP/1.1 200 OK" & vbCRLF & _
				"Cache-Control: no-cache, pre-check=0, post-check=0" & vbCRLF & _
				"Pragma: no-cache" & vbCRLF
	End Property


End Class

'[Отправка саундтрека браузеру]
'-------------------------------------------------------------------------------------------
Sub SendMp3Track(sRequest)

		Dim id, name

		'/Индекс в БД/ 
		'---------------------------------------------------------------------------
		Set mts = Sys.RXP.Execute(sRequest,"GET\s+\/([0-9]+)\/(.+)\s+HTTP", True, False)
			id = mts(0).submatches(0)
			name = CStr(mts(0).submatches(1))
			' Избавиться от escape-символов
			name = nameScr.unescapestr(name)

		'/Выборка файла/ 
		'---------------------------------------------------------------------------
		Err.Clear
		On Error Resume Next

		If objADODBRst.State <> 0 Then objADODBRst.Close()
		objADODBRst.Open "SELECT filestore.file FROM filestore WHERE filestore.name='" & name & _
				 "' AND filestore.id=" & id, objADODBConn, adOpenStatic, adLockReadOnly
		
		If Err.Number<>0 Then GetConnError()
		'---------------------------------------------------------------------------
		Form.Wsk(2).SendData 	oCns.ServHeader & _
					"Content-Type: audio/*" & vbCRLF & vbCRLF & Sys.Conv.Buf(objADODBRst.Fields(0).Value, vbString)

		' Важно
		DoEvents
		objADODBRst.Close()	
End Sub

'[Отправка страницы браузеру]
'--------------------------------------------------------------------------------------------
Sub SendIndexPage()

		Dim sDataStr
		
		sDataStr = vbCRLF & "<OPTION VALUE='0'>Выберите пункт списка...</OPTION>" & vbCRLF

		Err.Clear
		On Error Resume Next
		'----------------------------------------------------------------------------
		If objADODBRst.State <> 0 Then objADODBRst.Close()
		Set objADODBRst = objADODBConn.Execute("SELECT filestore.id, filestore.name FROM filestore")

		With objADODBRst
			If Not .EOF Then
				.MoveFirst
				While Not .EOF
					sDataStr = sDataStr & "<OPTION VALUE='" & CStr(.Fields(0).Value) & "'>" & CStr(.Fields(1).Value) & "</OPTION>" & vbCRLF
					.MoveNext
				Wend
			End If
			.Close()
		End With
		If Err.Number<>0 Then GetConnError()

		'----------------------------------------------------------------------------
		Form.Wsk(2).SendData oCns.ServHeader & _
				"Content-Type: text/html" & vbCRLF & vbCRLF & Sys.SHD.ResToStr("1") & sDataStr & Sys.SHD.ResToStr("2")
		' Важно
		DoEvents

End Sub

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

	Dim objADODBStream	

	Dim lPos1, lPos2
	Dim lPosBnd1, lPosBnd2
	Dim sText

	Dim crc32
	Dim buf
	Dim lSize
	Dim div, chunk, ptr
	Dim SZ1

	Const BUF_SIZE = 65536
	Const SZ = 1024

	Set objADODBStream = CreateObject("ADODB.Stream")

	'/Разобрать upload-файл(найти начальную и конечную позицию данных, открыть поток как text)/
	'------------------------------------------------------------------------------------
	'------------------------------------------------------------------------------------
	With objADODBStream

		.Charset = "windows-1251"
		.Type = adTypeText
		.Open()
		.LoadFromFile sTempFile

		' Найти начало upload-файла
		'=========================================================
		sText = .ReadText(SZ)

		Set mts = Sys.RXP.Execute(sText,"boundary=(.+)\r\n[\W\w]+filename=""(.+)""\r\n",True,True)
		If mts.Count = 0 Then
			objADODBStream.Close()
			MsgBox "Форма не содержит корректных данных",vbExclamation + vbSystemModal,"Reply"
			Exit Sub
		End If

		sBound = CStr(mts(0).submatches(0))
		sFileName = CStr(mts(0).submatches(1))
		lPosBnd1 = InStrRev(sText, sBound, SZ,0)

		'---------------------------------------------------------
		.Position = lPosBnd1
		Do
			.SkipLine()
		Loop Until Asc(.ReadText(1)) = 13
		lPos1 = .Position + 1

		' Найти конец upload-файла
		'=========================================================
		.Position = .Size - SZ
		sText = .ReadText(SZ)
		lPosBnd2 = InStr(1,sText, sBound, 0)
		lPos2 = .Size - SZ + (lPosBnd2-1) - 4
		'=========================================================
		.Close()

	End With


	'/Получение контрольной суммы crc32 буфера фрагментами (переоткрыть поток как Byte())/
	'------------------------------------------------------------------------------------
	'------------------------------------------------------------------------------------
	With objADODBStream
		.Type = adTypeBinary
		.Open()
		.LoadFromFile sTempFile
		.Position = lPos1
	End With

	lSize = lPos2-lPos1	'Размер данных
	chunk = lSize Mod BUF_SIZE
	div = (lSize - chunk)/BUF_SIZE

	crc32 = 0
	SZ1 = BUF_SIZE
	For u=0 To div

		If u=div Then SZ1 = chunk
		buf = Sys.SHD.ArrayByte(objADODBStream.Read(SZ1))
		ptr = Sys.SHD.ArrayPtr(buf)
		crc32 = RtlComputeCrc32(crc32, ptr, SZ1)

	Next
	'/MsgBox "Файл: " & sFileName & vbCRLF & "CRC32: " & Hex(crc32),vbSystemModal Or vbInformation


	'/Запись файла в БД/
	'------------------------------------------------------------------------------------	
	'------------------------------------------------------------------------------------
	objADODBStream.Position = lPos1

	Err.Clear
	On Error Resume Next

	If objADODBRst.State <> 0 Then objADODBRst.Close()
	
	objADODBRst.Open "SELECT * FROM filestore", objADODBConn, adOpenStatic, adLockBatchOptimistic
	
	With objADODBRst
		.AddNew
		.Fields(1).Value = CStr(sFileName)
		.Fields(2).Value = CStr(crc32)
		.Fields(3).Value = objADODBStream.Read(lSize)
		.UpdateBatch adAffectCurrent
	End With
		

	objADODBRst.Close()	
	objADODBStream.Close()
	'------------------------------------------------------------------------------------	
	If Err.Number<>0 Then GetConnError()

End Sub

<#Module>

'[Обработчики событий элементов управления формы]
'-------------------------------------------------------------------------------------------
<#Form=Form>

	'/Отправка страницы/изображений обозревателю/ 
	'------------------------------------------------------------------------------------
	Sub Wsk1_ConnectionRequest(RequestID)
		
		If Form.Wsk(2).State = 0 Then 
			Form.Wsk(2).Accept(RequestId)
		Else
			' Принудительно закрыть порт
			Form.Wsk(2).Close()
			Form.Wsk(2).Accept(RequestId)
		End If

	End Sub

	'------------------------------------------------------------------------------------
	Sub Wsk2_DataArrival(lBytes)

		Dim sData
		Dim r
		
		sData = CStr(sData)
		Form.Wsk(2).GetData sData, vbString
		
		'Проверка на соответствие формата адреса изображения
		r = Sys.RXP.Test(sData,"GET\s+\/[0-9]+\/.+\s+HTTP",True,False) 
		If r Then
			Call SendMp3Track(sData)			
		Else 
			Call SendIndexPage()
		End If

	End Sub

	'/Загрузка файла в БД/
	'------------------------------------------------------------------------------------
	Sub Wsk11_ConnectionRequest(RequestID)
		
		cnt = False

		If Form.Wsk(22).State = 0 Then 
			Form.Wsk(22).Accept(RequestId)
		Else
			' Принудительно закрыть порт
			Form.Wsk(22).Close()
			Form.Wsk(22).Accept(RequestId)
		End If

		'/Закрыть слушающий порт приема файла/
		Form.Wsk(11).Close()
		' Важно
		DoEvents

		'/Приостановить другие запросы, которые могут исходить от обозревателя/
		WaitMs(2000)	
		
		oStream.Close
		Call AddUploadFile2DB()	

		'/Вернуться на заглавную/
		'----------------------------------------------------------------------------
		Form.Wsk(22).SendData 	oCns.ServHeader & _
					"Content-Type: text/html" & vbCRLF & vbCRLF & Sys.SHD.ResToStr("3")
		
		' Важно
		DoEvents

		cnt = False
		
	End Sub

	'//Асинхронный приемник данных//
	'------------------------------------------------------------------------------------
	Sub Wsk22_DataArrival(lBytes)
		
		Dim sData
		Dim r

		sData = CStr(sData)
		'sData = String(lBytes, Chr(0))
		Form.Wsk(22).GetData sData, vbString

		'/Убедиться что данные содержат файл/
		'----------------------------------------------------------------------------
		If Not cnt Then	
			r = Sys.RXP.Test(sData,"boundary=(.+)\r\n",True,True)
			cnt = True
			If Not r Then 
				Exit Sub
			Else
				Set oStream = oFs.OpenTextFile(sTempFile, 2, True, 0) 
			End If
		End If

		'/Записать данные в файл/
		oStream.Write sData

	End Sub

	'------------------------------------------------------------------------------------
	Sub Wsk2_SendComplete() 
		Form.Wsk(2).Close()
		' Важно
		DoEvents

		'/Открыть слушающий порт приема файла/
		If Form.Wsk(11).State = sckClosed Then 
			
			'/Приостановить другие запросы, которые могут исходить от обозревателя/
			WaitMs(1000)

			Form.Wsk(11).Listen()
		End If
	End Sub

	'------------------------------------------------------------------------------------
	Sub Wsk22_SendComplete() 
		Form.Wsk(22).Close()
		' Важно
		DoEvents
	End Sub

	'------------------------------------------------------------------------------------
	Sub Tray_MouseDown(button)
		If button=2 Then Form.Menu.Show()
	End Sub

	'------------------------------------------------------------------------------------
	Sub Menu1_Click()
		ConnectDB True
	End Sub

	'------------------------------------------------------------------------------------
	Sub Menu2_Click()
		Unload Form
	End Sub

	'------------------------------------------------------------------------------------
	Sub Form_Load()
		
	End Sub

	'-----------------------------------------------------------------------------------
	Sub Form_Unload()
		EndMF
		DoEvents
	End Sub

<#Form>

'-------------------------------------------------------------------------------------------
<#Script=nameScr#>
function unescapestr(sTxt)
{
	return unescape(String(sTxt));
}  
<#Script#>


'[Ресурсы (заглавная страница)]
'/Начало заглавной страницы/
'-------------------------------------------------------------------------------------------
<#res id="1" name="begin" #>
<HTML> 
<HEAD>
<meta http-equiv="Content-Language" content="ru">
<meta http-equiv="Content-Type" content="text/html; charset=windows-1251">
<meta http-equiv="Content-Script-Type" content="text/javascript">
<link rel="icon" href="data:,">
<link rel="shortcut icon" href="#" />
<TITLE>Simple Server</TITLE>

<STYLE type=text/css>
	TD {border:1px solid black;}
</STYLE>
</HEAD>

<BODY>
<TABLE align=center>
<TR align=center>
<TD>
<SELECT ID="fld1" SIZE=1 style="width: 300px" onchange="setimage()">
<#res#>

'[OPTIONS]

'/Конец заглавной страницы/
'-------------------------------------------------------------------------------------------
<#res id="2" name="end" #>
</SELECT>
</TD>

<TD>
<FORM METHOD="post" ENCTYPE="multipart/form-data" ACTION="http://127.0.0.1:10000/">
	<INPUT TYPE="FILE" NAME="filesender" SIZE=30 ACCEPT="audio/mpeg">
	<INPUT TYPE="SUBMIT" NAME="submit1" VALUE="Отправить"/>
	<INPUT TYPE="RESET" NAME="reset1" VALUE="Сброс"/>
</FORM>
</TD>
</TR>

<TR align=center>
<TD COLSPAN=2>
<AUDIO ID="sound1" controls preload="metadata" style="width:100%"></AUDIO>
</TD>
</TR>

<SCRIPT>
var obj = document.getElementById("fld1");
var objSound = document.getElementById("sound1");
obj.selectedIndex = 0;

function setimage()
{
	var i = obj.selectedIndex;
	if (i==0){return;}

	var id = obj.value;
	var name = escape(obj.item(i).text);

	sURL = String("http://127.0.0.1/" + id + "/" + name);
	//alert(sURL);
	objSound.src = sURL;

}
</SCRIPT>
</BODY>
</HTML>
<#res#>


'/Перенаправление на заглавную/
'-------------------------------------------------------------------------------------------
<#res id="3" name="refer" #>
<HTML> 
<HEAD>
<meta http-equiv="Content-Language" content="ru">
<meta http-equiv="Content-Type" content="text/html; charset=windows-1251">
<meta http-equiv="Content-Script-Type" content="text/javascript">
<A HREf="http://127.0.0.1/">Вернуться</A>
<BODY>
<SCRIPT>
window.location.href="http://127.0.0.1/"
</SCRIPT>
</BODY>
</HTML>
<#res#>