Private A() As Byte
Private B() As Byte
Private C() As Byte

Private Sub InitSign()
    Const startStr = "VersionCompatible32=""393222000"""
    Const finishStr = "CMG=""", GC = "GC="""
    Dim i As Long, fullStr As String
    fullStr = startStr & Chr(&HD) & Chr(&HA) & finishStr
    A = "Root Entry" & String(10, Chr(0))
    ReDim B(1 To Len(fullStr))
    For i = 1 To UBound(B)
        B(i) = Asc(Mid$(fullStr, i, 1))
    Next
    ReDim C(1 To Len(GC))
    For i = 1 To UBound(C)
        C(i) = Asc(Mid$(GC, i, 1))
    Next
End Sub

Private Function Change1Pos(ByVal fileNum As Integer, ByVal FileLength As Long) As Long
    Const lastAId = 39
    Dim ARead(1 To lastAId) As Byte, AChange(1 To 5) As Byte
    Dim i As Long, k As Long, isEqual As Boolean, l As Long
    For i = 1 To FileLength - lastAId
        Get #fileNum, i, ARead
        isEqual = True
        For k = 1 To lastAId
            If A(k) <> ARead(k) Then isEqual = False: Exit For
        Next
        If isEqual Then
            Get #fileNum, i + 235, AChange
            For l = 1 To 5
                AChange(l) = CByte(255 * Math.Rnd)
            Next
            Put #fileNum, i + 235, AChange
            Stop
            Change1Pos = i
            Exit Function
        End If
    Next
    Change1Pos = 0
End Function

Private Function Change2Pos(ByVal fileNum As Integer, ByVal FileLength As Long) As Long
    Const lastBId = 38, lastCId = 4, FSign As Byte = &H46
    Dim BRead(1 To lastBId) As Byte, pos As Long, isNext As Boolean
    Dim i As Long, k As Long, l As Long, isEqual As Boolean
    Dim vChange As Byte, CRead(1 To lastCId) As Byte
    For i = 1 To FileLength - lastBId
        Get #fileNum, i, BRead
        isEqual = True
        For k = 1 To lastBId
            If B(k) <> BRead(k) Then isEqual = False: Exit For
        Next
        If isEqual Then
            pos = i + lastBId: isNext = True
            Do While isNext
                Get #fileNum, pos, vChange
                If vChange = &H22 Then
                    isNext = False
                Else
                    Put #fileNum, pos, FSign
                End If
                pos = pos + 1
            Loop
            Exit For
        End If
    Next
    If isEqual Then
        For k = pos To FileLength - UBound(C)
            Get #fileNum, k, CRead
            isEqual = True
            For l = 1 To lastCId
                If C(l) <> CRead(l) Then isEqual = False: Exit For
            Next
            If isEqual Then
                pos = k + lastCId: isNext = True
                Do While isNext
                    Get #fileNum, pos, vChange
                    If vChange = &H22 Then
                        isNext = False
                    Else
                        Put #fileNum, pos, FSign
                    End If
                    pos = pos + 1
                Loop
                Change2Pos = pos: Exit Function
            End If
        Next
    End If
    Change2Pos = 0
End Function

Public Sub MakeUnviewable()
    Dim vLen As Long, res As Long
    Dim fNum As Integer
    fNum = FreeFile
    vLen = FileLen("d:\path\vbaProject.bin")
    Open "d:\path\vbaProject.bin" For Binary As #fNum Len = 1
    InitSign
    res = Change1Pos(fNum, vLen)
    If res > 0 Then
        res = Change2Pos(fNum, vLen)
        If res > 0 Then MsgBox "Успешно", vbOKOnly + vbInformation, "Выполнено"
    End If
    Close #fNum
End Sub