Wert aus der Registry mit VBA auslesen

Hallo allerseits

Aus Excel werden E-Mails mit Thunderbird verschickt. Dies erfolgt mit folgender Routine



Public Function CreateThunderbirdEmailObject(Optional ProgrammPfad As String = _

          "C:\Program Files (x86)\Mozilla Thunderbird\Thunderbird.exe")

  '

  Dim strMailAufbau As String

  Dim varAttachments As Variant

  Dim lngAttachCount As Long

  '

  Call set_trace("4, CreateThunderbirdEmailObject - start")

  With NeueThunderbirdEMail

    '

    ' Anzuhängende Dateien auflisten

    varAttachments = Split(.Anhang, ";")

    '

    ' Email aufbauen

    strMailAufbau = ProgrammPfad & " -compose format=" & .EmailFormat & ",preselectid=id" & .SendenVonKonto & _

              ",to='" & .Empfaenger & "',subject='" & .Betreff & "',body='" & .EMailText

    '

    ' Prüfen auf "Kopie senden an"

    If .KopieAn > "" Then

      strMailAufbau = strMailAufbau & "',cc='" & .KopieAn

    End If '  .KopieAn > ""

    '

    ' Prüfen auf "Blindkopie an"

    If .BlindKopieAn > "" Then

      strMailAufbau = strMailAufbau & "',bcc='" & .BlindKopieAn

    End If '  .BlindKopieAn >

    '

    ' Prüfen auf "Anhang setzen"

    If UBound(varAttachments) >= 0 Then

      strMailAufbau = strMailAufbau & "',attachment='file:///" & .OptionalDateiPfad & varAttachments(0)

      For lngAttachCount = 1 To UBound(varAttachments)

        strMailAufbau = strMailAufbau & "," & .OptionalDateiPfad & varAttachments(lngAttachCount)

      Next lngAttachCount '  lngAttachCount =

    End If '  UBound(varAttachm

    strMailAufbau = strMailAufbau & "'"

    '

    ' Email erstellen

    Shell strMailAufbau, vbMaximizedFocus

    '

  End With '  NeueThunderbirdEM



  '

End Function

Funktioniert bestens. Das Problem, nicht auf jedem Rechner ist Thunderbird.exe im Ordner "C:\Program Files (x86)\Mozilla Thunderbird\Thunderbird.exe" abgelegt. Und bei diesen Rechnern funktioniert es natürlich nicht. Nun gibt es zwei Möglichkeiten, durch sämtliche Ordner auf allen Disks zu sausen und nach der Datei suchen oder den Pfad aus der Registry auslesen. Die zweite Variante ist da wesentlich effizienter und die möchte ich auch nutzen. Nun habe ich folgende Routine gefunden, die das machen sollte





Sub Read_Specific_RegKey()



Dim myWSH As Object

Dim myReadRegKey As String

Dim myResRegKey As Variant



Set myWSH = CreateObject("WScript.Shell")

myReadRegKey = "HKEY_CLASSES_ROOT\Applications\thunderbird.exe\shell\open\command"

myResRegKey = myWSH.RegRead(myReadRegKey)

MsgBox myResRegKey



End Sub

Leider bringt sie folgende Meldung:

Laufzeitfehler '-2147024894 (80070002)'

Registrierungsschlüssel
"HKEY_CLASSES_ROOT\Applications\thunderbird.exe\shell\open\command" wurde nicht zum Lesen geöffnet.

Was mus ich da machen?

Gruss
yogi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub checkRegistryEintrag_Thunderbird() Dim HKEY_CURRENT_USER As Long, oReg As Object, arrApps Dim strKeyPath, strWert, strApp, sProg As String sProg = "Thunderbird.exe" 'anpassen HKEY_CURRENT_USER = &H80000001 Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") strKeyPath = "Software\Classes\Local Settings\Software\Microsoft\Windows\Shell\MuiCache" oReg.EnumValues HKEY_CURRENT_USER, strKeyPath, arrApps If Not IsArray(arrApps) Then Exit Sub For Each strApp In arrApps If InStr(1, LCase(strApp), LCase(sProg & ".FriendlyAppName")) > 0 Then oReg.GetStringValue HKEY_CURRENT_USER, strKeyPath, strApp, strWert MsgBox "der Eintrag " & vbCrLf & sProg & vbCrLf & " ist in der Registry vorhanden." Exit Sub End If Next MsgBox "der Eintrag " & sProg & vbCrLf & "ist in der Registry" & vbCrLf & "NICHT vorhanden." Set oReg = Nothing End Sub

Option Explicit 'Verweis auf 'Windows Script Host Object Model' Dim objWSH As New WshShell Public Function readKey() On Local Error GoTo readKeyERR Dim strKey As String, strApp As String, strReturn As String strApp = "thunderbird.exe" strKey = "HKEY_CURRENT_USER\SOFTWARE\Classes\Applications\" & strApp & "\shell\open\command\" With objWSH strReturn = .RegRead(strKey) End With readKeyOUT: readKey = strReturn Exit Function readKeyERR: strReturn = "" Resume readKeyOUT End Function

Beliebteste Forumthreads (12 Monate)

Wert aus der Registry mit VBA auslesen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread