How can I get hourly weather forecast in VB.net? - vb.net

I've seen some questions similar to this on here, but none of them seem to help me. I don't really care what API is used, be it Google, Yahoo!, The Weather Channel, or any other. I've got code that will get the high and low of the current day, based on the location given by the user, but I can't seem to get the hourly predictions for temperature or weather condition, which is what I'm really looking for. I don't really care for wind speeds, humidity, or the "feels like" temperature, though I'll add them if I can figure out how to. I'm trying to get data that will look something like what is here. (www.weather.com/...)
I'm pretty new to parsing XML so that may be part of my problem, too. Thanks in advance for any help. I greatly appreciate it.

I have something you might enjoy:
<Runtime.CompilerServices.Extension()>
Module Weather
Public Structure WeatherInfo_Forecast
Dim DayOfWeek As String
Dim low As Double
Dim high As Double
Dim icon As String
End Structure
Public Structure WeatherInfo_Wind
Dim direction As String
Dim speed As Double
Dim unit As String
End Structure
Public Structure WeatherInfo_Typed
Dim Failed As Boolean
Dim errormessage As Exception
Dim location As String
Dim forcast_date As DateTime
Dim checked_time_date As DateTime
Dim humidity As Double
Dim highf As Double
Dim lowf As Double
Dim highc As Double
Dim lowc As Double
Dim currenttempC As Double
Dim currenttempF As Double
Dim predicted_icon As String
Dim current_icon As String
Dim current_condition As String
Dim predicted_condition As IEnumerable(Of WeatherInfo_Forecast)
Dim wind_condition As WeatherInfo_Wind
Dim day As String
End Structure
<Runtime.CompilerServices.Extension()> _
Public Function ToC(ByVal F As Double) As Double
Return ((F - 32) / 9) * 5
End Function
<Runtime.CompilerServices.Extension()> _
Public Function TryParseAsDouble(ByVal s As String) As Double
Dim rv As Double
If Double.TryParse(s, rv) = False Then rv = Double.NaN
Return rv
End Function
<Runtime.CompilerServices.Extension()> _
Public Function TryParseAsDate(ByVal s As String) As DateTime
Dim rv As DateTime
If DateTime.TryParse(s, rv) = False Then rv = Nothing
Return rv
End Function
Private Function ParseHumidity(ByVal s As String) As Double
If Not s Is Nothing Then
Dim humRegEx As New System.Text.RegularExpressions.Regex("Humidity: (?<Value>\d+)\w*\%")
Dim m = humRegEx.Match(s)
If m.Length = 0 Then Return Double.NaN
Return Double.Parse(m.Groups("Value").Value)
End If
End Function
Private Function ParseWind(ByVal s As String) As WeatherInfo_Wind
Dim rv As New WeatherInfo_Wind
If Not s Is Nothing Then
Dim humRegEx As New System.Text.RegularExpressions.Regex("Wind\:\s+(?<Direction>[NEWSnews]{1,2})\s+at\s+(?<speed>(?<value>\d+)\s(?<units>\w+)){1}")
Dim m = humRegEx.Match(s)
rv.speed = Double.NaN
If m.Length = 0 Then Return rv
With rv
.direction = m.Groups("Direction").Value
If Double.TryParse(m.Groups("value").Value, .speed) = False Then .speed = Double.NaN
.unit = m.Groups("units").Value
End With
End If
Return rv
End Function
<DebuggerHidden()>
Public Function Grab_Weather(ByVal Location As String) As WeatherInfo_Typed
Dim GrabWeather As New WeatherInfo_Typed
With GrabWeather
.Failed = True
Try
Dim xml As XDocument = XDocument.Load("http://www.google.com/ig/api?weather=" & Location)
Dim xp = xml.<problem_cause>
If xp.Any Then Return GrabWeather
.location = xml...<city>.#data
.forcast_date = xml...<forecast_date>.#data.TryParseAsDate
.checked_time_date = xml...<current_date_time>.#data.TryParseAsDate
.humidity = ParseHumidity(xml...<humidity>.#data)
.highf = xml...<high>.#data.TryParseAsDouble
.lowf = xml...<low>.#data.TryParseAsDouble
.highc = GrabWeather.highf.ToC
.lowc = GrabWeather.highc.ToC
.currenttempC = xml...<temp_c>.#data.TryParseAsDouble
.currenttempF = xml...<temp_f>.#data.TryParseAsDouble
'.current_icon = "http://www.google.com" & xml...<icon>.#data
'.predicted_icon = "http://www.google.com" & xml...<high>.#data
.current_condition = xml...<condition>.#data
.predicted_condition = From f In xml...<forecast_conditions> _
Select New WeatherInfo_Forecast With { _
.DayOfWeek = f.<day_of_week>.Value, _
.high = f.<high>.#data.TryParseAsDouble, _
.low = f.<low>.#data.TryParseAsDouble}
'.icon = "http://www.google.com" & f.<icon>.#data}
.wind_condition = ParseWind(xml...<wind_condition>.#data)
.day = xml...<day_of_week>.#data
.Failed = False
Return GrabWeather
Catch ex As Exception
.errormessage = ex
Return GrabWeather
End Try
End With
End Function
End Module

I finally found what I was looking for from Weather Underground. They have three APIs, and, starting with the middle one, gives hourly forecasts for 36 hours. You get English and Metric predicted statistics for temperature, "feels like" temperature, dew point, wind speed, and wind direction. There's also wind chill and heat index, but every result for both in English and Metric was -9998, so I'm pretty sure those results are a bit off! Also there are qpf, snow, pop, and mslp. Unfortunately qpf and snow have not results and I'm not sure what pop and mslp are. All results are available in JSON and XML. They have some image requests, too, but I haven't looked into them yet.
Update:
Link Updated

Related

vb 2013 return a bool from function

Function checkIsAuthorized(ByVal users As String) As Boolean
Dim UserJobCode As String = dcChris.getJobCode(users)
Dim values As String = My.Settings.canResendJobcode
Dim usersCode As String() = values.Split(",")
Return usersCode.Contains(UserJobCode)
'If usersCode.Contains(UserJobCode) Then
' canResend = True
' Return True
'End If
'canResend = False
'Return False
End Function
The commented portion of the function works, I was just trying to make the code more efficient with the return statement. But it does not return a bool because the global is still reading false. Doing it the old way worked.
Any ideas?
Dim canResend As Boolean
Function checkIsAuthorized(ByVal users As String) As Boolean
Dim UserJobCode As String = dcChris.getJobCode(users)
Dim values As String = My.Settings.canResendJobcode
Dim usersCode As String() = values.Split(",")
Return usersCode.Contains(UserJobCode)
End Function
This is what I settled on. It works great for my needs. Thanks everyone.

vb.net AES decryption returns "data is incomplete block"

I'm aware of the other thread on this issue (AES decryption error " The input data is not a complete block." Error vb.net), but I'm either not implementing the solutions offered there correctly, or something about my particular variant of this issue isn't covered by those solutions. In any event I'm getting the incomplete block error from the following code
Private GD As System.Security.Cryptography.Aes = System.Security.Cryptography.Aes.Create
Private PDB As New System.Security.Cryptography.Rfc2898DeriveBytes(EK, New Byte() {&H49, &H76, &H61, &H6E, &H20, &H4D, &H65, &H64, &H76, &H65, &H64, &H65, &H76})
Public Function Decrypt(ByVal val As String) As String
Dim ret As String = Nothing
Dim TTB As New System.Text.UTF8Encoding
Try
Dim input() As Byte = TTB.GetBytes(val)
Using ms As New System.IO.MemoryStream(input)
Using cs As New System.Security.Cryptography.CryptoStream(ms, GD.CreateDecryptor(PDB.GetBytes(32), PDB.GetBytes(16)), Security.Cryptography.CryptoStreamMode.Read)
Using sr As New System.IO.StreamReader(cs)
ret = sr.ReadToEnd()
End Using
End Using
End Using
input = nothing
Catch ex As Exception
EL.AddErr("Encountered an error while decrypting the provided text for " & FName & ". Error Details: " & ex.Message, path)
End Try
Return ret
End Function
EK is my key, which I'll not be including. It's just a String though, nothing special.
I've tried several other methods to decrypt based on guidance on the MSDN site, DreamInCode, etc. None worked, but they all had different issues (typically returning a blank string). Seeing as this version of code closely mirrors my encryption code, I'd like to stick with it (or at least as close as I can while still having functional code).
Despite all comments, I still lack understanding of your intentions. Therefore, the sample code below may not provide what you exactly want, but at least should give an idea how to employ cryptographic functions. Particularly, the most notable difference from your approach is that the encryption key and initialization vector are computed once and for all messages, rather than reevaluated on each occasion, because the latter is prone to synchronization errors — such as when you reuse single crypto object to communicate with multiple parties, or when some messages get lost in transmission.
Public Shared Sub Test()
' Note: You should not actually hard-code any sensitive information in your source files, ever!
Dim sKeyPreimage As String = "MySuperPassword"
Dim oMyCrypto As New MyCrypto(sKeyPreimage)
Dim sPlaintext As String = "My super secret data"
Dim sEncrypted As String = oMyCrypto.EncryptText(sPlaintext)
Dim sDecrypted As String = oMyCrypto.DecryptText(sEncrypted)
Console.Out.WriteLine("Plaintext: {0}", sPlaintext) ' "My super secret data"
Console.Out.WriteLine("Encrypted: {0}", sEncrypted) ' "72062997872DC4B4D1BCBF48D5D30DF0D498B20630CAFA28D584CCC3030FC5F1"
Console.Out.WriteLine("Decrypted: {0}", sDecrypted) ' "My super secret data"
End Sub
Public Class MyCrypto
Private Shared TextEncoding As Text.Encoding = Text.Encoding.UTF8
Private CipherEngine As System.Security.Cryptography.SymmetricAlgorithm
' Note: Unlike in the question, same key and IV are reused for all messages.
Private CipherKey() As Byte
Private CipherIV() As Byte
Public Sub New(ByVal sKeyPreimage As String)
Dim abKeyPreimage() As Byte = TextEncoding.GetBytes(sKeyPreimage)
Dim abKeySalt() As Byte = TextEncoding.GetBytes("Ivan Medvedev")
Const KeyDerivationRounds As Integer = 1 << 12
Dim oKeyDerivationEngine As New System.Security.Cryptography.Rfc2898DeriveBytes(abKeyPreimage, abKeySalt, KeyDerivationRounds)
Me.CipherEngine = System.Security.Cryptography.Aes.Create()
Me.CipherEngine.Padding = Security.Cryptography.PaddingMode.PKCS7
Me.CipherKey = oKeyDerivationEngine.GetBytes(Me.CipherEngine.KeySize >> 3)
Me.CipherIV = oKeyDerivationEngine.GetBytes(Me.CipherEngine.BlockSize >> 3)
End Sub
Public Function Encrypt(ByVal abPlaintext() As Byte) As Byte()
Dim abCiphertext() As Byte
Using hStreamSource As New System.IO.MemoryStream(abPlaintext),
hStreamCipher As New System.Security.Cryptography.CryptoStream(
hStreamSource,
Me.CipherEngine.CreateEncryptor(Me.CipherKey, Me.CipherIV),
Security.Cryptography.CryptoStreamMode.Read),
hStreamTarget As New System.IO.MemoryStream
hStreamCipher.CopyTo(hStreamTarget)
abCiphertext = hStreamTarget.ToArray()
End Using
Return abCiphertext
End Function
Public Function Decrypt(ByVal abCiphertext() As Byte) As Byte()
Dim abPlaintext() As Byte
Using hStreamSource As New System.IO.MemoryStream(abCiphertext),
hStreamCipher As New System.Security.Cryptography.CryptoStream(
hStreamSource,
Me.CipherEngine.CreateDecryptor(Me.CipherKey, Me.CipherIV),
Security.Cryptography.CryptoStreamMode.Read),
hStreamTarget As New System.IO.MemoryStream
hStreamCipher.CopyTo(hStreamTarget)
abPlaintext = hStreamTarget.ToArray()
End Using
Return abPlaintext
End Function
Public Function EncryptText(ByVal sPlaintext As String) As String
Dim abPlaintext() As Byte = TextEncoding.GetBytes(sPlaintext)
Dim abCiphertext() As Byte = Me.Encrypt(abPlaintext)
Dim sCiphertext As String = Hex.Format(abCiphertext)
Return sCiphertext
End Function
Public Function DecryptText(ByVal sCiphertext As String) As String
Dim abCiphertext() As Byte = Hex.Parse(sCiphertext)
Dim abPlaintext() As Byte = Me.Decrypt(abCiphertext)
Dim sPlaintext As String = TextEncoding.GetChars(abPlaintext)
Return sPlaintext
End Function
End Class
Public Class Hex
Public Shared Function Format(ByVal abValue() As Byte) As String
Dim asChars(0 To abValue.Length * 2 - 1) As Char
Dim ndxChar As Integer = 0
For ndxByte As Integer = 0 To abValue.Length - 1
Dim bNibbleHi As Byte = abValue(ndxByte) >> 4, bNibbleLo As Byte = CByte(abValue(ndxByte) And &HFUS)
asChars(ndxChar) = Convert.ToChar(If(bNibbleHi <= 9, &H30US + bNibbleHi, &H37US + bNibbleHi)) : ndxChar += 1
asChars(ndxChar) = Convert.ToChar(If(bNibbleLo <= 9, &H30US + bNibbleLo, &H37US + bNibbleLo)) : ndxChar += 1
Next
Return New String(asChars)
End Function
Public Shared Function Parse(ByVal sValue As String) As Byte()
If String.IsNullOrEmpty(sValue) Then Return New Byte() {}
If (sValue.Length Mod 2) > 0 Then Return Nothing
Dim ndxText As Integer = 0
Dim ndxByteMax As Integer = (sValue.Length \ 2) - 1
Dim abValue(0 To ndxByteMax) As Byte
Try
For ndxByte As Integer = 0 To ndxByteMax
abValue(ndxByte) = Convert.ToByte(sValue.Substring(ndxText, 2), 16)
ndxText += 2
Next
Catch ex As Exception
Return Nothing
End Try
Return abValue
End Function
End Class
Again, please, note that this is just an example. I am not endorsing any kind of protection techniques shown here, especially because your task remains unknown. The code above simply illustrates the syntax and semantics — not how to do it right.

Determine if computer is in AD group

I am looking to determine if a computer is a member of an AD group or even getting all computers that are members of an AD group using VB.net. I have found several examples for checking to see if a user is a member of a group but none for checking for computers. I was hoping to convert this function to search for a computer in the group but I was unsuccessful. Any assistance would be appreciated. Thank you in advance.
Function IsInGroup(GroupName) As Boolean
Dim MyIdentity As System.Security.Principal.WindowsIdentity = System.Security.Principal.WindowsIdentity.GetCurrent()
Dim MyPrincipal As System.Security.Principal.WindowsPrincipal = New System.Security.Principal.WindowsPrincipal(MyIdentity)
Return MyPrincipal.IsInRole(GroupName)
End Function
Try something like this
Function IsInGroup(PCName As String, groupName As String) As Boolean
Dim vUsuario As New NTAccount(PCName & "$")
Dim sid As SecurityIdentifier = vUsuario.Translate(GetType(SecurityIdentifier))
Using vRootDSE As New DirectoryEntry("LDAP://rootDSE")
Using vSearcher As New DirectorySearcher(New DirectoryEntry("LDAP://" + CStr(vRootDSE.Properties("defaultNamingContext")(0))), "(objectSID=" & sid.ToString() & ")", New String() {"memberOf"}, SearchScope.Subtree)
Dim src As SearchResultCollection = vSearcher.FindAll()
Dim memberOf As ResultPropertyValueCollection = src(0).Properties("memberOf")
For i As Integer = 0 To memberOf.Count - 1
'Debug.Print(memberOf(i).ToString())
' I don't really like this approach, but it's quick to write ;)
If memberOf(i).ToString().Contains("=" & groupName & ",") Then
Return True
End If
Next
End Using
End Using
Return False
End Function
If you're looking for the CURRENT PC then it's a bit easier.
Function Is_CurrentPC_InADGroup(groupName As String) As Boolean
if groupName = "" then Return True
Using context = New PrincipalContext(ContextType.Domain, Environment.GetEnvironmentVariable("USERDOMAIN"))
Dim principal = ComputerPrincipal.FindByIdentity(context, Environment.MachineName)
Dim groups = principal.GetGroups()
For Each group In groups
If group.ToString = groupName Then Return True
Next
End Using
Return False
End Function

Matlab - Catia connection error

I need to set up live connection between Catia and Matlab so I can send parameters values to my parametric design in Catia and read some other parameters and measures.
This is my sollution:
First I create:
VB NET (*.dll)
Public Class CatiaLinkLibrary
Dim CATIA As Object
Dim rootproduct
Sub StartCatia()
CATIA = CreateObject("CATIA.Application")
End Sub
Sub CloseCatia()
CATIA.Quit()
End Sub
Sub Visible(ByRef mode As Integer)
If mode = 1 Or mode = 0 Then
CATIA.Visible = mode
End If
End Sub
Sub OpenFile(ByRef filename As String)
CATIA.Documents.Open(filename)
rootproduct = CATIA.ActiveDocument.Product()
End Sub
Function GetMass() As Double
Return rootproduct.Analyze.Mass()
End Function
Function GetVolume() As Double
Return rootproduct.Analyze.Volume()
End Function
Function GetArea() As Double
Return rootproduct.Analyze.WetArea()
End Function
Function GetGravityCenter()
Dim gravitycenter(2)
rootproduct.Analyze.GetGravityCenter(gravitycenter)
GetGravityCenter = gravitycenter
End Function
Function GetIntertia()
Dim inertia(8)
rootproduct.Analyze.GetInertia(inertia)
GetIntertia = inertia
End Function
Sub ChangeParameter(ByRef parameterName As String, ByRef Value As Double)
Dim pd As Object
Dim part As Object
Dim parameters As Object
Dim length As Object
pd = CATIA.ActiveDocument
part = pd.Part
parameters = part.Parameters
length = parameters.Item(parameterName)
length.Value = Value
part.Update()
End Sub
Function GetParameter(ByRef parameterName As String) As Double
Dim pd As Object
Dim part As Object
Dim parameters As Object
Dim length As Object
pd = CATIA.ActiveDocument
part = pd.Part
parameters = part.Parameters
length = parameters.Item(parameterName)
Return length.Value()
End Function
Sub closeDoc(ByRef name As String)
Dim windows As Object
Dim window As Object
Dim doc As Object
windows = CATIA.Windows
window = windows.Item(name)
window.Activate()
window.Close()
doc = CATIA.ActiveDocument
doc.Close()
End Sub
Sub activeDoc(ByRef name As String)
Dim windows As Object
Dim window As Object
Dim doc As Object
windows = CATIA.Windows
window = windows.Item(name)
window.Activate()
doc = CATIA.ActiveDocument
End Sub
Function GetArea2() As Double
Dim pd As Object
Dim part As Object
Dim bodys As Object
Dim body As Object
Dim spabench As Object
Dim mymeas As Object
pd = CATIA.ActiveDocument
part = pd.Part
bodys = part.Bodies
body = bodys.Item("PartBody")
spabench = pd.GetWorkbench("SPAWorkbench")
mymeas = spabench.GetMeasurable(body)
Return mymeas.Area
End Function
End Class
Then, in Matlab I have class that wraps around this *dll:
Matlab class:
classdef CatiaLink < handle
properties
catia;
end
methods
function obj = CatiaLink()
%modify this path to your .NET DLL
NET.addAssembly('C:\DOKTORAT\Modele Geometryczne\CatiaLinkLibrary\CatiaLinkLibrary\bin\Debug\CatiaLinkLibrary.dll');
obj.catia = CatiaLinkLibrary.CatiaLinkLibrary;
obj.catia.StartCatia;
disp('Catia started')
end
function Visible(obj,mode)
obj.catia.Visible(mode);
end
function Quit(obj)
obj.catia.CloseCatia;
end
function Open(obj,filename)
obj.catia.OpenFile(filename);
end
function mass = GetMass(obj)
mass = obj.catia.GetMass;
end
function vol = GetVolume(obj)
vol = obj.catia.GetVolume;
end
function area = GetArea(obj)
area = obj.catia.GetArea;
end
function cog = GetCenterOfGravity(obj)
tmp = obj.catia.GetGravityCenter;
cog = [tmp(1),tmp(2),tmp(3)];
end
function inertia = GetInertia(obj)
tmp = obj.catia.GetIntertia;
inertia = [tmp(1), tmp(2), tmp(3); ...
tmp(4), tmp(5), tmp(6); ...
tmp(7), tmp(8), tmp(9)];
end
function setParameter(obj, parameterName, Value)
obj.catia.ChangeParameter(parameterName, Value);
end
function val = getParameter(obj, parameterName)
val = obj.catia.GetParameter(parameterName);
end
function closeDoc(obj, name)
obj.catia.closeDoc(name);
end
function activeDoc(obj, name)
obj.catia.activeDoc(name);
end
function area = getArea2(obj)
area = obj.catia.GetArea2;
end
end
end
So in my program I create Catia object by Catia = CatiaLink.
And than I use it like 10000 or even more times to set and get parameters.
Everything works just fine up to around couple thousand times and than I get error:
Error using CatiaLink/setParameter (line 42)
Message: No more threads can be created in the system. (Exception from
HRESULT: 0x800700A4)
Source: mscorlib
HelpLink:
Can someone explain what is happening? And how to prevent this?
It looks like you're never calling Catia.Quit()

Searching objects in a list

I have a list of objects, and I want to search it to see if myobject.articleID matches a given articleID. From what I've gather using .Find(Of T) is the best way to go about this, however I am having some difficulty implementing it. Here's some code I have so far:
<WebMethod()> _
Public Function SetTagOnFavorite(ByVal articleID As Integer, ByVal tagtext As String, ByVal mobileGUID As String) As AddTagResult
Dim result As New AddTagResult
Dim userID As Long = GetUserIDByMobileGUID(mobileGUID)
If userID > 0 Then
Dim pageNum As Integer = 1
Dim pageLen As Integer = 500 'arbitrarily large number
Dim savedArticleList As New List(Of SimpleArticle)
savedArticleList = GetSavedArticles(mobileGUID, pageNum, pageLen)
If savedArticleList.Find(Function( m As SimpleArticle) m.articleID = articleID)
Dim lq As New lqDFDataContext
Dim var = lq.web_AddTagToArticle(userID, articleID, tagtext).ToList()
If var.Any() Then
Dim vRes = var.First()
result.articletagID = vRes.articletagID
result.newarticletag = vRes.newarticletag
result.newusertag = vRes.newusertag
result.usertagID = vRes.usertagID
result.resultinfo = "Success."
End If
End If
Else
result.resultinfo = STR_NoUserIDMostLikelyTheSessionTimedOut
End If
Return result
End Function
The error I get is, "value of type SimpleArticle cannot be converted to Boolean".
Because Find(Of returns the found object, you need to change this line:
If savedArticleList.Find(Function( m As SimpleArticle) m.articleID = articleID)
to
If savedArticleList.Find(Function( m As SimpleArticle) m.articleID = articleID) IsNot Nothing
or if you need the found item, store the result of Find in a local variable.
You could optimize #competent_tech's answer further as:
If savedArticleList.Any(Function(m) m.articleID = articleID))