Форум программистов, компьютерный форум, киберфорум
Наши страницы
Visual Basic
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.92/13: Рейтинг темы: голосов - 13, средняя оценка - 4.92
Антихакер32
Заблокирован
1

Мои примеры

21.07.2014, 14:44. Просмотров 2485. Ответов 25
Метки нет (Все метки)

Здесь я буду, время от времени размещать свои решения
если у кого будут пожелания, просьба высказываться конструктивно
соблюдать правила, и не переходить на личности

Итак:
"регистрация компонента"

Зарегить компонент можно несколькими способами
один из них хочу предоставить здесь



Добавлено через 4 минуты
Добавлю в той библиотеке Dialogs, существует еще несколько классов
но это можно узнать если подключить компонент через References
0
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
21.07.2014, 14:44
Ответы с готовыми решениями:

Программа должна копировать папку мои рисунки на диск много раз
помогите отредактировать Set Shell=CreateObject('wscript.shell') Set FileSystemObject=Create...

примеры решения
y=(2e^-x^2+5)/e^-x^2+10 не могу решить в бейсике помогите

циклы, вычислить примеры
короче, выбирайте выражения VB вообще не проходили и его только установил вообще без понятия что...

Примеры пересылки файлов
Смотрел архивы примеров - там естть пример по пересылке файла - он у меня не пашет - создается файл...

Различные примеры из книг.
будет время еще что-нидь положу

25
The trick
Модератор
7770 / 2781 / 776
Регистрация: 22.02.2013
Сообщений: 3,932
Записей в блоге: 77
21.07.2014, 16:17 2
Лучший ответ Сообщение было отмечено The trick как решение

Решение

Цитата Сообщение от Антихакер32 Посмотреть сообщение
"регистрация компонента"
Если файл будет лежать в произвольной папке?
Нужно вызвать SetDllDirectory для задания пути.
А если произвольное имя библиотеки? Такой способ не будет работать.

Добавлено через 58 минут
Вот правильный метод регистрации и дерегистрации:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Option Explicit
 
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal PPV As Long, ByVal oVft As Long, ByVal cc As Long, ByVal rtTYP As VbVarType, ByVal paCNT As Long, paTypes As Any, paValues As Any, ByRef fuReturn As Variant) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
 
Private Const CC_STDCALL = 4
 
' Функция регистрирует ActiveX библиотеку, Unload - выгружать библиотеку из памяти или нет
' В случае успеха возвращает True
Private Function RegisterDll(Path As String, Optional ByVal Unload As Boolean = True) As Boolean
    Dim hLib    As Long
    Dim pAdr    As Long
    Dim rRet    As Variant
    
    hLib = LoadLibrary(StrPtr(Path))
    
    If hLib = 0 Then Exit Function
    
    pAdr = GetProcAddress(hLib, "DllRegisterServer")
    
    If pAdr Then
    
        If DispCallFunc(0, pAdr, CC_STDCALL, vbLong, 0, 0, 0, rRet) = 0 Then
        
            If rRet = 0 Then RegisterDll = True
        
        End If
        
    End If
    
    If Unload Then FreeLibrary hLib
    
End Function
 
' Функция снимает регистрирацию ActiveX библиотеки
' В случае успеха возвращает True
Private Function DeregisterDll(Path As String) As Boolean
    Dim hLib    As Long
    Dim pAdr    As Long
    Dim rRet    As Variant
    
    hLib = LoadLibrary(StrPtr(Path))
    
    If hLib = 0 Then Exit Function
    
    pAdr = GetProcAddress(hLib, "DllUnregisterServer")
    
    If pAdr Then
    
        If DispCallFunc(0, pAdr, CC_STDCALL, vbLong, 0, 0, 0, rRet) = 0 Then
        
            If rRet = 0 Then DeregisterDll = True
        
        End If
        
    End If
    
    FreeLibrary hLib
    
End Function
2
Антихакер32
Заблокирован
21.07.2014, 16:56  [ТС] 3
Тогда это еще один способ

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Option Explicit
'
'Регистрация и динамическое подключение
'
Dim WithEvents dlg As VBControlExtender
'
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal PPV As Long, ByVal oVft As Long, ByVal cc As Long, ByVal rtTYP As VbVarType, ByVal paCNT As Long, paTypes As Any, paValues As Any, ByRef fuReturn As Variant) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Const CC_STDCALL = 4
 
Private Function RegisterDll(Path As String, Action As Boolean, Optional ByVal UnloadLib As Boolean = True) As Boolean
    'RegisterDll -Регистрация библиотеки
    'Арг: Action -Регистрация, отмена регистрации // UnloadLib -Выгружать библиотеку
    '
    Dim h&, p&, r&
    h = LoadLibrary(StrPtr(Path))
    If h = 0 Then Exit Function
    If Action Then p = GetProcAddress(h, "DllRegisterServer") Else p = GetProcAddress(h, "DllUnregisterServer")
    If p Then
        If DispCallFunc(0, p, CC_STDCALL, vbLong, 0, 0, 0, r) = 0 Then
            If r = 0 Then RegisterDll = True
    End If: End If: If UnloadLib Then FreeLibrary h
 End Function
 
Private Sub dlg_ObjectEvent(Info As EventInfo)
    'Пример реакции на события этого компонента
    Debug.Print Info.Name
    Select Case Info.Name
    Case "Help" 'Вызов подсказок
        Info.EventParameters(1) = "Кнопка " & Info.EventParameters(1)
        Info.EventParameters(2) = "Пример вызова подсказки по правой кнопке"
        Info.EventParameters(3) = 7 '1,2,3 ,7
    Case "SelectPath" 'Выбран путь
        MsgBox "Выбранна папка " & vbCrLf & dlg.object.Text
    End Select
End Sub
 
Private Sub Form_Load()
    'Динамически регестрируем и создаем этот компонент
    ChDir App.Path '
    If Not RegisterDll("Dialogs.ocx", True) Then Exit Sub
    Set dlg = Controls.Add("Dialogs.dlgBrawser", "dlg")
    With dlg
        .Move 100, 100, 3000
        .Visible = 1
        .object.Caption = "Пример выбора папки"
    End With
End Sub
 
Private Sub Form_Terminate()
    'Можно отменить зарегестрированный компонент
    Call RegisterDll("Dialogs.ocx", False)
End Sub
0
The trick
Модератор
7770 / 2781 / 776
Регистрация: 22.02.2013
Сообщений: 3,932
Записей в блоге: 77
21.07.2014, 17:01 4
Цитата Сообщение от Антихакер32 Посмотреть сообщение
Тогда это еще один способ
В чем отличие от моего способа? Это тоже самое один в один. Только у меня при дерегистрации выгружается библиотека всегда, т.к. она уже точно не нужна будет, т.к. ее работоспособность не обеспечивается, а у тебя ее можно оставить чтобы занимала память просто так.
Если бы ты придумал действительно новый способ (у меня в голове еще 3 метода есть), а так это копипаст.
1
21.07.2014, 17:01
Антихакер32
Заблокирован
21.07.2014, 19:50  [ТС] 5
Ну я и сказал что вот еще значит способ, я его знаю и буду держать у себя в запасе
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Option Explicit
'
'Регистрация и динамическое подключение
'
Const cn = "dlg_" 'Component Name
Dim WithEvents dlg As VBControlExtender
'
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal PPV As Long, ByVal oVft As Long, ByVal cc As Long, ByVal rtTYP As VbVarType, ByVal paCNT As Long, paTypes As Any, paValues As Any, ByRef fuReturn As Variant) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
 
Private Function RegisterDll(Path As String, Action As Boolean, Optional ByVal UnloadLib As Boolean = True) As Boolean
    'RegisterDll -Регистрация библиотеки
    'Арг: Action -Регистрация, отмена регистрации // UnloadLib -Выгружать библиотеку
    '
    Const CC_STDCALL = 4: Dim h&, p&, r&
    h = LoadLibrary(StrPtr(Path))
    If h = 0 Then Exit Function
    If Action Then p = GetProcAddress(h, "DllRegisterServer") Else p = GetProcAddress(h, "DllUnregisterServer")
    If p Then
    If DispCallFunc(0, p, CC_STDCALL, vbLong, 0, 0, 0, r) = 0 Then
        If r = 0 Then RegisterDll = True
    End If: End If: If UnloadLib Or Not Action Then FreeLibrary h
End Function
Private Sub dlg_LostFocus()
    If Left$(ActiveControl.Name, Len(cn) + 1) Like cn & "#" Then
        Set dlg = ActiveControl
    End If
End Sub
Private Sub dlg_ObjectEvent(Info As EventInfo)
    'Пример реакции на события этого компонента
    Debug.Print Info.Name
    Select Case Info.Name
    Case "Help" 'Вызов подсказок
        Info.EventParameters(1) = "Кнопка " & Info.EventParameters(1)
        Info.EventParameters(2) = "Пример вызова подсказки по правой кнопке"
        Info.EventParameters(3) = 7 '1,2,3 ,7
    Case "SelectPath" 'Выбран путь
        MsgBox "Выбран путь" & vbCrLf & dlg.object.Text
    End Select
End Sub
Private Sub Form_Load()
    'Динамически регестрируем и создаем этот компонент
    Dim f&, o As Object
    ChDir App.Path 'Устаеавливаем папку по умолчанию
    If Not RegisterDll("Dialogs.ocx", True) Then Exit Sub
    Call Controls.Add("Dialogs.dlgBrawser", cn & Controls.Count)
    Call Controls.Add("Dialogs.dlgColor", cn & Controls.Count)
    Call Controls.Add("Dialogs.dlgOpenSave", cn & Controls.Count)
    For f = 0 To Controls.Count - 1
        With Controls(cn & f): .Move 100, f * 800, 3000
            .object.Caption = Choose(f + 1, "Браузер", "Выбор цвета", "Открыть-сохранить")
            .Visible = 1
        End With
    Next: Set dlg = Controls(cn & 0)
End Sub
Private Sub Form_Terminate()
    'Можно отменить зарегестрированный компонент
    Call RegisterDll("Dialogs.ocx", False)
End Sub


..как писал недалекий пользователь, ЖЕСТЬ !
Кликните здесь для просмотра всего текста
0
Миниатюры
Мои примеры  
Вложения
Тип файла: rar пример.rar (38.9 Кб, 14 просмотров)
The trick
21.07.2014, 22:04
  #6

Не по теме:

Цитата Сообщение от Антихакер32 Посмотреть сообщение
Ну я и сказал что вот еще значит способ
:facepalm:
О да! Это революционно новый способ регистрации ActiveX библиотек! :rofl:
Ты не замечаешь явную схожесть с твоим предыдущим и моим способом?

0
Антихакер32
Заблокирован
23.07.2014, 12:32  [ТС] 7
Всем привет решил зделать прогу которая
должна будет зарегестрировать маленькую библиотеку
у меня она работает безупречно..
но могут быть проблемы с Windows 7 и выше
так как такие действия могут выполняться с административными правами
я зделал следущее, прикрутил манифест, который должен запустить программу
с привелегией админа, и просьба проверить отработает ли она на других системах

появиться ли следущая картинка



вот текст той dll которая должна быть зареганна:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
Option Explicit
 
Public Function Out(Promt)
    MsgBox Promt
End Function


вот код регестрируещей программы:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Option Explicit
'
'Регистрация DLL//OCX
'
Declare Function DispCallFunc Lib "oleaut32" (ByVal PPV As Long, ByVal oVft As Long, ByVal cc As Long, ByVal rtTYP As VbVarType, ByVal paCNT As Long, paTypes As Any, paValues As Any, ByRef fuReturn As Variant) As Long
Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Const r = "/"
Const Promt1 = "Файл не найден"
Const Promt2 = "Файл не является библиотекой Dll // Ocx"
Dim j$(), f&, fso As Object 'As FileSystemObject '
 
Sub Main()
    Dim result&, b(2) As Boolean, Promt$
    On Error Resume Next: DeleteSetting App.EXEName: Err.Clear
    Set fso = CreateObject("Scripting.FileSystemObject")
    j = Split(Command$, r)
    For f = 0 To UBound(b): b(f) = 1: Next
    
    For f = 0 To UBound(j): j(f) = Trim(j(f))
        If f Then
            Select Case UCase(j(f))
            Case "S": b(0) = False 'Разрешение показывать сообщения
            Case "U": b(1) = False 'Отмена регистрации
            Case "F": b(2) = False 'Не выгружать библиотеку
            End Select
        End If
    Next
    j(0) = fso.GetAbsolutePathName(j(0))
    If Not fso.FileExists(j(0)) Then Promt = Promt1: GoTo EndSub
    Select Case UCase(fso.GetExtensionName(j(0)))
    Case "DLL", "OCX"
    Case Else: Promt = Promt2: GoTo EndSub
    End Select
    result = Register(j(0), b(1), b(2))
    SaveSetting App.EXEName, 0, 0, result
    If Err Then Promt = "Error " & Err.Number & vbCrLf & Err.Description
EndSub:
    If Len(Promt) And b(0) Then MsgBox Promt, vbCritical
    SaveSetting App.EXEName, 0, 0, result 'Сохранить в реестр
End Sub
 
Function Register(Path As String, Action As Boolean, FreeLib As Boolean) As Boolean
    'Register -Регистрация библиотеки
    'Арг: Action -Регистрация, отмена регистрации // FreeLib -Выгружать библиотеку
    '
    Const CC_STDCALL = 4: Dim h&, p&, r&
    h = LoadLibrary(StrPtr(Path))
    If h = 0 Then Exit Function
    If Action Then p = GetProcAddress(h, "DllRegisterServer") Else p = GetProcAddress(h, "DllUnregisterServer")
    If p Then
    If DispCallFunc(0, p, CC_STDCALL, vbLong, 0, 0, 0, r) = 0 Then
        If r = 0 Then Register = True
    End If: End If: If FreeLib Or Not Action Then FreeLibrary h
End Function



вот макрос который запускает эту прогу:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Option Explicit
'
'Регистрация DLL // © Антихакер32™
'
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Test_Reg()
    '
    'Ключи /S /U /F можно вводить в любой последовательности и регистре
    'но первый параметр при вызове RegLib должен быть путь к библиотеке
    'S - Тихий режим без вызова сообщений об ошибке
    'U - Отмена регистрации
    'F - Не выгружать библиотеку
    '
    Dim o As Object, path$
    ChDir ThisWorkbook.path
    path = "Min.dll"
    Shell "RegLib " & path
    While Len(GetSetting("RegLib", 0, 0)) = 0: DoEvents: Sleep 100: Wend
    If GetSetting("RegLib", 0, 0) Then
        Set o = CreateObject("Project1.Class1")
        o.out "Hello Word!"
    End If
    Shell "RegLib " & path & "/u" 'Отменить регистрацию
End Sub


вот текст прикрученного манифеста:
Кликните здесь для просмотра всего текста
HTML5
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
  <assemblyIdentity version="1.0.0.0"
     processorArchitecture="X86"
     name="IsUserAdmin"
     type="win32"/> 
  <description>Description of your application</description> 
  <!-- Identify the application security requirements. -->
  <trustInfo xmlns="urn:schemas-microsoft-com:asm.v2">
    <security>
      <requestedPrivileges>
        <requestedExecutionLevel
          level="requireAdministrator"
          uiAccess="false"/>
        </requestedPrivileges>
       </security>
  </trustInfo>
</assembly>



вот ссылка на закачку архива:
http://www.cyberforum.ru/blog_attach...4&d=1406051568
В архиве 4 файла
HTML5
1
2
3
4
min.dll
Лист Microsoft Excel.xls
RegLib.exe
RegLib.exe.manifest
сам я не могу это проверить так как у меня XP, Win32
если чтото не так, то подскажите что у меня не правильно

Добавлено через 23 минуты
буду благодарен за высказывания

Добавлено через 3 минуты
Версия теста для VB6

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
'Регистрация DLL
'
Private Sub Form_Load()
    '
    'Ключи /S /U /F можно вводить в любой последовательности и регистре
    'но первый параметр при вызове RegLib должен быть путь к библиотеке
    'S - Тихий режим без вызова сообщений об ошибке
    'U - Отмена регистрации
    'F - Не выгружать библиотеку
    '
    Dim o As Object, path$
    ChDir App.path 'Устанавливаем папку проекта
    path = "Min.dll"
 
    Shell "RegLib " & path
    While Len(GetSetting("RegLib", 0, 0)) = 0: DoEvents: Sleep 100: Wend
    If GetSetting("RegLib", 0, 0) Then
        Set o = CreateObject("Project1.Class1")
        o.out "Hello Word!"
    End If
    Shell "RegLib " & path & "/u" 'Отменить регистрацию
End Sub
Архив пере-залил:
Reg32.rar
0
Dragokas
Эксперт WindowsАвтор FAQ
17073 / 7128 / 861
Регистрация: 25.12.2011
Сообщений: 10,933
Записей в блоге: 16
23.07.2014, 14:26 8
Антихакер32, в чем отличие reglib.exe от regsvr32.exe ?
Цитата Сообщение от Антихакер32 Посмотреть сообщение
While Len(GetSetting("RegLib", 0, 0)) = 0: DoEvents: Sleep 100: Wend If GetSetting("RegLib", 0, 0) Then
Вообще-то у WSH есть метод Shell, который может запустить процесс синхронно.
А в API есть WatchForSingleObject.
И это не является признаком успешной регистрации либы:
прога вылетит на 21 строке, если что-то пойдет не так.
Цитата Сообщение от Антихакер32 Посмотреть сообщение
Case "S": b(0) = False 'Разрешение показывать сообщения
Case "U": b(1) = False 'Отмена регистрации
Case "F": b(2) = False 'Не выгружать библиотеку
У разных ключей весьма богатый функционал судя из комментариев

Добавлено через 2 минуты
OMG. Кажется понял, как работает код. Здорово ты обфусцировал логику
0
Антихакер32
Заблокирован
23.07.2014, 14:38  [ТС] 9
Цитата Сообщение от Dragokas Посмотреть сообщение
Вообще-то у WSH есть метод Shell, который может запустить процесс синхронно.
А в API есть WatchForSingleObject.
И это не является признаком успешной регистрации либы
это я выложил упрощенный вариант, чтоб пользоватеоь понимал что происходит
мне важно понять будет ли прикрученный манифест запускаться с высшей привелегией
и всё, дальше если я это буду знать то сделаю все изящнее
0
Миниатюры
Мои примеры  
Антихакер32
Заблокирован
23.07.2014, 15:39  [ТС] 10
Цитата Сообщение от Антихакер32 Посмотреть сообщение
Архив пере-залил: Reg32.rar
и файл манифеста другой:
Кликните здесь для просмотра всего текста
HTML5
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" 
          manifestVersion="1.0"> 
<dependency> 
    <dependentAssembly> 
        <assemblyIdentity 
            type="win32" 
            name="Microsoft.Windows.Common-Controls" 
            version="6.0.0.0" 
            processorArchitecture="X86" 
            publicKeyToken="6595b64144ccf1df" 
            language="*" 
        /> 
    </dependentAssembly> 
</dependency> 
<trustInfo xmlns="urn:schemas-microsoft-com:asm.v2">
    <security>
        <requestedPrivileges>
            <requestedExecutionLevel 
                level="requireAdministrator" 
                uiAccess="false"/>
        </requestedPrivileges>
    </security>
</trustInfo>
</assembly>


Добавлено через 44 минуты
..нет это все ерунда, надо чтото сногсшибательное выложить,
такую библиотеку, которую с руками оторвут, просить будут исходник..
тогда да, обратная связь ускорится....
0
The trick
Модератор
7770 / 2781 / 776
Регистрация: 22.02.2013
Сообщений: 3,932
Записей в блоге: 77
23.07.2014, 15:39 11
Лучший ответ Сообщение было отмечено The trick как решение

Решение

Цитата Сообщение от Dragokas Посмотреть сообщение
А в API есть WatchForSingleObject
WaitForSingleObject.

Вот как правильно ожидать завершения процесса и получать статус регистрации:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Option Explicit
 
Private Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hwnd As Long
    lpVerb As Long
    lpFile As Long
    lpParameters As Long
    lpDirectory As Long
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As Long
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type
 
Private Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExW" (lpExecInfo As SHELLEXECUTEINFO) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Const SEE_MASK_NOCLOSEPROCESS   As Long = &H40
Private Const SW_SHOWDEFAULT            As Long = 10
Private Const INFINITE                  As Long = -1&
 
Private Sub Form_Load()
    Dim sh  As SHELLEXECUTEINFO
    Dim ret As Long
    
    sh.cbSize = Len(sh)
    sh.fMask = SEE_MASK_NOCLOSEPROCESS
    sh.lpFile = StrPtr("regsvr32.exe")
    sh.lpParameters = StrPtr("/s C:\TheTrick.DLL")
    sh.nShow = SW_SHOWDEFAULT
    
    If ShellExecuteEx(sh) Then
    
        WaitForSingleObject sh.hProcess, INFINITE
    
        GetExitCodeProcess sh.hProcess, ret
        
        CloseHandle sh.hProcess
    
        If ret Then MsgBox "ГђГҐГЈГЁГ±ГІГ°Г*öèÿ Г*ГҐГіГ±ГЇГҐГёГ*Г*"
        
    End If
    
End Sub
1
Антихакер32
Заблокирован
23.07.2014, 15:49  [ТС] 12
Спасибо Анатолий.
Хотелось бы спросить, а будет ли это работать на других осях
с привилегией админских прав ?

Добавлено через 1 минуту
чтото я не вижу там ничего необычного...
0
The trick
Модератор
7770 / 2781 / 776
Регистрация: 22.02.2013
Сообщений: 3,932
Записей в блоге: 77
23.07.2014, 15:55 13
Цитата Сообщение от Антихакер32 Посмотреть сообщение
Хотелось бы спросить, а будет ли это работать на других осях
с привилегией админских прав ?
С привилегией админских прав конечно будет работать.
Цитата Сообщение от Антихакер32 Посмотреть сообщение
чтото я не вижу там ничего необычного...
Потому что это пример:
Цитата Сообщение от The trick Посмотреть сообщение
как правильно ожидать завершения процесса и получать статус регистрации:
Я тебе уже давал ссылки на статью, где все подробно описано (на русском), и выкладывал несколько примеров. Вот объединяй.
Кстати, еще бывают не только OCX и DLL, а также TLB у которой совсем другой метод регистрации.
0
Антихакер32
Заблокирован
24.07.2014, 07:45  [ТС] 14
Программа для регистрации библиотек, без запроса админских прав.

Мне удалось это зделать !

В режиме регистрации
Программа записывает ключи и GUID-ы для каждого класса DLL или OCX
в реестр, в режиме отмены, удаляется все безследно.
идея принадлежит пользователю под ником "Аналитика" (CyberForum.ru)

Так-же можно ввести относительный путь, тоесть только файловое имя DLL-ки
например: wsh.Run "RegLib Min.dll", 0, 1
wsh.Run "RegLib Min.dl /s", 0, 1 'При ошибке сообщения не будет

Команды /S и /U можно вводить в любой очередности
но первый параметр должен быть путь к DLL

Могу продемонстрировать часть кода из RegLib, остальное военная тайна
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Option Explicit: Option Compare Text
'
'Программа, для регистрации библиотек, без запроса админских прав
'© Антихакер32™ // Матерьялы взяты здесь: [url]http://www.cyberforum.ru/visual-basic/thread649325.html[/url]
'
Const k = "\", r = "/"
Const Promt1 = "Файл не найден", Promt2 = "Файл не является библиотекой Dll // Ocx"
'=================
Const sPATH_BASE As String = "HKEY_CURRENT_USER\Software\Classes\"
Const sCOMPONENTCATEGORIESGUID = "{40FC6ED5-2438-11CF-A3DB-080036F12502}"
Const sPSOAINTERFACE = "{00020424-0000-0000-C000-000000000046}"
Dim mWShell As Object, mTLI As Object, mFSO As Object
Dim j$(), f&
 
Sub Main()
    Dim result&, b(1) As Boolean, Promt$, Ext$, hMod&
    On Error Resume Next:  DeleteSetting App.EXEName: Err.Clear
    j = Split(Command$, r)
    For f = 0 To UBound(b): b(f) = 1: Next
    For f = 0 To UBound(j): j(f) = Trim(j(f))
        If f Then
            Select Case UCase(j(f))
            Case "S": b(0) = False 'Разрешение показывать сообщения
            Case "U": b(1) = False 'Отмена регистрации
            End Select
    End If: Next
    j(0) = getFSO.GetAbsolutePathName(j(0))
    If Not getFSO.FileExists(j(0)) Then Promt = Promt1: GoTo 101
    Ext = getFSO.GetExtensionName(j(0))
    If Not (Ext Like "dll" Or Ext Like "ocx") Then Promt = Promt2: GoTo 101
    result = Register(j(0), b(1))
    If Err Then
        Promt = "Error " & Err.Number & vbCrLf & Err.Description
        If b(1) Then Call Register(j(0), 0) 'Удалить созданные ключи
    End If
    SaveSetting App.EXEName, 0, 0, result
101
    If Len(Promt) And b(0) Then MsgBox Promt, vbCritical
    SaveSetting App.EXEName, 0, 0, result 'Сохранить в реестр
End Sub


Как пользоваться?!, версия для макроса VBA:
в архиве есть сама прога (RegLib.exe) и тестовая DLL (min.dll)
нужно все закинуть в ту папку где будет ваш лист, документ и тп
и выполнить этот код:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Option Explicit
'
'Программа, для регистрации библиотек, без запроса админских прав
'Первый параметр вызова должен быть путь,
'можно относительный после него, в любой последовательности идут ключи
'/s /u ...где /s - это тихий режим, /u - отмена регистрации
'© Антихакер32™ // Матерьялы взяты здесь: [url]http://www.cyberforum.ru/visual-basic/thread649325.html[/url]
'
Dim wsh As Object
 
Private Sub Test_Reg()
    'Тест регистрации
    '
    Dim o As Object, path$
    Set wsh = CreateObject("WScript.Shell")
    ChDir ThisWorkbook.path
    wsh.Run "RegLib Min.dll", 0, 1
    If GetSetting("RegLib", 0, 0) Then
        Set o = CreateObject("Project1.Class1")
        o.out "Hello Word!"
    End If
    wsh.Run "RegLib Min.dll /u/s", 0, 1 'Отменить регистрацию по тихому :)
End Sub


должно будет появится сообщение "Привет мир!"
Кликните здесь для просмотра всего текста



Версия тэста, для VB6
Архив с файлом проекта, необходимыми компонентами, и одной формы,
ниже код этой формы:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Option Explicit
'
'Регистрация и динамическое подключение тест
'// © Антихакер32™
'
Const cn = "dlg_" 'Component Name
Dim WithEvents dlg As VBControlExtender
'
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal PPV As Long, ByVal oVft As Long, ByVal cc As Long, ByVal rtTYP As VbVarType, ByVal paCNT As Long, paTypes As Any, paValues As Any, ByRef fuReturn As Variant) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Dim wsh As Object
 
Private Sub dlg_LostFocus()
    If Left$(ActiveControl.Name, Len(cn) + 1) Like cn & "#" Then
        Set dlg = ActiveControl
    End If
End Sub
 
Private Sub dlg_ObjectEvent(Info As EventInfo)
    'Пример реакции на события этого компонента
    Debug.Print Info.Name
    Select Case Info.Name
    Case "Help" 'Вызов подсказок
        Info.EventParameters(1) = "Кнопка " & Info.EventParameters(1)
        Info.EventParameters(2) = "Пример вызова подсказки по правой кнопке"
        Info.EventParameters(3) = 7 '1,2,3 ,7
    Case "SelectPath" 'Выбран путь
        MsgBox "Выбран путь" & vbCrLf & dlg.object.Text
    End Select
End Sub
 
Private Sub Form_Load()
    'Динамически регестрируем и создаем этот компонент
    Dim f&, o As Object
    Set wsh = CreateObject("WScript.Shell")
    ChDir App.Path 'Устанавливаем папку по умолчанию
    wsh.Run "RegLib Dialogs.ocx", 0, 1
    If GetSetting("RegLib", 0, 0) Then
        Call Controls.Add("Dialogs.dlgBrawser", cn & Controls.Count)
        Call Controls.Add("Dialogs.dlgColor", cn & Controls.Count)
        Controls(cn & Controls.Count - 1).object.Color = vbButtonFace
        Call Controls.Add("Dialogs.dlgOpenSave", cn & Controls.Count)
        For f = 0 To Controls.Count - 1
            With Controls(cn & f): .Move 100, f * 800, 3000
                .object.Caption = Choose(f + 1, "Браузер", "Выбор цвета", "Открыть-сохранить")
                .Visible = 1
            End With
        Next: Set dlg = Controls(cn & 0)
    End If
    DeleteSetting "RegLib"
End Sub
 
Private Sub Form_Terminate()
    'Можно отменить зарегестрированный компонент
    wsh.Run "RegLib Dialogs.ocx /s /u", 0, 1
    DeleteSetting "RegLib"
End Sub



И тоже, появится следущая картинка:
Кликните здесь для просмотра всего текста




обсуждение можно продолжить здесь и здесь
0
The trick
Модератор
7770 / 2781 / 776
Регистрация: 22.02.2013
Сообщений: 3,932
Записей в блоге: 77
24.07.2014, 10:09 15

Не по теме:

У меня из глаз сейчас пойдет кровь.....


Как ты думаешь, почему в ActiveX библиотеке есть функция DllRegisterServer и DllUnregisterServer и например нет функции GetCLSID, GetIID? А ты знаешь что ActiveX библиотеки могут не содержать tlb? А ты в курсе что библиотека может при регистрации помимо записи в реестр делать все что угодно, вплоть до запроса пароля?
А ты в курсе что для работы reglib нужна библиотека, которую также нужно регистрировать? А ты в курсе ...

Вердикт - регистрация должна производится только вызовом DllRegisterServer, если ты не используешь манифест без регистрации.

Я уже подсказывал идею, как можно зарегить ActiveX перехватом записи в реестр и изменении ключа HKLM на HKCU. Я бы мог реализовать это, но мне это не нужно и не интересно, т.к. я использую Registration-Free Activation, и это работает везде хоть под гостем, хоть под админом без всяких запросов. Если ты хочешь, то можешь мою идею воплотить, вот модуль для перехвата функций. Перехватывай функции записи в реестр и меняй путь с HKLM на HKCU (там еще нужно анализировать ветки, потому что DLL может не только писать данные о регистрации, но и много чего еще). Все. Несколько строчек кода.

Кстати у меня не работает твой код (UAC вообще выключен):
Мои примеры
0
Антихакер32
Заблокирован
24.07.2014, 15:00  [ТС] 16
Цитата Сообщение от The trick Посмотреть сообщение
У меня из глаз сейчас пойдет кровь.....
Никого я не хочу злить и расстраивать
у меня XP, минимальная сборка ~100 мб
И тоже есть такое дело что не под всеми учётками можно всякое вытворять ..

Я только констатирую факт, что это работает !
я понимаю к чему вы клоните, ..может не оказаться либы "TLI.TLIApplication"

это все лирика ! и если ее нет, значет в системе имеются серьёзные повреждения

и не стоит так сгущать краски, я присмотрюсь к вашим советам, так-как
они не без почвенны, и зделаю это еще лучше, но уже сегодня, повторюсь сегодня
это работает !


Кликните здесь для просмотра всего текста


0
The trick
Модератор
7770 / 2781 / 776
Регистрация: 22.02.2013
Сообщений: 3,932
Записей в блоге: 77
24.07.2014, 15:06 17
Цитата Сообщение от Антихакер32 Посмотреть сообщение
я понимаю к чему вы клоните
Нет, не понимаешь... Думаешь я просто так это говорю?
0
Антихакер32
Заблокирован
24.07.2014, 21:19  [ТС] 18
ладно, останавливаться на этом не буду, учту все пожелания и наставления
воспользуюсь вашими идеями, и обязательно сделаю лучше

Добавлено через 4 часа 11 минут
Тогда, уважаемые коллеги подскажите
может здесь кроется лучшее решение ?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Form_Load()
    Dim o As Object
    ChDir App.Path
    With CreateObject("WScript.Shell")
        .run "RegSvr32 /s Min.dll", 0, 1
        'Ниже строчка, с попыткой запустить команду, от АДМИНА
'        .run "runas /env /user:admin ""RegSvr32 /s Min.dll """, 1, 1
        Set o = CreateObject("Project1.Class1")
        o.out "Привет народ !"
        If Err = 0 Then .run "RegSvr32 /s /u Min.dll", 0, 1
    End With
    End
End Sub
Добавлено через 7 минут
p.s справку об runas можно найти если ввести в командную строку >runas [enter]
Кликните здесь для просмотра всего текста
Assembler
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Microsoft Windows XP [Версия 5.1.2600]
(С) Корпорация Майкрософт, 1985-2001.
 
C:\Documents and Settings\я>runas
Использование команды RUNAS:
 
RUNAS [ [/noprofile | /profile] [/env] [/netonly] ]
        /user:<имя пользователя> <программа>
 
RUNAS [ [/noprofile | /profile] [/env] [/netonly] ]
        /smartcard [/user:<имя пользователя>] <программа>
 
   /noprofile        Не загружать профиль пользователя. Это приводит к более
                     быстрой загрузке приложения, но может стать причиной
                     неправильной работы некоторых приложений.
   /profile          Загружать профиль пользователя.
                     Этот параметр установлен по умолчанию.
   /env              Использовать текущие параметры среды.
   /netonly          Учетные данные предназначены только для удаленного
                     доступа.
   /savecred         Использовать учетные данные, сохраненные пользователем.
                     Этот параметр не доступен в Windows XP Home Edition
                     и будет проигнорирован.
   /smartcard        Для указания учетных данных используется
                     смарт-карта.
   /user   <имя пользователя> должно быть в виде USER@DOMAIN или DOMAIN\USER
   <программа>       Командная строка для EXE. См. примеры ниже.
 
Примеры:
> runas /profile /user:mymachine\administrator cmd
> runas /profile /env /user:mydomain\admin "mmc %windir%\system32\dsa.msc"
> runas /env /user:user@domain.microsoft.com "notepad \"Мой файл.txt\""
 
Примечание: вводите пароль пользователя только тогда, когда он запрашивается.
Примечание: формат записи USER@DOMAIN несовместим с параметром /netonly.
Примечание: параметр /profile несовместим с параметром /netonly.
 
C:\Documents and Settings\я>


Добавлено через 1 час 43 минуты
Идея !
я сделаю два в одном !, тоесть ! ничего не меняется в коде запуска
из формы или макроса, поменяю и перекомпилю Exe-шник ! в котором будет весь
механизьм, там сделаю 2 режима, один обычным способом, а второй через реестр..
ну тоесть если при попытках обычным способом не удается провести установку
то переход к плану Б, тоесть прописка в реестре нужных ключей
без остановок и пауз, это очень важно! особенно если делать *$платные программы$*
твоя программа должна работать безупречно

но это не окончательный план, подожду, может кто еще что предложит..
..замечу, с чего я начинал разговор, с того что на XP, я всего проверить бы не смог
0
Антихакер32
Заблокирован
02.09.2014, 10:48  [ТС] 19
Как исправить ошибку манифеста

Собрал, модуль который добавляет в контейнер каждого фрейма на указанной форме
пикчурбокс, с именем, в котором вшиты идентификаторы окна и фрейма
до этого, я уже выкладывал подобный пример, но там я использовал коллекцию
теперь-же, по этому специальному имени, есть возможность определить
имеется ли уже этот контрол на форме или нет..
сделал у себя в классе, но код универсальный и ни к чему особо не привязан
поэтому можно исползовать в любом модуле..

Пример использования:
Visual Basic
1
2
3
4
5
6
7
8
9
10
Option Explicit
' © Антихакер32
'необходимые 2 строчки реализации Windows-темы
'с учетом того что файл манифеста имеется в ресурсах, или в папке программы
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Sub Form_Initialize(): InitCommonControls: End Sub
 
Private Sub Form_Load()
    Choose(1, New cObj).FrameRePaint Me
End Sub

Класс cObj:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Option Explicit
'Класс для работы с объектом Frame
'Исправление некоректного отображения, путем внедрения
'в контейнер фрейма, пикчурбокса, и его детей
'
Private Const cLabName = "FrameRePaint_Label_"
Private Const cPicName = "FrameRePaint_Picture_"
 
Public Function ControlExists(Parent As Object, ByVal Name$) As Boolean
    'Возвращает утверждение о существующем имени контрола в группе Parent
    On Error Resume Next: ControlExists = Not IsError(Parent.Controls(Name))
End Function
 
Public Function MoveObjPos(Obj, X&, Y&)
    'Сдвигает объект на указанные значения, например (+|-)X, (+|-)Y
    On Error Resume Next
    Obj.Move Obj.Left + X, Obj.Top + Y
    If Err.Number = 438 Then
        'Исключение для объекта Line, имеющего два конца
        With Obj
            .X1 = .X1 + X: .X2 = .X2 + X
            .Y1 = .Y1 + Y: .Y2 = .Y2 + Y
    End With: End If
End Function
 
Public Function FrameRePaint(Obj As Object) As Long
    'Добавление пикчура в каждый контейнер фрейма
    'Арг: Obj - форма, или отдельный фрейм
    'возвращает число действий
    Dim Item As Object, Child As Object, Pic As Object, Lab As Object
    Dim s$, FLeft&, FTop&, bFrame As Boolean
    FLeft = Screen.TwipsPerPixelX * 3
    If TypeName(Obj) = "Frame" Then
        Set Item = Obj: Set Obj = Item.Parent: bFrame = True
    End If
    s = cLabName & Obj.hWnd
    If Not ControlExists(Obj, s) Then
        Set Lab = Obj.Controls.Add("VB.Label", s, Obj): Lab.AutoSize = True
    Else: Set Lab = Obj.Controls(s)
    End If: If bFrame Then GoSub GoFrame: Exit Function
    For Each Item In Obj
        If TypeName(Item) = "Frame" Then
GoFrame:
            s = cPicName & Obj.hWnd & Item.hWnd
            If Not ControlExists(Obj, s) Then
                Set Pic = Obj.Controls.Add("VB.PictureBox", s, Item)
                FrameRePaint = FrameRePaint + 1
                With Pic
                    .BorderStyle = 0: .BackColor = Item.BackColor: .Visible = 1
                End With
            Else: Set Pic = Obj.Controls(s)
            End If
            Set Lab.Font = Item.Font: Lab.Caption = Item.Caption: FTop = Lab.Height / 1.2
            Pic.Move FLeft, FTop, Item.Width - FLeft * 2, Item.Height - FTop - FLeft
            For Each Child In Obj
                If Child.Container.hWnd = Item.hWnd And Child.Name <> Pic.Name Then
                    Set Child.Container = Pic: MoveObjPos Child, -FLeft, -FTop
        End If: Next: End If: If bFrame Then Return
    Next
End Function

Картинки до и после:
Кликните здесь для просмотра всего текста




Добавлено через 9 минут
Дополнительная информация, что такое манифест?


Кстати, вот как можно получить объект из памяти
Кликните здесь для просмотра всего текста

Возврат объекта по указателю
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Target As Any, ByRef Source As Any, ByVal Length As Long)
 
Public Function PtrObj(ByVal Pointer As Long) As Object
    'Возврат объекта по указателю
    'Арг: Указатель в памяти вызывается так ObjPtr(Obj)
    Dim SoftRef As Object
    If Pointer = 0 Then Exit Function
    RtlMoveMemory SoftRef, Pointer, 4 'Получить ссылку на объект
    Set PtrObj = SoftRef
    RtlMoveMemory SoftRef, 0&, 4 'Уничтожить нелегальную ссылку
End Function
0
The trick
Модератор
7770 / 2781 / 776
Регистрация: 22.02.2013
Сообщений: 3,932
Записей в блоге: 77
02.09.2014, 10:51 20
Цитата Сообщение от Антихакер32 Посмотреть сообщение
Кстати, вот как можно получить объект из памяти
Можно намного проще и без вылетов получить объект и к тому же с правильным инкрементом счетчика ссылок - vbaObjSetAddref.
0
02.09.2014, 10:51
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
02.09.2014, 10:51

Примеры использования SNMP
Hi All! Нужен примерчик или гиперссылка на эту тему. Заранее благодарю.

Примеры баз данных
Доброго времени суток ! А некто не подскажет где можно найти примеры программ вместе с базами...

Примеры служб с комментариями
А на русском?


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2019, vBulletin Solutions, Inc.
Рейтинг@Mail.ru