Но работает через раз. Вернее не на всех машинах.
Пробовал под разными системами (2000 и ХР).
В одних случаях программа после непродолжительной паузы запускается, в других случаях висит в процессах, отжирая около 90% процессорного времени и всё. Снимается только убиением процесса.
Автоматическая регистрация нужна для того чтобы моя программа могла запуститься с компакт-диска на компьютере, где она не установлена, при условии наличия в каталоге программы нужных OCX.
Подскажите, плиз, как правильнее сделать.
Привожу свой способ решения
В глобальном модуле:
- Код: Выделить всё
Sub Main()
Dim sFileName As String
Dim blnAXnotReg As Boolean
blnAXnotReg = False
With FiltrOpt
.FiltrType = NO_FILTER
.Invert = False
.srchString = vbNullString
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
gAppPath = IIf(Right$(App.Path, 1) = "\", App.Path, App.Path & "\")
If FSO.GetDrive(Left$(gAppPath, 1)).DriveType = CDRom Then
blnIniOnlyRead = True
Else: blnIniOnlyRead = False
End If
If Not FSO.FileExists(gAppPath & App.EXEName & ".ini") Then
CreateIniFile (gAppPath & App.EXEName & ".ini")
cIni.FileName = gAppPath & App.EXEName & ".ini"
Else
cIni.FileName = gAppPath & App.EXEName & ".ini"
CheckIniFile
End If
'Проверим на наличие ключ в регистре: HKEY_CLASSES_ROOT\TypeLib\{71A2702D-C7D8-11D2-BEF8-525400DFB47A}
cRegistry.ClassKey = HKEY_CLASSES_ROOT
cRegistry.SectionKey = "TypeLib\{71A2702D-C7D8-11D2-BEF8-525400DFB47A}"
If Not cRegistry.KeyExists Then
blnAXnotReg = True
sFileName = gAppPath & "SSubTmr6.dll"
checkFile sFileName
RegActiveX sFileName, " /s "
End If
cRegistry.SectionKey = "CLSID\{543749E2-8732-11D3-A204-0090275C8BC1}"
If Not cRegistry.KeyExists Then
blnAXnotReg = True
sFileName = gAppPath & "vbalGrid6.ocx"
checkFile sFileName
RegActiveX sFileName, " /s "
End If
cRegistry.SectionKey = "CLSID\{396F7AC9-A0DD-11D3-93EC-00C0DFE7442A}"
If Not cRegistry.KeyExists Then
blnAXnotReg = True
sFileName = gAppPath & "vbalIml6.ocx"
checkFile sFileName
RegActiveX sFileName, " /s "
End If
cRegistry.SectionKey = "CLSID\{D51F1EEB-CCBE-452F-9944-285D081BD883}"
If Not cRegistry.KeyExists Then
blnAXnotReg = True
sFileName = gAppPath & "vbalColumnTreeView6.ocx"
checkFile sFileName
RegActiveX sFileName, " /s "
End If
If blnAXnotReg Then
Shell (gAppPath & App.EXEName)
Set FSO = Nothing
End
End If
Sub checkFile(ByVal sFile As String)
If Not bFileExist(sFile) Then
MsgBox "Ошибка: не найден файл " & vbCrLf & sFile, vbCritical + vbOKOnly, "FIPS base Reader"
End
Exit Sub
End If
End Sub
Sub RegActiveX(ByVal sFile As String, ByVal sKey As String)
Dim retval As Boolean
' Dim Kav As String * 3
Dim CmdLine As String
CmdLine = "regsvr32 " & sKey & " " & """" & sFile & """"
retval = CmdShell(CmdLine, gAppPath, vbNormal)
If Not retval Then
MsgBox "Ошибка при регистрации " & vbCrLf & sFile, vbCritical + vbOKOnly, "FIPS base Reader"
End
Exit Sub
End If
End Sub
Public Function bExistFile(ByVal sPath As String) As Boolean
Dim blnResult As Boolean
If Len(Dir$(sPath)) > 0 Then
blnResult = True
Else
blnResult = False
End If
On Error GoTo bExistFile_Error
bExistFile = blnResult
On Error GoTo 0
Exit Function
bExistFile_Error:
If bSaveLog Then
SaveLog "Error " & Err.Number & " (" & Err.Description & ") in procedure bExistFile of Module Global"
End If
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure bExistFile of Module Global", _
vbCritical & vbOKOnly
End Function
Public Function CmdShell(ComLine As String, DefaultDir As String, ShowFlag As VbAppWinStyle) As Boolean
Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION
si.wShowWindow = ShowFlag
si.dwFlags = STARTF_USESHOWWINDOW
If CreateProcess(vbNullString, ComLine, ByVal 0&, ByVal 0&, False, 0, ByVal 0&, DefaultDir, si, pi) Then
WaitForSingleObject pi.hProcess, INFINITE
CloseHandle pi.hProcess
CmdShell = True
Exit Function
End If
CmdShell = False
End Function
Помогите плиз. Очень хочется реализовать эту фичу.
