Visual Basic

Option Explicit
'****************************************************************************************
'API CONSTANTS
'****************************************************************************************
Private Enum EditTypes
    WM_CUT = &H300
    WM_COPY = &H301
    WM_PASTE = &H302
    WM_CLEAR = &H303
    WM_UNDO = &H304
End Enum

Const EM_CANUNDO = &HC6
Const EM_GETMODIFY = &HB8

'****************************************************************************************
'API FUNCTIONS
'****************************************************************************************
Private Declare Function SendMessage Lib "user32" _
        Alias "SendMessageA" ( _
                ByVal hWnd As Long, _
                ByVal wMsg As Long, _
                ByVal wParam As Long, _
                lParam As Any) _
                As Long

'****************************************************************************************
'CONSTANTS - PRIVATE
'****************************************************************************************
'filter for dialog
Private Const mFILEMASK = "Text Files (*.txt)|*.txt|" & _
        "Encrypted Text Files (*.etf)|*.etf|" & _
        "All Files (*.*)|*.*"
'Initial caption for form
Private Const mCAPTION = "Text Encryption Utility"

'edit menu item constants
Const mUNDO = 0
Const mCUT = 2
Const mCOPY = 3
Const mPASTE = 4
Const mDELETE = 5
'toolbar item constants
Const mUNDOTOOL = 7
Const mCUTTOOL = 8
Const mCOPYTOOL = 9
Const mPASTETOOL = 10
Const mDELETETOOL = 11

'encoder increment value - needs to be same for encryption and decryption
Const mENCODE = 3

'****************************************************************************************
'VARIABLES - PRIVATE
'****************************************************************************************
'flag to track status of control key - True means control key is pressed
Private mbControlKey As Boolean
'flag to track changes in open document
Private mbIsDirty As Boolean
Private msFileTitle As String

'****************************************************************************************
'EVENTS - PRIVATE
'****************************************************************************************
Private Sub Form_Activate()
    ToggleEditMenu
    mbIsDirty = False
End Sub

Private Sub Form_Load()
    Call NewDocument
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    CheckModified
    Set frmMain = Nothing
    End
End Sub

Private Sub Form_Resize()
    With rtbScript
        .Top = tbrCommands.Height
        .Left = Me.ScaleLeft
        .Width = Me.ScaleWidth
        .Height = Me.ScaleHeight - sbrStatus.Height - tbrCommands.Height
    End With
End Sub

Private Sub mnuEdit_Click(Index As Integer)
    Select Case Index
        Case mUNDO
            PerformEdit WM_UNDO
        Case mCUT
            PerformEdit WM_CUT
        Case mCOPY
            PerformEdit WM_COPY
        Case mPASTE
            PerformEdit WM_PASTE
        Case mDELETE
            PerformEdit WM_CLEAR
    End Select
End Sub

Private Sub mnuEditTop_Click()
    Call ToggleEditMenu
End Sub

Private Sub mnuExample_Click()
    Dim sMsg As String
    Dim iRet As Integer
    Dim sTitle As String
    
    sTitle = "Text Encryption Example"
    
    sMsg = "This Utility was Designed and Developed by Jim Kahl" & _
        " as a way to save Visual Basic Routines as encoded script files." & _
        vbCrLf & vbCrLf & "Do you want to see this message" & _
        " as it would appear in an encrypted file?"
        
    iRet = MsgBox(sMsg, vbInformation + vbYesNo, sTitle)
    If iRet = vbYes Then
        sMsg = Encrypt(sMsg)
        sTitle = Encrypt(sTitle)
        MsgBox sMsg, vbInformation, sTitle
    End If
    
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

Private Sub mnuFile_Click(Index As Integer)
    Select Case Index
        Case 0
            Call NewDocument
        Case 1
            Call OpenDocument
        Case 2
            Call SaveDocument
        Case Else
    End Select
    
End Sub

Private Sub mnuFind_Click(Index As Integer)
    With frmFind
        If Index = 1 Then
            .cmdReplace.Value = True
            .cmdReplace.Enabled = True
            .cmdReplaceAll.Visible = True
            .cmdReplaceAll.Enabled = True
            .lblReplace.Visible = True
            .cboReplace.Visible = True
        End If
        .Show
    End With
End Sub

Private Sub mnuSelect_Click()
    If TypeOf Me.ActiveControl Is TextBox Or _
        TypeOf Me.ActiveControl Is RichTextBox Then
            Me.ActiveControl.SelStart = 0
            Me.ActiveControl.SelLength = Len(Me.ActiveControl.Text)
    End If
    ToggleEditMenu
End Sub

Private Sub rtbScript_Change()
    ToggleEditMenu
    mbIsDirty = True
End Sub

Private Sub rtbScript_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyControl Then
        mbControlKey = True
    End If
End Sub

Private Sub rtbScript_KeyPress(KeyAscii As Integer)
    Debug.Print rtbScript.SelStart
    If KeyAscii = 9 Then
        KeyAscii = 0
        SendKeys Space(4)
    End If
End Sub

Private Sub rtbScript_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyControl Then
        mbControlKey = False
    End If
End Sub

Private Sub rtbScript_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ToggleEditMenu
End Sub

Private Sub tbrCommands_ButtonClick(ByVal Button As ComctlLib.Button)
    'this section is done this way so it is more or less
    'self documenting
    Select Case Button.Tag
        Case "New"
            Call NewDocument
        Case "Open"
            Call OpenDocument
        Case "Save"
            Call SaveDocument
        Case "Print"
            Call PrintDocument
        Case "Undo"
            PerformEdit WM_UNDO
        Case "Cut"
            PerformEdit WM_CUT
        Case "Copy"
            PerformEdit WM_COPY
        Case "Paste"
            PerformEdit WM_PASTE
        Case "Delete"
            PerformEdit WM_CLEAR
        Case "Find"
            frmFind.Show
        Case Else
    End Select
End Sub

'****************************************************************************************
'METHODS - PRIVATE------------------------------THIS_____________________________________
'****************************************************************************************
Private Function Encrypt(ByRef TestScript As String) As String
    Dim nLen As Long
    Dim lCur As Long
    Dim lCodes As Long
    Dim sInput As String
    Dim sOut As String
    Dim sFirst As String
    Dim lEncode As Long
    
    sbrStatus.Panels("pnlMessage").Text = "Encoding Text... Please Wait"
    'NOTE: this encryption routine encodes everything including spaces, tabs,
    'carriage returns, etc. so it in effect saves the text exactly as formatted
    'and does not actually reduce the size of the resulting file: a 7KB Text file
    'will be a 7KB encoded text file
    nLen = Len(TestScript)
    sInput = TestScript
    Do Until lCur = nLen
        lCur = lCur + 1
        'increment encoder value
        lEncode = lEncode + mENCODE
        If lEncode >= &HFF Then lEncode = 1
        'get the next character in our script
        sFirst = Mid(sInput, lCur, 1)
        'get ascii character value and encode
        lCodes = Asc(sFirst)
        lCodes = lCodes Xor lEncode
        'add encoded character to out string
        sOut = sOut & Chr(lCodes)
    Loop
    Encrypt = sOut
    sbrStatus.Panels("pnlMessage").Text = "Encoding Complete!"
End Function

Private Function Decrypt(ByRef TestScript As String) As String
    Dim nLen As Long
    Dim lCur As Long
    Dim lCodes As Long
    Dim sInput As String
    Dim sOut As String
    Dim sFirst As String
    Dim lEncode As Long
    
    nLen = Len(TestScript)
    sInput = TestScript
    
    sbrStatus.Panels("pnlMessage").Text = "Decoding File... Please Wait"
    'NOTE: this simply decodes the encoded text preserving all characters, including
    'spaces, tabs, carriage returns so the text looks exactly as it did before it
    'went through the encryption process
    Do Until lCur = nLen
        lCur = lCur + 1
        'increment encoder value
        lEncode = lEncode + mENCODE
        If lEncode >= &HFF Then lEncode = 1
        'retrieve a character from the script
        sFirst = Mid(sInput, lCur, 1)
        'get ascii character value and decode
        lCodes = Asc(sFirst)
        lCodes = lCodes Xor lEncode
        'add decoded character to our string
        sOut = sOut & Chr(lCodes)
    Loop
    
    'make sure we do not display the end of file marker
    Decrypt = Left(sOut, Len(sOut) - 2)
    sbrStatus.Panels("pnlMessage").Text = "Decoding Complete!"
End Function

Private Sub NewDocument()
    CheckModified
    'set caption to default and empty the textbox
    Me.Caption = mCAPTION
    rtbScript.Text = vbNullString
    mbIsDirty = False
End Sub

Private Sub OpenDocument()
    On Error GoTo OpenDocumentErr
                
    Dim f As Integer
    Dim sFile As String
    Dim sLine As String
    
    'has present text been modified?
    CheckModified
    
    Screen.MousePointer = vbHourglass
    Me.Caption = mCAPTION
    'setup and return common dialog values
    With cdlFiles
        .Filter = mFILEMASK
        .FilterIndex = 2
        .InitDir = "c:\temp"
        .CancelError = True
        .ShowOpen
        sbrStatus.Panels("pnlMessage").Text = "Opening File... Please Wait!"
        
        rtbScript.Text = vbNullString
        Me.Refresh
        f = FreeFile
        'need to open encrypted files as binary
        If InStr(1, LCase(.FileName), ".etf") Then
            Open .FileName For Binary As #f
                sFile = Input(32000, #f)
                rtbScript.Text = Decrypt(sFile)
            Close #f
        'anything else we treat as simple text
        Else
            Open .FileName For Input As #f
                Do Until EOF(f)
                    Line Input #f, sLine
                    sFile = sFile & vbCrLf & sLine
                Loop
                rtbScript.Text = sFile
            Close #f
        End If
                
        'set form caption to display filename
        msFileTitle = .FileTitle
        Me.Caption = Me.Caption & " - " & msFileTitle
    End With
    
    mbIsDirty = False
    
OpenDocumentExit:
    'cleanup and exit
    Screen.MousePointer = vbDefault
    sbrStatus.Panels("pnlMessage").Text = vbNullString
    Exit Sub
    
OpenDocumentErr:
    If Err.Number <> 32755 Then
        'user did not cancel so display error message
        Dim sMsg As String
        Dim sTitle As String
        Dim lRet As Long
        
        sMsg = Err.Number & ": " & Err.Description
        sTitle = "Error Opening File"
        
        lRet = MsgBox(sMsg, vbCritical + vbRetryCancel, sTitle)
        If lRet = vbRetry Then
            'try to open the document again
            Call OpenDocument
        End If
    End If
    GoTo OpenDocumentExit
    
End Sub

Private Sub SaveDocument()
    On Error GoTo SaveDocumentErr
    
    Dim f As Integer
    Dim sFile As String
    Dim iCnt As Integer
    Dim sSearch As String
    Dim sReplace As String
    
    Const NIL = "0"
    Const ONE = "1"
    Const TWO = "2"
    Const TRE = "3"
            
    Screen.MousePointer = vbHourglass
    'first replace constants with their literal equivalents
    sbrStatus.Panels("pnlMessage").Text = "Replacing Enumerated Constants with Literal Values"
    
    'replace all constants with their literal equivalents
    
    'NOTE: This section taken out for Company confidentiality
    'Example:
    'Replace "TEST", "5"
    
    sbrStatus.Panels("pnlMessage").Text = vbNullString
    
    mbIsDirty = True
    
    'setup and return common dialog
    With cdlFiles
        .Filter = mFILEMASK
        .FilterIndex = 2
        .InitDir = "c:\temp"
        .CancelError = True
        .ShowSave
        sbrStatus.Panels("pnlMessage").Text = "Saving File... Please Wait"
        Me.Refresh
        f = FreeFile
        'encrypt script file
        If InStr(1, .FileName, ".etf") Then
            sFile = Encrypt(rtbScript.Text)
        'save as simple text file
        Else
            sFile = rtbScript.Text
        End If
        
        Open .FileName For Output As #f
            Print #f, sFile
        Close #f
        mbIsDirty = False
        
        'change caption to reflect filename
        msFileTitle = .FileTitle
        Me.Caption = mCAPTION & " - " & msFileTitle
    End With
    
    
SaveDocumentExit:
    'return the mouse pointer to default before exiting
    Screen.MousePointer = vbDefault
    sbrStatus.Panels("pnlMessage").Text = vbNullString
    Exit Sub
    
SaveDocumentErr:
    If Err.Number <> 32755 Then
        'user did not cancel so display error message
        Dim sMsg As String
        Dim sTitle As String
        Dim lRet As Long
        
        sMsg = Err.Number & ": " & Err.Description
        sTitle = "Error Saving File"
        
        lRet = MsgBox(sMsg, vbCritical + vbRetryCancel, sTitle)
        If lRet = vbRetry Then
            Call SaveDocument
        End If
    End If
    GoTo SaveDocumentExit
End Sub

Private Sub PrintDocument()
    'not sure why but any line greater than the page width gets clipped and doesn't wrap
    'to the next line when it's printed
    sbrStatus.Panels("pnlMessage").Text = "Printing Document"
    CheckModified
    'set up the printer object and send contents of text box to it
    With Printer
        With .Font
            .Name = "Courier New"
            .Size = 10
        End With
        .Orientation = vbPRORPortrait
        .PaperSize = vbPRPSLetter
        Printer.Print rtbScript.Text
        .EndDoc
    End With
    sbrStatus.Panels("pnlMessage").Text = vbNullString
End Sub

Private Sub Replace(ByVal Find As String, ByVal Replace As String)
    'this is a scaled down version of the routine in frmFind since
    'we are performing a replace all for our enumerated constants
    Dim lszFile As Long
    Dim iFile1 As Integer
    Dim iFile2 As Integer
    Dim lszFind As Long
    Dim lszReplace As Long
    Dim sLine As String
    Dim lStart As Long
    Dim lRet As Long
    Dim sLine1 As String
    Dim sLine2 As String
    Dim sNewLine As String
    
    Const OLDFILE = "c:\oldtemp.txt"
    Const NEWFILE = "c:\newtemp.txt"
    
    Find = Trim(Find)
    Replace = Trim(Replace)
        
    On Error GoTo ErrHandler
          
   'create temporary file of current contents
    frmMain.rtbScript.SaveFile OLDFILE
    'return the file length of temp file
    lszFile = FileLen(OLDFILE)
    
    'open both temp files
    iFile1 = FreeFile
    Open OLDFILE For Input As #iFile1
    iFile2 = FreeFile
    Open NEWFILE For Output As #iFile2

    'get the length of the find and replace strings
    lszFind = Len(Find)
    lszReplace = Len(Replace)

    Do Until EOF(iFile1)
        'read in the first line to get going
        Line Input #iFile1, sNewLine
        lStart = 1

        Do Until lStart >= Len(sNewLine)
            lRet = InStr(lStart, sNewLine, Find, vbTextCompare)
            If lRet = 0 Then
                Exit Do
            Else
                'selection found so replace it and set position to start
                'searching again
                sLine1 = Left(sNewLine, lRet - 1)
                sLine2 = Mid(sNewLine, (lRet + lszFind))
                sNewLine = sLine1 & Replace & sLine2
                lStart = lRet + lszReplace
            End If
        Loop
        'print the updated line to the new temp file
        Print #iFile2, sNewLine
    Loop

    Close
    
    'load the contents of the new temp file into the test box
    rtbScript.LoadFile NEWFILE

    'delete the temp files
    Kill OLDFILE
    Kill NEWFILE
    
    Exit Sub
    
ErrHandler:
    Debug.Print Err.Number & ": " & Err.Description
End Sub

Private Sub PerformEdit(ByRef EditType As EditTypes)
    If TypeOf Me.ActiveControl Is TextBox Then
        Call SendMessage(Me.ActiveControl.hWnd, EditType, 0, 0&)
    ElseIf TypeOf Me.ActiveControl Is RichTextBox Then
        If mbControlKey = False Then
            Call SendMessage(Me.ActiveControl.hWnd, EditType, 0, 0&)
        End If
    Else
    End If
End Sub

Private Sub ToggleEditMenu()
    On Error Resume Next
    If TypeOf Me.ActiveControl Is TextBox Or _
            TypeOf Me.ActiveControl Is RichTextBox Then
        'Determine if last edit can be undone
        Me.mnuEdit(mUNDO).Enabled = SendMessage(Me.ActiveControl.hWnd, EM_CANUNDO, 0, 0&)
        'See if there's anything to cut, copy, or delete
        Me.mnuEdit(mCUT).Enabled = Me.ActiveControl.SelLength
        Me.mnuEdit(mCOPY).Enabled = Me.ActiveControl.SelLength
        Me.mnuEdit(mDELETE).Enabled = Me.ActiveControl.SelLength
        'See if there's anything to paste
        Me.mnuEdit(mPASTE) = Clipboard.GetFormat(vbCFText)
        'enable disable toolbar buttons based on menu items
        Me.tbrCommands.Buttons(mUNDOTOOL).Enabled = Me.mnuEdit(mUNDO).Enabled
        Me.tbrCommands.Buttons(mCUTTOOL).Enabled = Me.mnuEdit(mCUT).Enabled
        Me.tbrCommands.Buttons(mCOPYTOOL).Enabled = Me.mnuEdit(mCOPY).Enabled
        Me.tbrCommands.Buttons(mDELETETOOL).Enabled = Me.mnuEdit(mDELETE).Enabled
        Me.tbrCommands.Buttons(mPASTETOOL).Enabled = Me.mnuEdit(mPASTE).Enabled
    Else
        'If active control is not a textbox then disable all
        Me.mnuEdit(mUNDO).Enabled = False
        Me.mnuEdit(mCUT).Enabled = False
        Me.mnuEdit(mCOPY).Enabled = False
        Me.mnuEdit(mPASTE).Enabled = False
        Me.mnuEdit(mDELETE).Enabled = False
        Me.tbrCommands.Buttons(mUNDOTOOL).Enabled = False
        Me.tbrCommands.Buttons(mCUTTOOL).Enabled = False
        Me.tbrCommands.Buttons(mCOPYTOOL).Enabled = False
        Me.tbrCommands.Buttons(mDELETETOOL).Enabled = False
        Me.tbrCommands.Buttons(mPASTETOOL).Enabled = False
    End If
End Sub

Private Sub CheckModified()
    Dim lRet As Integer
    
    'See if user has changed the text, and if so prompt before loading new copy.
    If mbIsDirty Then
        If SendMessage(rtbScript.hWnd, EM_GETMODIFY, 0, 0&) Then
            lRet = MsgBox("Text has been modified do you wish to save it?", _
                    vbYesNo + vbQuestion, "Warning")
        End If
    End If
    
    If lRet = vbYes Then SaveDocument
    
End Sub

moonshaddow wrote:

sha512 but i don't want to use the ones provided by visual studio