VBA: Dictionary - Can only retrieve the last entry - class

This is probably a newbie mistake where I'm not aware of some setting that I haven't changed. Anyways, I'm trying use Dictionary to store a instances of class I've created.
Class cls_Connote is just a container of details.
Public connoteNumber As String
Public despatchDate As Date
Public carrier As String
Public service As String
Public items As Integer
Public weight As Integer
Public cost As Single
Public surchargeType As String
Here is how I'm storing the details into the class then into the dictionary.
Function getSurcharge_tag(givenTag As String, givenCol As String, ByRef dicStore As Dictionary, ByRef counter As Integer)`
Dim tagLen As Integer
Dim conNum, conTag As String
Dim clsSurchargeDetails As New cls_Connote
Dim despatchDate, carrier As String
Dim items, weight As Integer
Dim cost As Single
Range(givenCol).Select
tagLen = Len(givenTag)
Do While (ActiveCell.Value <> "")
conNum = Mid(ActiveCell.Value, 1, Len(ActiveCell.Value) - 1)
conTag = Mid(ActiveCell.Value, Len(ActiveCell.Value) - tagLen + 1, Len(ActiveCell.Value))
If (conTag = givenTag) Then 'Remove: both the Original and Adjusted connote lines
despatchDate = ActiveCell.Offset(0, -2).Value
items = ActiveCell.Offset(0, 10).Value
weight = ActiveCell.Offset(0, 11).Value
cost = ActiveCell.Offset(0, 12).Value
clsSurchargeDetails.connoteNumber = conNum
clsSurchargeDetails.despatchDate = despatchDate
clsSurchargeDetails.carrier = carrier
clsSurchargeDetails.items = items
clsSurchargeDetails.weight = weight
clsSurchargeDetails.cost = cost
clsSurchargeDetails.surchargeType = givenTag
dicStore.Add conNum, clsSurchargeDetails
givenCtr = givenCtr + 1
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Function
This is how I'm trying to get the connotes out of the Dictionary.
Function displaySurcharges(wrkShtName As String, ByRef dicList As Dictionary)
'Remove the existing worksheet
Dim wrkSht As Worksheet
On Error Resume Next
Set wrkSht = Sheets(wrkShtName)
On Error GoTo 0
If Not wrkSht Is Nothing Then
Worksheets(wrkShtName).Delete
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = wrkShtName
populateColumnHeaders
Range("A2").Select
Dim getCon As cls_Connote
Set getCon = New cls_Connote
Dim vPtr As Variant
Dim ptrDic As Integer
For Each vPtr In dicList.Keys
Set getCon = dicList.Item(vPtr)
ActiveCell.Value = getCon.connoteNumber
ActiveCell.Offset(0, 1).Value = getCon.despatchDate
ActiveCell.Offset(0, 2).Value = getCon.carrier
ActiveCell.Offset(0, 12).Value = getCon.items
ActiveCell.Offset(0, 13).Value = getCon.weight
ActiveCell.Offset(0, 15).Value = getCon.cost
ActiveCell.Offset(0, 16).Value = getCon.surchargeType
Set getCon = Nothing
ActiveCell.Offset(1, 0).Select
Next vPtr
End Function
I can see dicList does contain different details, getCon only gets the last entry in the Dictionary.
Any help would be fantastic !

To avoid reusing and adding the same reference within the loop, when you need a new instance (after If (conTag = givenTag)) just ask for one:
Set clsSurchargeDetails = New cls_Connote

Related

Getting Email Addresses for Recipients (Outlook)

I have a code that I was able to string together that logs my sent emails into an excel sheet so i can use that data for other analysis.
In it, I have it resolving the name into an email as outlook shortens it ("Jimenez, Ramon" = email#address.com) as outlook configured this and it works when i send an email to anyone in my company as they are in my address book.
Now, when I email anyone outside it defaults to lastName, firstName so it is not converting this and logging it.
I thought the code I have in here already does this, but I guess not. I have already come this far and I am NOT a software guru at all. Does anyone have insight on how I can also include this as well?? Please see code below:
Private WithEvents Items As Outlook.Items
Const strFile As String = "C:\Users\a0227084\Videos\work\test.xlsx"
Private Sub Application_Startup()
Dim OLApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set OLApp = Outlook.Application
Set objNS = OLApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' ******************
FullName = Split(Msg.To, ";")
For i = 0 To UBound(FullName)
If i = 0 Then
STRNAME = ResolveDisplayNameToSMTP(FullName(i))
Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
ElseIf ResolveDisplayNameToSMTP(FullName(i)) <> "" Then
STRNAME = ResolveDisplayNameToSMTP(FullName(i))
Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
End If
Next i
'Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Sub tes2t()
End Sub
Function getRecepientEmailAddress(eml As Variant)
Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array
For Each emlAddr In eml.Recipients
If Left(emlAddr.Address, 1) = "/" Then
' it's an Exchange email address... resolve it to an SMTP email address
out.Add ResolveDisplayNameToSMTP(emlAddr)
Else
out.Add emlAddr.Address
End If
Next
getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function
Function ResolveDisplayNameToSMTP(sFromName) As String
' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith#myco.com)
' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
' source: https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel
Dim OLApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set OLApp = CreateObject("Outlook.Application")
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
Dim PR_SMTP_ADDRESS As String
PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
End Select
End If
End Function
Sub Write_to_excel(str1 As String, str2 As String, str3 As String)
Dim xlApp As Object
Dim sourceWB As Workbook
Dim sourceWH As Worksheet
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With
Set sourceWB = Workbooks.Open(strFile, False, False)
Set sourceWH = sourceWB.Worksheets("Sheet1")
sourceWB.Activate
With sourceWH
lastrow = .Cells(.rows.Count, "A").End(xlUp).Row
End With
sourceWH.Cells(lastrow + 1, 1) = str1
sourceWH.Cells(lastrow + 1, 2) = str2
sourceWH.Cells(lastrow + 1, 3) = str3
sourceWB.Save
sourceWB.Close
End Sub
Error message and corrected code
Regards,
Ramon
First of all, there is no need to create a new Application instance in the ResolveDisplayNameToSMTP method:
Set OLApp = CreateObject("Outlook.Application")
Instead, you can use the Application property available in the Outlook VBA editor out of the box.
Second, you need to use the following code to get the SMTP address from the AddressEntry object:
Dim PR_SMTP_ADDRESS As String
Set PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
Instead of the following line:
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
Read more about that in the How to get the SMTP Address of the Sender of a Mail Item using Outlook Object Model? article.

Updated Yahoo Weather API - .NET

I'm trying to implement the newest yahoo weather API in a .NET application (the one we were using was discontinued in favor of this new one): https://developer.yahoo.com/weather/documentation.html#commercial
Their only examples are in PHP and Java. I've done my best to convert the Java example to .NET but I still am getting a "401 - Unauthorized" response. I've gone over my code several times and cannot find any problems so I'm hoping someone else will be able to see where I went wrong. Code is below.
Private Sub _WeatherLoader_DoWork(sender As Object, e As DoWorkEventArgs)
Try
Dim oauth As New OAuth.OAuthBase
Dim forecastRssResponse As query
Dim appId As String = My.Settings.YahooAppID
Dim consumerKey As String = My.Settings.YahooAPIConsumerKey
Dim yahooUri As String = String.Format("{0}?location=billings,mt&format=xml", YAHOO_WEATHER_API_BASE_ENDPOINT)
Dim oAuthTimestamp As Integer = oauth.GenerateTimeStamp()
Dim oAuthNonce As String = oauth.GenerateNonce()
Dim parameters As New List(Of String)
Try
parameters.Add(String.Format("oauth_consumer_key={0}", consumerKey))
parameters.Add(String.Format("oauth_nonce={0}", oAuthNonce))
parameters.Add("oauth_signature_method=HMAC-SHA1")
parameters.Add(String.Format("oauth_timestamp={0}", oAuthTimestamp.ToString()))
parameters.Add("oauth_version=1.0")
' Encode the location
parameters.Add(String.Format("location={0}", HttpUtility.UrlEncode("billings,mt", Encoding.UTF8)))
parameters.Add("format=xml")
' Sort parameters ascending
parameters = parameters.OrderBy(Function(item) item).ToList()
Dim i As Integer = 0
Dim builder As New StringBuilder()
Do While (i < parameters.Count())
builder.Append(String.Format("{0}{1}", If(i > 0, "&", String.Empty), parameters(i)))
i += 1
Loop
Dim signatureString As String = String.Format("GET&{0}&{1}", HttpUtility.UrlEncode(YAHOO_WEATHER_API_BASE_ENDPOINT, Encoding.UTF8), HttpUtility.UrlEncode(builder.ToString(), Encoding.UTF8))
Dim oAuthSignature As String = _CreateOauthSignature(signatureString)
Dim authorizationLine As String = String.Format("OAuth oauth_consumer_key={0}, oauth_nonce={1}, oauth_timestamp={2}, oauth_signature_method=HMAC-SHA1, oauth_signature={3}, oauth_version=1.0", consumerKey, oAuthNonce, oAuthTimestamp, oAuthSignature)
Dim forecastRequest As WebRequest = WebRequest.Create(yahooUri)
forecastRequest.Headers.Add("Authorization", authorizationLine)
forecastRequest.Headers.Add("Yahoo-App-Id", appId)
' Cast to HttpWebRequest to set ContentType through property
CType(forecastRequest, HttpWebRequest).ContentType = "text/xml"
Dim forecastResponse As WebResponse = forecastRequest.GetResponse()
If forecastResponse IsNot Nothing Then
Using responseStream As Stream = forecastResponse.GetResponseStream()
Dim rssDoc As New XmlDocument()
rssDoc.Load(responseStream)
forecastRssResponse = rssDoc.OuterXml().FromXml(Of query)()
End Using
e.Result = forecastRssResponse
End If
Catch ex As Exception
e.Result = Nothing
LoadingManually = False
End Try
Catch ex As Exception
modMain.SendDevErrorEmail(ex, "_WeatherLoader_DoWork in WeatherWidget", "Catch around dowork code in fired from refresh timer event in wether widget")
e.Result = Nothing
LoadingManually = False
End Try
End Sub
Private Function _CreateOauthSignature(baseInfo As String) As String
Dim secretKey As String = String.Format("{0}&", My.Settings.YahooAPIConsumerSecretKey)
Dim encoding As New System.Text.ASCIIEncoding()
Dim keyBytes As Byte() = encoding.GetBytes(secretKey)
Dim messageBytes As Byte() = encoding.GetBytes(baseInfo)
Dim hashMessage As Byte()
Using hmac As New HMACSHA1(keyBytes)
hashMessage = hmac.ComputeHash(messageBytes)
End Using
Return Convert.ToBase64String(hashMessage)
End Function
After painstakingly creating a Java app, pasting in the Java example and stepping through it I found that the issue is in a poorly implemented URL Decode function on the receiving end.
In the Java app, URL Encode uses upper case characters while in .NET HTTPUtility.URLEncode uses lower case characters. This is enough to throw off your signature and cause a 401 - Unauthorized error.
My solution was to create a string extension method that will URL Encode in upper case:
<Extension>
Public Function UppercaseURLEncode(ByVal sourceString As String) As String
Dim temp As Char() = HttpUtility.UrlEncode(sourceString).ToCharArray()
For i As Integer = 0 To temp.Length - 2
If temp(i).ToString().Equals("%", StringComparison.OrdinalIgnoreCase) Then
temp(i + 1) = Char.ToUpper(temp(i + 1))
temp(i + 2) = Char.ToUpper(temp(i + 2))
End If
Next
Return New String(temp)
End Function
Using this extension method my signature gets created exactly like the one in the Java app and I am able to retrieve the response.
Hope this helps other .net programmers with this issue!

CreateChangesetAsync - How to checkin an existing file without knowing enconding or file type (just file path)

i tried to follow the example on how to create a changeset with multiple files: [See link][1]
Although i am a bit stuck at the TFVCItem and ItemContent stage where i don't know how to extract the content and enconding of my file.
Im trying to write some code in order to checkin a file given to me by a filePath and check it in at a given location.
Would anyone care to help me out on how to do this?
This is what i came up so far:
Public Function CreateChangeset(ByVal projectName As String,
ByVal files As Dictionary(Of String, String),
ByVal comment As String) As TfvcChangesetRef
Dim c = TFSConnection.GetClient(Of TfvcHttpClient)
Dim newChangetset = New TfvcChangeset
Dim changes = New List(Of TfvcChange)
For Each fKP In files
Dim fileSource = fKP.Key
Dim fileTarget = fKP.Value
Dim newChange = New TfvcChange
newChange.ChangeType = VersionControlChangeType.Add
Dim newItem = New TfvcItem
newItem.Path = $"&/{projectName}/{fileTarget}"
newItem.ContentMetadata = New FileContentMetadata
'' TODO: How to extract the correct encoding, and type?...
'newItem.ContentMetadata.Encoding = GetFileEncoding(fileSource)
'newItem.ContentMetadata.ContentType = "text/plain"
'newChange.Item = newItem
'' TODO: How to extract the correct content, and type?...
'Dim newContent = New ItemContent
'newContent.Content = "Blabla"
'newContent.ContentType = ItemContentType.RawText
'newChange.NewContent = newContent
changes.Add(newChange)
Next
newChangetset.Changes = changes
newChangetset.Comment = comment
Dim changesetRef = c.CreateChangesetAsync(newChangetset).Result
Return changesetRef
End Function
UPDATE:
Ok so i managed to make it work but i still am not sure how to properly set the ContentType.
I have the choice between ItemContentType.RawText and ItemContentType.Base64Encoded but i am not sure when to use one or the other.
Here is the new code which seems to work:
Public Function CreateChangeset(ByVal projectName As String,
ByVal files As Dictionary(Of String, String),
ByVal comment As String) As TfvcChangesetRef
Dim c = TFSConnection.GetClient(Of TfvcHttpClient)
Dim newChangetset = New TfvcChangeset
Dim changes = New List(Of TfvcChange)
For Each fKP In files
' Extract and build our target and source paths.
Dim fileSource = fKP.Key
Dim fileTarget = fKP.Value
Dim fileName = IO.Path.GetFileName(fileSource)
Dim newChange = New TfvcChange
' Create the new TFVC item which will be checked-in.
Dim newItem = New TfvcItem
newItem.Path = $"$/{projectName}/{fileTarget}/{fileName}"
newItem.ContentMetadata = New FileContentMetadata
' Try to extract the item from the server.
Dim serverItem = c.GetItemAsync(newItem.Path).Result
If serverItem Is Nothing Then
' If the file is not on the server, then its a new file.
newChange.ChangeType = VersionControlChangeType.Add
Else
' Indicate that we are dealing with a file modification
' and specify which version we are editing.
newChange.ChangeType = VersionControlChangeType.Edit
newItem.ChangesetVersion = serverItem.ChangesetVersion
End If
' Read the file content to a stream.
Using reader = New StreamReader(fileSource,
Text.Encoding.Default,
True) ' This last parameter allows to extract the correct encoding.
Dim fileContent As String = String.Empty
' Read all the file content to a string so that we can store
' it in the itemcontent.
' NOTE: reading it also allows to retrieve the correct file enconding.
If reader.Peek() >= 0 Then
fileContent = reader.ReadToEnd
End If
' Set the file enconding and MIME Type.
newItem.ContentMetadata.Encoding = reader.CurrentEncoding.WindowsCodePage
newItem.ContentMetadata.ContentType = System.Web.MimeMapping.GetMimeMapping(fileSource)
newChange.Item = newItem
' Set the file content.
Dim newContent = New ItemContent
newContent.Content = fileContent
' TODO: What should be the logic to set the Content Type? Not too sure...
' If newItem.ContentMetadata.ContentType.StartsWith("text/") Then
newContent.ContentType = ItemContentType.RawText
' Else
' newContent.ContentType = ItemContentType.Base64Encoded
' End If
' Store the content to the change.
newChange.NewContent = newContent
End Using
changes.Add(newChange)
Next
newChangetset.Changes = changes
newChangetset.Comment = comment
Dim changesetRef = c.CreateChangesetAsync(newChangetset).Result
Return changesetRef
End Function

How to call a value of an object property from a class in a text box?using VBA

I have the following property in my clsdata class:
Public Property Get PatientCount() As Long
PatientCount = UBound(maobjPatient)
End Property
I also have this function in my class:
Private Function CountNonEmptyLines(ByVal strfile As String) As Long
Dim intFile As Integer
Dim strLine As String
Dim lngcount As Long
intFile = FreeFile
Open strfile For Input As intFile
lngcount = 0&
Do While Not EOF(intFile)
Line Input #intFile, strLine
If Len(strLine) > 0 Then
lngcount = lngcount + 1
End If
Loop
Close #intFile
CountNonEmptyLines = lngcount
End Function
the code of InputData is the following:
Public Sub InputData()
Dim blnLoaded As Boolean
Dim path As String
Dim file As String
Dim lnglines As Long
path = MyForm.TextPath
file = MyForm.TextFile
If LoadData(path, file) = False Then
MsgBox FileErrorString
Else
blnLoaded = LoadData(path, file)
End If
End Sub
and the code of LoadData is:
Private Function LoadData( _
ByVal strPath As String, _
ByVal strfile As String) _
As Boolean
Dim strPathFile As String
Dim lngRows As Long
LoadData = False
EraseData
InitialiseState
strPathFile = strPath & "\" & strfile
If Not FileExists(strPathFile) Then
Exit Function
End If
lngRows = CountNonEmptyLines(strPathFile)
If lngRows = 0 Then
Exit Function
End If
If Not LoadPatientLines(strPathFile, lngRows) Then
Exit Function
End If
mFileError = leNOERROR
LoadData = True
End Function
In my form I have a button which loads some data from a file:
Private Sub CmdLoad_Click()
Dim myData As New clsData
Call myData.InputData
End Sub
I also have a textbox:
Private Sub TextEntries_Change()
End Sub
How can I have the value of PatientCount or the lngcount from countnonemptylines function, in my textbox when I click CmdLoad, something like TextEntries.text=...?
As follow up from comments, this one works:
TextEntries.text = myData.PatientCount

VB6: Remaining time class

I always wanted a simple system that would show me how many minutes approximately are left while processing a long for-next-statement.
I tried do achieve this by creating a class.
At the start, I want to set how many for-nexts I have (-> setMax)
At each For-Next, I will tell the class that one of the for-nexts was done. (->addOneDone)
The class would then tell me how many minutes I still have to wait until the entire for-next-statement will be done.
I was pretty sure I made that quite ok, but something is still wrong.
I suspect it is the milliseconds to minutes conversion.
Would anybody try to help me find my mistake?
Thank you very much!
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private m_lMax&
Private m_lItemsDone&
Private m_lStart&
Private m_cMillisecondsAlreadyNeeded As Currency
Private m_lMinutesLeft&
Private m_lLastTick&
Public Sub setMax(ByVal uCount As Long)
m_lMax = uCount
m_lStart = GetTickCount()
End Sub
Public Sub addOneDone()
m_lItemsDone = (m_lItemsDone + 1)
Dim lTick&
lTick = GetTickCount
Dim lMillisecondsNeeded&
lMillisecondsNeeded = (lTick - m_lLastTick)
If (m_lLastTick > 0) Then
m_cMillisecondsAlreadyNeeded = (m_cMillisecondsAlreadyNeeded + lMillisecondsNeeded)
Dim lMillisecondsForOneItem&
lMillisecondsForOneItem = (m_cMillisecondsAlreadyNeeded / m_lItemsDone)
Dim lItemsLeft&
lItemsLeft = (m_lMax - m_lItemsDone)
Dim cMillisecondsLeftToBeDone As Currency
cMillisecondsLeftToBeDone = (lMillisecondsForOneItem * lItemsLeft)
Dim lMinutes&
lMinutes = MillisecondsToMinutes(cMillisecondsLeftToBeDone)
m_lMinutesLeft = lMinutes
End If
m_lLastTick = lTick
End Sub
Private Function MillisecondsToMinutes(ByVal uMilliseconds As Long) As Integer
Dim seconds As Double
seconds = uMilliseconds / 1000
Dim minutes As Double
minutes = seconds / 60
MillisecondsToMinutes = minutes
End Function
Public Property Get MinutesLeft() As Long
MinutesLeft = m_lMinutesLeft
End Property
I changed my code, and it works now:
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private m_lMax&
Private m_lItemsDone&
Private m_lStart&
Private m_cMillisecondsAlreadyNeeded As Currency
Private m_lMinutesLeft&
Public Sub setMax(ByVal uCount As Long)
m_lMax = uCount
m_lStart = GetTickCount()
End Sub
Public Sub addOneDone()
m_lItemsDone = (m_lItemsDone + 1)
Dim lTick&
lTick = GetTickCount
Dim lMillisecondsNeeded&
lMillisecondsNeeded = (lTick - m_lStart)
Dim dblMillisecondsForOneItem As Double
dblMillisecondsForOneItem = (lMillisecondsNeeded / m_lItemsDone)
Dim lItemsLeft&
lItemsLeft = (m_lMax - m_lItemsDone)
Dim cMillisecondsLeftToBeDone As Currency
cMillisecondsLeftToBeDone = (dblMillisecondsForOneItem * lItemsLeft)
Dim lMinutes&
lMinutes = MillisecondsToMinutes(cMillisecondsLeftToBeDone)
m_lMinutesLeft = lMinutes
End Sub
Private Function MillisecondsToMinutes(ByVal uMilliseconds As Long) As Integer
MillisecondsToMinutes = uMilliseconds / 1000 / 60
End Function
Public Property Get MinutesLeft() As Long
MinutesLeft = m_lMinutesLeft
End Property