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
Related
I have a .DLL that I've written in VB.Net to be used in Excel. For context the .DLL is supposed to go and retrieve a dataset from an SQL server, convert it to a ADODB.RecordSet that Excel can use.
I've registered from COM interop use and made the assembly COM-Visible by following the instructions here: http://csharphelper.com/blog/2013/10/make-a-c-dll-and-use-it-from-excel-vba-code/
The dll appears in Tools -> References in excel VBA editor.
EDIT
#Rory spotted the mistake on the second line with the incorrect 'set' code. I have corrected this but no improvement.
When I go to look in the Object Browser it also appears there.
However when I go to run the sub routine it fails on the first line with the error message "User-defined type not defined".
I've seen other questions which recommend trying late binding with Set objMyConn = CreateObject("bbsSQLForExcel.SQLCOMS") but this produces an error where excel cannot create the Active X component.
If posting the code for the DLL would help then I can do that as well. (Its not huge)
EDIT Comment have pointed the error could be to do with my VB.net code so I'm going to post it up here and add the vb.net tag.
Imports System.Runtime.InteropServices
Imports System.Windows.Forms
Namespace bbsSQLForExcel
<ComVisible(True)>
Public Class SQLCOMS
Function SQLDate(ByVal dtmDate As DateTime, Optional ByVal blTime As Boolean = False) As String
'From #BBS, TimeLog, BulkMailer, Contacts, BBSProjects, SchemeDocs, Billings, FileLoader.
Dim strDate As String
strDate = Month(dtmDate) & "/" & Microsoft.VisualBasic.Day(dtmDate) & "/" & Microsoft.VisualBasic.Year(dtmDate)
If blTime Then
strDate &= " " & Microsoft.VisualBasic.Hour(dtmDate) & ":" & Microsoft.VisualBasic.Minute(dtmDate) & ":00"
End If
SQLDate = "CONVERT(DATETIME, '" & strDate & "', 102)"
End Function
Function RunSQL(ByVal strSQL As String, ByVal strDatabase As String, Optional ByVal strTeam As String = "", Optional ByVal blAlwaysDS As Boolean = False, Optional ByVal blTimeLogComments As Boolean = False, Optional ByVal blSomerfield As Boolean = False, Optional ByVal blUsePayrollLive As Boolean = False, Optional ByVal intTimeOutOverride As Integer = 15) As ADODB.Recordset
'Fom FileLoader, BBS Contacts, BulkMailer, Time Log, SchemeDocs, Bookings, Accounts, #BBS, Billings, Projects, TimeCost
Dim strConn As String
Dim sqlConnection As System.Data.SqlClient.SqlConnection
Dim sqlCommand As System.Data.SqlClient.SqlCommand
Dim dataAdapter As System.Data.SqlClient.SqlDataAdapter
Dim dataSet As System.Data.DataSet
Select Case strDatabase
Case "Employees", "Users"
strConn = "data source=192.168.0.222;initial catalog=BBSEmployees;persist security info=False;user id=user;workstation id=DELL_LT;packet size=4096;password=pwd"
Case "P3"
strConn = "data source=192.168.0.222;initial catalog=p3;persist security info=False;user id=user;workstation id=DELL_LT;packet size=4096;password=pwd"
If Not (blUsePayrollLive) Then
strSQL = Replace(strSQL, "PayrollSQL", "PayrollSQLTest", , , CompareMethod.Text)
End If
End Select
sqlConnection = New System.Data.SqlClient.SqlConnection(strConn)
strSQL = "Set Arithabort ON; " + strSQL
sqlCommand = New System.Data.SqlClient.SqlCommand(strSQL, sqlConnection)
sqlCommand.CommandTimeout = intTimeOutOverride
dataAdapter = New System.Data.SqlClient.SqlDataAdapter(sqlCommand)
dataSet = New System.Data.DataSet()
Try
dataAdapter.Fill(dataSet)
Catch ex As System.Data.SqlClient.SqlException
MessageBox.Show(ex.Message)
Catch ex As Exception
MessageBox.Show(ex.Message)
End Try
Return ConvertToRecordset(dataSet.Tables(0))
Exit Function
End Function
Public Shared Function ConvertToRecordset(ByVal inTable As DataTable) As ADODB.Recordset
Dim result As ADODB.Recordset = New ADODB.Recordset()
result.CursorLocation = ADODB.CursorLocationEnum.adUseClient
Dim resultFields As ADODB.Fields = result.Fields
Dim inColumns As System.Data.DataColumnCollection = inTable.Columns
For Each inColumn As DataColumn In inColumns
resultFields.Append(inColumn.ColumnName, TranslateType(inColumn.DataType), inColumn.MaxLength, If(inColumn.AllowDBNull, ADODB.FieldAttributeEnum.adFldIsNullable, ADODB.FieldAttributeEnum.adFldUnspecified), Nothing)
Next
result.Open(System.Reflection.Missing.Value, System.Reflection.Missing.Value, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic, 0)
For Each dr As DataRow In inTable.Rows
result.AddNew(System.Reflection.Missing.Value, System.Reflection.Missing.Value)
For columnIndex As Integer = 0 To inColumns.Count - 1
resultFields(columnIndex).Value = dr(columnIndex)
Next
Next
Return result
End Function
Private Shared Function TranslateType(ByVal columnType As Type) As ADODB.DataTypeEnum
Select Case columnType.UnderlyingSystemType.ToString()
Case "System.Boolean"
Return ADODB.DataTypeEnum.adBoolean
Case "System.Byte"
Return ADODB.DataTypeEnum.adUnsignedTinyInt
Case "System.Char"
Return ADODB.DataTypeEnum.adChar
Case "System.DateTime"
Return ADODB.DataTypeEnum.adDate
Case "System.Decimal"
Return ADODB.DataTypeEnum.adCurrency
Case "System.Double"
Return ADODB.DataTypeEnum.adDouble
Case "System.Int16"
Return ADODB.DataTypeEnum.adSmallInt
Case "System.Int32"
Return ADODB.DataTypeEnum.adInteger
Case "System.Int64"
Return ADODB.DataTypeEnum.adBigInt
Case "System.SByte"
Return ADODB.DataTypeEnum.adTinyInt
Case "System.Single"
Return ADODB.DataTypeEnum.adSingle
Case "System.UInt16"
Return ADODB.DataTypeEnum.adUnsignedSmallInt
Case "System.UInt32"
Return ADODB.DataTypeEnum.adUnsignedInt
Case "System.UInt64"
Return ADODB.DataTypeEnum.adUnsignedBigInt
Case Else
Return ADODB.DataTypeEnum.adVarChar
End Select
End Function
End Class
End Namespace
when searching for a particular event. e.g. "oscars 2018 date", Google shows a widget with the date of the event, before any search results. I need to get this date in Excel but it seems difficult in terms of actual coding. I have been tinkering with these functions but not getting any results. The div I am interested in is:
<div class="Z0LcW">5 March 2018, 1:00 am GMT</div>
Here is the full code I am trying to use:
Option Explicit
Public Sub Example()
Call GoogleSearchDescription("oscars 2018 date")
End Sub
Public Function GoogleSearchDescription(ByVal SearchTerm As String) As String
Dim Query As String: Query = "https://www.google.com/search?q=" & URLEncode(SearchTerm)
Dim HTML As String: HTML = GetHTML(Query)
Dim Description() As String: Description = RegExer(HTML, "(<div class=""Z0LcW"">[\w\s.<>/]+<\/div>)")
Description(0) = FilterHTML(Description(0))
Debug.Print Description(0)
Debug.Print "ok"
End Function
Public Function GetHTML(ByVal URL As String) As String
On Error Resume Next
Dim HTML As Object
With CreateObject("InternetExplorer.Application")
.navigate URL
Do Until .ReadyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
Set HTML = .Document.Body
GetHTML = HTML.innerHTML
.Quit
End With
Set HTML = Nothing
End Function
Private Function URLEncode(ByVal UnformattedString As String) As String
'CAUTION: This function URLEncodes strings to match Google Maps API URL specifications, see note below for details
'Note: We convert spaces to + signs, and skip converting plus signs to anything because they replace spaces
'We also skip ampersands [&] as they should not be parsed out of a valid query
Dim Index As Long, ReservedChars As String: ReservedChars = "!#$'()*/:;=?#[]""-.<>\^_`{|}~"
'Convert all % symbols to encoding, as the unformatted string should not already contain URL Encoded characters
UnformattedString = Replace(UnformattedString, "%", "%" & Asc("%"))
'Convert spaces to plus signs to match Google URI query specifications
UnformattedString = Replace(UnformattedString, " ", "+")
'Iterate through the reserved characters for encoding
For Index = 1 To (Len(ReservedChars) - 1)
UnformattedString = Replace(UnformattedString, Mid(ReservedChars, Index, 1), "%" & Asc(Mid(ReservedChars, Index, 1)))
Next Index
'Return URL encoded string
URLEncode = UnformattedString
End Function
Private Function FilterHTML(ByVal RawHTML As String) As String
If Len(RawHTML) = 0 Then Exit Function
Dim HTMLEntities As Variant, HTMLReplacements As Variant, Counter As Long
Const REG_HTMLTAGS = "(<[\w\s""':.=-]*>|<\/[\w\s""':.=-]*>)" 'Used to remove HTML formating from each step in the queried directions
HTMLEntities = Array(" ", "<", ">", "&", """, "'")
HTMLReplacements = Array(" ", "<", ">", "&", """", "'")
'Parse HTML Entities into plaintext
For Counter = 0 To UBound(HTMLEntities)
RawHTML = Replace(RawHTML, HTMLEntities(Counter), HTMLReplacements(Counter))
Next Counter
'Remove any stray HTML tags
Dim TargetTags() As String: TargetTags = RegExer(RawHTML, REG_HTMLTAGS)
'Preemptively remove new line characters with actual new lines to separate any conjoined lines.
RawHTML = Replace(RawHTML, "<b>", " ")
For Counter = 0 To UBound(TargetTags)
RawHTML = Replace(RawHTML, TargetTags(Counter), "")
Next Counter
FilterHTML = RawHTML
End Function
Public Function RegExer(ByVal RawData As String, ByVal RegExPattern As String) As String()
'Outputs an array of strings for each matching expression
Dim RegEx As Object: Set RegEx = CreateObject("VBScript.RegExp")
Dim Matches As Object
Dim Match As Variant
Dim Output() As String
Dim OutputUBound As Integer
Dim Counter As Long
With RegEx
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = RegExPattern
End With
If RegEx.test(RawData) Then
Set Matches = RegEx.Execute(RawData)
For Each Match In Matches
OutputUBound = OutputUBound + 1
Next Match
ReDim Output(OutputUBound - 1) As String
For Each Match In Matches
Output(Counter) = Matches(Counter)
Counter = Counter + 1
Next Match
RegExer = Output
Else
ReDim Output(0) As String
RegExer = Output
End If
End Function
You can use data from web, with this query
https://www.google.com/search?q=oscars+2018+date&oq=oscars+2018
then check the whole page and import. it for me it was in row 27.
I have built a program that allows the user to search for a customer or add a new user with various information related to that customer. However when I run the program I get an error that says An unhandled exception of type 'System.OverflowException' occurred in Microsoft.VisualBasic.dll attached to the telephone number. I am not sure what I am doing wrong here.
My code:
Imports System.IO
Public Class Form1
Dim txtFile As StreamWriter ' object variable
Dim searchFile As StreamReader ' object variable
' structure declaration
Structure CustomerAccounts
Dim Records As StreamReader
Dim LastName As String
Dim FirstName As String
Dim CustomerNumber As String
Dim Address As String
Dim City As String
Dim State As String
Dim ZIPCode As Integer
Dim TelephoneNumber As Int64
Dim AccountBalance As Double
Dim DateOfLastPayment As String
End Structure
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
End Sub
Private Sub SaveCtrlSToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles SaveCtrlSToolStripMenuItem.Click
Dim CustomerRecord As CustomerAccounts ' Structure Variable
' Assigning data to structure variable
CustomerRecord.LastName = txtLast.Text
CustomerRecord.FirstName = txtFirst.Text
CustomerRecord.CustomerNumber = txtNumber.Text
CustomerRecord.Address = txtAddress.Text
CustomerRecord.City = txtCity.Text
CustomerRecord.State = txtState.Text
CustomerRecord.ZIPCode = CInt(txtZIPCode.Text)
CustomerRecord.TelephoneNumber = CInt(txtTelephone.Text)
CustomerRecord.AccountBalance = CDbl(txtAccountBalance.Text)
While CustomerRecord.AccountBalance < 0
CustomerRecord.AccountBalance = CDbl(InputBox("Please enter a non-negative balance"))
End While
CustomerRecord.DateOfLastPayment = CDate(txtPayment.Text)
' Opening a file in append mode
txtFile = File.CreateText("Records.txt")
' Writing data to a file
txtFile.WriteLine(CustomerRecord.LastName)
txtFile.WriteLine(CustomerRecord.FirstName)
txtFile.WriteLine(CustomerRecord.CustomerNumber)
txtFile.WriteLine(CustomerRecord.Address)
txtFile.WriteLine(CustomerRecord.City)
txtFile.WriteLine(CustomerRecord.State)
txtFile.WriteLine(CustomerRecord.ZIPCode)
txtFile.WriteLine(CustomerRecord.TelephoneNumber)
txtFile.WriteLine(CustomerRecord.AccountBalance)
txtFile.WriteLine(CustomerRecord.DateOfLastPayment)
txtFile.Close() ' Close the data file after writing the data
clearFields()
End Sub
Private Sub ExitCtrlQToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles ExitCtrlQToolStripMenuItem.Click
' Close the form
Me.Close()
End Sub
Private Sub SearchToolStripMenuItem1_Click(sender As Object, e As EventArgs) Handles SearchToolStripMenuItem1.Click
' Open a file in read mode
searchFile = File.OpenText("Records.Txt")
Dim lastName As String
Dim flag As Integer
flag = 0
' get the record name from user input
lastName = InputBox("Please enter the last name to search")
Dim CSearchRecord As CustomerAccounts
Try
While Not searchFile.EndOfStream
CSearchRecord.LastName = searchFile.ReadLine()
CSearchRecord.FirstName = searchFile.ReadLine()
CSearchRecord.CustomerNumber = searchFile.ReadLine()
CSearchRecord.Address = searchFile.ReadLine()
CSearchRecord.City = searchFile.ReadLine()
CSearchRecord.State = searchFile.ReadLine()
CSearchRecord.ZIPCode = searchFile.ReadLine()
CSearchRecord.TelephoneNumber = searchFile.ReadLine()
CSearchRecord.AccountBalance = searchFile.ReadLine()
CSearchRecord.DateOfLastPayment = searchFile.ReadLine()
' Compare current record with search record
If CSearchRecord.LastName.Equals(lastName) Then
flag = 1
Exit While
End If
End While
' If record found display txt fields
If flag.Equals(1) Then
txtLast.Text = CSearchRecord.LastName.ToString()
txtFirst.Text = CSearchRecord.FirstName.ToString()
txtNumber.Text = CSearchRecord.CustomerNumber.ToString()
txtAddress.Text = CSearchRecord.Address.ToString()
txtCity.Text = CSearchRecord.City.ToString()
txtState.Text = CSearchRecord.City.ToString()
txtZIPCode.Text = CSearchRecord.ZIPCode.ToString()
txtTelephone.Text = CSearchRecord.TelephoneNumber.ToString()
txtAccountBalance.Text = CSearchRecord.AccountBalance.ToString()
txtPayment.Text = CSearchRecord.DateOfLastPayment.ToString()
Else
' If record not found alert user
MessageBox.Show("Record Not Found")
clearFields()
End If
Catch ex As Exception
End Try
End Sub
Private Sub ReportToolStripMenuItem1_Click(sender As Object, e As EventArgs) Handles ReportToolStripMenuItem1.Click
Dim report As String
report = "Report of Customer Accounts" + vbNewLine
' Open file in read mode
searchFile = File.OpenText("Record.txt")
Try
' Reading the file until end
While Not searchFile.EndOfStream
report += searchFile.ReadLine() + " "
report += searchFile.ReadLine() + " "
report += searchFile.ReadLine() + " "
report += searchFile.ReadLine() + " "
report += vbNewLine
End While
Catch ex As Exception
End Try
' Display file Content as report
MessageBox.Show(report)
End Sub
Private Sub clearFields()
txtAccountBalance.Clear()
txtAddress.Clear()
txtCity.Clear()
txtFirst.Clear()
txtLast.Clear()
txtNumber.Clear()
txtPayment.Clear()
txtState.Clear()
txtTelephone.Clear()
txtZIPCode.Clear()
End Sub
End Class
Any help offered would be greatly appreciated. I just need to know how to fix this.
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
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