'Добавление
Private Sub btnAdd_Click()
Dim fDialog As Office.FileDialog
Dim iFreeFile As Integer
Dim vFileName As Variant
Dim bFileDate() As Byte
Dim sFolderName As String
Dim CMD As ADODB.Command
On Error GoTo ErrHandler
'Открываем окно выбора файлов
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.AllowMultiSelect = True
.Title = "Выбрать приклепляемые файлы..."
.ButtonName = "Прикрепить файл"
'Открываем диалог
If .Show = True Then
'Команда сохранения
Set CMD = New ADODB.Command
CMD.ActiveConnection = CurrentProject.Connection
CMD.CommandType = adCmdStoredProc
CMD.CommandText = "[dbo].[procSalesInstFiles];02"
CMD.Parameters.Append CMD.CreateParameter("ReturnValue", adInteger, adParamReturnValue)
CMD.Parameters.Append CMD.CreateParameter("FileID", adInteger, adParamInputOutput, , 0)
CMD.Parameters.Append CMD.CreateParameter("SaleID", adInteger, adParamInput, , Me.txtSaleID)
CMD.Parameters.Append CMD.CreateParameter("FileName", adVarWChar, adParamInput, 255)
CMD.Parameters.Append CMD.CreateParameter("FileNote", adVarWChar, adParamInput, 255)
CMD.Parameters.Append CMD.CreateParameter("FileData", adLongVarBinary, adParamInput, 1) 'Надо обязательно указувать длинну
For Each vFileName In .SelectedItems
'Читаем данные из файла
iFreeFile = FreeFile
Open vFileName For Binary Access Read Lock Write As iFreeFile
If LOF(iFreeFile) > 0 Then
ReDim bFileDate(0 To LOF(iFreeFile) - 1)
Get iFreeFile, , bFileDate
Close iFreeFile
'Запускаем команду для каждого файла
CMD![FileID] = 0
CMD![FileName] = udfSalesInstAll_FileNameOnly(CStr(vFileName))
CMD![FileData].SIZE = UBound(bFileDate) + 1
CMD![FileData] = bFileDate
CMD.Execute
If Not CMD![ReturnValue] = 0 Then
MsgBox "Ошибка записи информации о сохраняемом файле!", vbCritical, "Прикрепление файла"
End If
Else
MsgBox "Ошибка чтения файла [" & vFileName & "]!", vbExclamation, "Ошибка чтения!"
End If
Next
End If
End With
Call Form_Current
ExitHere:
Set CMD = Nothing
Set fDialog = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Source & "-->" & Err & ":" & Err.Description, vbExclamation, "Error"
Resume ExitHere
Resume
End Sub
|