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 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 для загрузки файла mp3 в БД/
	'----------------------------------------------------------------------------------
	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-символов
			If name=~ig/\%// Then name = nameScr.decodeURL(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()
		objADODBRst.Open "SELECT filestore.id, filestore.name FROM filestore", objADODBConn, adOpenStatic, adLockReadOnly

		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 oTxtStream
	Dim lPos1, lPos2
	Dim sText

	Dim crc32
	Dim lSize
	Dim lfSZ
	Dim div, chunk
	Dim SZ1

	Const OPEN_EXISTING = 3
	Const GENERIC_READ = &H80000000

	Const RONLY = 1
	Const NOCRNEW = False
	Const FMTASCII = 0
	
	Const BUFSZ = 1048576
	SZ1 = 1024
	
	'/Разобрать upload-файл(найти начальную и конечную позицию данных)/
	'------------------------------------------------------------------------------------
	'------------------------------------------------------------------------------------
	Set f = sys.file.api
	If f.FOpen(sTempFile, OPEN_EXISTING, GENERIC_READ) = -1 Then 
		MsgBox "Не найден файл данных",vbExclamation + vbSystemModal,"Reply"
		Exit Sub
	End If

	lfSZ = f.LOF
	If SZ1>lfSZ Then SZ1 = lfSZ

	' Найти начало upload-файла
	'=========================================================
	sText = String(SZ1, Chr(32))
	f.FGet sText, 1

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

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

	' Найти конец upload-файла
	'=========================================================
	f.FGet sText, lfSZ - SZ1 + 1
	lPos2 = lfSZ - SZ1 + Len(Sys.RXP.Replace(sText, sBound & "[\w\W]*","", True, True)) - 4
	'=========================================================

	'/Получение контрольной суммы crc32 upload-данных/
	'------------------------------------------------------------------------------------
	'------------------------------------------------------------------------------------
	lSize = lPos2 - lPos1	'Размер данных
	crc32 = GetCRC32(f, lPos1 + 1, lSize)
	'/MsgBox "Файл: " & sFileName & vbCRLF & "Размер: " & lSize & vbCRLF & "CRC32: " & Hex(crc32),vbSystemModal Or vbInformation
	f.FClose

	'/Запись файла в БД/
	'------------------------------------------------------------------------------------	
	'------------------------------------------------------------------------------------
	chunk = lSize Mod BUFSZ
	div = (lSize-chunk)/BUFSZ

	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)
	End With
		
	'/Вставка файла фрагментами с использованием TextStream/
	'------------------------------------------------------------------------------------			
	Set otxtStream = oFs.OpenTextFile(sTempFile, RONLY, NOCRNEW, FMTASCII)
	otxtStream.Skip lPos1
		
	SZ1 = BUFSZ
	For u=0 To div
		If u = div Then SZ1 = chunk
		objADODBRst.Fields(3).AppendChunk Sys.Conv.Buf(otxtStream.Read(SZ1),vbByte Or vbArray)
		DoEvents
		objADODBRst.Update
		DoEvents
	Next

	'/Применить изменения/
	'------------------------------------------------------------------------------------			
	objADODBRst.UpdateBatch adAffectCurrent
	DoEvents
	otxtStream.Close()	
	objADODBRst.Close()
	'------------------------------------------------------------------------------------	
	If Err.Number<>0 Then GetConnError()

End Sub

'/Получить CRC32 участка upload-файла/
'-----------------------------------------------------------------------
Function GetCRC32(obj, startpos, ldSize)

	Dim pos
	Dim chunk, div, SZ
	Dim u
	Dim buf, ptr
	Dim crc

	Const BUF_SIZE = 65536

	' Получение контрольной суммы фрагментами
	'---------------------------------------------------------------
	Set buf = Sys.NewBuf()

	If BUF_SIZE < ldSize Then

		chunk = ldSize Mod BUF_SIZE
		div = (ldSize - chunk)/BUF_SIZE

		SZ = BUF_SIZE
		buf.Size = SZ
		ptr = buf.Ptr

	Else	
		chunk = ldSize
		div = 0
	End If
	'---------------------------------------------------------------

	crc = 0
	pos = startpos
	For u=0 To div

		If u = div Then 
			SZ = chunk
			buf.Size = SZ
			ptr = buf.Ptr
		End If

		obj.GetMem ptr, SZ, pos
		crc = RtlComputeCrc32(crc, ptr, SZ)
		pos = pos + SZ
	Next
	'---------------------------------------------------------------
	buf.Size = 0
	GetCRC32 = crc

End Function

<#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 decodeURL(sTxt)
{
	return decodeURI(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>
</TABLE>

<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 = 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#>

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-символов
			If name=~ig/\%// Then name = nameScr.decodeURL(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()
		objADODBRst.Open "SELECT filestore.id, filestore.name FROM filestore", objADODBConn, adOpenStatic, adLockReadOnly

		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 decodeURL(sTxt)
{
	return decodeURI(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>
</TABLE>

<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 = 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#>

<#Module=FileBaseAccess_ADO>

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

	Public Const adLockBatchOptimistic = 4
	Public Const adLockReadOnly = 1
	Public Const adLockOptimistic = 3

	Public Const adAffectCurrent = 1
	Public Const adSaveCreateOverWrite = 2

	Public Const adUseServer = 2
	Public Const adUseNone = 1
	Public Const adUseClient = 3
	Public Const adUseClientBatch = 3

	'-----------------------------------------------------------------------------------
	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 objPic
	Public lpicW,lpicH
	
	
'[Создание формы]
'-------------------------------------------------------------------------------------------
Sub Load(cmdstr)

	bImg = False
	Set oCns = new CNSTR

	Set objPic = Sys.CreateImage()
	objPic.AutoSize = True
	
	Set objADODBConn = CreateObject("ADODB.Connection")
	Set objADODBRst = CreateObject("ADODB.Recordset")
	Set objFs = CreateObject("Scripting.FileSystemObject")

	objADODBConn.CursorLocation = adUseServer
	

	'/Установка параметров формы/
	'----------------------------------------------------------------------------------		
	With Form
		
		.ScaleMode = 3
		.Caption = "Файловая БД Access(ADO)[LangMF 9.0](text_stream_no_enc) 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.95, 1"
		.Add "CImage", 1, "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, "Удалить файл"

		.CImage(1).Picture = Nothing
		.CImage(1).Visible = False
		.List(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)

	Dim sPth
	
	'/Запрос на параметры открываемой БД/	
	'------------------------------------------------------------------------------------	
	If q Then
		
		sPth = Sys.CDlg.ShowOpen("Access database files (*.mdb)|*.mdb", _
                                            "Открыть БД Access:", _
                                            Sys.Path, "mdb", Form.hWnd, 1, 1, "")

		If Len(sPth) = 0 Then 
			Exit Sub
		Else
			sDBQCur = sPth 
		End If
	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)

	Err.Clear
	On Error Resume Next

	'/Добавление записи/
	'------------------------------------------------------------------------------------
	If objADODBRst.State <> 0 Then objADODBRst.Close()
	objADODBRst.Open "filestore", objADODBConn, adOpenStatic, adLockBatchOptimistic

	For i = 1 To xColl.Count
		InsertFile CStr(xColl.Item(i)), False
	Next
	objADODBRst.Close()	
	If Err.Number<>0 Then GetConnError(): Exit Sub
	'------------------------------------------------------------------------------------
	res = SendMsg(hBar, SB_SETTEXTW, 0, "Выбрана БД: " & sDBQCur)
	ViewDB()
	Form.List(1).ListIndex = Form.List(1).ListCount - 1	

End Sub

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

	Dim sFilePath
	Dim index
	Dim sfname, sfindex

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

	If Len(sFilePath) = 0 Then Exit Sub
	'--------------------------------------------------------------------------	
	
	index = Form.List(1).ListIndex	'Запомнить текущее выделение
	
	sfname = Form.List(1).Text
	sfindex = CStr(Form.List(1).ItemData(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='" & sfname & _
                      "' AND filestore.id=" & sfindex, objADODBConn, adOpenStatic, adLockBatchOptimistic
		
	InsertFile sFilePath, True
	objADODBRst.Close()
	If Err.Number<>0 Then GetConnError(): Exit Sub
	'--------------------------------------------------------------------------
	ViewDB()	
	Form.List(1).ListIndex = index
	MsgBox "Данные обновлены.", vbInformation Or vbSystemModal,"Reply"

End Sub


'//Вставка файла фрагментами с использованием TextStream(снижение нагрузки на память)//
'--------------------------------------------------------------------------------------------
Sub InsertFile(sFilePth, bUpdate)

	Dim oFile
	Dim lfSz, chunk, div, u, i, SZ
	Dim crcfile

	Const BUFSZ = 1048576
	Const RONLY = 1
	Const NOCRNEW = False
	Const FMTASCII = 0

	'------------------------------------------------------------------------------------
	Set oFile = objFs.GetFile(sFilePth)	
	lfSz = oFile.Size
	chunk = lfSz Mod BUFSZ
	div = (lfSz-chunk)/BUFSZ

	Sys.File.CRC32.File sFilePth
	crcfile = Sys.File.CRC32.crc32Result Xor -1
	'------------------------------------------------------------------------------------
	With objADODBRst

		If bUpdate Then
			.Update			
		Else
			.AddNew
		End If

		.Fields(1).Value = CStr(Sys.File.GetFName(sFilePth))
		.Fields(2).Value = CStr(crcfile)			
	End With
		
	'/Вставка файла фрагментами с использованием TextStream/
	'------------------------------------------------------------------------------------			
	Set oStream = objFs.OpenTextFile(sFilePth, RONLY, NOCRNEW, FMTASCII)
		
	SZ = BUFSZ
	For u=0 To div
		If u = div Then SZ = chunk
		objADODBRst.Fields(3).AppendChunk Sys.Conv.Buf(oStream.Read(SZ),vbByte Or vbArray)
		DoEvents
		objADODBRst.Update
		DoEvents

		If div>0 Then res = SendMsg(hBar, SB_SETTEXTW, 0, "Запись файла: " & Int((u/div)*100) & "%")			
		DoEvents
	Next

	'/Применить изменения/
	'------------------------------------------------------------------------------------			
	objADODBRst.UpdateBatch adAffectCurrent
	DoEvents
	oStream.Close()			
	
End Sub

'[Извлечение файла из БД]
'--------------------------------------------------------------------------------------------
Sub ExtractFile()
	
	Dim sFilePath
	Dim crc32
	Dim crcfile
	Dim sfname, sfindex

	Const OVRWRT = 2
	Const CRNEW = True
	Const FMTASCII = 0

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

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

	If Len(sFilePath) = 0 Then Exit Sub
	'--------------------------------------------------------------------------
	res = SendMsg(hBar, SB_SETTEXTW, 0, "Извлечение файла " & Form.List(1).Text & "...")

	sfname = Form.List(1).Text
	sfindex = CStr(Form.List(1).ItemData(Form.List(1).ListIndex))

	Err.Clear
	On Error Resume Next

	'/Выборка записи и извлечение файла на диск/
	'--------------------------------------------------------------------------
	If objADODBRst.State <> 0 Then objADODBRst.Close()
	objADODBRst.Open "SELECT filestore.crc,filestore.file FROM filestore WHERE filestore.name='" & sfname & _
                      "' AND filestore.id=" & sfindex, objADODBConn, adOpenStatic, adLockReadOnly

	crc32 = objADODBRst.Fields(0).Value

	'/Извлечение файла/
	'--------------------------------------------------------------------------
	'/text stream/
		Set oStream = objFs.OpenTextFile(sFilePath, OVRWRT, CRNEW, FMTASCII)
		oStream.Write Sys.Conv.Buf(objADODBRst.Fields(1).Value, vbString)	 
		DoEvents
		oStream.Close()

	'/Buf2File/
		'/Sys.Conv.Buf2File objADODBRst.Fields(1).Value, sFilePath
		'/DoEvents

	objADODBRst.Close()
	If Err.Number <> 0 Then GetConnError(): Exit Sub
		
	'/Проверка контрольной суммы/
	'--------------------------------------------------------------------------
	If Sys.File.IsDirFile(sFilePath) Then

		Sys.File.CRC32.File sFilePath
		crcfile = Sys.File.CRC32.crc32Result Xor -1
 
		If CCur(crc32) = CCur(crcfile) Then
			MsgBox "Файл "& sFilePath &" успешно извлечен.", vbInformation Or vbSystemModal,"Reply"
		Else
			MsgBox "Ошибка контрольной суммы " & sFilePath, vbExclamation Or vbSystemModal,"Error"
		End If
	End If
	'--------------------------------------------------------------------------
	res = SendMsg(hBar, SB_SETTEXTW, 0, "Выбрана БД: " & sDBQCur)

End Sub

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

	Dim sfname, sfindex
	Dim iAnsw

	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

	sfname = Form.List(1).Text
	sfindex = CStr(Form.List(1).ItemData(Form.List(1).ListIndex))

	Err.Clear
	On Error Resume Next

	'/Удаление записи/
	'--------------------------------------------------------------------------		
	If objADODBRst.State <> 0 Then objADODBRst.Close()
	objADODBConn.Execute "DELETE * FROM filestore WHERE filestore.name='" & sfname & _
                      "' AND filestore.id=" & sfindex
	DoEvents	
	If Err.Number<>0 Then GetConnError(): Exit Sub
	'--------------------------------------------------------------------------
	
	Form.List(1).RemoveItem Form.List(1).ListIndex
	Form.List(1).SetFocus

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

	MsgBox "Запись, содержащая файл [" & sfname & "] удалена.", 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)

	Dim sfname, sfindex

	sfname = Form.List(1).Text
	sfindex = CStr(Form.List(1).ItemData(Form.List(1).ListIndex))

	Err.Clear
	On Error Resume Next

	'/Выборка записи и извлечение файла/
	'--------------------------------------------------------------------------
	If objADODBRst.State <> 0 Then objADODBRst.Close()
	objADODBRst.Open "SELECT filestore.file FROM filestore WHERE filestore.name='" & sfname & _
                      "' AND filestore.id=" & sfindex, objADODBConn, adOpenStatic, adLockReadOnly
	
	objPic.Picture = Sys.Conv.Str2Image(objADODBRst.Fields(0).Value)

	objADODBRst.Close()
	If Err.Number<>0 Then GetConnError()	
	'--------------------------------------------------------------------------	
	lpicW = objPic.Width
	lpicH = objPic.Height	
	
	Form.CImage(1).Picture = objPic
	Form.CImage(1).Visible = True
	bImg = True
	ResizeImg()

End Sub

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

	Dim a,b,xw,yh,x1,x2,s1,s2

	a = Form.ScaleWidth-Form.List(1).Width-20
	b = Form.List(1).Height

	If (lpicW < a) And (lpicH < b) Then
		
		'Отображать небольшие изображения в натуральную величину
		'--------------------------------------------------------
		xw = lpicW
		yh = lpicH
		x1 = (a - xw)/2 + 5
		x2 = (b - yh)/2 + 5		
		
	Else
		'Масштабировать большие изображения
		'--------------------------------------------------------
		s1 = a/lpicW
		s2 = b/lpicH

		If (lpicH*s1>b) And (lpicW*s2<a) Then
		
			xw = lpicW*s2
			yh = b
			x1 = (a - xw)/2+5
			x2 = 5
		Else
			xw = a
			yh = lpicH*s1	
			x1 = 5
			x2 = (b - yh)/2	+5	
			
		End If
	End If
	
	Form.Move2 Form.CImage(1),-2,-2,x1,x2,xw,yh
	
End Sub

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

	With Form	
		.List(1).Visible = False	
		.CImage(1).Picture = Nothing
		.CImage(1).Visible = False
			objPic.Picture = Nothing
			bImg = 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=32768;" & _	
                     "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//

		If result Then 
			ShowImage sFItem
			bImg = True
		Else
			Form.CImage(1).Picture = Nothing
			Form.CImage(1).Visible = False
			objPic.Picture = Nothing
			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 bImg 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 objADODBRst = Nothing
		Set objADODBConn = Nothing
		
		EndMF
		DoEvents
		
	End Sub

<#Form>