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
Related
I'm learning about storing multiple values for a Key in VBA. My research has lead to me to utilize a custom Collection Class.
I got it to work in theory and then in practice I wanted to look up values based on the key but was only able to do it via "index number". I then generated a Property to return that index number, but that means if I have to loop through Keys each each will loop through the entire collection to find the index number before moving forward. This seems like too much computation and I'm wondering if there is a way to use a dicitonary key/value setup to store the Keys Index and have this all setup inside the Collection Class so I can directly call a keys value via it's index from the dictionary.
Here is my code so far:
Module:
'https://www.wiseowl.co.uk/blog/s239/collections.htm
Sub CreatePeople()
Dim p1 As New clsPersons, p2 As New clsPersons, p3 As New clsPersons
With p1
.FirstName = "Rita"
.LastName = "Smith"
End With
With p2
.FirstName = "Sue"
.LastName = "Jones"
End With
With p3
.FirstName = "Bob"
.LastName = "Brown"
End With
Debug.Print p1.FirstName, p1.LastName, p1.FullName
Debug.Print p1.FullName, p2.FullName, p3.FullName
End Sub
Sub CreatePersonsCollectionSafer()
Dim Persons As New clsPersons
Persons.Add "Rita", "Smith"
Persons.Add "Sue", "Jones"
Persons.Add "Bob", "Brown"
Dim Person As clsPersons
Dim PersonNumber As Integer
Debug.Print Persons.Count
For PersonNumber = 1 To Persons.Count
Debug.Print Persons.Item(PersonNumber).FullName
Next PersonNumber
Dim LastName As String
LastName = "Brown"
Debug.Print "Last Name = " & LastName & " & First Name = " & Persons.ItemByLastName(LastName).FirstName
End Sub
Class (clsPersons):
Option Explicit
Private Persons As New Collection
Private Person As clsPersons
Public FirstName As String
Public LastName As String
''Subs
Sub Add(FirstName As String, LastName As String)
Dim p As New clsPersons
p.FirstName = FirstName
p.LastName = LastName
Persons.Add p
End Sub
Sub Remove(NameOrNumber As Variant)
Persons.Remove NameOrNumber
End Sub
''EndSubs
''Properties
Property Get Count() As Long
Count = Persons.Count
End Property
Property Get Item(Index As Variant) As clsPersons
Set Item = Persons(Index)
End Property
Property Get FullName() As String
FullName = FirstName & " " & LastName
End Property
Property Get Items() As Collection
Set Items = Persons
End Property
Property Get ItemByLastName(LastName As String) As clsPersons
Dim PersonsIndex As Integer
For PersonsIndex = 1 To Persons.Count
Debug.Print Persons.Item(PersonsIndex).LastName
If Persons.Item(PersonsIndex).LastName = LastName Then
Set ItemByLastName = Persons(PersonsIndex)
Exit For
End If
Next PersonsIndex
End Property
''EndProperties
You should be using the keys provided by the collection. You don't need an extra collection/dictionary.
Sub Add(FirstName As String, LastName As String)
Dim p As New clsPersons
p.FirstName = FirstName
p.LastName = LastName
Persons.Add p, LastName
End Sub
Property Get ItemByLastName(LastName As String) As clsPersons
Set ItemByLastName = Persons(LastName)
End Property
However, you should not be working with a single class here. You are basically holding a new collection of persons inside each person. You should have a Person and a Persons class to make code easier to read and maintain.
You should also hide your members and expose getters to achieve encapsulation. In your code you can easily change the name of a person and thus the keys will be useless.
Here is a different approach:
Person class:
Option Explicit
Private m_firstName As String
Private m_lastName As String
Private m_initialized As Boolean
Public Function Init(ByVal firstName_ As String, ByVal lastName_ As String) As Boolean
If m_initialized Then
Err.Raise 5, TypeName(Me) & ".Init", "Already initialized"
End If
If firstName_ = vbNullString Or lastName_ = vbNullString Then Exit Function 'Returns False
m_firstName = firstName_
m_lastName = lastName_
m_initialized = True
Init = True
End Function
Property Get FirstName() As String
FirstName = m_firstName
End Property
Property Get LastName() As String
LastName = m_lastName
End Property
Property Get FullName() As String
FullName = m_firstName & " " & m_lastName
End Property
Public Function Self() As Person
Set Self = Me
End Function
Persons class:
Option Explicit
Private m_persons As New Collection
Public Function Add(ByVal p As Person) As Boolean
On Error Resume Next 'Name can already exist
m_persons.Add p, p.LastName 'Or maybe full name would be better as multiple persons can share the same last name
Add = Err.Number = 0
On Error GoTo 0
End Function
Public Function AddFromValues(ByVal firstName_ As String, ByVal lastName_ As String) As Boolean
With New Person
If Not .Init(firstName_, lastName_) Then Exit Function
AddFromValues = Me.Add(.Self)
End With
End Function
Public Sub Remove(ByVal indexOrLastName As Variant)
m_persons.Remove indexOrLastName
End Sub
Public Property Get Count() As Long
Count = m_persons.Count
End Property
Property Get Item(ByVal indexOrLastName As Variant) As Person
Set Item = m_persons(indexOrLastName)
End Property
Property Get Items() As Collection
Set Items = m_persons
End Property
Public Function Exists(ByVal lastName_ As String) As Boolean
On Error Resume Next
m_persons.Item lastName_
Exists = (Err.Number = 0)
On Error GoTo 0
End Function
and then the testing code in a standard .bas module:
Option Explicit
Public Sub CreatePeople()
Dim p1 As New Person
Dim p2 As New Person
Dim p3 As New Person
p1.Init "Rita", "Smith"
p2.Init "Sue", "Jones"
p3.Init "Bob", "Brown"
Debug.Print p1.FirstName, p1.LastName, p1.FullName
Debug.Print p1.FullName, p2.FullName, p3.FullName
End Sub
Public Sub CreatePersonsCollectionSafer()
Dim myPersons As New Persons
myPersons.AddFromValues "Rita", "Smith"
myPersons.AddFromValues "Sue", "Jones"
myPersons.AddFromValues "Bob", "Brown"
Dim tempPerson As Person
For Each tempPerson In myPersons.Items
Debug.Print tempPerson.FullName
Next tempPerson
Dim lastNameToSearch As String
lastNameToSearch = "Brown"
Debug.Print "Last Name = " & lastNameToSearch & " & First Name = " _
& myPersons.Item(lastNameToSearch).FirstName
End Sub
I've solved this issue via the following:
Private PersonsIndexDic As Object
Sub Add(FirstName As String, LastName As String)
Dim p As New clsPersons
p.FirstName = FirstName
p.LastName = LastName
Persons.Add p
PersonsIndexDic.Add Key:=LastName, Item:=PersonsIndexDic.Count + 1
End Sub
Property Get ItemByLastName(LastName As String) As clsPersons
Set ItemByLastName = Persons(PersonsIndexDic(LastName))
End Property
Test:
Dim LastName As String
LastName = "Brown"
Debug.Print "Last Name = " & LastName & " & First Name = " & Persons.ItemByLastName(LastName).FirstName
I have an Excel sheet with a code that gives every row a hyperlink at the end.
What should be happening next is: Once i click this hyperlink, "Data is confirmed" should be saved to an Access file.
For example: There are 10 rows, thanks to the current code, a hyperlink gets added to every single row. If i click on this hyperlink on row 8 , "Data is confirmed" should be added to the Access file on row 8 (and only row 8!)
Thanks to Basodre, i currently have this code but can't figure out a way to get a text saved in Access. Any ideas?
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Confirm that this is a hyperlink in column 3
If Not Intersect(Target.Range, Columns(3)) Is Nothing Then
MsgBox SaveData(Target.Range)
End If
End Sub
Private Function SaveData(rng As Range) As Boolean
Debug.Print rng.Address & " has been saved."
SaveData = True
End Function
I have an class module I use for creating DB objects. It's name is AccessBackEnd.
Option Explicit
' ConnectModeEnum
'Private Const adModeRead = 1
'Private Const adModeReadWrite = 3
Private Const adModeShareDenyNone As Long = 16
' adStateEnum
'Const adStateClosed As Long = 0 'Indicates that the object is closed.
Const adStateOpen As Long = 1 'Indicates that the object is open.
'Const adStateConnecting As Long = 2 'Indicates that the object is connecting.
'Const adStateExecuting As Long = 4 'Indicates that the object is executing a command.
'Const adStateFetching As Long = 8 'Indicates that the rows of the object are being retrieved.
' CursorTypeEnum
Const adOpenStatic As Long = 3
' LockTypeEnum
Const adLockOptimistic As Long = 3
Private dataSource As Object
Public Property Get Connection() As Object
If dataSource Is Nothing Then
Set dataSource = CreateObject("ADODB.Connection")
With dataSource
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Mode = adModeShareDenyNone
End With
End If
Set Connection = dataSource
End Property
Private localFileName as string
Public Property Get FileName() As String
FileName = localFileName
End Property
Public Property Set FileName(newFileName As String) As String
localFileName = newFileName
End Property
Public Sub Connect(ByVal dataBaseName As String)
Connection.Open "Data Source=" & dataBaseName & ";"
End Sub
''' Recordset command is used to access table data
Public Function Record(ByVal sqlQuery As String) As Object
If Not ((Connection.state And adStateOpen) = adStateOpen) Then
Connect FileName
End If
Set Record = CreateObject("ADODB.Recordset")
Record.Open Source:=sqlQuery, ActiveConnection:=Connection, CursorType:=adOpenStatic, LockType:=adLockOptimistic
End Function
Public Sub Dispose()
If dataSource Is Nothing Then
Debug.Print "You disposed of nothing..."
Else
If (Connection.state And adStateOpen) = adStateOpen Then dataSource.Close
Set dataSource = Nothing
End If
End Sub
This example shows how you can update an Access field from Excel.
Dim thisDB As AccessBackEnd
Set thisDB = New AccessBackEnd
thisDB.FileName = "Your DB full path goes here.accdb"
With thisDB.Record("SELECT * FROM yourTable WHERE ID=" & PrimaryKey & ";")
If Not (.EOF Or .BOF) Then
.Fields("Your Field to update goes here").Value = rng.Address
.Update
End If
End With
thisDB.Dispose
My application requires variables to be set and retrieved multiple times in different forms and subs. Instead of writing the code multiple times i was hoping to use a loop to loop through the variables and set them accordingly. The code below shows my settings menu and how it is built. I'm stuck with setting the variables based on a name that is stored as a string (See last code snippet below).
The section imedialty below are the menu classes. This bit works as expected
Public Class MenuItem
Public Name As String
Public Type As TypeEnum
Enum TypeEnum
CheckBox
ComboBox
TextBox
End Enum
Public Sub New()
End Sub
End Class
Public Class Menu
Public MenuItems() As MenuItem
Public Name As String
Public LinkedVariable as Object
Public Sub New()
End Sub
Public Sub AddMenuItem(ByVal ItemName As String, _
ByVal ItemType As MenuItem.TypeEnum, _
ByVal ItemLinkedVariable as Object)
If MenuItems Is Nothing Then
ReDim MenuItems(0)
Else
ReDim Preserve MenuItems(MenuItems.Length)
End If
MenuItems(MenuItems.Length - 1) = New MenuItem
MenuItems(MenuItems.Length - 1).Name = ItemName
MenuItems(MenuItems.Length - 1).Type = ItemType
MenuItems(MenuItems.Length - 1).LinkedVariable = ItemLinkedVariable
End Sub
End Class
Build the menus in the main form class. This bit works as expected
Public Class Form1
Public Settings As New SettingsForm
Public Sub CreateMenu()
Settings.AddMenu("Menu1")
Settings.Menus(0).AddMenuItem("CheckBoxA", MenuItem.TypeEnum.CheckBox, VariableA)
Settings.Menus(0).AddMenuItem("TextBoxB", MenuItem.TypeEnum.TextBox, VariableB)
Settings.Menus(0).AddMenuItem("TextBoxC", MenuItem.TypeEnum.TextBox, VariableC)
Settings.AddMenu("Menu2")
Settings.Menus(1).AddMenuItem("CheckBoxD", MenuItem.TypeEnum.CheckBox, VariableD)
Settings.Menus(1).AddMenuItem("TextBoxE", MenuItem.TypeEnum.TextBox, VariableE)
'etc......
Settings.Build()
Settings.Show()
End Sub
End Class
Public Class SettingsForm
Public Menus() As Menu
Public VariableA As Boolean
Public VariableB As String
Public VariableC As String
Public VariableD As Boolean
Public VariableE As String
Public Sub New()
InitializeComponent()
End Sub
Public Sub Build()
SettingsTabControl.TabPages.Clear()
If Menus IsNot Nothing Then
For i As Integer = 0 To Menus.Length - 1
SettingsTabControl.TabPages.Add(Menus(i).Name)
SettingsTabControl.TabPages(i).Name = Menus(i).Name & "TabPage"
SettingsTabControl.TabPages(i).Text = Menus(i).Name
AddSettingsItems(Menus(i), i)
Next
End If
End Sub
Public Sub AddSettingsItems(ByVal SelectedMenu As Menu, ByVal TabPageIndex As Integer)
Dim y As Integer = 50
Dim yinc As Integer = 25
If SelectedMenu IsNot Nothing Then
If SelectedMenu.MenuItems IsNot Nothing Then
For i As Integer = 0 To SelectedMenu.MenuItems.Length - 1
Dim formObj As Object
'Specific Settings
Select Case SelectedMenu.MenuItems(i).Type
Case MenuItem.TypeEnum.CheckBox
formObj = New CheckBox
Case MenuItem.TypeEnum.ComboBox
formObj = New ComboBox
Case MenuItem.TypeEnum.TextBox
formObj = New TextBox
formObj.TextAlign = HorizontalAlignment.Right
formObj.BorderStyle = BorderStyle.FixedSingle
End Select
formObj.Name = SelectedMenu.MenuItems(i).Name
formObj.Location = New Point(25, y)
SettingsTabControl.TabPages(TabPageIndex).Controls.Add(formObj)
y = y + yinc
Next
End If
End If
End Sub
End Class
This is the bit i am stuck on i want to be able to set the Variables A,B,C,D,E from the controls that were added to the SettingsTabControl. However i can't work out how to link the Variables to the LinkedVariable objects in each MenuItem. This is what i have but it doesn't work
Private Sub SettingsFromOkButton_Click(sender As Object, e As EventArgs) Handles OkButton.Click
For m As Integer = 0 To Menus.Length - 1
For i As Integer = 0 To Menus(m).MenuItems.Length
Dim currentcontrol As Object = SettingsTabControl.TabPages(m).Controls(Menus(m).MenuItems(i).Name)
Select Case Menus(m).MenuItems(i).Type
Case MenuItem.TypeEnum.CheckBox
If currentcontrol.CheckedState = True Then
Menus(m).MenuItems(i).LinkedVariable = True
Else
Menus(m).MenuItems(i).LinkedVariable = False
End If
Case MenuItem.TypeEnum.ComboBox
Case MenuItem.TypeEnum.TextBox
Menus(m).MenuItems(i).LinkedVariable = currentcontrol.Text
End Select
Next
Next
MsgBox(VariableA & vbCrLf _
VariableB & vbCrLf _
VariableC & vbCrLf _
VariableD & vbCrLf _
VariableE & vbCrLf)
End Sub
I used a reflection
Dim Flags As BindingFlags = BindingFlags.GetField Or BindingFlags.Instance Or BindingFlags.Public
Dim fVar As System.Reflection.FieldInfo = Me.GetType.GetField(ObjectName, Flags)
If TypeOf SettingsTabControl.TabPages(TabPageIndex).Controls(CtrlName) Is TextBox Then
ctrlValue = SettingsTabControl.TabPages(TabPageIndex).Controls(CtrlName).Text
ElseIf TypeOf SettingsTabControl.TabPages(TabPageIndex).Controls(CtrlName) Is CheckBox Then
ctrlValue = CType(SettingsTabControl.TabPages(TabPageIndex).Controls(CtrlName), CheckBox).Checked
ElseIf TypeOf SettingsTabControl.TabPages(TabPageIndex).Controls(CtrlName) Is RadioButton Then
ctrlValue = CType(SettingsTabControl.TabPages(TabPageIndex).Controls(CtrlName), RadioButton).Checked
End If
fVar.SetValue(Me, ctrlValue)
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 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