Тема: LangMF 9/11: хранение файлов в БД Access
Без гарантий. Используете на свой страх и риск.
Скрипт предназначен для управления файловой базой данных в формате Access(ADO). Пользуясь пунктами меню "Файл" можно создавать новую базу, открывать соединение с уже созданной БД, добавлять и извлекать файлы. Добавление группы файлов, также, происходит при перетаскивании значков файлов из проводника на форму. Если файл является изображением (gif, jpg, jpeg, bmp), то выбор пункта списка(одиночный щелчок) выводит изображение в область просмотра. Двойной щелчок по списку выводит контекстное меню, позволяющее обновлять, извлекать или удалять заданный файл из БД.
Формат таблицы хранения файлов: CREATE TABLE filestore(id COUNTER, name varchar, crc varchar, file longbinary). Для добавления файлов используется TextStream.
Потребуется установленный LangMF 9.0.
OC Win 7
f_access.mf
<#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>