I just want to catch evry node in the xml post from the iphone, for example this is the xml file that i need to "get"
<Matchs>
<owner>Me</owner>
<typeAction>Me</typeAction>
<match id=21>sept 3 2011 </match>
<match id=22>sept 4 2011 </match>
<match id=23>sept 5 2011 </match>
</Matchs>
I'm able to get every node but when there is more than one node with the same name I dont know how to do it...
this is my code to get the values:
Public Shared Function TryParse(ByVal value As String, ByRef notification As MatchModel) As Boolean
Dim success As Boolean = False
notification = Nothing
Try
Dim xReader As System.Xml.XmlReader = System.Xml.XmlReader.Create(New System.IO.StringReader(value))
Dim element As System.Xml.Linq.XElement = System.Xml.Linq.XElement.Load(xReader)
notification = New MatchModel()
' Populate the top XML elements values
Dim wItem As System.Xml.Linq.XElement = Nothing
Dim actual As matchAlone = Nothing
While xReader.MoveToElement()
If element IsNot Nothing Then
wItem = element.Element("match")
actual.Description = GetXElementValue(element, "match")
actual.Id = GetWorkItemAttributeValue(wItem, "id")
End If
End While
notification.Owner = GetXElementValue(element, "owner")
notification.TypeAction = GetXElementValue(element, "typeAction")
success = True
Catch e As Exception
Console.WriteLine(e.Message)
End Try
Return success
End Function
Public Shared Function GetXElementValue(ByVal element As System.Xml.Linq.XElement, ByVal name As System.Xml.Linq.XName) As String
Dim value As String = Nothing
If element IsNot Nothing Then
value = element.Element(name).Value
End If
Return value
End Function
Public Shared Function GetWorkItemAttributeValue(ByVal element As System.Xml.Linq.XElement, ByVal name As System.Xml.Linq.XName) As String
Dim value As String = Nothing
If element IsNot Nothing Then
value = element.Attribute(name).Value
End If
Return value
End Function
Please heeeeeelp :)
Dim doc as XmlDocument = New XmlDocument()
doc.LoadXml(value)
For Each node as XmlNode in doc.SelectNodes("/Matches/Match")
'Do work
Next
Related
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.
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!
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
I have more than 40 check-boxes in a single calc sheet, and I don't want to code each one of them. I just want a clear working code to get the name of checkbox.
In this program I have to manually type the name for the check-box within the macro code:
A="CheckBox1"
This is all I have so far:
Sub Marco1
Dim ocheckbox1
Dim oForm
Dim A
A="CheckBox1"
oForm = ThisComponent.Sheets(0).DrawPage.Forms.getByIndex(0)
ocheckbox1 = oForm.getByName(A)
if ocheckbox1.State = "0" then
if MsgBox ("Are you sure ?Note: It can't be re-edited", 292) = 6 then
ocheckbox1.Label = "Checked"
ocheckbox1.Enabled="False"
else
ocheckbox1.Label = "Not Checked"
End if
End if
End Sub
Assuming the macro is triggered by interaction with the checkbox:
Sub Macro1 (oEvent As Object)
Dim oCheckbox1 As Object
Dim sCheckbox1Name As String
oCheckbox1 = oEvent.source.model
sCheckbox1Name = oCheckbox1.Name
End Sub
I need to list all the private variables of a class. something like:
Variables in the class:
Dim varOne as String
Dim varTwo as Integer
Dim varThree as Date
Dim varFour as String
Sub that retruns all the variable names:
For Each classVariable In clsMyClass
Msgbox classVariable.Name
Next
Result:
varOne
varTwo
varThree
varFour
I found the solution in this forum but only for VB.NET, not for VBA. is there anyway I can do this in VBA?
thanks in advance.
what's the problem with the code below:
Private Sub btnTest_Click()
Dim obj_Utilitario As cls_Utilitario
Dim objColecao As Collection
Dim item As Variant
Set obj_Utilitario = New cls_Utilitario
Set objColecao = obj_Utilitario.ColecaoForm(Me.Form)
For Each item In objColecao
MsgBox item.Name
Next item
Set objColecao = Nothing
End Sub
this is the cls_Utilitario class code:
Public Function ColecaoForm(arg_form As Object) As Collection
Dim colecao As Collection
Dim campo As Control
For Each campo In arg_form.Controls
With campo
Select Case .ControlType
Case acComboBox, acTextBox
colecao.Add (.Object)
End Select
End With
Next campo
Set ColecaoForm = colecao
Set colecao = Nothing
Set campo = Nothing
Set arg_form = Nothing
End Function
when I remove the parentheses in the folowing code in the Me.Form argument:
Set objColecao = obj_Utilitario.ColecaoForm(Me.Form)
it lets me keep on running the code but it shows runtime error 2455 (invalid reference...)
what now? any idea?
thanks in advance.
this is the cls_Ativo class code so far:
Option Compare Database
Option Explicit
Private obj_Utilitario As New cls_Utilitario
Private col_Ativo As Collection
Private Const SQL As String = "SELECT tbl_Ativos.codigo_ativo, tbl_Ativos.especificacao FROM tbl_Ativos ORDER BY tbl_Ativos.codigo_ativo;"
Private Sub Class_Initialize()
Dim registro As Recordset
Dim campoRegistro As Field
Dim i As Integer
Set col_Ativo = New Collection
Set registro = CurrentDb.OpenRecordset(SQL)
If (Not (IsNull(registro)) And (registro.RecordCount > 0)) Then
registro.MoveLast
registro.MoveFirst
For i = 0 To registro.Fields.Count - 1
Set campoRegistro = registro.Fields(i)
col_Ativo.Add campoRegistro, campoRegistro.SourceField
Next i
Else
Set col_Ativo = Nothing
End If
Set registro = Nothing
Set campoRegistro = Nothing
End Sub
Private Sub Class_Terminate()
Set col_Ativo = Nothing
Set obj_Utilitario = Nothing
End Sub
Public Property Get Campo(arg_Item As Variant) As Variant
Campo = col_Ativo.item(arg_Item)
End Property
Public Property Let Campo(arg_Item As Variant, arg_Valor As Variant)
Select Case arg_Item
Case "codigo_ativo"
If VarType(arg_Valor) = vbString Then
If ValidaCodigoAtivo(arg_Valor) Then
col_Ativo.item(arg_Item) = arg_Valor
Else
MsgBox "O código inserido não é válido."
End If
Else
MsgBox "O código inserido não é um texto."
End If
Case "especificacao"
If VarType(arg_Valor) = vbString Then
col_Ativo.item(arg_Item) = arg_Valor
Else
MsgBox "A especificação inserida não é um texto válido."
End If
End Select
End Property
and this is what i want to do in the form module:
Private Sub btnTeste_Click()
Dim obj_Ativo As cls_Ativo
Set obj_Ativo = New cls_Ativo
'Save a text into the collection item "especificacao" using Let property
obj_Ativo.Campo ("especificacao","texto de exemplo, texto de exemplo...")
'Return the collection item using Get property
Msgbox obj_Ativo.Campo ("especificacao")
Set obj_Ativo = Nothing
End Sub
when i call obj_Ativo.Campo, it just allows me to pass arg_Item as parameter and shows that it will not return any value, as if it were a Let property. but if it were a Let property indeed, it should allow me to pass the second argument as parameter.
what i want is to have a collection object in the class with all the variables with different types instead of private variables.
thanks in advance.
In addition to David's suggestion, you can also look into using CallByName:
Sub Tester()
Dim c As New clsTest
c.one = 1
c.two = "two"
c.three = True
Debug.Print "Before-----------"
Debug.Print CallByName(c, "one", VbGet)
Debug.Print CallByName(c, "two", VbGet)
Debug.Print CallByName(c, "three", VbGet)
CallByName c, "one", VbLet, 10
CallByName c, "two", VbLet, "changed"
CallByName c, "three", VbLet, False
Debug.Print "After-----------"
Debug.Print CallByName(c, "one", VbGet)
Debug.Print CallByName(c, "two", VbGet)
Debug.Print CallByName(c, "three", VbGet)
End Sub
clsTest:
Public one As Long
Public two As String
Public three As Boolean
The only thing to note is you still can't examine directly the members of an instance of clsTest - it would have to be driven by the names of the controls on the form.
To your second question, I think you do not have to pass whole Form. It will be ok if you pass Controls only.
Set objColecao = obj_Utilitario.ColecaoForm(Me.Controls)
Then in the function do not forget to initialize the Collection object with 'New' keyword.
Public Function ColecaoForm(arg_form_controls As Controls) As Collection
Dim campo As Control
Set ColecaoForm = New Collection
For Each campo In arg_form_controls
If campo.ControlType = acComboBox Or _
campo.ControlType = acTextBox Then
ColecaoForm.Add campo
End If
Next campo
End Function