Программирование на Visual Basic

Возможно Вам придется из программы регистрировать некоторые ActiveX Элементы. Этот пример показывает, как можно создать регистрацию элемента из Access, а также как можно ее удалить.

'  Проверка ссылок в таблице (дополнительная функция)
'
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