Installerede pogrammer m.v.

www.allapi.net - prøv at kik der, eller prøv søgefunktionen. Tror du skal have fat i API

http://www.eksperten.dk/spm/325175

Tilføj et nyt modul, kald det "modRegistry" og indsæt denne kode i det:

'-----------------------------------------------------------------------
Public sKeys As Collection
Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Const ERROR_SUCCESS = 0&
Const REG_SZ = 1
Const REG_DWORD = 4
Public Const REG_EXPAND_SZ = 2

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Enum HKeyTypes
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_PERFORMANCE_DATA = &H80000004
End Enum


Public Function GetString(hKey As HKeyTypes, strPath As String, strValue As String)
   
    Dim keyhand As Long
    Dim datatype As Long
    Dim lRegResult As Long
    Dim strBuf As String
    Dim lDataBufSize As Long
    Dim intZeroPos As Integer
    Dim lValueType As Long
   
  lRegResult = RegOpenKey(hKey, strPath, keyhand)
  lRegResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)
  intZeroPos = InStr(strbuffer, Chr$(0))

    If lValueType = REG_SZ Or REG_EXPAND_SZ Then
        strBuf = String(lDataBufSize, " ")
        lresult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)


        If lresult = ERROR_SUCCESS Then
            intZeroPos = InStr(strBuf, Chr$(0))


            If intZeroPos > 0 Then
                GetString = Left$(strBuf, intZeroPos - 1)
            Else
                GetString = strBuf
            End If
        End If
    End If
End Function


Public Sub SaveString(hKey As HKeyTypes, strPath As String, strValue As String, strdata As String)
      Dim keyhand As Long
    Dim r As Long
    r = RegCreateKey(hKey, strPath, keyhand)
    r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
    r = RegCloseKey(keyhand)
End Sub


Public Function DeleteValue(ByVal hKey As HKeyTypes, ByVal strPath As String, ByVal strValue As String)
 
    Dim keyhand As Long
    r = RegOpenKey(hKey, strPath, keyhand)
    r = RegDeleteValue(keyhand, strValue)
    r = RegCloseKey(keyhand)
End Function


Public Function DeleteKey(ByVal hKey As HKeyTypes, ByVal strPath As String)
 
    Dim keyhand As Long
    r = RegDeleteKey(hKey, strPath)
End Function
       

Public Sub GetKeyNames(ByVal hKey As Long, ByVal strPath As String)
Dim Cnt As Long, StrBuff As String, StrKey As String, TKey As Long
    RegOpenKey hKey, strPath, TKey
    Do
        StrBuff = String(255, vbNullChar)
        If RegEnumKeyEx(TKey, Cnt, StrBuff, 255, 0, vbNullString, 0, ByVal 0&) <> 0 Then Exit Do
        Cnt = Cnt + 1
        StrKey = Left(StrBuff, InStr(StrBuff, vbNullChar) - 1)
        sKeys.Add StrKey
    Loop
End Sub

Public Sub SaveKey(mPath As String, sfile As String)
 
    Dim temp As String
    FileAppend "", sfile
    temp = GetDosPath(sfile)
    Shell "regedit /E " & temp & " " & Chr(34) & mPath & Chr(34)
End Sub

Public Sub FileAppend(Text As String, FilePath As String)
On Error Resume Next
Dim f As Integer
f = FreeFile
Dim Directory As String
              Directory$ = FilePath
    Open Directory$ For Append As #f
        Print #f, Text
    Close #f
Exit Sub
End Sub

Public Function GetDosPath(LongPath As String) As String
    Dim s As String
    Dim i As Long
    Dim PathLength As Long
    i = Len(LongPath) + 1
    s = String(i, 0)
    PathLength = GetShortPathName(LongPath, s, i)
    GetDosPath = Left$(s, PathLength)

End Function
'-----------------------------------------------------------------------


Sæt en knap("Command1"), og et liste("List1") ind i din form, og indsæt denne kode:

'-----------------------------------------------------------------------
Dim GetlocString, RegName, UString, Dname, Publisher, DVersion, HelpLink, UIAbout, Contact As String
Dim iKetetapan As Integer

Private Sub GetKetReg()
GetlocString = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
modRegistry.GetKeyNames HKEY_LOCAL_MACHINE, GetlocString
End Sub

Private Sub ShowUninstallList()
On Error Resume Next
Call GetKetReg

List1.Clear
For iKetetapan = 1 To sKeys.Count - 0
    Dname = GetString(HKEY_LOCAL_MACHINE, GetlocString & sKeys(iKetetapan), "DisplayName")
    UString = GetString(HKEY_LOCAL_MACHINE, GetlocString & sKeys(iKetetapan), "UninstallString")
    Publisher = GetString(HKEY_LOCAL_MACHINE, GetlocString & sKeys(iKetetapan), "Publisher")
    DVersion = GetString(HKEY_LOCAL_MACHINE, GetlocString & sKeys(iKetetapan), "DisplayVersion")
    HelpLink = GetString(HKEY_LOCAL_MACHINE, GetlocString & sKeys(iKetetapan), "HelpLink")
    UIAbout = GetString(HKEY_LOCAL_MACHINE, GetlocString & sKeys(iKetetapan), "URLInfoAbout")
    Contact = GetString(HKEY_LOCAL_MACHINE, GetlocString & sKeys(iKetetapan), "Contact")

    If Trim(Dname) <> "" Then
      List1.AddItem Dname
    End If

Next iKetetapan
   
 
End Sub

Private Sub Command1_Click()
Call ShowUninstallList
End Sub

Private Sub Form_Load()
Set sKeys = New Collection
End Sub
'-----------------------------------------------------------------------

Du kan evt. også sætte "List1"'s "Sorded" til "True", og så det vist i alfabetisk rækkefølge.

Hej wannadoo.....

Når jeg trykker på command1 kommer der intet i list1.

den løkke der er i "Private Sub ShowUninstallList" returnerer variablen sKeys.Count en værdi 0

I samme sub bruger du en Trim(Dname). Den kan jeg ikke finde dimentioneret nogen steder og hvad gør den ?

Hej wannadoo..!!

Jeg har fået det til at virke nu. Jeg ændrede kaldet i Private Sub GetKetReg()
fra : modRegistry.GetKeyNames HKEY_LOCAL_MACHINE, GetlocString
til : GetKeyNames HKEY_LOCAL_MACHINE, GetlocString

Jeg takker....!!

Det var godt at du fik det til at virke :)

Hvis du sætter en string (tekstværdi) i Trim funktionen, fjerner den alle mellemrum, der findes i stringen.

Vedr. det med at du ikke kunne få programmerne indsat i List1: Har du husket at kalde det oprettede modul, for "modRegistry"??

Det er årsagen til at det ikke virkede i første forsøg ;)

Nevermind, nu virker det :D

Hejsan..!!

Jeg hvade kaldt modulet "ModRegistry" med stort M. Jeg regner ikke med at det var grunden til det ikke virkede. Men det virker perfekt nu.

Jeg har i øvrigt nu accepteret dit svar 2 gange nu, men det ser ikke ud til at det slår igennem ??

Sørg for at du er logget ind
Marker wannodo's navn
Accepter

Virker det ikke?

Jeg er logget på, trykker på "accepter" og der sker NADA. Desuden kan jeg jo ikke ligge en kommentar hvis jeg ikke er logget på.

Hmm.. Kan de mon lade sig gøre, hvis du opretter et nyt spm, og giver pointene dér?
Jeg har ikke været udsat for dette før :)

Jeg har nu igen prøvet fra en anden computer. Same problem.. kan ikke acceptere. Jeg prøver at afvise dit svar og opretter et nyt.

HA... meget morsomt. Jeg kan heller afvise dit svar. Jeg har nu været medlem i en del år efterhånden, nok nærmere 5-6 år og dette er også første gang jeg ikke kan acceptere. Men jeg opretter et nyt spm.

prøver selv at smide et svar.

HM

http://www.eksperten.dk/spm/489760 - lidt lettere for at ham at finde, hvis han får link her tror jeg ;)

Jo, det har du ret i, Jeg takker...