Reading and Writing binary File

I am trying to use a binary file to secure passing of a string.  This would be helpful because if the user emails the excel file they would not have the binary file to be able to connect to data.  Some experts helped me with the below code but the problem I am having is that I do not want to have both the create and read the binary file in the same excel file.  I need to be able to create the file and then read it later.  

Thanks for the help,
Montrof


 Here is the code




Sub ReadBinary(oMyInfo As String)
    Dim mFNo As Long
    Dim DataDir As String, mFleNm As String
    DataDir = "C:\SomeDirectory\"
    mFleNm = "MySuperSecetPassWordFile.Sec"
    mFNo = FreeFile
    On Error Resume Next
    Open DataDir & mFleNm For Binary Access Read Write As #mFNo
    Get #mFNo, 1, oMyInfo
    Close mFNo
    If Err.Number <> 0 Then Err.Clear
    On Error GoTo 0
End Sub

Sub WriteBinary(iMyInfo As String)
    Dim mFNo As Long
    Dim DataDir As String, mFleNm As String
    DataDir = "C:\SomeDirectory\"
    mFleNm = "MySuperSecetPassWordFile.Sec"
    mFNo = FreeFile
    On Error Resume Next
    Open DataDir & mFleNm For Binary Access Read Write As #mFNo
    Put #mFNo, 1, oMyInfo
    Close mFNo
    If Err.Number <> 0 Then Err.Clear
    On Error GoTo 0
End Sub





Sub Main()
    Dim UserName As String, Password As String
    Dim Newstring As String
    'set the login
    UserName = "FredDollarStore"
    Password = "FriedTaters"
    Newstring = Space(10) & ">" & UserName & "<" & String(50, 14) & ">" & Password & "<" & String(59, 12)
    'write the username and password to the file
    WriteBinary Newstring
    'read the user name and password from the file
    ReadBinary Newstring
    UserName = Mid(Newstring, 12, InStr(12, Newstring, "<") - 12)
    Password = Mid(Newstring, InStr(50, Newstring, ">") + 1, (InStr(50, Newstring, "<") - 1) - (InStr(50, Newstring, ">")))
End Sub

Open in new window

LVL 1
montrofAsked:
Who is Participating?
 
montrofAuthor Commented:
I was able to figure it out

Private Declare Function GetPrivateProfileStringA Lib _
    "kernel32" (ByVal strSection As String, _
    ByVal strKey As String, ByVal strDefault As String, _
    ByVal strReturnedString As String, _
    ByVal lngSize As Long, ByVal strFileNameName As String) As Long
Private Declare Function WritePrivateProfileStringA Lib _
    "kernel32" (ByVal strSection As String, _
    ByVal strKey As String, ByVal strString As String, _
    ByVal strFileNameName As String) As Long
Public Function Encrypt(ToEncrypt As Variant) As String
tmpEncrypt = ""
Encrypt = ""
For T = 1 To Len(ToEncrypt)
tmpEncrypt = tmpEncrypt & Chr(Asc(Mid(ToEncrypt, T, 1)) + 128)
If Len(tmpEncrypt) = 1000 Then
DoEvents
Encrypt = Encrypt & tmpEncrypt
tmpEncrypt = ""
End If
Next T
Encrypt = Encrypt & tmpEncrypt
End Function

Sub WriteUserInfo()
' saves information in the file IniFileName
    If Not WritePrivateProfileString32("t:\secure.ini","SECURE", _
        "X:", "125255758") Then
        MsgBox "Not able to save user info in " & IniFileName, _
            vbExclamation, "Folder does not exist!"
        Exit Sub
    End If
    WritePrivateProfileString32 "t:\secure.ini","SECURE", _
        "X:", Encrypt("12334")
    WritePrivateProfileString32 "t:\secure.ini", "SECURE", _
        "XX:", Encrypt("543456234")
    WritePrivateProfileString32 "t:\secure.ini","SECURE", _
        "XXX:", Encrypt("245247")
End Sub
Private Function WritePrivateProfileString32(ByVal strFileName As String, _
    ByVal strSection As String, ByVal strKey As String, _
    ByVal strValue As String) As Boolean
Dim lngValid As Long
    On Error Resume Next
    lngValid = WritePrivateProfileStringA(strSection, strKey, _
        strValue, strFileName)
    If lngValid > 0 Then WritePrivateProfileString32 = True
    On Error GoTo 0
End Function


Sub ReadUserInfo()
' reads information from the file IniFileName
    If Dir("C:\Test.ini") = "" Then Exit Sub
    Range("B3").Formula = Decrypt(GetPrivateProfileString32("t:\secure.ini", _
       "SECURE", "X:"))
    Range("B4").Formula = Decrypt(GetPrivateProfileString32("t:\secure.ini", _
       "SECURE", "XX:"))
    Range("B5").Formula = Decrypt(GetPrivateProfileString32("t:\secure.ini", _
       "SECURE", "XXX:"))
End Sub
Private Function GetPrivateProfileString32(ByVal strFileName As String, _
    ByVal strSection As String, ByVal strKey As String, _
    Optional strDefault) As String
Dim strReturnString As String, lngSize As Long, lngValid As Long
    On Error Resume Next
    If IsMissing(strDefault) Then strDefault = ""
    strReturnString = Space(1024)
    lngSize = Len(strReturnString)
    lngValid = GetPrivateProfileStringA(strSection, strKey, _
        strDefault, strReturnString, lngSize, strFileName)
    GetPrivateProfileString32 = Left(strReturnString, lngValid)
    On Error GoTo 0
End Function
Public Function Decrypt(ToDecrypt As Variant) As String
tmpDecrypt = ""
Decrypt = ""
For T = 1 To Len(ToDecrypt)
tmpDecrypt = tmpDecrypt & Chr(Asc(Mid(ToDecrypt, T, 1)) - 128)
If Len(tmpDecrypt) = 1000 Then
DoEvents
Decrypt = Decrypt & tmpDecrypt
tmpDecrypt = ""
End If
Next T
Decrypt = Decrypt & tmpDecrypt
End Function

Open in new window

0
 
[ fanpages ]IT Services ConsultantCommented:
The previous Question thread, for reference:

"encypting sql connection string"
[ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28126785.html ]
0
 
montrofAuthor Commented:
Thanks
0
 
montrofAuthor Commented:
This is the solution I came up with.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.