Private Sub SaveReferensesToTable()
′es 17.01.04
′Процедура сохранения библиотечных ссылок в таблицу
′========================================================
Dim tdf As TableDef
Dim fld As Field
Dim idx As Index
Dim ref As Reference
Dim strSQL As String
′Создаем таблицу с попыткой ее предварительного удаления
On Error Resume Next
CurrentDb.TableDefs.Delete "tblReferences"
Err.Clear
On Error GoTo SaveReferensesToTableErr
′Создание таблицы
Set tdf = CurrentDb.CreateTableDef("tblReferences")
tdf.Fields.Append tdf.CreateField("refName", dbText, 40)
tdf.Fields.Append tdf.CreateField("refMajor", dbLong)
tdf.Fields.Append tdf.CreateField("refMinor", dbLong)
tdf.Fields.Append tdf.CreateField("refGUID", dbText, 50)
tdf.Fields.Append tdf.CreateField("refBuildIn", dbBoolean)
tdf.Fields.Append tdf.CreateField("refPath", dbText, 250)
Set idx = tdf.CreateIndex("Primary Key")
With idx
.Fields.Append .CreateField("refName")
.Unique = True
.Primary = True
End With
tdf.Indexes.Append idx
CurrentDb.TableDefs.Append tdf
′Добавляем записи по каждой ссылке
For Each ref In References
strSQL = "INSERT INTO tblReferences " & _
"(refName, refPath, refMajor, refMinor, refGUID, refBuildIn)" & _
" VALUES (′" & ref.Name & "′, ′" & ref.FullPath & "′, ′" & _
ref.Major & "′, ′" & ref.Minor & "′, ′" & ref.Guid & "′, " & ref.BuiltIn & ")"
CurrentDb.Execute strSQL
Next ref
Exit Sub
SaveReferensesToTableErr:
MsgBox "Процедура [SaveReferensesToTable] привела к ошибке:" & vbCrLf & _
Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical
End Sub
|
