Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0702: Prüfen ob COM-Server registriert ist

VB 5/6-Tipp 0702: Prüfen ob COM-Server registriert ist

 von Arne Elster

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA, RtlMoveMemory (CpyMem), FreeLibrary, GetProcAddress, LoadLibraryA (LoadLibrary), LoadTypeLib, QueryPathOfRegTypeLib, VirtualAlloc, VirtualFree, VirtualProtect

Download: Download des Beispielprojektes [4,22 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (COMDLG32.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Standarddialog-Steuerelement "dlg"
' Steuerelement: Schaltfläche "Command1"

Option Explicit

Private Sub Command1_Click()
    dlg.FileName = vbNullString
    dlg.ShowOpen
    
    If dlg.FileName <> vbNullString Then
        Select Case IsRegistered(dlg.FileName)
            Case COMRegQueryResult.COMServerRegistered
                MsgBox "Server registriert!", vbInformation
            Case COMRegQueryResult.COMServerNotRegistered
                MsgBox "Server nicht registriert!", vbExclamation
            Case COMRegQueryResult.COMNoServer
                MsgBox "Kein COM Server oder Datei nicht gefunden!", vbExclamation
        End Select
    End If
End Sub

Private Sub Form_Load()

End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--- Anfang Modul "modIsRegistered" alias modIsRegistered.bas ---

Option Explicit

Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" ( _
    ByVal strLib As String _
) As Long

Private Declare Function FreeLibrary Lib "kernel32" ( _
    ByVal hModule As Long _
) As Long

Private Declare Function GetProcAddress Lib "kernel32" ( _
    ByVal hMod As Long, _
    ByVal strExport As String _
) As Long

Private Declare Function VirtualAlloc Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flAllocType As Long, _
    ByVal flProtect As Long _
) As Long

Private Declare Function VirtualFree Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal dwFreeType As Long _
) As Long

Private Declare Function VirtualProtect Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flNewProtect As Long, _
    lpflOldProtect As Long _
) As Long

Private Declare Function CallWindowProcA Lib "user32" ( _
    ByVal adr As Long, _
    ByVal p1 As Long, _
    ByVal p2 As Long, _
    ByVal p3 As Long, _
    ByVal p4 As Long _
) As Long

Private Declare Function LoadTypeLib Lib "oleaut32" ( _
    ByVal szFile As Long, _
    pptlib As Any _
) As HRESULT

Private Declare Sub CpyMem Lib "kernel32" _
Alias "RtlMoveMemory" ( _
    pDst As Any, _
    pSrc As Any, _
    ByVal dwLen As Long _
)

Private Declare Function QueryPathOfRegTypeLib Lib "oleaut32" ( _
    gd As Uuid, _
    ByVal wVerMajor As Integer, _
    ByVal wVerMinor As Integer, _
    ByVal lcid As Long, _
    ByVal lpbstrPathName As Long _
) As Long

Private Type Uuid
    Data1                   As Long
    Data2                   As Integer
    Data3                   As Integer
    Data4(7)                As Byte
End Type

Private Type IUnknown
    QueryInterface          As Long
    AddRef                  As Long
    Release                 As Long
End Type

Private Type ITypeLib
    IUnk                    As IUnknown
    GetTypeInfoCount        As Long
    GetTypeInfo             As Long
    GetTypeInfoType         As Long
    GetTypeInfoOfGuid       As Long
    GetLibAttr              As Long
    GetTypeComp             As Long
    GetDocumentation        As Long
    IsName                  As Long
    FindName                As Long
    ReleaseTLibAttr         As Long
End Type

Private Type TLIBATTR
    guid                    As Uuid
    lcid                    As Long
    syskind                 As Long
    wMajorVerNum            As Integer
    wMinorVerNum            As Integer
    wLibFlags               As Integer
End Type

Private Type allocated_memory
    address                 As Long
    bytes                   As Long
End Type

Private Enum HRESULT
    S_OK = 0
End Enum

Private Enum VirtualFreeTypes
    MEM_DECOMMIT = &H4000
    MEM_RELEASE = &H8000&
End Enum

Private Enum VirtualAllocTypes
    MEM_COMMIT = &H1000
    MEM_RESERVE = &H2000
    MEM_RESET = &H8000&
    MEM_LARGE_PAGES = &H20000000
    MEM_PHYSICAL = &H100000
    MEM_WRITE_WATCH = &H200000
End Enum

Private Enum VirtualAllocPageFlags
    PAGE_EXECUTE = &H10
    PAGE_EXECUTE_READ = &H20
    PAGE_EXECUTE_READWRITE = &H40
    PAGE_EXECUTE_WRITECOPY = &H80
    PAGE_NOACCESS = &H1
    PAGE_READONLY = &H2
    PAGE_READWRITE = &H4
    PAGE_WRITECOPY = &H8
    PAGE_GUARD = &H100
    PAGE_NOCACHE = &H200
    PAGE_WRITECOMBINE = &H400
End Enum

Public Enum COMRegQueryResult
    COMServerRegistered
    COMServerNotRegistered
    COMNoServer
End Enum

Public Function IsRegistered(ByVal strLib As String) As COMRegQueryResult
    Dim strRegPath  As String
    Dim hMod        As Long

    hMod = LoadLibrary(strLib)

    If hMod <> 0 Then
        If GetProcAddress(hMod, "DllRegisterServer") = 0 Then
            IsRegistered = COMNoServer
        Else
            With GetLibInfo(strLib)
                If QueryPathOfRegTypeLib(.guid, .wMajorVerNum, .wMinorVerNum, _
                                         .lcid, VarPtr(strRegPath)) = S_OK Then

                    If Len(Trim$(strRegPath)) > 0 Then
                        IsRegistered = COMServerRegistered
                    Else
                        IsRegistered = COMServerNotRegistered
                    End If
                Else
                    IsRegistered = COMServerNotRegistered
                End If
            End With
        End If
        
        FreeLibrary hMod
    Else
        IsRegistered = COMNoServer
    End If
End Function

Private Function GetLibInfo(ByVal strLib As String) As TLIBATTR
    Dim oLib        As Long
    Dim pLibAttr    As Long
    Dim tLib        As ITypeLib
    Dim tattr       As TLIBATTR
    
    If LoadTypeLib(StrPtr(strLib), oLib) = S_OK Then
        CpyMem tLib, ByVal GetMem4(oLib), Len(tLib)

        CallStd tLib.GetLibAttr, oLib, VarPtr(pLibAttr)
        If pLibAttr <> 0 Then
            CpyMem tattr, ByVal pLibAttr, Len(tattr)
            CallStd tLib.ReleaseTLibAttr, oLib, pLibAttr
        End If

        CallStd tLib.IUnk.Release, oLib

        GetLibInfo = tattr
    End If
End Function

Private Function GetMem4(ByVal ptr As Long) As Long
    CpyMem GetMem4, ByVal ptr, 4
End Function

Private Function AllocMemory( _
    ByVal bytes As Long, _
    Optional ByVal lpAddr As Long = 0, _
    Optional ByVal PageFlags As VirtualAllocPageFlags = PAGE_READWRITE _
) As allocated_memory

    With AllocMemory
        .address = VirtualAlloc(lpAddr, bytes, MEM_COMMIT, PageFlags)
        .bytes = bytes
    End With
End Function

Private Function FreeMemory(udtMem As allocated_memory) As Boolean
    VirtualFree udtMem.address, udtMem.bytes, MEM_DECOMMIT

    udtMem.address = 0
    udtMem.bytes = 0
End Function

Private Function CallStd(ByVal fnc As Long, ParamArray Params() As Variant) As Long
    Dim udtMem              As allocated_memory
    Dim pASM                As Long
    Dim i                   As Integer

    udtMem = AllocMemory(&HEC00&, , PAGE_EXECUTE_READWRITE)
    If udtMem.address = 0 Then Exit Function
    pASM = udtMem.address

    AddByte pASM, &H58                  ' POP EAX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H50                  ' PUSH EAX

    If UBound(Params) = 0 Then
        If IsArray(Params(0)) Then
            For i = UBound(Params(0)) To 0 Step -1
                AddPush pASM, CLng(Params(0)(i))    ' PUSH dword
            Next
        Else
            For i = UBound(Params) To 0 Step -1
                AddPush pASM, CLng(Params(i))       ' PUSH dword
            Next
        End If
    Else
        For i = UBound(Params) To 0 Step -1
            AddPush pASM, CLng(Params(i))           ' PUSH dword
        Next
    End If

    AddCall pASM, fnc                   ' CALL rel addr
    AddByte pASM, &HC3                  ' RET

    CallStd = CallWindowProcA(udtMem.address, 0, 0, 0, 0)

    FreeMemory udtMem
End Function

Private Sub AddPush(pASM As Long, lng As Long)
    AddByte pASM, &H68
    AddLong pASM, lng
End Sub

Private Sub AddCall(pASM As Long, addr As Long)
    AddByte pASM, &HE8
    AddLong pASM, addr - pASM - 4
End Sub

Private Sub AddLong(pASM As Long, lng As Long)
    CpyMem ByVal pASM, lng, 4
    pASM = pASM + 4
End Sub

Private Sub AddByte(pASM As Long, Bt As Byte)
    CpyMem ByVal pASM, Bt, 1
    pASM = pASM + 1
End Sub
'--- Ende Modul "modIsRegistered" alias modIsRegistered.bas ---
'-------------- Ende Projektdatei Projekt1.vbp --------------