LEADERSOFT.ru Разработка на заказ программ и сайтов
Раздел обучения информационным технологиям
Разработка программ на Access
Возможно Вам придется из программы регистрировать некоторые ActiveX Элементы. Этот пример показывает, как можно создать регистрацию элемента из Access, а также как можно ее удалить.
Свойства продукта

 Microsoft Office: 2000,2002,2003,2007,2010  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\01 Автоматизация\ActiveX\01 RegActiveX.mdb
 Язык интерфейса: Русский

   


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

Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access