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

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

Related

Sub or Function Not Defined Error - Sub in Class Module

I am attempting to pass values from an ADODB.Recordset into a Class Module and am receiving the Sub or Function Not Defined Error when I call Call PopulateJHAData(GeneralInfo.Range("genLoanProg"), CStr(nm)) from within the function to get the data from the recordset; I know i dont need Call in front of the sub; I was just seeing if it made any difference. I can already imagine that there are a host of other items that are wrong with this code since I am just now getting into how to use Class Modules.
'---Class Loan Info
Public LoanNumber As String
Public InterestRate As String
Public OriginalAmount As Double
Public OriginationDate As String
Public MaturityDate As Date
Public NextPaymentDate As Date
Public PaymentAmount As Double
Public Census As String
Public RateNumber As Long
Public Margin As String
Public RoundTo As String
Public RateCeiling As String
Public RateChangeDate As Date
Public ARMNotice As String
Public QualifiedMortgageCode As String
Public ln1098 As String
Public CallReportCode As String
Public CollateralCode As String
Public PurposeCode As String
Public HPML As String
Public LoanTypeCode As String
Public Flood As String
Public CLTV As String
Public Branch As Long
Public FHLBElig As String
Public RepToCB As String
Public Occupancy As String
Public tName As String
Public eNumber As Long
Public Sub PopulateJHAData(ByVal LoanProg As String, ByVal TableName As String, ByVal JHALoanInfo As ADODB.Recordset)
Select Case Left(LoanProg, 4)
Case Is = "FHLB", "Cons", "15yr"
InterestRate = Trim(JHALoanInfo.Fields("Rate").Value)
LoanAmount = Trim(JHALoanInfo.Fields("OrigAmnt").Value)
LoanDate = Trim(JHALoanInfo.Fields("OrigDate").Value)
MaturityDate = Trim(JHALoanInfo.Fields("MatDate").Value)
NextPaymentDate = Trim(JHALoanInfo.Fields("NextPmtDate").Value)
PaymentAmount = Trim(JHALoanInfo.Fields("PaymentAmt").Value)
Census = Trim(JHALoanInfo.Fields("Census").Value)
QualifiedMortgageCode = Trim(JHALoanInfo.Fields("QMCode").Value)
ln1098 = Trim(JHALoanInfo.Fields("ln1098").Value)
CallReportCode = Trim(JHALoanInfo.Fields("CallRep").Value)
CollateralCode = Trim(JHALoanInfo.Fields("ColCode").Value)
PurposeCode = Trim(JHALoanInfo.Fields("PurpCode").Value)
HPML = Trim(JHALoanInfo.Fields("HPML").Value)
LoanTypeCode = Trim(JHALoanInfo.Fields("LnTypeCode").Value)
Flood = Trim(JHALoanInfo.Fields("Flood").Value)
CLTV = Trim(JHALoanInfo.Fields("CombLTV").Value)
Branch = Trim(JHALoanInfo.Fields("Branch").Value)
FHLBElig = Trim(JHALoanInfo.Fields("EligFHLV").Value)
RepToCB = Trim(JHALoanInfo.Fields("RepCB").Value)
Occupancy = Trim(JHALoanInfo.Fields("Occupancy").Value)
Case Else
InterestRate = Trim(JHALoanInfo.Fields("Rate").Value)
LoanAmount = Trim(JHALoanInfo.Fields("OrigAmnt").Value)
LoanDate = Trim(JHALoanInfo.Fields("OrigDate").Value)
MaturityDate = Trim(JHALoanInfo.Fields("MatDate").Value)
NextPaymentDate = Trim(JHALoanInfo.Fields("NextPmtDate").Value)
PaymentAmount = Trim(JHALoanInfo.Fields("PaymentAmt").Value)
Census = Trim(JHALoanInfo.Fields("Census").Value)
RateNumber = Trim(JHALoanInfo.Fields("RateNum").Value)
Margin = Trim(JHALoanInfo.Fields("Margin").Value)
RoundTo = Trim(rs.Fields("RoundTo").Value)
RateCeiling = Trim(rs.Fields("RateCeiling").Value)
RateChangeDate = Trim(rs.Fields("RateChangeDate").Value)
ARMNotice = Trim(rs.Fields("ArmNot").Value)
QualifiedMortgageCode = Trim(JHALoanInfo.Fields("QMCode").Value)
ln1098 = Trim(JHALoanInfo.Fields("ln1098").Value)
CallReportCode = Trim(JHALoanInfo.Fields("CallRep").Value)
CollateralCode = Trim(JHALoanInfo.Fields("ColCode").Value)
PurposeCode = Trim(JHALoanInfo.Fields("PurpCode").Value)
HPML = Trim(JHALoanInfo.Fields("HPML").Value)
LoanTypeCode = Trim(JHALoanInfo.Fields("LnTypeCode").Value)
Flood = Trim(JHALoanInfo.Fields("Flood").Value)
CLTV = Trim(JHALoanInfo.Fields("CombLTV").Value)
Branch = Trim(JHALoanInfo.Fields("Branch").Value)
FHLBElig = Trim(JHALoanInfo.Fields("EligFHLV").Value)
RepToCB = Trim(JHALoanInfo.Fields("RepCB").Value)
Occupancy = Trim(JHALoanInfo.Fields("Occupancy").Value)
End Select
End Sub
Sub LoanInfoGrab()
uName = Environ("username")
empName = StrConv(Left(uName, Len(uName) - 1), vbProperCase)
Dim lnNum As String
lnNum = GeneralInfo.Range("genLoanNumber")
msgCap = "Hello " & empName & "," & vbCrLf & _
"The data for " & lnNum & " is not available, or unable to be retrieved." & _
"This loan will need to be manually checked."
Dim LoanRecordGrab As clsLoanInfo
'passing in all potential table names/sources in array
Set LoanRecordGrab = getLoanInfoRecord(Array(CNCTTP08, BHSCHLP8))
Dim nm
If LoanRecordGrab Is Nothing Then
MsgBox msgCap, vbExclamation, "Error Getting Data"
Else
rem not sure if this should be the sub from the class module or if it should be LoanRecordGrab.
'PopulateJHAData GeneralInfo.Range("genLoanProg"), CStr(nm) yet.
End If
JHACheckFormat
Dim lnData As Range, cData1 As Range, cData2 As Range
Set lnData = JHACheck.Range("H7:H32")
Set cData1 = JHACheck.Range("H35:H41")
Set cData2 = JHACheck.Range("K35:K41")
If loanData.Range("CIF_2") = vbNullString Then
CompareJHACheck lnData, cData1
Else
CompareJHACheck lnData, cData1, cData2
End If
End Sub
Function getLoanInfoRecord(arrNames) As clsLoanInfo
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim SQL As String, nm, okSql As Boolean
Dim LoanRecordGrab As clsLoanInfo
Dim lNum As Range: Set lNum = GeneralInfo.Range("genLoanNumber")
conn.Open CONNSTR
'try each provided name: exit loop on successful query
For Each nm In arrNames
SQL = getLoanDBGrabSQL(CStr(nm), lNum)
On Error Resume Next
rs.Open SQL, conn 'try this name
If Err.Number = CONNECTIONERROR Then
okSql = False
Else
okSql = True
End If
On Error GoTo 0 'cancel on error resume next
If okSql Then
If rs.EOF Then
'rs.MoveFirst
Do While Not rs.EOF
Set LoanRecordGrab = New clsLoanInfo 'create an instance to populate
Call PopulateJHAData(GeneralInfo.Range("genLoanProg"), CStr(nm)) 'Sub or Function not Defined happens here
rs.MoveNext
Loop
End If
Exit For 'done trying names
End If
Next nm
If rs.State = adStateOpen Then rs.Close
If conn.State = adStateOpen Then conn.Close
Set getLoanInfoRecord = LoanRecordGrab
End Function

After Connect to Access, String cannot join together

I use VB.net to create a program, the function is search data from Access, then save the data to html file.
But when after search data from Access, the string cannot join together.
Dim strpath As String = System.Windows.Forms.Application.StartupPath + "\\output\\"
If (Not System.IO.Directory.Exists(strpath)) Then
System.IO.Directory.CreateDirectory(strpath)
End If
Dim strfilename As String = strpath + DateTime.Now.ToString("yyyy-MM-dd--HH-mm-ss") + "_" + textBox_name.Text + ".html"
Dim screach_name As String = textBox_name.Text
Dim html_code As String = ""
html_code += "<!DOCTYPE html><html><head><title>"
html_code += screach_name
html_code += "</title></head><body>"
html_code += "Screach:<b>" + screach_name + "</b><br />"
Try
Dim strcon As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=data.mdb;"
Dim con_db As OleDbConnection = New OleDbConnection(strcon)
Dim sql_count As String = "SELECT COUNT(*) FROM table where name Like '%" + search_name + "%'"
Dim com_data As OleDbCommand = New OleDbCommand(sql_count, con_db)
Dim count_data As Integer = Convert.ToInt32(com_data.ExecuteScalar())
html_code += "Number of records = "
html_code += count_data.ToString
Catch ex As Exception
Finally
End Try
html_code += "</body></html>"
Using file As StreamWriter = New StreamWriter(strfilename, True)
file.WriteLine(html_code)
End Using
But the html output only
Blockquote
<!DOCTYPE html> <html> <head> <title>
screach_name
</title> </head> <body>
Screach: <b> screach_name </b> <br />
Blockquote
There are 3 different things going on in your method. Your code would be easier to follow, maintain, and test if you break it up into 3 different methods. Notice that the demonstrated methods are not connected to the user interface (no direct references to textBox_name.Text). This could come in handy if you restructure your app and move, for example, the GetRecordCount method to a DataAccess class.
The Using...End Using blocks in the GetRecordCount method ensure that your database objects are closed and disposed even if there is an error.
The StringBuilder in the BuildHTMLString method saves the program form creating and throwing away strings. Everytime you change a string in any way the program must throw away the old string and create an entirely new one.
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim RecordCount = GetRecordCount(textBox_name.Text)
Dim HTMLString = BuildHTMLString(RecordCount, textBox_name.Text)
SaveHTMLString(HTMLString, textBox_name.Text)
End Sub
Private Function GetRecordCount(SearchName As String) As Integer
Dim RecordCount As Integer
'Pass the connection string directly to the constructor of the connection
Using cn As New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=data.mdb;")
'Pass the query text an the connection directly to the constructor of the command
Using cmd As New OleDbCommand("SELECT COUNT(*) FROM table where name Like #SearchName;", cn)
'Always use parameters
cmd.Parameters.Add("#SearchName", OleDbType.VarChar).Value = "%" & SearchName & "%"
RecordCount = CInt(cmd.ExecuteScalar())
End Using
End Using
Return RecordCount
End Function
Private Function BuildHTMLString(RecordCount As Integer, SearchName As String) As String
Dim HTMLString As String = ""
Dim sb As New StringBuilder()
sb.AppendLine("<!DOCTYPE html><html><head><title>")
sb.AppendLine(SearchName)
sb.AppendLine("</title></head><body>")
sb.AppendLine("Screach:<b>" & SearchName & "</b><br />")
sb.AppendLine("Number of records = " & RecordCount.ToString)
sb.AppendLine("</body></html>")
HTMLString = sb.ToString
Return HTMLString
End Function
Private Sub SaveHTMLString(HTML As String, SearchName As String)
'Add Imports System.IO to the top or the file
'Using Path.Combine makes sure the back slashes are OK
Dim strpath As String = Path.Combine(Application.StartupPath, "\output\")
If (Not Directory.Exists(strpath)) Then
Directory.CreateDirectory(strpath)
End If
Dim HTMLFileName As String = DateTime.Now.ToString("yyyy-MM-dd--HH-mm-ss") & "_" & SearchName & ".html"
Dim strfilename As String = Path.Combine(strpath, HTMLFileName)
Using file As StreamWriter = New StreamWriter(strfilename, True)
file.WriteLine(HTML)
End Using
End Sub

Best way to lookup a list of character strings against dictionary to output English words

I've got a list of about 20,000 strictly alpha/text character strings outputted as a CSV file to Excel, but it's quite a mess.
What I want to do is query a separate, reference file of English dictionary words so that I can essentially create a lookup and return the dictionary word, minus a load of the text noise that is either prepended or appended to the string. Example below.
xyzbuildingcontractor = Building Contractor
upholsteryabcdef = Upholstery
lmnoengineer = Engineer
As a relative n00b programmer I just want to gauge opinion as to the best way to do this and whether Excel is the best platform to use.
Any guidance would be very gratefully recieved, thanks in advance.
Jim
Ok, this is a very rough draft which you might have to tweak, but the general idea is this:
A Trie is used to build a dictionary of words
A clsTrieIterator class allows tracking multiple words at a time within the Trie
The string to be tested is parsed one character at a time, each one starting a new clsTrieIterator
All the existing active clsTrieIterators consume each next character, and if the resulting combination of characters is not possible given the dictionary, it stops being tracked
Here is a short example of the use:
Public Sub Main()
Dim wf As clsWordFinder
Set wf = New clsWordFinder
wf.Add "Building"
wf.Add "Contractor"
wf.Add "Upholstery"
wf.Add "Engineer"
Debug.Print wf.getWordsFromString("xyzbuildingcontractor")
Debug.Print wf.getWordsFromString("upholsteryabcdef")
Debug.Print wf.getWordsFromString("lmnoengineer")
End Sub
Which outputs the following to the immediate window in VBA:
Building Contractor
Upholstery
Engineer
...and below are the classes.
clsTrieNode is each individual node of the tree. It represents a single letter and it may have up to 26 children, assuming they form valid words in the dictionary. If the combination of characters, node by node down the tree from the root to this point forms a word, the Trie will set "isWord".
Option Compare Database
Option Explicit
Public KeyChar As String
Public isWord As Boolean
Private m_Children(0 To 25) As clsTrieNode
Public Property Get Child(strChar As String) As clsTrieNode
'better be ONE char
Set Child = m_Children(charToIndex(strChar))
End Property
Public Property Set Child(strChar As String, oNode As clsTrieNode)
Set m_Children(charToIndex(strChar)) = oNode
End Property
Private Function charToIndex(strChar As String) As Long
charToIndex = Asc(strChar) - 97 'asc("a")
End Function
clsTrie is the public facing interface to interact with the tree of nodes that forms the trie. It contains an Add method to put words into the dictionary and an isWord method which allows testing a string against the trie dictionary to see if it is a valid word. Remove is a method that is nice to have, but probably not necessary for your problem, so I haven't implemented it.
Option Compare Database
Option Explicit
Private m_Head As clsTrieNode
Private Sub Class_Initialize()
Set m_Head = New clsTrieNode
End Sub
Public Sub Add(strKey As String)
Dim currNode As clsTrieNode
Dim tempNode As clsTrieNode
Set currNode = m_Head
Dim strLCaseKey As String
strLCaseKey = LCase(strKey)
Dim i As Long
For i = 1 To Len(strLCaseKey)
If Not currNode.Child(Mid(strLCaseKey, i, 1)) Is Nothing Then
Set currNode = currNode.Child(Mid(strLCaseKey, i, 1))
Else
Exit For
End If
Next
For i = i To Len(strLCaseKey)
Set tempNode = New clsTrieNode
tempNode.KeyChar = Mid(strLCaseKey, i, 1)
Set currNode.Child(Mid(strLCaseKey, i, 1)) = tempNode
Set currNode = tempNode
Next
currNode.isWord = True
End Sub
Public Sub Remove(strKey As String)
'Might be nice to have
End Sub
Public Function isWord(strKey As String)
Dim currNode As clsTrieNode
Set currNode = m_Head
Dim strLCaseKey As String
strLCaseKey = LCase(strKey)
Dim i As Long
For i = 1 To Len(strLCaseKey)
If Not currNode.Child(Mid(strLCaseKey, i, 1)) Is Nothing Then
Set currNode = currNode.Child(Mid(strLCaseKey, i, 1))
Else
isWord = False
Exit Function
End If
Next
If currNode.isWord Then
isWord = True
Else
isWord = False
End If
End Function
Public Function getIterator() As clsTrieIterator
Dim oIterator As clsTrieIterator
Set oIterator = New clsTrieIterator
oIterator.Init m_Head
Set getIterator = oIterator
End Function
clsTrieIterator is a special class returned by clsTrie which allows parsing of a string to be done character by character with consumeChar instead of all at once as with clsTrie.isWord. This allows some freedom in parsing the string without backtracking or reading the same character more than once and it allows finding words when you are not sure how long they will be.
Option Compare Database
Option Explicit
Private m_currNode As clsTrieNode
Private m_currString As String
Public Property Get getCurrentString() As String
getCurrentString = m_currString
End Property
Public Sub Init(oNode As clsTrieNode)
Set m_currNode = oNode
End Sub
Public Function consumeChar(strChar As String) As Boolean
Dim strLCaseChar As String
strLCaseChar = LCase(strChar)
If Not m_currNode.Child(strLCaseChar) Is Nothing Then
consumeChar = True
Set m_currNode = m_currNode.Child(strLCaseChar)
m_currString = m_currString & strChar
Else
consumeChar = False
Set m_currNode = Nothing
End If
End Function
Public Function isWord() As Boolean
isWord = m_currNode.isWord
End Function
clsWordFinder puts everything together in a simple api tailored to your specific problem. It might be worth adding some logic to handle different behavior, like "greedy" matching vs "lazy" matching and overlapping vs nonoverlapping word parsing.
Option Compare Database
Option Explicit
Private m_Trie As clsTrie
Private Sub Class_Initialize()
Set m_Trie = New clsTrie
End Sub
Public Sub Add(strWord As String)
m_Trie.Add strWord
End Sub
Public Function getWordsFromString(strString As String) As String
Dim colIterators As Collection
Set colIterators = New Collection
Dim colMatches As Collection
Set colMatches = New Collection
Dim oIterator As clsTrieIterator
Dim strMatch As String
Dim i As Long
Dim iter
For i = 1 To Len(strString)
Set oIterator = m_Trie.getIterator
colIterators.Add oIterator, CStr(ObjPtr(oIterator))
For Each iter In colIterators
If Not iter.consumeChar(Mid(strString, i, 1)) Then
colIterators.Remove CStr(ObjPtr(iter))
ElseIf iter.isWord() Then
strMatch = iter.getCurrentString
Mid(strMatch, 1, 1) = UCase(Mid(strMatch, 1, 1))
colMatches.Add strMatch
colIterators.Remove CStr(ObjPtr(iter))
End If
Next
Next
getWordsFromString = JoinCollection(colMatches)
End Function
Public Function getWordsCollectionFromString(strString As String) As Collection
Dim colIterators As Collection
Set colIterators = New Collection
Dim colMatches As Collection
Set colMatches = New Collection
Dim oIterator As clsTrieIterator
Dim strMatch As String
Dim i As Long
Dim iter
For i = 1 To Len(strString)
Set oIterator = m_Trie.getIterator
colIterators.Add oIterator, CStr(ObjPtr(oIterator))
For Each iter In colIterators
If Not iter.consumeChar(Mid(strString, i, 1)) Then
colIterators.Remove CStr(ObjPtr(iter))
ElseIf iter.isWord() Then
strMatch = iter.getCurrentString
Mid(strMatch, 1, 1) = UCase(Mid(strMatch, 1, 1))
colMatches.Add strMatch
colIterators.Remove CStr(ObjPtr(iter))
End If
Next
Next
Set getWordsCollectionFromString = colMatches
End Function
Private Function JoinCollection(colStrings As Collection, Optional strDelimiter = " ") As String
Dim strOut As String
Dim i As Long
If colStrings.Count > 0 Then
strOut = colStrings.Item(1)
For i = 2 To colStrings.Count
strOut = strOut & strDelimiter & colStrings.Item(i)
Next
JoinCollection = strOut
End If
End Function

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

get a field value from a webpage - lotusscript

I need to read the field value from a webpage using lotusscript. Essentially I am planning on writing an agent to go to a specific URL, get a value from the page, and then use this value for the url it sends the user to.
Can anyone give me a pointer?
A
Update December 2019: As of Notes 10 (released in 2018) there is a NotesHTTPRequest class that does exactly the same thing as my code.
I do this all the time, it is not hard at all (on Windows). I created a class to do this, so it is very easy to implement.
Here is how you call it:
Dim internet As New RemoteHTML()
Dim html As String
html = internet.GetHTTP("http://www.texasswede.com/mypage.html")
That's it, now you just pull whatever information you want out of the html string.
Here is the class:
Option Public
Option Declare
Class RemoteHTML
Private httpObject As Variant
Public httpStatus As Integer
Public Sub New()
Set httpObject = CreateObject("MSXML2.ServerXMLHTTP")
End Sub
Public Function GetHTTP(httpURL As String) As String
Dim retries As Integer
retries = 0
Do
If retries>1 Then
Sleep 1 ' After the two first calls, introduce a 1 second delay betwen each additional call
End If
retries = retries + 1
Call httpObject.open("GET", httpURL, False)
Call httpObject.send()
httpStatus = httpObject.Status
If retries >= 10 Then
httpStatus = 0 ' Timeout
End If
Loop Until httpStatus = 200 Or httpStatus > 500 Or httpStatus = 404 Or httpStatus = 0
If httpStatus = 200 Then
GetHTTP = Left$(httpObject.responseText,16000)
Else
GetHTTP = ""
End If
End Function
Public Function GetFile(httpURL As String, filename As String) As Boolean
Dim session As New NotesSession
Dim retries As Integer
Dim stream As NotesStream
Dim flag As Boolean
Dim responsebody As variant
Dim cnt As Long
Dim buffer As String
Dim tmp As Byte
Set stream = session.CreateStream
retries = 0
Do
If retries>1 Then
Sleep 1 ' After the two first calls, introduce a 1 second delay betwen each additional call
End If
retries = retries + 1
Call httpObject.open("GET", httpURL, False)
Call httpObject.send()
httpStatus = httpObject.Status
If retries >= 10 Then
httpStatus = 0 ' Timeout
End If
Loop Until httpStatus = 200 Or httpStatus > 500 Or httpStatus = 404 Or httpStatus = 0
If httpStatus = 200 Then
flag = stream.Open(filename, "binary")
If flag = False Then
MsgBox "Failed to create " & filename & "..."
GetFile = False
Exit function
End If
responsebody = httpObject.ResponseBody
ForAll r in responsebody
tmp = r
Call Stream.Write(Chr$(CInt(tmp)))
cnt = cnt + 1
End ForAll
MsgBox cnt
GetFile = True
Else
GetFile = False
End If
End Function
Private Function getString(ByVal StringBin As string)
Dim intCount As Long
getString =""
For intCount = 1 To LenB(StringBin)
getString = getString & Chr( Asc(MidB(StringBin, intCount, 1)) )
Next
End Function
End Class
If your code will be running on Windows, you can use either WinHTTP or XMLHTTP COM classes to read web pages. If the code will be running on any other platform, you will be better off using Java instead of LotusScript.
If You're trying to read form a NotesField, you could go for below approach. Tha Class was created to specifically handle export of RichText items into html-strings in order to find the otherwise kind-of-hidden embedded images (pasted graphics) that may exist in NotesRichText items.
The function ExportDoc() copies the html response text into a user defined field on the document at hand:
Public Class RTExporter
session As NotesSession
db As NotesDatabase
doc As NotesDocument
obj As Variant
url As String
Public Sub New()
Set Me.session = New NotesSession()
Set db = session.CurrentDatabase
Set obj = CreateObject("Microsoft.XMLHTTP")
End Sub
' Handles export from eventual NotesRichTextitems in the form of HTml
Public Function ExportDoc(hostUrl As String, doc As NotesDocument, rtFieldName As String, htmlFieldName As String)
Dim htmlString As String
url = hostUrl & Me.db.FilePath & "/0/" & doc.Universalid & "/" & rtFieldname & "?openfield&charset=utf-8
Set Me.doc = doc
htmlString = GetHtmlFromField(htmlFieldName)
Call doc.ReplaceItemValue(htmlFieldName, htmlString)
Call doc.Save(True, False)
End Function
' Get http response text and store it in <fieldname>
Private Function GetHtmlFromField(rtFieldName As String) As String
Dim html As String
On Error Goto ERH
obj.open "GET", Me.url, False, "", ""
obj.send("")
GetHtmlFromField = Trim$(obj.responseText)
Exit Function
ERH:
GetHtmlFromField = "Error " & Err & ": " & Error & " occured on line: " & Erl
End Function
End Class

Resources