В качестве эксперимента делаю универсальную функцию для загрузки значений в форму
Public Function fncFindReturn(frmName As Form, fldName As String, IDPath As Long, frmOutTbl As String, frmTbl As String)
'******************************************************************************
'frmName - форма, которую необходимо обработать
'IDPath - ID файла в таблице tblPathValues
'frmOutTbl - таблица во внешнем источнике
'frmTbl - таблица в текущем источнике
'fldName - наименование поля для поиска
'******************************************************************************
'On Error GoTo Err_fncFindReturn
'==============================================================================
'Раздел описания переменных
Dim rstRSOut As DAO.Recordset
Dim OutDb As Database
Dim wspCon1 As Workspace
Dim strFind As String
Dim flgSetOut As Boolean 'Флаг установки ссылки и открытия для объектов OUT
Dim flgSetIn As Boolean 'Флаг установки и открытия для обьектов IN
Dim flgIsField As Boolean 'Флаг проверки существования указанного поля в рекордсете
Dim flgIsFind As Boolean 'Флаг проверки введенного критерия поиска
Dim flgTrans As Boolean 'Флаг открытой транзакции
Dim lngCntFields As Long
Dim i As Long 'Index FindField
Dim k As Long 'RecordsetOut: First Or Next
Dim l As Long 'Index Field RecordsetOut And RecordsetIn
Dim m As Long 'Count Controls On frmName
Dim rstRSLoc As DAO.Recordset
flgSetOut = False
flgSetIn = False
flgIsField = False
flgIsFind = False
flgTrans = False
k = 0
strFind = Trim(InputBox(mdlErrors.MsgInformation(30), mdlErrors.MsgInformation(14)))
If strFind <> "" Then '+
If mdlUtil.fncInitData(IDPath) Then 'Функция инициализации файлов с данными
Set wspCon1 = DBEngine.Workspaces(0)
Set OutDb = wspCon1.OpenDatabase(fncFileDialog(IDPath, False)) 'Извлекаем путь к БД с ID=IDPath, без диалогового окна
'Сделать проверку на существование таблицы в подключаемой БД
DoCmd.Hourglass True
Set rstRSOut = OutDb.OpenRecordset(frmOutTbl, dbOpenDynaset)
flgSetOut = True
lngCntFields = rstRSOut.Fields.Count
For i = 0 To lngCntFields - 1
If rstRSOut.Fields(i).Name = fldName Then
flgIsField = True
Exit For
End If
Next i
If flgIsField Then
'Проверка типа и значения поиска
Select Case rstRSOut.Fields(i).Type
Case 4, 2, 3, 5, 6, 7, 20 'Long, Byte, Integer, Currency...
If IsNumeric(strFind) Then
Select Case rstRSOut.Fields(i).Size
Case 1
'Byte
strFind = CByte(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]=" & CStr(strFind)
Case 2
'Integer
strFind = CInt(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]=" & CStr(strFind)
Case 4
'И для Long и для Single
strFind = CSng(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]=" & CStr(strFind)
Case 8
'И для Currency и для Double
strFind = CDbl(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]=" & CStr(strFind)
Case 16
'Действительное ???
strFind = CDec(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]=" & CStr(strFind)
End Select
Else
'Ошибка преобразования типа
MsgBox mdlErrors.MsgErrors(156), vbCritical
End If
Case 10 'Текстовый тип
If Len(strFind) <= rstRSOut.Fields(i).Size Then
strFind = CStr(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]LIKE '*" & strFind & "*'"
Else
'Если превышение числа символов в критерии поиска
MsgBox mdlErrors.MsgErrors(13), vbCritical
End If
Case 8 'Поле Дата/время
If IsDate(strFind) Then
'Форматирование как Дата/Время
strFind = CDate(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]=" & CStr(strFind)
Else
'Ошибка преобразования типа
MsgBox mdlErrors.MsgErrors(156), vbCritical
End If
Case 1 'Логический тип
If strFind = "1" Then
'Записываем как True
strFind = CBool(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]=" & CStr(strFind)
ElseIf strFind = "0" Then
'Записываем как False
strFind = CBool(strFind)
flgIsFind = True
strFind = "[" & rstRSOut.Fields(i).Name & "]=" & CStr(strFind)
End If
Case Else
'В указанном поле поиск невозможен
MsgBox mdlErrors.MsgErrors(160), vbCritical
End Select
End If
End If
End If '+
'Формируем выборку для инсерта во внутренний mdb
'++++++++++++++++++++++++++++++++++++++++++++++++++++++
If flgIsFind Then
If IsTable(frmTbl) Then 'Проверка на существования указанной таблицы в текущей БД
CurrentDb.Execute "DELETE * FROM " & frmTbl & ";"
Set rstRSLoc = CurrentDb.OpenRecordset(frmTbl, dbOpenDynaset)
flgSetIn = True
End If
DBEngine(0).BeginTrans
flgTrans = True
Do While flgIsFind
If k = 0 Then
rstRSOut.FindFirst strFind
Else
rstRSOut.FindNext strFind
End If
If Not rstRSOut.NoMatch Then
k = k + 1
'Сделать проверку на Count, Name и Type/Size в локальном рекордсете
rstRSLoc.AddNew
For l = 0 To lngCntFields - 1
rstRSLoc.Fields(l) = rstRSOut.Fields(l)
Next l
rstRSLoc.Update
Else
flgIsFind = False
End If
Loop
DBEngine(0).CommitTrans
flgTrans = False
End If
If k > 0 Then
rstRSLoc.Requery
frmName.Recordset = rstRSLoc
For m = 0 To frmName.Controls.Count - 1
For l = 0 To frmName.Recordset.Fields.Count - 1
If frmName.Controls(m).Name = frmName.Recordset.Fields(l).Name Then
frmName.Controls(m).Value = frmName.Recordset.Fields(l)
End If
Next l
Next m
End If
DoCmd.Hourglass False
Exit_fncFindReturn:
If flgSetOut Then
Set wspCon1 = Nothing
Set OutDb = Nothing
rstRSOut.Close
Set rstRSOut = Nothing
End If
If flgSetIn Then
rstRSLoc.Close
Set rstRSLoc = Nothing
End If
Exit Function
Err_fncFindReturn:
DoCmd.Hourglass False
MsgBox Err.Description, vbCritical
If flgTrans Then
DBEngine(0).Rollback
End If
Resume Exit_fncFindReturn
End Function
Незадача в том, что при таком раскладе получаю следующее сообщение об ошибке:
Неправильный тип аргумента переданного по ссылке, почему так происходит?