Office: Laufzeitfehler 9

Ich habe in Zusammenarbeit mit einem Firmen-Kollegen, der sich in VBA einigermaßen auskennt, ein Excel-Rechenprogram erstellt. Ich habe die Berechnungsformeln in Excel erstellt und, da ich mich in VBA nicht auskenne, hat der Kollege, der nun nicht mehr erreichbar ist, den dazu erforderlichen Code geschrieben.

Damit die einfache Weitergabe verhindert werden kann, ist die Vergabe eines Passwortes vorgesehen, dass mit dem MD5 Hash im Programm hinterlegt wird. Trägt der Anwender das Passwort ein, dann wird geprüft, ob der aus dem Passwort gebildete MD5 Hash mit dem im Programm hinterlegten MD5 Hash übereinstimmt.

Bei der Anwendung auf meinem PC mit 64-Bit Prozessor wird folgender Laufzeitfehler angezeigt:

Laufzeitfehler ´9´ Index außerhalb des gültigen Bereichs

Hier der Code aus dem Debugger

(Der Fehler ist fett gekennzeichnet)

Function Crypt(Text As String, Art As Algorithmus) As String

Dim AcquireContext As Long

Dim HashHandle As Long

Dim result As Long

Dim ByteText() As Byte

Dim LängeResult As Long

Dim ByteResult() As Byte

Dim Zähler As Integer

ByteText() = StrConv(Text, vbFromUnicode)


result = CryptAcquireContext(AcquireContext, vbNullString, vbNullString, 1, 0)

If result = 0 And Err.LastDllError = &H80090016 Then _

result = CryptAcquireContext(AcquireContext, vbNullString, vbNullString, 1, &H8)

result = CryptCreateHash(AcquireContext, Art, 0, 0, HashHandle)

result = CryptHashData(HashHandle, ByteText(0), Len(Text), 0)

result = CryptGetHashParam(HashHandle, 4, LängeResult, 4, 0)


ReDim ByteResult(0 To LängeResult - 1) As Byte

result = CryptGetHashParam(HashHandle, 2, ByteResult(0), LängeResult, 0)


For Zähler = 0 To UBound(ByteResult)

Crypt = Crypt & Right$("0" & Hex$(ByteResult(Zähler)), 2)

Next


CryptDestroyHash HashHandle
CryptReleaseContext AcquireContext, 0


End Function

Kann jemand den Fehler erkennen und mir mitteilen, wie ich den beseitige.
Danke im Voraus.
Gruß
A.Ruck

 

Hallo,

dann wird halt folgende Funktion für die Variable LängeResult
result = CryptGetHashParam(HashHandle, 4, LängeResult, 4, 0)
den Wert 0 zurückliefern, sofern dort überhaupt ein Wert zurückgeliefert wird. Es müsste dort in dieser Funktion der formale 3. Parameter als ByRef (statt ByVal) deklariert sein. Das kann ich nicht überprüfen - das musst du wissen, wie es dort im Inneren dieser Funktion aussieht.

Das bewirkt, dass in der folgenden dynamischen Deklaration - nachdem dazwischen diese Variable nicht verändert wird -
ReDim ByteResult(0 To LängeResult - 1) As Byte
schlussendlich folgende Deklaration
ReDim ByteResult(0 to -1) As Byte
zu stehen kommt, was nicht möglich ist.

 

Hallo,
zunächst einmal besten Dank für die Antwort.
Wie ich ja bereits mitgeteilt habe, habe ich den Code nicht geschrieben, da ich mich mit VBA kaum auskenne. Deshalb werde ich dass mit einem Mitarbeiter aus dem EDV Support einer benachbarten Firma besprechen.
Ich werde mich jedenfalls noch einmal melden. Ob sich ein Erfolg ergab oder nicht.

 

Hallo,

CryptGetHashParam function (wincrypt.h) - Win32 apps | Microsoft Learn

Vgl. dein Posting vom 28.3.2022 in:
VBA-Forum - Das Forum zu Microsoft VBA

Deklaration der Funktion "CryptGetHashParam":

Code:

Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32.dll" ( _
  ByVal hHash As Long, _
  ByVal dwParam As Long, _
  pbData As Any, _
  pdwDataLen As Long, _
  ByVal dwFlags As Long) As Long

Im folgenden GitHub-Link habe ich eine Lösung gefunden, die unter 32/64-bit Access/Excel arbeiten soll. Soweit ich gesehen habe, nützt es zu Beginn des Codes die bedingte Kompilation, indem es die beiden Variablen VBA7 und Win64 abfragt:

Code:

#If VBA7 And Win64 Then
  'Deklarationsblock 64bit Access/Excel
#Else
  'Deklarationsblock
#End If

How to Use advapi32.dll Encryption Functions in 64-bit VBA · GitHub
'Reference: VB6 Hash Class - MD5 , SHA-1, SHA-256, SHA-384, SHA-512
'The above article is excellent but that code works for 32-bit Access/Excel only.
'This works on both 32-bit and 64-bit Access/Excel.
'Requires no dll References in the VB Editor. It uses advapi32.dll, which needs no Reference
' as these are Windows API calls only.
'I have not seen documented anywhere else on the Internet how to make these calls in 64-bit apps.

 

Hallo,
Allerbesten Dank für die Antwort. Da ich jedoch den Mitarbeiter einer benachbarten Firma, der sich mit VBA auskennt, noch nicht erreichen konnte, hier noch folgen Anmerkungen:
Durch den Hinweis auf die Deklaration der Funktion "CryptGetHashParam" stellte ich fest, dass ich am Anfang meiner Anfrage nicht den kompletten Code hier eingestellt hatte, denn diese Deklaration ist bereits Bestandteil meines Codes.
Den kompletten Code füge ich im Anschluss an meine folgenden Bemerkungen ein.
Ich habe eine weitere Frage zu deiner im GitHub-Link gefundenen Lösung, die unter 32/64-bit Access/Excel arbeiten soll.
Wie und wo muss ich den Code, den du mir genannt hast, in meinen Code einfügen. Bitte nicht wundern, ich muss nochmal erklären, dass ich mich vorher noch nie mit VBA beschäftigt habe.
Hier nun der komplette Code, der zu Beginn meiner Anfrage nur teilweise vorlag.
Ich würde mich über eine Antwort freuen.

Option Explicit


Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32.dll" _
Alias "CryptAcquireContextA" ( _
ByRef phProv As Long, _
ByVal pszContainer As String, _
ByVal pszProvider As String, _
ByVal dwProvType As Long, _
ByVal dwFlags As Long) As Long

Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32.dll" ( _
ByVal hProv As Long, _
ByVal dwFlags As Long) As Long

Private Declare PtrSafe Function CryptCreateHash Lib "advapi32.dll" ( _
ByVal hProv As Long, _
ByVal Algid As Long, _
ByVal hKey As Long, _
ByVal dwFlags As Long, _
ByRef phHash As Long) As Long

Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32.dll" ( _
ByVal hHash As Long) As Long

Private Declare PtrSafe Function CryptHashData Lib "advapi32.dll" ( _
ByVal hHash As Long, _
pbData As Byte, _
ByVal dwDataLen As Long, _
ByVal dwFlags As Long) As Long

Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32.dll" ( _
ByVal hHash As Long, _
ByVal dwParam As Long, _
pbData As Any, _
pdwDataLen As Long, _
ByVal dwFlags As Long) As Long

Private Const ALG_CLASS_HASH As Long = (4 * 2 ^ 13)
Private Const ALG_SID_HMAC As Long = 9
Private Const ALG_SID_MD2 As Long = 1
Private Const ALG_SID_MD4 As Long = 2
Private Const ALG_SID_MD5 As Long = 3
Private Const ALG_SID_SHA As Long = 4
Private Const ALG_SID_SHA1 As Long = 4
Private Const ALG_TYPE_ANY As Long = 0
Private Const CALG_MD2 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2)
Private Const CALG_MD4 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4)
Private Const CALG_MD5 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
Private Const CALG_SHA1 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA1)

Enum Algorithmus
md2 = CALG_MD2
md4 = CALG_MD4
md5 = CALG_MD5
SHA1 = CALG_SHA1
End Enum

Function Crypt(Text As String, Art As Algorithmus) As String
Dim AcquireContext As Long
Dim HashHandle As Long
Dim result As Long
Dim ByteText() As Byte
Dim LängeResult As Long
Dim ByteResult() As Byte
Dim Zähler As Integer
ByteText() = StrConv(Text, vbFromUnicode)

result = CryptAcquireContext(AcquireContext, vbNullString, vbNullString, 1, 0)
If result = 0 And Err.LastDllError = &H80090016 Then _
result = CryptAcquireContext(AcquireContext, vbNullString, vbNullString, 1, &H8)

result = CryptCreateHash(AcquireContext, Art, 0, 0, HashHandle)

result = CryptHashData(HashHandle, ByteText(0), Len(Text), 0)

result = CryptGetHashParam(HashHandle, 4, LängeResult, 4, 0)

ReDim ByteResult(0 To LängeResult - 1) As Byte
result = CryptGetHashParam(HashHandle, 2, ByteResult(0), LängeResult, 0)

For Zähler = 0 To UBound(ByteResult)
Crypt = Crypt & Right$("0" & Hex$(ByteResult(Zähler)), 2)
Next

CryptDestroyHash HashHandle
CryptReleaseContext AcquireContext, 0

End Function

Private Sub CommandButton1_Click()
Unload Gültigkeitsprüfung
Eingabemaske.Show
End Sub

Private Sub CommandButton2_Click()
Unload Gültigkeitsprüfung
End Sub

Private Sub CommandButton3_Click()
If TextBox1.Value <> vbNullString Then
Worksheets("Tabelle1").Range("B77").Value = Crypt(TextBox1.Value, md5)
Dim result As Integer
result = StrComp(Worksheets("Tabelle1").Range("B77").Value, Worksheets("Tabelle1").Range("B75").Value, vbTextCompare)
If result = 0 Then
Worksheets("Tabelle1").Range("B76").Value = "x"
Worksheets("Tabelle1").Range("B78").Value = Environ("Username")
MsgBox "Der eingegebene Lizenzschlüssel ist korrekt."
Unload Gültigkeitsprüfung
Eingabemaske.Show
Else
MsgBox "Ungültiger Lizenzschlüssel"
End If
Else
MsgBox "Bitte geben Sie einen Lizenzschlüssel ein."

End If

End Sub

Private Sub Label1_Click()

End Sub

Private Sub UserForm_Initialize()
If Date > Worksheets("Tabelle1").Range("B73").Value Then
CommandButton1.Enabled = False
Label1.Caption = "Diese Testversion ist abgelaufen." & vbCrLf & vbCrLf & "Bitte geben Sie einen gültigen Lizenzschlüssel ein."
Else
CommandButton1.Enabled = True
Label1.Caption = "Diese Testversion ist noch bis zum " & Worksheets("Tabelle1").Range("B73").Value & " gültig." & vbCrLf & "Danach benötigen Sie einen Lizenzschlüssel. Bis dahin zuerst den Button -Betätigen- drücken"
End If

End Sub

 

Hallo,

Code:

Option Explicit

'=================================================================
' #Encryption #VBA
'=================================================================
'Reference: http://khoiriyyah.blogspot.com/2012/06/vb6-hash-class-md5-sha-1-sha-256-sha.html
'The above article is excellent but that code works for 32-bit Access/Excel only.
'This works on both 32-bit and 64-bit Access/Excel.
'Requires no dll References in the VB Editor.  It uses advapi32.dll, which needs no Reference
'  as these are Windows API calls only.
'I have not seen documented anywhere else on the Internet how to make these calls in 64-bit apps.

#If VBA7 And Win64 Then
   Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
                               (ByRef phProv As LongPtr, ByVal pszContainer As String, ByVal pszProvider As String, _
                                ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
   Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32.dll" _
                               (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
   Private Declare PtrSafe Function CryptCreateHash Lib "advapi32.dll" _
                               (ByVal hProv As LongPtr, ByVal Algid As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, _
                                ByRef phHash As LongPtr) As Long
   Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32.dll" _
                               (ByVal hHash As LongPtr) As Long
   Private Declare PtrSafe Function CryptHashData Lib "advapi32.dll" _
                               (ByVal hHash As LongPtr, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long
   Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32.dll" _
                               (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByRef pcbData As Long, _
                                ByVal dwFlags As Long) As Long
#Else
   Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
                               (ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, _
                                ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
   Private Declare Function CryptReleaseContext Lib "advapi32.dll" _
                               (ByVal hProv As Long, ByVal dwFlags As Long) As Long
   Private Declare Function CryptCreateHash Lib "advapi32.dll" _
                               (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, _
                                ByRef phHash As Long) As Long
   Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
                               (ByVal hHash As Long) As Long
   Private Declare Function CryptHashData Lib "advapi32.dll" _
                               (ByVal hHash As Long, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long
   Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
                               (ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, ByRef pcbData As Long, _
                                ByVal dwFlags As Long) As Long
#End If


   Private Const PROV_RSA_FULL   As Long = 1
   Private Const PROV_RSA_AES    As Long = 24
   Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
 
   Private Const HP_HASHVAL      As Long = 2
   Private Const HP_HASHSIZE     As Long = 4
 
   Private Const ALG_TYPE_ANY    As Long = 0
   Private Const ALG_CLASS_HASH  As Long = 32768
 
   Private Const ALG_SID_MD2     As Long = 1
   Private Const ALG_SID_MD4     As Long = 2
   Private Const ALG_SID_MD5     As Long = 3
   Private Const ALG_SID_SHA     As Long = 4
   Private Const ALG_SID_SHA_256 As Long = 12
   Private Const ALG_SID_SHA_384 As Long = 13
   Private Const ALG_SID_SHA_512 As Long = 14
 
   Private Const CALG_MD2        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2)
   Private Const CALG_MD4        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4)
   Private Const CALG_MD5        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
   Private Const CALG_SHA        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)
   Private Const CALG_SHA_256    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_256)
   Private Const CALG_SHA_384    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_384)
   Private Const CALG_SHA_512    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_512)

Enum Algorithmus
   md2 = CALG_MD2
   md4 = CALG_MD4
   md5 = CALG_MD5
   SHA1 = CALG_SHA
   SHA256 = CALG_SHA_256
   SHA384 = CALG_SHA_384
   SHA512 = CALG_SHA_512
End Enum

' Create Hash
Public Function CreateHash(abytData() As Byte, ByVal Art As Algorithmus) As String
    #If VBA7 And Win64 Then
       Dim hProv As LongPtr
       Dim hHash As LongPtr
    #Else
       Dim hProv As Long
       Dim hHash As Long
    #End If
    Dim abytHash(0 To 63) As Byte
    Dim lngLength As Long
    Dim lngResult As Long
    Dim strHash As String
    Dim i As Long
    Dim z As Long
    strHash = ""
 
    z = 0
    If CryptAcquireContext(hProv, vbNullString, vbNullString, _
                           IIf(Art >= CALG_SHA_256, PROV_RSA_AES, PROV_RSA_FULL), _
                           CRYPT_VERIFYCONTEXT) <> 0& Then
        If CryptCreateHash(hProv, Art, 0&, 0&, hHash) <> 0& Then
            lngLength = UBound(abytData()) - LBound(abytData()) + 1
            If lngLength > 0 Then lngResult = CryptHashData(hHash, abytData(LBound(abytData())), lngLength, 0&) _
                             Else lngResult = CryptHashData(hHash, ByVal 0&, 0&, 0&)
            If lngResult <> 0& Then
                lngLength = UBound(abytHash()) - LBound(abytHash()) + 1
                If CryptGetHashParam(hHash, HP_HASHVAL, abytHash(LBound(abytHash())), lngLength, z) <> 0& Then
                    For i = 0 To lngLength - 1
                        strHash = strHash & Right$("0" & Hex$(abytHash(LBound(abytHash()) + i)), 2)
                    Next
                End If
            End If
            CryptDestroyHash hHash
        End If
        CryptReleaseContext hProv, 0&
    End If
    CreateHash = LCase$(strHash)
End Function

' Create Hash From String(Shift_JIS)
Public Function CreateHashString(ByVal strData As String, ByVal Art As Algorithmus) As String
    CreateHashString = CreateHash(StrConv(strData, vbFromUnicode), Art)
End Function

' Create Hash From File
Public Function CreateHashFile(ByVal strFileName As String, ByVal Art As Algorithmus) As String
    Dim abytData() As Byte
    Dim intFile As Integer
    Dim lngError As Long
    On Error Resume Next
        If Len(Dir(strFileName)) > 0 Then
            intFile = FreeFile
            Open strFileName For Binary Access Read Shared As #intFile
            abytData() = InputB(LOF(intFile), #intFile)
            Close #intFile
        End If
        lngError = Err.Number
    On Error GoTo 0
    If lngError = 0 Then CreateHashFile = CreateHash(abytData(), Art) _
                    Else CreateHashFile = ""
End Function

'=================================================================
' Formular Gültigkeitsprüfung
'=================================================================
'
Private Sub CommandButton1_Click()
   Unload Gültigkeitsprüfung
   Eingabemaske.Show
End Sub
'
Private Sub CommandButton2_Click()
   Unload Gültigkeitsprüfung
End Sub

Private Sub CommandButton3_Click()
   Dim result As Integer

   If TextBox1.Value <> vbNullString Then
      With Worksheets("Tabelle1")
  
         ' Hash-String nach MD5-Verfahren wird erzeugt:
         .Range("B77").Value = CreateHashString(TextBox1.Value, md5)
      
         result = StrComp(.Range("B77").Value, .Range("B75").Value, vbTextCompare)
         If result = 0 Then
            .Range("B76").Value = "x"
            .Range("B78").Value = Environ("Username")
            MsgBox "Der eingegebene Lizenzschlüssel ist korrekt."
            Call CommandButton1_Click
         Else
            MsgBox "Ungültiger Lizenzschlüssel"
         End If
      End With
   Else
      MsgBox "Bitte geben Sie einen Lizenzschlüssel ein."
   End If

End Sub

Private Sub Label1_Click()
' Label1: enthält Lizenzschlüssel-Info - ein Klick darauf bewirkt nichts.
End Sub

Private Sub UserForm_Initialize()
  Dim LizDatum As Date
  LizDatum = Worksheets("Tabelle1").Range("B73").Value
   If Date > LizDatum Then
      CommandButton1.Enabled = False
      Label1.Caption = "Diese Testversion ist abgelaufen." & vbCrLf & vbCrLf & _
                       "Bitte geben Sie einen gültigen Lizenzschlüssel ein."
   Else
      CommandButton1.Enabled = True
      Label1.Caption = "Diese Testversion ist noch bis zum " & LizDatum & " gültig." & vbCrLf & _
                       "Danach benötigen Sie einen Lizenzschlüssel. Bis dahin zuerst den Button -Betätigen- drücken"
   End If

End Sub

Dieser gesamte VBA-Code gehört in das Code-Modul des benutzerdefinierten Formulars "Gültigkeitsprüfung" kopiert.

 

Hallo Exl121150,
allerbesten Dank für deine bemerkenswerte Hilfe. Ich habe deinen Code copiert und in das Modul "Gültigkeitsprüfung" eingepflegt.
Es funktioniert auf meinem PC und ich bin überglücklich. Du hast mir eine große Freude bereitet.
Ich werde es morgen einem Bekannten zusenden, der es auf seinem Rechner testen soll.
Über das Ergebnis werde ich dich informieren.
Wünsche einen angenehmen Abend.
Gruß