|
|
' Проверка ссылок в таблице (дополнительная функция)
'
Private Sub Form_Open(Cancel As Integer)
Dim ref As Reference, i As Long
Dim dbs As DAO.Database, rst As DAO.Recordset
Dim strName As String
On Error Resume Next
' Определяем свою папку OCX для ActiveX
Me.myFolder = Application.CurrentProject.Path & "\ocx"
' Инициализируем таблицу
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("SELECT * FROM [Example 01] WHERE [myRef]=True")
' Просматриваем все ссылки
rst.MoveLast
rst.MoveFirst
For i = 0 To rst.RecordCount - 1
strName = rst!Name
Set ref = Application.References(strName)
rst.Edit
If ref Is Nothing Then
Err.Clear
rst!Path = "Файл не найден!"
Else
rst.Edit
rst!Path = CStr(ref.FullPath)
rst!Ver = CStr(ref.Major) & "." & CStr(ref.Minor)
Set ref = Nothing
End If
rst.Update
rst.MoveNext
Next
rst.Close
Set dbs = Nothing
' Обновляем таблицу
Me.[01 RegActiveX_sub].Requery
Exit Sub
999:
MsgBox Err & ": " & Err.Description
Err.Clear
Resume Next
End Sub
' Регистрация элементов
Private Sub butReg32_Click()
Dim ref As Reference, i As Long, strName As String
Dim dbs As Database, rst As Recordset
Dim strOcx As String
On Error GoTo 999
Set dbs = CurrentDb
' Определяем свою папку OCX для ActiveX
Me.myFolder = Application.CurrentProject.Path & "\OCX"
' Инициализируем таблицу
Set rst = dbs.OpenRecordset("SELECT * FROM [Example 01] WHERE [Path]='Файл не найден!'")
On Error Resume Next
' Изменяем ссылки
rst.MoveLast
rst.MoveFirst
For i = 0 To rst.RecordCount - 1
strOcx = Me.myFolder & "\" & rst!File
If Dir(strOcx) <> "" Then ' Файл существует
funRegsvr32 strOcx, "" ' Регистрируем ActiveX
rst.Edit
rst!Path = strOcx
rst.Update
Else
MsgBox "Файл " & strOcx & " не найден!"
End If
rst.MoveNext
Next
Set dbs = Nothing
Me.[01 RegActiveX_sub].Requery
Exit Sub
999:
MsgBox Err & ": " & Err.Description
Err.Clear
End Sub
' Регистрация ActiveX элемента в OC
' regsvr32.exe a.ocx ' регистрация ActiveX
' regsvr32.exe -u a.ocx ' отмена регистрации
' Параметры
' strFlag = "" или "-u"
'
Public Sub funRegsvr32(strOcx As String, strFlag As String)
Dim fs, strExe As String, strSysFolder
On Error GoTo 999
Set fs = CreateObject("Scripting.FileSystemObject") 'Создаем файловую систему
' Определяем системную папку
strSysFolder = fs.GetSpecialFolder(1)
strExe = strSysFolder & "\regsvr32.exe" ' Составляем exe файл
If Dir(strExe) <> "" Then ' Проверяем exe-файл
If Dir(strOcx) <> "" Then
' Копируем в системную папку (не так важно)
'fs.CopyFile strOcx, strSysFolder & "\"
'strOcx = strSysFolder & "\" & fs.GetFileName(strOcx) ' Системный файл
' 1 способ
If strFlag <> "-u" Then
References.AddFromFile strOcx
Else
' Удаление регистрации
'Dim ref As Reference
'Set ref = References(strOcx)
'References.Remove ref
End If
' 2 способ. Регистрация/Удаление
'strExe = strExe & " " & strFlag & " """ & strOcx & """"
'Shell strExe, vbHide 'Запускаем программу
Else
MsgBox "Нет файла: " & strOcx
End If
Else
MsgBox "Нет файла: " & strExe
End If
Set fs = Nothing
Exit Sub
999:
MsgBox Err.Description
Err.Clear
End Sub
|
|