Hi, i have tried the code below, which succesfully encrpyt outlook emails and microsoft word, including password into string. but does not work when attempting to unencrpt. I get not responding application and have to close. grateful for anyones attention to fix code.
Dim iMAXLEN As Integer
Dim chSlashR As String
Dim chSlashN As String
Dim strText As String
Dim strPass As String
Dim bToCode As Boolean
Sub OutlookToCode()
bToCode = True
ExecuteOutlook (bToCode)
End Sub
Sub OutlookFromCode()
bToCode = False
ExecuteOutlook (bToCode)
End Sub
Sub WordToCode()
bToCode = True
ExecuteWord (bToCode)
End Sub
Sub WordFromCode()
bToCode = False
ExecuteWord (bToCode)
End Sub
Sub ExcelToCode()
bToCode = True
ExecuteExcel (bToCode)
End Sub
Sub ExcelFromCode()
bToCode = False
ExecuteExcel (bToCode)
End Sub
' //------------------------------------------------------------------ ExecuteOutlook Function
Function ExecuteOutlook(ByVal bToCode As Boolean)
strText = ""
strPass = ""
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objItem As Object
On Error Resume Next
Set objOL = Application
Set objItem = objOL.ActiveInspector.CurrentItem 'or objOL.ActiveExplorer.Selection(1)
If Not objItem Is Nothing Then
Set objNS = objOL.Session 'Dim strStamp As String 'strStamp = Now & " - " & objNS.CurrentUser.Name
strText = objItem.Body
End If
If Len(strText) > 2 Then
strPass = InputBox("Password (code)", "Please provide password", "")
strText = PerformToFromCode(strText, strPass, bToCode)
Else
strText = "Error"
End If
If Len(strText) > 0 And StrComp(strText, "Error") <> 0 Then
objItem.Body = strText '& vbCrLf & strStamp
End If
Set objOL = Nothing
Set objNS = Nothing
Set objItem = Nothing
End Function
' //------------------------------------------------------------------ ExecuteWord
Function ExecuteWord(ByVal bToCode As Boolean)
Dim singleLine As Paragraph
strText = ""
strPass = ""
For Each singleLine In ActiveDocument.Paragraphs
strText = strText + singleLine.Range.Text
Next singleLine
strPass = InputBox("Password (code)", "Please provide password", "")
strText = PerformToFromCode(strText, strPass, bToCode)
If Len(strText) > 0 And StrComp(strText, "Error") <> 0 Then
ActiveDocument.Range.Text = strText
End If
End Function
' //------------------------------------------------------------------ ExecuteExcel
Function ExecuteExcel(ByVal bToCode As Boolean)
strText = ""
strPass = ""
strText = ActiveCell.Value
strPass = Application.InputBox(prompt:="Please provide code:")
ActiveCell.Value = PerformToFromCode(strText, strPass, bToCode)
strText = PerformToFromCode(strText, strPass, bToCode)
If Len(strText) > 0 And StrComp(strText, "Error") <> 0 Then
ActiveCell.Value = strText
End If
End Function
' //------------------------------------------------------------------ PerformToFromCode
Function PerformToFromCode(ByVal strText As String, ByVal strPass As String, ByVal bToCode As Boolean) As String
If Len(strText) < 2 Then
sTemp = "Could not see text"
MsgBox (sTemp)
PerformToCode = "Error"
Exit Function
End If
If Len(strPass) < 2 Then
sTemp = "Please provide password(code)"
MsgBox (sTemp)
PerformToCode = "error"
Exit Function
End If
iMAXLEN = 1000
chSlashR = Chr(13) '"\r"
chSlashN = Chr(10) '"\n"
Dim sCoded As String
If bToCode Then
sCoded = ToCode(strText, strPass)
Else
sCoded = FromCode(strText, strPass)
End If
PerformToFromCode = sCoded
End Function
' //------------------------------------------------------------------ BuildPosition
Function BuildPosition(ByRef intTemp() As Integer, ByVal iTxtLength As Integer) As Integer
Dim i As Integer
Dim iPos As Integer
Dim iLength As Integer
iPos = 1
iLength = UBound(intTemp) - 1
For i = 0 To iLength Step 1
iPos = iPos + intTemp(i)
Next
If (iTxtLength <= iPos) Then
Do While (iPos > iTxtLength)
iPos = iPos / 2
Loop
End If
BuildPosition = iPos
End Function
' //------------------------------------------------------------------ BuildNumber
Public Function BuildNumber(ByVal strPass As String) As Integer()
Dim intTemp(1000) As Integer
Dim iReturn() As Integer
Dim chTemp As String
Dim i As Integer
Dim strTemp
Dim str As String
Dim length As Integer
Dim cTemp As String
Dim bUseFullSize As Boolean
bUseFullSize = False
strTemp = ""
length = Len(strPass)
For i = 1 To length Step 1
cTemp = Mid(strPass, 1, 1)
intTemp(i - 1) = Asc(cTemp)
strTemp = strTemp + CStr(intTemp(i - 1))
Next
length = Len(strTemp)
For i = 1 To length Step 1
chTemp = Mid(strTemp, 1, 1)
intTemp(i - 1) = CInt(chTemp)
Next
If (intTemp(1) = 0) Then
If (intTemp(0) = 1) Then
intTemp(0) = 2
End If
End If
If bUseFullSize Then
BuildNumber = intTemp()
Else
ReDim iReturn(length)
For i = 0 To length Step 1
iReturn(i) = intTemp(i)
Next
BuildNumber = iReturn()
End If
End Function
' //------------------------------------------------------------ ChangeMinus
Public Function ChangeMinus(ByVal iNumber As Integer) As Integer
Dim iRet As Integer
Select Case iNumber
Case 0: iRet = 6
Case 1: iRet = 6
Case 2: iRet = 5
Case 3: iRet = 5
Case 4: iRet = 4
Case 5: iRet = 4
Case 6: iRet = 3
Case 7: iRet = 3
Case 8: iRet = 2
Case 9: iRet = 2
Case Else: iRet = 6
End Select
ChangeMinus = iRet
End Function
' //------------------------------------------------------GetFromAscii
Public Function GetFromAscii(ByRef regStr As String, ByVal iMinus As Integer) As String
Dim strBuff As String
Dim i, minus, integ As Integer
Dim getCh As String
Dim strTemp As String
Dim iLength As Integer
strBuff = ""
strTemp = reverseMe(regStr)
iLength = Len(regStr)
For i = 1 To iLength Step 1
getCh = Mid(strTemp, i, 1)
integ = Asc(getCh)
If (integ <= 5) Then
Select Case integ
Case 1: minus = 123
Case 2: minus = 124
Case 3: minus = 125
Case 4: minus = 126
Case Else: minus = 42
End Select
Else: minus = integ - iMinus
End If
strBuff = strBuff + Chr(minus)
Next
GetFromAscii = strBuff
End Function
' //------------------------------------------------------------------ ChangeToAscii
Public Function ChangeToAscii(ByVal regStr As String, ByVal iMinus As Integer) As String
Dim i As Integer
Dim minus As Integer
Dim finalStr As String
Dim intTemp() As Integer
Dim temp As String
Dim iLength As Integer
Dim cTemp As String
finalStr = ""
temp = regStr
iLength = Len(temp)
ReDim intTemp(iLength)
For i = 1 To iLength Step 1
cTemp = Mid(temp, i, 1)
intTemp(i - 1) = Asc(cTemp)
If (intTemp(i) >= 123) Then
Select Case intTemp(i)
Case 123: minus = 1
Case 124: minus = 2
Case 125: minus = 3
Case 126: minus = 4
Case Else: minus = 5
End Select
Else: minus = intTemp(i - 1) + iMinus
End If
finalStr = finalStr + Chr(minus)
Next
finalStr = reverseMe(finalStr)
ChangeToAscii = finalStr
End Function
' //------------------------------------------------------------------ reverseMe
Public Function reverseMe(ByVal s As String) As String
Dim sb As String
Dim i As Integer
sb = ""
i = Len(s)
Do While i > 0
sb = sb + Mid(s, i, 1)
i = i - 1
Loop
reverseMe = sb
End Function
' //----------------------------------------------------------------- ClearIdent
Public Function ClearIdent(ByVals As String) As String
Dim bChangeForSpace As Boolean
Dim strText As String
Dim i As Integer
Dim iLength As Integer
bChangeForSpace = False
strText = s
iLength = Len(strText)
If bChangeForSpace Then
For i = 1 To iLength Step 1
If Mid(strText, i, 1) = "Æ" Then
Mid(strText, i, 1) = ""
End If
Next
Else
i = InStr(strText, "Æ")
If i > 0 And i <= iLength Then
strText = Right(strText, iLength - i)
iLength = Len(strText)
End If
i = InStr(strText, "Æ")
If i > 1 Then
strText = Left(strText, i - 1)
End If
End If
ClearIdent = strText
End Function
' //------------------------------------------------------------------ AddNsRs
Public Function AddNsRs(ByVal s As String) As String
Dim strText As String
Dim iLength As Integer
Dim sTemp As String
strText = s
iLength = Len(strText)
For i = 1 To iLength Step 1
sTemp = Mid(strText, i, 1)
If (sTemp = " ") Then
If (Mid(strText, i + 1, 1) = " ") Then
Mid(strText, i, 1) = vbCrLf
End If
ElseIf sTemp = sTempN Or sTemp = sTempR Then
strText = Left(strText, i) & vbCrLf & Right(strText, iLength - 1)
ElseIf (sTemp = vbCrLf) Then
Mid(strText, i, 1) = vbCrLf
End If
Next
AddNsRs = strText
End Function
' //------------------------------------------------------------------ ClearNs
Public Function ClearNs(ByRef s As String) As String
Dim strText As String
Dim cTemp As String
Dim i As Integer
strText = s
i = 1
Do While i < Len(strText)
cTemp = Mid(strText, i, 1)
If cTemp = " " Or sTemp = chSlashN Or sTemp = chSlashR Then
Mid(strText, i, 1) = " "
End If
i = i + 1
Loop
ClearNs = strText
End Function
' //------------------------------------------------------------------ ClearRs
Public Function ClearRs(ByRef s As String) As String
Dim iLength As Integer
Dim cTemp As String
Dim strText As String
strText = s
iLength = Len(s)
If (iLength < 1) Then
ClearRs = ""
End If
Dim i As Integer
i = 1
Do While i < iLength
cTemp = Mid(strText, i, 1)
If cTemp = "" Or sTemp = chSlashN Or sTemp = chSlashR Then
Mid(strText, i, 1) = ""
End If
i = i + 1
Loop
ClearRs = strText
End Function
' //------------------------------------------------------ ChangePosForward
Public Function ChangePosForward(ByVal str As String, ByRef intTemp() As Integer, ByVal length As Integer) As String
Dim strLength As Integer
strLength = Len(str)
If (strLength = 0) Then
ChangePosForward = str
End If
Dim i, subIndex, pos As Integer
Dim iStep As Integer
Dim chTemp, chTempPos As String
Dim strRet As String
i = 0
iStep = 0
strRet = str
strLength = strLength + 1
On Error GoTo ErrHandler: Do While (i < strLength)
subIndex = 0
Do While i < strLength And subIndex < length
pos = iStep + intTemp(subIndex)
If (intTemp(subIndex) < length And pos < strLength) Then
chTemp = Mid(strRet, i + 1, 1)
chTempPos = Mid(strRet, pos + 1, 1)
Mid(strRet, i + 1, 1) = chTempPos
Mid(strRet, pos + 1, 1) = chTemp
End If
i = i + 1
subIndex = subIndex + 1
Loop
iStep = i
Loop
ChangePosForward = strRet
ErrHandler: ChangePosForward = strRet
End Function
'------------------------------------------------------ ChangePosBack
Public Function ChangePosBack(ByRef str As String, ByRef intTemp() As Integer, ByRef length As Integer) As String
'End Function
Dim strLength As Integer
strLength = Len(str)
If strLength = 0 Then
ChangePosBack = str
End If
Dim strRet As String
Dim chTemp, chTempPos As String
Dim iStep As Integer
Dim i, pos, index, subIndex, iSubStep, iLeft As Integer
strRet = str
i = 0
iStep = 0
Do While (i < strLength)
iLeft = strLength - i
If (iLeft < length) Then
length = iLeft + 1
End If
iStep = i + length
subIndex = length - 1
index = 0
Do While i <= strLength And subIndex >= 0
pos = iStep - length + intTemp(subIndex)
iSubStep = iStep - (length - subIndex)
If (intTemp(subIndex) < length And pos < strLength And iSubStep < strLength) Then
chTemp = Mid(strRet, iSubStep + 1, 1)
chTempPos = Mid(strRet, pos + 1, 1)
Mid(strRet, iSubStep + 1, 1) = chTempPos
Mid(strRet, pos + 1, 1) = chTemp
End If
i = i + 1
index = index + 1
subIndex = subIndex - 1
Loop
iStep = i + length
Loop
ChangePosBack = strRet
End Function
' //------------------------------------------------------ActionToCode
Public Function ToCode(ByVal strText As String, ByVal strPass As String) As String
'End Function
Dim strTextStart As String
Dim i, iMinus, length, TxtLength As Integer
Dim iarrTemp() As Integer
length = Len(strPass)
If (length < 4) Then
ToCode = "Error"
Exit Function
End If
iarrTemp() = BuildNumber(strPass)
iMinus = ChangeMinus(iarrTemp(0))
i = Len(strText)
If (i = 0 Or i = 1) Then
ToCode = "Error"
Exit Function
End If
strText = ClearRs(strText)
strText = Trim(strText)
strText = ChangeToAscii(strText, iMinus)
strText = ChangePosForward(strText, iarrTemp(), length)
strPass = ChangeToAscii(strPass, iMinus)
strPass = ChangePosForward(strPass, iarrTemp(), length)
TxtLength = Len(strText) - 1
i = BuildPosition(iarrTemp(), TxtLength)
strTextStart = Mid(strText, 1, i)
strText = Right(strText, TxtLength - i + 1)
strText = "Æ" + strTextStart + strPass + strText + "Æ"
ToCode = strText
End Function
' //------------------------------------------------------ActionFromCode
Public Function FromCode(ByVal strCodedText As String, ByVal strPass As String) As String
'End Function
Dim bResult As Boolean
Dim i, iMinus, iTxtLength, length As Integer
Dim iarrTemp() As Integer
Dim strToTest, strTextStart, strText As String
If (Len(strPass) < 2) Then
FromCode = "Error"
Exit Function
End If
strToTest = ""
strCodedText = ClearNs(strCodedText)
strCodedText = ClearIdent(strCodedText)
strCodedText = LTrim(strCodedText)
length = Len(strPass)
iarrTemp() = BuildNumber(strPass)
iMinus = ChangeMinus(iarrTemp(0))
strPass = ChangeToAscii(strPass, iMinus)
strPass = ChangePosForward(strPass, iarrTemp(), length)
iTxtLength = Len(strCodedText) - length
i = BuildPosition(iarrTemp(), iTxtLength - 1)
strTextStart = Left(strCodedText, i)
iTxtLength = iTxtLength - i
i = i + 1
strToTest = Mid(strCodedText, i, length)
strText = Right(strCodedText, iTxtLength)
strCodedText = strTextStart + strText
If StrComp(strToTest, strPass) <> 0 Then
FromCode = "Error"
Exit Function
End If
strCodedText = LTrim(strCodedText)
strCodedText = ChangePosBack(strCodedText, iarrTemp(), length)
strCodedText = GetFromAscii(strCodedText, iMinus)
strCodedText = AddNsRs(strCodedText)
FromCode = strCodedText
End Function