Solved

registry

Posted on 2000-04-08
4
290 Views
Last Modified: 2010-05-02
I have written a set of preferences to the registry using

GetSetting(App.Title, "Settings", "prefs")

and

SaveSetting App.Title, "Settings", "prefs", "some value"

This is ok for most things, but to keep a couple of things from being easily accessable, I'd like to have them written in binary or something - that is to get and save the values to the registry with something other than text.  I believe this is possible, but I'm not sure of the method or one similar to it.
0
Comment
Question by:Daron1
  • 2
4 Comments
 
LVL 1

Accepted Solution

by:
skip99 earned 300 total points
ID: 2697110
Convert the String into Just that Binary (ones and zeros), and save it, then when you want to read it back in convert it back. Unless somebody wants to write an application to convert the setting back it's pretty safe.

Add the following code to a module and your on your way!

'-------------------------------------
'Convert text To Binary:
' SaveSetting App.Title, "Settings", "prefs", TextToBinary("string you want to convert")
'
'Convert Binary back to Text:
'Dim VariableX as String
'
'VariableX = BinaryToText(GetSetting(App.Title, "Settings", "prefs"))


Public Function ChrAscii(Char As String) As Long
    Dim GetAscii&


    For GetAscii& = 0 To 255


        If Mid(Char$, 1, 1) = Chr(GetAscii) Then
            ChrAscii = GetAscii
            Exit Function
        End If
    Next GetAscii&
End Function

Public Function TextToBinary(StringT As String) As String
    Dim Ascii, FinalBinary$, GetNum&
    FinalBinary$ = ""


    For GetNum& = 1 To Len(StringT$)
        Ascii = ChrAscii(Mid(StringT$, GetNum, 1))
        ' 128


        If Ascii >= 128 Then
            FinalBinary$ = FinalBinary$ & "1"
            Ascii = Ascii - 128
        Else
            FinalBinary$ = FinalBinary$ & "0"
        End If
       
        ' 64


        If Ascii >= 64 Then
            FinalBinary$ = FinalBinary$ & "1"
            Ascii = Ascii - 64
        Else
            FinalBinary$ = FinalBinary$ & "0"
        End If
       
        ' 32


        If Ascii >= 32 Then
            FinalBinary$ = FinalBinary$ & "1"
            Ascii = Ascii - 32
        Else
            FinalBinary$ = FinalBinary$ & "0"
        End If
       
        ' 16


        If Ascii >= 16 Then
            FinalBinary$ = FinalBinary$ & "1"
            Ascii = Ascii - 16
        Else
            FinalBinary$ = FinalBinary$ & "0"
        End If
       
        ' 8


        If Ascii >= 8 Then
            FinalBinary$ = FinalBinary$ & "1"
            Ascii = Ascii - 8
        Else
            FinalBinary$ = FinalBinary$ & "0"
        End If
       
        ' 4


        If Ascii >= 4 Then
            FinalBinary$ = FinalBinary$ & "1"
            Ascii = Ascii - 4
        Else
            FinalBinary$ = FinalBinary$ & "0"
        End If
       
        ' 2


        If Ascii >= 2 Then
            FinalBinary$ = FinalBinary$ & "1"
            Ascii = Ascii - 2
        Else
            FinalBinary$ = FinalBinary$ & "0"
        End If
       
        ' 1


        If Ascii >= 1 Then
            FinalBinary$ = FinalBinary$ & "1"
            Ascii = Ascii - 1
        Else
            FinalBinary$ = FinalBinary$ & "0"
        End If


        If Mid(StringT$, GetNum + 1, 1) = Chr(32) Then
            FinalBinary$ = FinalBinary$ '& " "
        Else
            FinalBinary$ = FinalBinary$ '& Chr(32)
        End If
    Next GetNum&
    TextToBinary$ = FinalBinary$
End Function


Public Function BinaryToText(BinaryString As String) As String
    Dim GetBinary&, Num$, Binary&, FinalString$, NewString$
NextChr:


For GetBinary& = 1 To 8
    Num$ = Mid(BinaryString$, GetBinary&, 1)


    Select Case Num$
       
        Case "1"


        If GetBinary = 1 Then
            Binary = Binary + 128
        ElseIf GetBinary = 2 Then
            Binary = Binary + 64
        ElseIf GetBinary = 3 Then
            Binary = Binary + 32
        ElseIf GetBinary = 4 Then
            Binary = Binary + 16
        ElseIf GetBinary = 5 Then
            Binary = Binary + 8
        ElseIf GetBinary = 6 Then
            Binary = Binary + 4
        ElseIf GetBinary = 7 Then
            Binary = Binary + 2
        ElseIf GetBinary = 8 Then
            Binary = Binary + 1
        End If
    End Select
Next GetBinary&
FinalString$ = FinalString$ & Chr(Binary)
NewString$ = Mid(BinaryString$, 9)



If NewString$ = "" Then
BinaryToText$ = FinalString$
Else
BinaryString$ = NewString$
Binary = 0
GoTo NextChr
End If
End Function


Public Function IsBinary(StringB As String) As Boolean
    Dim XX$, GetLet&


    For GetLet& = 1 To Len(StringB$)
        XX$ = Mid(StringB$, GetLet&, 1)


        If XX$ <> "0" Or XX$ <> "1" Then
            If XX$ = "0" Or XX$ = "1" Then GoTo GetNext
            IsBinary = False
            Exit Function
        Else
            '''
        End If
GetNext:
    Next GetLet&
    IsBinary = True
End Function


0
 

Author Comment

by:Daron1
ID: 2697145
Adjusted points from 200 to 300
0
 

Author Comment

by:Daron1
ID: 2697146
This works perfect.  I have hit a small problem though.  The binary is quite a bit longer than I expected.  I copied the binary in the registry to be the default value at the end of the getsetting call. It is so big it takes VB6 4 forced line breaks to display it(this particular variable is a long sentence string).  Are you aware of something that operates exactly the same but requires fewer characters than binary?  I don't mind modifying this code you've supplied if I know I'm working in the right direction.
0
 
LVL 14

Expert Comment

by:wsh2
ID: 2697180
Rather than play with REG_DWORD and REG_BINARY functions what you really need is an data Encryption/Decryption routine. Fortunately, to make one is not a hard thing to do.. <smile>.

Try This..

1. Create a New Standard.Exe Project and Copy/Paste the following into the code window.
2. Press F5 to run.

<----- Code Begin ----->

Option Explicit

Private Sub Form_Load()
   ' Routines that will encrypt/decrypt up to 94 characters
   Dim strWork1 As String
   Dim strWork2 As String
   strWork1 = xEncrypt("Your Password Here")
   strWork2 = xDecrypt(strWork1)
   MsgBox strWork1 & vbCrLf & strWork2
End Sub

Private Function xEncrypt _
(ByVal strInput As String) _
As String

   If Len(strInput) <= 0 _
   Or Len(strInput) >= 94 _
   Then
      Exit Sub
   End If
   
   Dim lngEncrypt As Long
   Dim lngIndex As Long
   Dim strOutput As String
   
   strOutput = Space(Len(strInput))
   For lngIndex = 1 To Len(strInput)
      lngEncrypt = Asc(Mid(strInput, lngIndex, 1))
      If lngEncrypt >= 32 _
      And lngEncrypt <= 126 _
      Then
         lngEncrypt = lngEncrypt + lngIndex
         If lngEncrypt > 126 _
         Then
            lngEncrypt = lngEncrypt - 126 + 32
         End If
      End If
      Mid(strOutput, Len(strInput) - lngIndex + 1, 1) = Chr(lngEncrypt)
   Next lngIndex
   xEncrypt = strOutput

End Function

Private Function xDecrypt _
(ByVal strInput As String) _
As String

   If Len(strInput) <= 0 _
   Then
      Exit Sub
   End If
   
   Dim lngEncrypt As Long
   Dim lngIndex As Long
   Dim strOutput As String
   strOutput = Space(Len(strInput))
   For lngIndex = 1 To Len(strInput)
      lngEncrypt = Asc(Mid(strInput, lngIndex, 1))
      If lngEncrypt >= 32 _
      And lngEncrypt <= 126 _
      Then
         lngEncrypt = lngEncrypt - (Len(strInput) - lngIndex + 1)
         If lngEncrypt < 32 _
         Then
            lngEncrypt = lngEncrypt + 126 - 32
         End If
      End If
      Mid(strOutput, Len(strInput) - lngIndex + 1, 1) = Chr(lngEncrypt)
   Next lngIndex
   xDecrypt = strOutput

End Function

<----- Code End ----->

Naturally you can embellish it if you like.. <smile>.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
Most everyone who has done any programming in VB6 knows that you can do something in code like Debug.Print MyVar and that when the program runs from the IDE, the value of MyVar will be displayed in the Immediate Window. Less well known is Debug.Asse…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

895 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now