string encryption/decryption - excel

I am interested if it's possible to do string encryption/decryption using Excel Visual Basic and some cryptographic service provider.
I have found a walk-through Encrypting and Decrypting Strings in Visual Basic, but it seems it's valid for standalone Visual Basic only.
So would you suggest me another encryption method or show how the walk-through could be adopted for Excel Visual Basic?

The link you provide shows how to perform string encryption and decryption using VB.NET, and thus, using the .NET Framework.
Currently, Microsoft Office products cannot yet use the Visual Studio Tools for Applications component which will enable Office products to access the .NET framework's BCL (base class libraries) which, in turn, access the underlying Windows CSP (cryptographic server provider) and provide a nice wrapper around those encryption/decryption functions.
For the time being, Office products are stuck with the old VBA (Visual Basic for Applications) which is based on the old VB6 (and earlier) versions of visual Basic which are based upon COM, rather than the .NET Framework.
Because of all of this, you will either need to call out to the Win32 API to access the CSP functions, or you will have to "roll-your-own" encryption method in pure VB6/VBA code, although this is likely to be less secure. It all depends upon how "secure" you'd like your encryption to be.
If you want to "roll-your-own" basic string encryption/decryption routine, take a look at these link to get you started:
Encrypt a String Easily
Better XOR Encryption with a readable string
vb6 - encryption function
Visual Basic 6 / VBA String Encryption/Decryption Function
If you want to access the Win32 API and use the underlying Windows CSP (a much more secure option), see these links for detailed information on how to achieve this:
How to encrypt a string in Visual Basic 6.0
Access to CryptEncrypt (CryptoAPI/WinAPI) functions in VBA
That last link is likely the one you'll want and includes a complete VBA Class module to "wrap" the Windows CSP functions.

This code works well for me (3DES Encryption/Decryption):
I store INITIALIZATION_VECTOR and TRIPLE_DES_KEY as environment variables (obviously different values than those posted here) and get them using VBA Environ() function, so all sensitive data (passwords) in VBA code is encrypted.
Option Explicit
Public Const INITIALIZATION_VECTOR = "zlrs$5kd" 'Always 8 characters
Public Const TRIPLE_DES_KEY = ">tlF8adk=35K{dsa" 'Always 16 characters
Sub TestEncrypt()
MsgBox "This is an encrypted string: -> " & EncryptStringTripleDES("This is an encrypted string:")
Debug.Print EncryptStringTripleDES("This is an encrypted string:")
End Sub
Sub TestDecrypt()
MsgBox "u99CVItCGiMQEVYHf8+S22QbJ5CPQGDXuS5n1jvEIgU= -> " & DecryptStringTripleDES("u99CVItCGiMQEVYHf8+S22QbJ5CPQGDXuS5n1jvEIgU=")
End Sub
Function EncryptStringTripleDES(plain_string As String) As Variant
Dim encryption_object As Object
Dim plain_byte_data() As Byte
Dim encrypted_byte_data() As Byte
Dim encrypted_base64_string As String
EncryptStringTripleDES = Null
On Error GoTo FunctionError
plain_byte_data = CreateObject("System.Text.UTF8Encoding").GetBytes_4(plain_string)
Set encryption_object = CreateObject("System.Security.Cryptography.TripleDESCryptoServiceProvider")
encryption_object.Padding = 3
encryption_object.key = CreateObject("System.Text.UTF8Encoding").GetBytes_4(TRIPLE_DES_KEY)
encryption_object.IV = CreateObject("System.Text.UTF8Encoding").GetBytes_4(INITIALIZATION_VECTOR)
encrypted_byte_data = _
encryption_object.CreateEncryptor().TransformFinalBlock(plain_byte_data, 0, UBound(plain_byte_data) + 1)
encrypted_base64_string = BytesToBase64(encrypted_byte_data)
EncryptStringTripleDES = encrypted_base64_string
Exit Function
FunctionError:
MsgBox "TripleDES encryption failed"
End Function
Function DecryptStringTripleDES(encrypted_string As String) As Variant
Dim encryption_object As Object
Dim encrypted_byte_data() As Byte
Dim plain_byte_data() As Byte
Dim plain_string As String
DecryptStringTripleDES = Null
On Error GoTo FunctionError
encrypted_byte_data = Base64toBytes(encrypted_string)
Set encryption_object = CreateObject("System.Security.Cryptography.TripleDESCryptoServiceProvider")
encryption_object.Padding = 3
encryption_object.key = CreateObject("System.Text.UTF8Encoding").GetBytes_4(TRIPLE_DES_KEY)
encryption_object.IV = CreateObject("System.Text.UTF8Encoding").GetBytes_4(INITIALIZATION_VECTOR)
plain_byte_data = encryption_object.CreateDecryptor().TransformFinalBlock(encrypted_byte_data, 0, UBound(encrypted_byte_data) + 1)
plain_string = CreateObject("System.Text.UTF8Encoding").GetString(plain_byte_data)
DecryptStringTripleDES = plain_string
Exit Function
FunctionError:
MsgBox "TripleDES decryption failed"
End Function
Function BytesToBase64(varBytes() As Byte) As String
With CreateObject("MSXML2.DomDocument").createElement("b64")
.DataType = "bin.base64"
.nodeTypedValue = varBytes
BytesToBase64 = Replace(.Text, vbLf, "")
End With
End Function
Function Base64toBytes(varStr As String) As Byte()
With CreateObject("MSXML2.DOMDocument").createElement("b64")
.DataType = "bin.base64"
.Text = varStr
Base64toBytes = .nodeTypedValue
End With
End Function
Source code taken from here: https://gist.github.com/motoraku/97ad730891e59159d86c
Note the difference between the original code and my code, that is additional option encryption_object.Padding = 3 which forces VBA to not perform padding. With padding option set to 3 I get result exactly as in C++ implementation of DES_ede3_cbc_encrypt algorithm and which is in agreement with what is produced by this online tool.

This code works fine in VBA and can easily be moved to VB.NET
Avoids dealing with not "normal" characters. You decide in AllowedChars what characters to allow.
Public Function CleanEncryptSTR(MyString As String, MyPassword As String, Encrypt As Boolean) As String
'Encrypts strings chars contained in Allowedchars
'MyString = String to decrypt
'MyPassword = Password
'Encrypt True: Encrypy False: Decrypt
Dim i As Integer
Dim ASCToAdd As Integer
Dim ThisChar As String
Dim ThisASC As Integer
Dim NewASC As Integer
Dim MyStringEncrypted As String
Dim AllowedChars As String
AllowedChars = "&0123456789;ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
If Len(MyPassword) > 0 Then
For i = 1 To Len(MyString)
' ThisASC = Asc(Mid(MyString, i, 1))
' ThisASC = IntFromArray(Asc(Mid(MyString, i, 1)), MyVector())
ThisChar = Mid(MyString, i, 1)
ThisASC = InStr(AllowedChars, ThisChar)
If ThisASC > 0 Then
ASCToAdd = Asc(Mid(MyPassword, i Mod Len(MyPassword) + 1, 1))
If Encrypt Then
NewASC = ThisASC + ASCToAdd
Else
NewASC = ThisASC - ASCToAdd
End If
NewASC = NewASC Mod Len(AllowedChars)
If NewASC <= 0 Then
NewASC = NewASC + Len(AllowedChars)
End If
MyStringEncrypted = MyStringEncrypted & Mid(AllowedChars, NewASC, 1)
Else
MyStringEncrypted = MyStringEncrypted & ThisChar
End If
Next i
Else
MyStringEncrypted = MyString
End If
CleanEncryptSTR = MyStringEncrypted
End Function

Create a Class Module called clsCifrado:
Option Explicit
Option Compare Binary
Private clsClave As String
Property Get Clave() As String
Clave = clsClave
End Property
Property Let Clave(value As String)
clsClave = value
End Property
Function Cifrar(Frase As String) As String
Dim Cachos() As Byte
Dim LaClave() As Byte
Dim i As Integer
Dim Largo As Integer
If Frase <> "" Then
Cachos() = StrConv(Frase, vbFromUnicode)
LaClave() = StrConv(clsClave, vbFromUnicode)
Largo = Len(clsClave)
For i = LBound(Cachos) To UBound(Cachos)
Cachos(i) = (Cachos(i) Xor LaClave(i Mod Largo)) + 34
Next i
Cifrar = StrConv(Cachos(), vbUnicode)
Else
Cifrar = ""
End If
End Function
Function Descifrar(Frase As String) As String
Dim Cachos() As Byte
Dim LaClave() As Byte
Dim i As Integer
Dim Largo As Integer
If Frase <> "" Then
Cachos() = StrConv(Frase, vbFromUnicode)
LaClave() = StrConv(clsClave, vbFromUnicode)
Largo = Len(clsClave)
For i = LBound(Cachos) To UBound(Cachos)
Cachos(i) = Cachos(i) - 34
Cachos(i) = (Cachos(i) Xor LaClave(i Mod Largo))
Next i
Descifrar = StrConv(Cachos(), vbUnicode)
Else
Descifrar = ""
End If
End Function
Now you can use it in your code:
to cipher
Private Sub btnCifrar_Click()
Dim Texto As String
Dim cCifrado As clsCifrado
Set cCifrado = New clsCifrado
'---poner la contraseña
If tbxClave.Text = "" Then
MsgBox "The Password is missing"
End Sub
Else
cCifrado.Clave = tbxClave.Text
End If
'---Sacar los datos
Texto = tbxFrase.Text
'---cifrar el texto
Texto = cCifrado.Cifrar(Texto)
tbxFrase.Text = Texto
End Sub
To descipher
Private Sub btnDescifrar_Click()
Dim Texto As String
Dim cCifrado As clsCifrado
Set cCifrado = New clsCifrado
'---poner la contraseña
If tbxClave.Text = "" Then
MsgBox "The Password is missing"
End Sub
Else
cCifrado.Clave = tbxClave.Text
End If
'---Sacar los datos
Texto = tbxFrase.Text
'---cifrar el texto
Texto = cCifrado.Descifrar(Texto)
tbxFrase.Text = Texto
End Sub

You can call pipe excel cell data through any shell script.
Install the GPL Bert (http://bert-toolkit.com/) R language interface for Excel.
Use the R script below in Excel to pipe cell data to Bash / perl / gpg / openssl.
c:\> cat c:\R322\callable_from_excel.R
CRYPTIT <- function( PLAINTEXT, MASTER_PASS ) {
system(
sprintf("bash -c 'echo '%s' |
gpg --symmetric --cipher-algo blowfish --force-mdc --passphrase '%s' -q |
base64 -w 0'",
PLAINTEXT, MASTER_PASS),
intern=TRUE)
}
DECRYPTIT <- function( CRYPTTEXT, MASTER_PASS ) {
system(
sprintf("bash -c 'echo '%s'|
base64 -d |
gpg --passphrase '%s' -q |
putclip | getclip' ",CRYPTTEXT,MASTER_PASS),
intern=TRUE)
}
In Excel, you can try: C1=CRYPTIT(A1,A2) and C2=DECRYPTIT(C1,A2)
Optional: putclip saves decrypted text in clipboard.
Both functions types are: String -> String.
Usual caveats about escaping single-quotes in single-quoted strings.

Here is a basic symmetric encryption/decryption example:
Sub testit()
Dim inputStr As String
inputStr = "Hello world!"
Dim encrypted As String, decrypted As String
encrypted = scramble(inputStr)
decrypted = scramble(encrypted)
Debug.Print encrypted
Debug.Print decrypted
End Sub
Function stringToByteArray(str As String) As Variant
Dim bytes() As Byte
bytes = str
stringToByteArray = bytes
End Function
Function byteArrayToString(bytes() As Byte) As String
Dim str As String
str = bytes
byteArrayToString = str
End Function
Function scramble(str As String) As String
Const SECRET_PASSWORD As String = "K*4HD%f#nwS%sdf032#gfl!HLKN*pq7"
Dim stringBytes() As Byte, passwordBytes() As Byte
stringBytes = stringToByteArray(str)
passwordBytes = stringToByteArray(SECRET_PASSWORD)
Dim upperLim As Long
upperLim = UBound(stringBytes)
ReDim scrambledBytes(0 To upperLim) As Byte
Dim idx As Long
For idx = LBound(stringBytes) To upperLim
scrambledBytes(idx) = stringBytes(idx) Xor passwordBytes(idx)
Next idx
scramble = byteArrayToString(scrambledBytes)
End Function
Be aware that this will crash if your given input string is longer than the SECRET_PASSWORD. This is just an example to get started with.

Related

Returning the numbers in a string as a variable [duplicate]

I need to find numbers from a string. How does one find numbers from a string in VBA Excel?
Assuming you mean you want the non-numbers stripped out, you should be able to use something like:
Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Calling this with:
Dim myStr as String
myStr = onlyDigits ("3d1fgd4g1dg5d9gdg")
MsgBox (myStr)
will give you a dialog box containing:
314159
and those first two lines show how you can store it into an arbitrary string variable, to do with as you wish.
Regular expressions are built to parse. While the syntax can take a while to pick up on this approach is very efficient, and is very flexible for handling more complex string extractions/replacements
Sub Tester()
MsgBox CleanString("3d1fgd4g1dg5d9gdg")
End Sub
Function CleanString(strIn As String) As String
Dim objRegex
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[^\d]+"
CleanString = .Replace(strIn, vbNullString)
End With
End Function
Expanding on brettdj's answer, in order to parse disjoint embedded digits into separate numbers:
Sub TestNumList()
Dim NumList As Variant 'Array
NumList = GetNums("34d1fgd43g1 dg5d999gdg2076")
Dim i As Integer
For i = LBound(NumList) To UBound(NumList)
MsgBox i + 1 & ": " & NumList(i)
Next i
End Sub
Function GetNums(ByVal strIn As String) As Variant 'Array of numeric strings
Dim RegExpObj As Object
Dim NumStr As String
Set RegExpObj = CreateObject("vbscript.regexp")
With RegExpObj
.Global = True
.Pattern = "[^\d]+"
NumStr = .Replace(strIn, " ")
End With
GetNums = Split(Trim(NumStr), " ")
End Function
Use the built-in VBA function Val, if the numbers are at the front end of the string:
Dim str as String
Dim lng as Long
str = "1 149 xyz"
lng = Val(str)
lng = 1149
Val Function, on MSDN
I was looking for the answer of the same question but for a while I found my own solution and I wanted to share it for other people who will need those codes in the future. Here is another solution without function.
Dim control As Boolean
Dim controlval As String
Dim resultval As String
Dim i as Integer
controlval = "A1B2C3D4"
For i = 1 To Len(controlval)
control = IsNumeric(Mid(controlval, i, 1))
If control = True Then resultval = resultval & Mid(controlval, i, 1)
Next i
resultval = 1234
This a variant of brettdj's & pstraton post.
This will return a true Value and not give you the #NUM! error. And \D is shorthand for anything but digits. The rest is much like the others only with this minor fix.
Function StripChar(Txt As String) As Variant
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\D"
StripChar = Val(.Replace(Txt, " "))
End With
End Function
This is based on another answer, but is just reformated:
Assuming you mean you want the non-numbers stripped out, you should be able to use something like:
'
' Skips all characters in the input string except digits
'
Function GetDigits(ByVal s As String) As String
Dim char As String
Dim i As Integer
GetDigits = ""
For i = 1 To Len(s)
char = Mid(s, i, 1)
If char >= "0" And char <= "9" Then
GetDigits = GetDigits + char
End If
Next i
End Function
Calling this with:
Dim myStr as String
myStr = GetDigits("3d1fgd4g1dg5d9gdg")
Call MsgBox(myStr)
will give you a dialog box containing:
314159
and those first two lines show how you can store it into an arbitrary string variable, to do with as you wish.
Alternative via Byte Array
If you assign a string to a Byte array you typically get the number equivalents of each character in pairs of the array elements. Use a loop for numeric check via the Like operator and return the joined array as string:
Function Nums(s$)
Dim by() As Byte, i&, ii&
by = s: ReDim tmp(UBound(by)) ' assign string to byte array; prepare temp array
For i = 0 To UBound(by) - 1 Step 2 ' check num value in byte array (0, 2, 4 ... n-1)
If Chr(by(i)) Like "#" Then tmp(ii) = Chr(by(i)): ii = ii + 1
Next i
Nums = Trim(Join(tmp, vbNullString)) ' return string with numbers only
End Function
Example call
Sub testByteApproach()
Dim s$: s = "a12bx99y /\:3,14159" ' [1] define original string
Debug.Print s & " => " & Nums(s) ' [2] display original string and result
End Sub
would display the original string and the result string in the immediate window:
a12bx99y /\:3,14159 => 1299314159
Based on #brettdj's answer using a VBScript regex ojbect with two modifications:
The function handles variants and returns a variant. That is, to take care of a null case; and
Uses explicit object creation, with a reference to the "Microsoft VBScript Regular Expressions 5.5" library
Function GetDigitsInVariant(inputVariant As Variant) As Variant
' Returns:
' Only the digits found in a varaint.
' Examples:
' GetDigitsInVariant(Null) => Null
' GetDigitsInVariant("") => ""
' GetDigitsInVariant(2021-/05-May/-18, Tue) => 20210518
' GetDigitsInVariant(2021-05-18) => 20210518
' Notes:
' If the inputVariant is null, null will be returned.
' If the inputVariant is "", "" will be returned.
' Usage:
' VBA IDE Menu > Tools > References ...
' > "Microsoft VBScript Regular Expressions 5.5" > [OK]
' With an explicit object reference to RegExp we can get intellisense
' and review the object heirarchy with the object browser
' (VBA IDE Menu > View > Object Browser).
Dim regex As VBScript_RegExp_55.RegExp
Set regex = New VBScript_RegExp_55.RegExp
Dim result As Variant
result = Null
If IsNull(inputVariant) Then
result = Null
Else
With regex
.Global = True
.Pattern = "[^\d]+"
result = .Replace(inputVariant, vbNullString)
End With
End If
GetDigitsInVariant = result
End Function
Testing:
Private Sub TestGetDigitsInVariant()
Dim dateVariants As Variant
dateVariants = Array(Null, "", "2021-/05-May/-18, Tue", _
"2021-05-18", "18/05/2021", "3434 ..,sdf,sfd 444")
Dim dateVariant As Variant
For Each dateVariant In dateVariants
Debug.Print dateVariant & ": ", , GetDigitsInVariant(dateVariant)
Next dateVariant
Debug.Print
End Sub
Public Function ExtractChars(strRef$) As String
'Extract characters from a string according to a range of charactors e.g'+.-1234567890'
Dim strA$, e%, strExt$, strCnd$: strExt = "": strCnd = "+.-1234567890"
For e = 1 To Len(strRef): strA = Mid(strRef, e, 1)
If InStr(1, strCnd, strA) > 0 Then strExt = strExt & strA
Next e: ExtractChars = strExt
End Function
In the immediate debug dialog:
? ExtractChars("a-5d31.78K")
-531.78

How to tokenize a string in Lotus Notes Script

I need to split a string into several tokens just like the java code below:
StringTokenizer st = new StringTokenizer(mystring);
while (st.hasMoreTokens()) {
System.out.println(st.nextToken());
}
You can use the function Split(myString, " "), where the first parameter is your string and the second one the token delimiter.
Here's the solution:
Dim myString = myDocument.myField(0)
Dim myTokens = Split(myString, " ")
Dim fisrtToken = myTokens(0)
Dim secondToken = myTokens(1)
Here's the code I implemented from the answers around for IBM Lotus Notes 7:
Function isTokenInStr(tokenStr As String, strToSearch As String) As Boolean
isTokenInStr = True
Dim tokenArr As Variant
tokenArr = Split(tokenStr, " ")
Dim idxTokenArr As Integer
For idxTokenArr = LBound(tokenArr) To UBound(tokenArr)
Dim tokenElementStr As String
tokenElementStr = tokenArr(idxTokenArr)
If InStr(strToSearch, tokenElementStr) <= 0 Then
isTokenInStr = False
Exit For
End If
next
End Function

Amazon web service IAM - Create User VB.NET - Signature Version 2 & 4

I am new to Amazon Identity management and I want to create new users by windows application. I know using AWS .NET SDK this is possible, but I need to create users using WSDL or API.
I need help on creating AWS IAM Signature version 2 or 4 code for IAM in VB.NET. Please find below the code and let me know the required the changes.
Imports System
Imports System.IO
Imports System.Net
Imports System.Text
Imports System.Web
Imports System.Collections.Generic
Imports System.Security.Cryptography
Public Class Form1
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim strURL As String
strURL = "https://iam.amazonaws.com/"
Dim strTimestamp As String = PercentEncodeRfc3986(DateTime.UtcNow.ToString("yyyy-MM-dd'T'HH:mm:ss'Z'"))
Dim strParams As String
strParams = "?AWSAccessKeyId=XXXXXXXX" &
"&Action=CreateUser" & _
"&Path=/" & _
"&UserName=User1" & _
"&Timestamp=" & strTimestamp & _
"&SignatureVersion=2" & _
"&Version=2010-05-08" & _
"&SignatureMethod=HmacSHA256"
Dim strStringToSign As String = "GET\nhttps://iam.amazonaws.com\n/\n" & strParams
strURL = strURL & strParams & "&Signature=" & PercentEncodeRfc3986(HashString(strStringToSign))
Dim wc As New WebClient()
Dim strResponse As String
strResponse = wc.DownloadString(strURL)
RichTextBox1.Text = strResponse
End Sub
Private Function PercentEncodeRfc3986(ByVal str As String) As String
str = HttpUtility.UrlEncode(str, System.Text.Encoding.UTF8)
str.Replace("'", "%27").Replace("(", "%28").Replace(")", "%29").Replace("*", "%2A").Replace("!", "%21").Replace("%7e", "~")
Dim sbuilder As New StringBuilder(str)
For i As Integer = 0 To sbuilder.Length - 1
If sbuilder(i) = "%"c Then
If [Char].IsDigit(sbuilder(i + 1)) AndAlso [Char].IsLetter(sbuilder(i + 2)) Then
sbuilder(i + 2) = [Char].ToUpper(sbuilder(i + 2))
End If
End If
Next
Return sbuilder.ToString()
End Function
Private Const PRIVATE_KEY As String = "XXXXXXX"
Private Function HashString(ByVal StringToHash As String) As String
Dim Key() As Byte = Encoding.UTF8.GetBytes(PRIVATE_KEY)
Dim XML() As Byte = Encoding.UTF8.GetBytes(StringToHash)
Dim myHMACSHA256 As New System.Security.Cryptography.HMACSHA256(Key)
Dim HashCode As Byte() = myHMACSHA256.ComputeHash(XML)
Return Convert.ToBase64String(HashCode)
End Function
End Class
Thanks,
Raj
I found solution for my problem and now I can build canonical & signed query to create a user in Amazon IAM using VB.NET windows application.
Please follow the below steps.
1.Create a VB.NET project and in AppConfig file, add your access & secret key.
<?xml version="1.0"?>
<configuration>
<appSettings>
<add key="AWSAccessKey" value="YOUR ACCESS KEY"/>
<add key="AWSSecretKey" value="YOUR SECRET KEY"/>
</appSettings>
</configuration>
2.Below is the code to call SignedHelperRequest
Imports System
Imports System.Collections.Generic
Imports System.Text
Imports System.Net
Imports System.IO
Imports System.Xml
Imports System.Web
Imports System.Xml.XPath
Imports System.Security.Cryptography
Imports System.Configuration
Public Class Form1
Dim MY_AWS_ACCESS_KEY_ID As String = ConfigurationManager.AppSettings("AWSAccessKey")
Dim MY_AWS_SECRET_KEY As String = ConfigurationManager.AppSettings("AWSSecretKey")
Const DESTINATION As String = "iam.amazonaws.com"
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim helper As New SignedRequestHelper(MY_AWS_ACCESS_KEY_ID, MY_AWS_SECRET_KEY, DESTINATION)
Dim requestParams As IDictionary(Of String, String) = New Dictionary(Of String, [String])()
requestParams("Action") = "CreateUser"
requestParams("Path") = "/"
requestParams("UserName") = Trim(TextBox1.Text)
requestParams("SignatureMethod") = "HmacSHA256"
requestParams("SignatureVersion") = "2"
requestParams("Version") = "2010-05-08"
Dim requestUrl As String = helper.Sign(requestParams)
Dim wc As New WebClient()
Dim strResponse As String
strResponse = wc.DownloadString(requestUrl)
RichTextBox1.Text = ""
RichTextBox1.Text = strResponse
End Sub
Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
Dim helper As New SignedRequestHelper(MY_AWS_ACCESS_KEY_ID, MY_AWS_SECRET_KEY, DESTINATION)
Dim requestParams As IDictionary(Of String, String) = New Dictionary(Of String, [String])()
requestParams("Action") = "ListUsers"
'requestParams("Marker") = ""
'requestParams("MaxItems") = ""
requestParams("PathPrefix") = "/"
requestParams("SignatureMethod") = "HmacSHA256"
requestParams("SignatureVersion") = "2"
requestParams("Version") = "2010-05-08"
Dim requestUrl As String = helper.Sign(requestParams)
Dim wc As New WebClient()
Dim strResponse As String
strResponse = wc.DownloadString(requestUrl)
RichTextBox1.Text = ""
RichTextBox1.Text = strResponse
End Sub
End Class
3.SignedRequestHelper Class
Imports System
Imports System.Collections.Generic
Imports System.Text
Imports System.Web
Imports System.Security.Cryptography
Class SignedRequestHelper
Private endPoint As String
Private akid As String
Private secret As Byte()
Private signer As HMAC
Private Const REQUEST_URI As String = "/onca/xml"
Private Const REQUEST_METHOD As String = "GET"
Public Sub New(ByVal awsAccessKeyId As String, ByVal awsSecretKey As String, ByVal destination As String)
Me.endPoint = destination.ToLower()
Me.akid = awsAccessKeyId
Me.secret = Encoding.UTF8.GetBytes(awsSecretKey)
Me.signer = New HMACSHA256(Me.secret)
End Sub
Public Function Sign(ByVal request As IDictionary(Of String, String)) As String
' Use a SortedDictionary to get the parameters in naturual byte order, as
' required by AWS.
Dim pc As New ParamComparer()
Dim sortedMap As New SortedDictionary(Of String, String)(request, pc)
' Add the AWSAccessKeyId and Timestamp to the requests.
sortedMap("AWSAccessKeyId") = Me.akid
sortedMap("Timestamp") = Me.GetTimestamp()
' Get the canonical query string
Dim canonicalQS As String = Me.ConstructCanonicalQueryString(sortedMap)
' Derive the bytes needs to be signed.
Dim builder As New StringBuilder()
builder.Append(REQUEST_METHOD).Append(vbLf).Append(Me.endPoint).Append(vbLf).Append(REQUEST_URI).Append(vbLf).Append(canonicalQS)
Dim stringToSign As String = builder.ToString()
Dim toSign As Byte() = Encoding.UTF8.GetBytes(stringToSign)
' Compute the signature and convert to Base64.
Dim sigBytes As Byte() = signer.ComputeHash(toSign)
Dim signature As String = Convert.ToBase64String(sigBytes)
' now construct the complete URL and return to caller.
Dim qsBuilder As New StringBuilder()
qsBuilder.Append("https://").Append(Me.endPoint).Append(REQUEST_URI).Append("?").Append(canonicalQS).Append("&Signature=").Append(Me.PercentEncodeRfc3986(signature))
Return qsBuilder.ToString()
End Function
'
' * Sign a request in the form of a query string.
' *
' * This method returns a complete URL to use. Modifying the returned URL
' * in any way invalidates the signature and Amazon will reject the requests.
'
Public Function Sign(ByVal queryString As String) As String
Dim request As IDictionary(Of String, String) = Me.CreateDictionary(queryString)
Return Me.Sign(request)
End Function
'
' * Current time in IS0 8601 format as required by Amazon
'
Private Function GetTimestamp() As String
Dim currentTime As DateTime = DateTime.UtcNow
Dim timestamp As String = currentTime.ToString("yyyy-MM-ddTHH:mm:ssZ")
Return timestamp
End Function
'
' * Percent-encode (URL Encode) according to RFC 3986 as required by Amazon.
' *
' * This is necessary because .NET's HttpUtility.UrlEncode does not encode
' * according to the above standard. Also, .NET returns lower-case encoding
' * by default and Amazon requires upper-case encoding.
'
Private Function PercentEncodeRfc3986(ByVal str As String) As String
str = HttpUtility.UrlEncode(str, System.Text.Encoding.UTF8)
str.Replace("'", "%27").Replace("(", "%28").Replace(")", "%29").Replace("*", "%2A").Replace("!", "%21").Replace("%7e", "~")
Dim sbuilder As New StringBuilder(str)
For i As Integer = 0 To sbuilder.Length - 1
If sbuilder(i) = "%"c Then
If [Char].IsDigit(sbuilder(i + 1)) AndAlso [Char].IsLetter(sbuilder(i + 2)) Then
sbuilder(i + 2) = [Char].ToUpper(sbuilder(i + 2))
End If
End If
Next
Return sbuilder.ToString()
End Function
'
' * Convert a query string to corresponding dictionary of name-value pairs.
'
Private Function CreateDictionary(ByVal queryString As String) As IDictionary(Of String, String)
Dim map As New Dictionary(Of String, String)()
Dim requestParams As String() = queryString.Split("&"c)
For i As Integer = 0 To requestParams.Length - 1
If requestParams(i).Length < 1 Then
Continue For
End If
Dim sep As Char() = {"="c}
Dim param As String() = requestParams(i).Split(sep, 2)
For j As Integer = 0 To param.Length - 1
param(j) = HttpUtility.UrlDecode(param(j), System.Text.Encoding.UTF8)
Next
Select Case param.Length
Case 1
If True Then
If requestParams(i).Length >= 1 Then
If requestParams(i).ToCharArray()(0) = "="c Then
map("") = param(0)
Else
map(param(0)) = ""
End If
End If
Exit Select
End If
Case 2
If True Then
If Not String.IsNullOrEmpty(param(0)) Then
map(param(0)) = param(1)
End If
End If
Exit Select
End Select
Next
Return map
End Function
'
' * Consttuct the canonical query string from the sorted parameter map.
'
Private Function ConstructCanonicalQueryString(ByVal sortedParamMap As SortedDictionary(Of String, String)) As String
Dim builder As New StringBuilder()
If sortedParamMap.Count = 0 Then
builder.Append("")
Return builder.ToString()
End If
For Each kvp As KeyValuePair(Of String, String) In sortedParamMap
builder.Append(Me.PercentEncodeRfc3986(kvp.Key))
builder.Append("=")
builder.Append(Me.PercentEncodeRfc3986(kvp.Value))
builder.Append("&")
Next
Dim canonicalString As String = builder.ToString()
canonicalString = canonicalString.Substring(0, canonicalString.Length - 1)
Return canonicalString
End Function
End Class
Class ParamComparer
Implements IComparer(Of String)
Public Function Compare(ByVal p1 As String, ByVal p2 As String) As Integer Implements IComparer(Of String).Compare
Return String.CompareOrdinal(p1, p2)
End Function
End Class

How to find numbers from a string?

I need to find numbers from a string. How does one find numbers from a string in VBA Excel?
Assuming you mean you want the non-numbers stripped out, you should be able to use something like:
Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Calling this with:
Dim myStr as String
myStr = onlyDigits ("3d1fgd4g1dg5d9gdg")
MsgBox (myStr)
will give you a dialog box containing:
314159
and those first two lines show how you can store it into an arbitrary string variable, to do with as you wish.
Regular expressions are built to parse. While the syntax can take a while to pick up on this approach is very efficient, and is very flexible for handling more complex string extractions/replacements
Sub Tester()
MsgBox CleanString("3d1fgd4g1dg5d9gdg")
End Sub
Function CleanString(strIn As String) As String
Dim objRegex
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[^\d]+"
CleanString = .Replace(strIn, vbNullString)
End With
End Function
Expanding on brettdj's answer, in order to parse disjoint embedded digits into separate numbers:
Sub TestNumList()
Dim NumList As Variant 'Array
NumList = GetNums("34d1fgd43g1 dg5d999gdg2076")
Dim i As Integer
For i = LBound(NumList) To UBound(NumList)
MsgBox i + 1 & ": " & NumList(i)
Next i
End Sub
Function GetNums(ByVal strIn As String) As Variant 'Array of numeric strings
Dim RegExpObj As Object
Dim NumStr As String
Set RegExpObj = CreateObject("vbscript.regexp")
With RegExpObj
.Global = True
.Pattern = "[^\d]+"
NumStr = .Replace(strIn, " ")
End With
GetNums = Split(Trim(NumStr), " ")
End Function
Use the built-in VBA function Val, if the numbers are at the front end of the string:
Dim str as String
Dim lng as Long
str = "1 149 xyz"
lng = Val(str)
lng = 1149
Val Function, on MSDN
I was looking for the answer of the same question but for a while I found my own solution and I wanted to share it for other people who will need those codes in the future. Here is another solution without function.
Dim control As Boolean
Dim controlval As String
Dim resultval As String
Dim i as Integer
controlval = "A1B2C3D4"
For i = 1 To Len(controlval)
control = IsNumeric(Mid(controlval, i, 1))
If control = True Then resultval = resultval & Mid(controlval, i, 1)
Next i
resultval = 1234
This a variant of brettdj's & pstraton post.
This will return a true Value and not give you the #NUM! error. And \D is shorthand for anything but digits. The rest is much like the others only with this minor fix.
Function StripChar(Txt As String) As Variant
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\D"
StripChar = Val(.Replace(Txt, " "))
End With
End Function
This is based on another answer, but is just reformated:
Assuming you mean you want the non-numbers stripped out, you should be able to use something like:
'
' Skips all characters in the input string except digits
'
Function GetDigits(ByVal s As String) As String
Dim char As String
Dim i As Integer
GetDigits = ""
For i = 1 To Len(s)
char = Mid(s, i, 1)
If char >= "0" And char <= "9" Then
GetDigits = GetDigits + char
End If
Next i
End Function
Calling this with:
Dim myStr as String
myStr = GetDigits("3d1fgd4g1dg5d9gdg")
Call MsgBox(myStr)
will give you a dialog box containing:
314159
and those first two lines show how you can store it into an arbitrary string variable, to do with as you wish.
Alternative via Byte Array
If you assign a string to a Byte array you typically get the number equivalents of each character in pairs of the array elements. Use a loop for numeric check via the Like operator and return the joined array as string:
Function Nums(s$)
Dim by() As Byte, i&, ii&
by = s: ReDim tmp(UBound(by)) ' assign string to byte array; prepare temp array
For i = 0 To UBound(by) - 1 Step 2 ' check num value in byte array (0, 2, 4 ... n-1)
If Chr(by(i)) Like "#" Then tmp(ii) = Chr(by(i)): ii = ii + 1
Next i
Nums = Trim(Join(tmp, vbNullString)) ' return string with numbers only
End Function
Example call
Sub testByteApproach()
Dim s$: s = "a12bx99y /\:3,14159" ' [1] define original string
Debug.Print s & " => " & Nums(s) ' [2] display original string and result
End Sub
would display the original string and the result string in the immediate window:
a12bx99y /\:3,14159 => 1299314159
Based on #brettdj's answer using a VBScript regex ojbect with two modifications:
The function handles variants and returns a variant. That is, to take care of a null case; and
Uses explicit object creation, with a reference to the "Microsoft VBScript Regular Expressions 5.5" library
Function GetDigitsInVariant(inputVariant As Variant) As Variant
' Returns:
' Only the digits found in a varaint.
' Examples:
' GetDigitsInVariant(Null) => Null
' GetDigitsInVariant("") => ""
' GetDigitsInVariant(2021-/05-May/-18, Tue) => 20210518
' GetDigitsInVariant(2021-05-18) => 20210518
' Notes:
' If the inputVariant is null, null will be returned.
' If the inputVariant is "", "" will be returned.
' Usage:
' VBA IDE Menu > Tools > References ...
' > "Microsoft VBScript Regular Expressions 5.5" > [OK]
' With an explicit object reference to RegExp we can get intellisense
' and review the object heirarchy with the object browser
' (VBA IDE Menu > View > Object Browser).
Dim regex As VBScript_RegExp_55.RegExp
Set regex = New VBScript_RegExp_55.RegExp
Dim result As Variant
result = Null
If IsNull(inputVariant) Then
result = Null
Else
With regex
.Global = True
.Pattern = "[^\d]+"
result = .Replace(inputVariant, vbNullString)
End With
End If
GetDigitsInVariant = result
End Function
Testing:
Private Sub TestGetDigitsInVariant()
Dim dateVariants As Variant
dateVariants = Array(Null, "", "2021-/05-May/-18, Tue", _
"2021-05-18", "18/05/2021", "3434 ..,sdf,sfd 444")
Dim dateVariant As Variant
For Each dateVariant In dateVariants
Debug.Print dateVariant & ": ", , GetDigitsInVariant(dateVariant)
Next dateVariant
Debug.Print
End Sub
Public Function ExtractChars(strRef$) As String
'Extract characters from a string according to a range of charactors e.g'+.-1234567890'
Dim strA$, e%, strExt$, strCnd$: strExt = "": strCnd = "+.-1234567890"
For e = 1 To Len(strRef): strA = Mid(strRef, e, 1)
If InStr(1, strCnd, strA) > 0 Then strExt = strExt & strA
Next e: ExtractChars = strExt
End Function
In the immediate debug dialog:
? ExtractChars("a-5d31.78K")
-531.78

VB6 encrypt text using password

Looking for a simple text encryption/decryption VB6 code. Ideally, the solution should accept (text, password) arguments and produce readable output (without any special characters), so it can be used anywhere without encoding issues.
There are lots of code available for .NET, but not really much I can find for legacy VB6. Only this I've found so far: http://www.devx.com/vb2themax/Tip/19211
I'm using RC4 implementation like this
Option Explicit
Private Sub Command1_Click()
Dim sSecret As String
sSecret = ToHexDump(CryptRC4("a message here", "password"))
Debug.Print sSecret
Debug.Print CryptRC4(FromHexDump(sSecret), "password")
End Sub
Public Function CryptRC4(sText As String, sKey As String) As String
Dim baS(0 To 255) As Byte
Dim baK(0 To 255) As Byte
Dim bytSwap As Byte
Dim lI As Long
Dim lJ As Long
Dim lIdx As Long
For lIdx = 0 To 255
baS(lIdx) = lIdx
baK(lIdx) = Asc(Mid$(sKey, 1 + (lIdx Mod Len(sKey)), 1))
Next
For lI = 0 To 255
lJ = (lJ + baS(lI) + baK(lI)) Mod 256
bytSwap = baS(lI)
baS(lI) = baS(lJ)
baS(lJ) = bytSwap
Next
lI = 0
lJ = 0
For lIdx = 1 To Len(sText)
lI = (lI + 1) Mod 256
lJ = (lJ + baS(lI)) Mod 256
bytSwap = baS(lI)
baS(lI) = baS(lJ)
baS(lJ) = bytSwap
CryptRC4 = CryptRC4 & Chr$((pvCryptXor(baS((CLng(baS(lI)) + baS(lJ)) Mod 256), Asc(Mid$(sText, lIdx, 1)))))
Next
End Function
Private Function pvCryptXor(ByVal lI As Long, ByVal lJ As Long) As Long
If lI = lJ Then
pvCryptXor = lJ
Else
pvCryptXor = lI Xor lJ
End If
End Function
Public Function ToHexDump(sText As String) As String
Dim lIdx As Long
For lIdx = 1 To Len(sText)
ToHexDump = ToHexDump & Right$("0" & Hex(Asc(Mid(sText, lIdx, 1))), 2)
Next
End Function
Public Function FromHexDump(sText As String) As String
Dim lIdx As Long
For lIdx = 1 To Len(sText) Step 2
FromHexDump = FromHexDump & Chr$(CLng("&H" & Mid(sText, lIdx, 2)))
Next
End Function
Command1 outputs this:
9ED5556B3F4DD5C90471C319402E
a message here
You might need better error handling on FromHexDump though.
Update (2018-05-04)
For much stronger AES 256-bit encryption (in ECB mode) and proper handling of unicode texts/passwords you can check out Simple AES 256-bit password protected encryption as implemented in mdAesEcb.bas module (~380 LOC).
MD5sum the the text and password together as a one way hash (and then to check, you encrypt again and compare with the stored hash. (This won't work if you MUST decrypt it again though)
Here's my encryption class. I use several constants to define the encryption key because in my mind it's a little more secure from someone trying to decompile the code to find it. Cryptography isn't my thing so maybe I'm kidding myself. Anyway, I used this class in an ActiveX dll called from other programs to do encryption and the reverse in a separate dll for decryption. I did it this way so people who shouldn't be seeing encrypted data don't even have the dll to do the decrypting. Change the key constants to what you want (5 long). I use a mix including unprintable characters and it has worked well for me so far. The CAPICOM is part of Windows® so you don't have to distribute.
Option Explicit
Private m_oENData As CAPICOM.EncryptedData
'combine these constants to build the encryption key
Private Const KEY1 = "12345"
Private Const KEY2 = "67890"
Private Const KEY3 = "abcde"
Private Const KEY4 = "fghij"
Private Const KEY5 = "klmno"
Private Sub Class_Initialize()
On Error Resume Next
Set m_oENData = New CAPICOM.EncryptedData
If Err.Number <> 0 Then
If Err.Number = 429 Then
Err.Raise Err.Number, App.EXEName, "Failed to create the capi com object. " & _
"Check that the capicom.dll file is installed and properly registered."
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End If
End Sub
Private Sub Class_Terminate()
Set m_oENData = Nothing
End Sub
Public Function EncryptAsBase64(ByVal RawString As String) As String
EncryptAsBase64 = Encrypt(RawString, CAPICOM_ENCODE_BASE64)
End Function
Public Function EncryptAsBinary(ByVal RawString As String) As String
EncryptAsBinary = Encrypt(RawString, CAPICOM_ENCODE_BINARY)
End Function
Private Function Encrypt(ByVal s As String, ByVal EncryptionType As CAPICOM.CAPICOM_ENCODING_TYPE) As String
Dim oEN As New CAPICOM.EncryptedData
Dim intENCType As CAPICOM.CAPICOM_ENCRYPTION_ALGORITHM
Dim strSecret As String
Dim intTries As Integer
On Error GoTo errEncrypt
intENCType = CAPICOM_ENCRYPTION_ALGORITHM_AES ' try this first and fall back if not supported
With oEN
startEncryption:
.Algorithm = intENCType
strSecret = KEY2 & KEY5 & KEY4 & KEY1 & KEY3
.SetSecret strSecret
strSecret = ""
.Content = s
' the first encryption type needs to be base64 as the .content property
' can loose information if I try to manipulate a binary string
.Content = StrReverse(.Encrypt(CAPICOM_ENCODE_BASE64))
strSecret = KEY1 & KEY4 & KEY3 & KEY2 & KEY5
.SetSecret strSecret
strSecret = ""
Encrypt = .Encrypt(EncryptionType)
End With
Set oEN = Nothing
Exit Function
errEncrypt:
If Err.Number = -2138568448 Then
' if this is the first time the step the encryption back and try again
If intTries < 1 Then
intTries = intTries + 1
intENCType = CAPICOM_ENCRYPTION_ALGORITHM_3DES
Resume startEncryption
End If
End If
Err.Raise Err.Number, Err.Source & ":Encrypt", Err.Description
strSecret = ""
Set oEN = Nothing
End Function

Resources