Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people, just like you, are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Solved

registry

Posted on 2000-04-08
4
292 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

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
Excel VBA combine two working workbooks 8 60
VBA error replacing data 6 40
Run code from text file in vb 1 71
Child Form in front 4 49
Introduction I needed to skip over some file processing within a For...Next loop in some old production code and wished that VB (classic) had a statement that would drop down to the end of the current iteration, bypassing the statements that were c…
Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
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…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

792 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