encrypt/decrypt string

Category:

String Manipulation

Type:

Modules

Difficulty:

Intermediate

Author: Anonymous

Version Compatibility: Visual Basic 6

More information:

Will encrypt or decrypt a specified string. and return the value as a string

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

Public Function encrypts(ByVal mystring, ByVal MySeed, ByVal MyMax) As String
    Dim temp As String
    Dim tempascii As Integer
    Dim tempstring As String
On Error GoTo err:
    For x = 1 To MyMax
        temp = Mid$(mystring, x, 1)
        tempascii = Asc(temp)
        tempascii = tempascii + MySeed
        tempstring = tempstring & Chr(tempascii)
    Next x
err:
    encrypts = tempstring
End Function

Public Function decrypts(ByVal mystring, ByVal MySeed, ByVal MyMax) As String
    Dim temp As String
    Dim tempascii As Integer
    Dim tempstring As String
On Error GoTo err:
    For x = 1 To MyMax
        temp = Mid$(mystring, x, 1)
        tempascii = Asc(temp)
        tempascii = tempascii - MySeed
        tempstring = tempstring & Chr(tempascii)
    Next x
err:
    decrypts = tempstring
End Function

Public Function stringtobinary(ByVal mystring, ByVal maxlength) As String
    Dim Filter As Integer
    For x = 1 To maxlength
        Filter = 1
        tempascii = Asc(Mid$(mystring, x, 1))
        For y = 1 To 8
            tempbit = tempascii And Filter
            If tempbit > 0 Then
                binary_string = 1 & binary_string
            Else
                binary_string = 0 & binary_string
            End If
            Filter = Filter * 2
        Next y
        temp = binary_string
        temp = rev(temp)
    Next x
    stringtobinary = temp
End Function

Public Function binarytostring(ByVal mystring, ByVal maxlength) As String
    Dim binarystring As String
    Dim place As Integer
    Dim Letter As String
    Dim my_string As String
    Dim total As Integer
    place = 128
    For x = 1 To Len(mystring) Step 8
        binarystring = rev(Mid$(mystring, x, 8))
        For y = 1 To 8
            total = total + Mid$(binarystring, y, 1) * place
            place = place / 2
        Next y
        place = 128
        my_string = my_string & Chr(total)
        total = 0
    Next x
    binarytostring = my_string

End Function

Public Function stringtooctal(ByVal mystring, ByVal maxlength) As String
    Dim tempascii As Integer
    Dim tempbit As Integer
    Dim binary_string As String
    Dim Filter As Integer

For x = 1 To maxlength
        Filter = 7
        tempascii = Asc(Mid$(mystring, x, 1))
        For y = 1 To 3
            tempbit = tempascii And Filter
            If tempbit > 0 Then
                binary_string = (7 * tempbit / Filter) & binary_string
            Else
                binary_string = 0 & binary_string
            End If
            Filter = Filter * 8
        Next y
         stringtooctal = stringtooctal & binary_string
        binary_string = ""
    Next x
End Function

Public Function octaltostring(ByVal mystring, ByVal maxlength) As String
    Dim binarystring As String
    Dim place As Integer
    Dim Letter As String
    Dim my_string As String
    Dim total As Integer
    place = 64
    For x = 1 To Len(mystring) Step 3
        binarystring = Mid$(mystring, x, 3)
        For y = 1 To 3
            total = total + Mid$(binarystring, y, 1) * place
            place = place / 8
        Next y
        place = 64
        my_string = my_string & Chr(total)
        total = 0
    Next x
    octaltostring = my_string

End Function

Public Function stringtohex(ByVal mystring, ByVal maxlength) As String
    Dim tempascii As Integer
    Dim tempbit As Integer
    Dim binary_string As String
    Dim Filter As Integer
    Dim Letter(6) As String
    Dim hexletter As Integer

Letter(0) = "A"
    Letter(1) = "B"
    Letter(2) = "C"
    Letter(3) = "D"
    Letter(4) = "E"
    Letter(5) = "F"
    
    For x = 1 To maxlength
        Filter = 15
        tempascii = Asc(Mid$(mystring, x, 1))
        For y = 1 To 2
            tempbit = tempascii And Filter
            hexletter = (15 * tempbit / Filter)
            If hexletter >= 10 Then
                binary_string = Letter(hexletter - 10) & binary_string
            Else
                binary_string = hexletter & binary_string
            End If
            Filter = Filter * 16
        Next y
         stringtohex = stringtohex & binary_string
        binary_string = ""
    Next x
End Function

Public Function hextostring(ByVal mystring, ByVal maxlength) As String
    Dim binarystring As String
    Dim place As Integer
    Dim Letter As String
    Dim my_string As String
    Dim total As Integer
    Dim value As Integer
    
    place = 16
    For x = 1 To Len(mystring) Step 2
        binarystring = Mid$(mystring, x, 2)
        For y = 1 To 2
            Select Case Mid$(binarystring, y, 1)
            Case "A"
                value = 10
            Case "B"
                value = 11
            Case "C"
                value = 12
            Case "D"
                value = 13
            Case "E"
                value = 14
            Case "F"
                value = 15
            Case Else
                value = Val(Mid$(binarystring, y, 1))
            End Select
            
            total = total + value * place
            place = place / 16
        Next y
        place = 16
        my_string = my_string & Chr(total)
        total = 0
    Next x
    hextostring = my_string

End Function

Public Function hexoctal(ByVal mystring, ByVal maxlength)
End Function

Public Function revbine(ByVal mystring, ByVal maxlength)

End Function

Public Function rev(ByVal mybinary)
    For x = 1 To 8
        a = Mid$(mybinary, x, 1)
        If a = 1 Then
            a = 0
        Else
            a = 1
        End If
        temp = temp & a
    Next x
    rev = temp
End Function