Bookmark and Share

VB .Net - Tagesgrafik aus: http://antwrp.gsfc.nasa.gov/apod/astropix.html auslesen 2


 

E-Mail :

 

Click to e-mail author

Url :

 

www.Visual-Basic5.de

Date :

 

25/07/2006

Version Compatibility :

 

VB .Net


Download
Download

 

'IN MainForm
'Beispiel: VB .Net - Tagesgrafik aus: http://antwrp.gsfc.nasa.gov/apod/astropix.html auslesen 2
'Hinweis : Stellen Sie sicher das eine Onlineverbindung besteht.
'Das Beispiel speichert die Datei im Anwendungspfad + image
'Es wird nach dem Download ein Thumbnail der Grafik zur Vorschau angezeigt.
'Die Grafik wird in eine .htm Seite integriert.
'Die Grafik kann per Klick auf die Vorschaugrafik per Mail versendet werden
'
Option Explicit On
Option Strict On
Imports System.IO
Imports System.Diagnostics
Imports System.Drawing.Imaging
Imports System.Drawing.Drawing2D
Imports System.Web.Mail
Public Partial Class MainForm
Public Sub New()
Me.InitializeComponent()
End Sub

Private WithEvents wc As New Net.WebClient
Private Filename As String
Private Success As Boolean = False
Private NotClosing As Boolean = False 'Initialisierung

Private url As System.Uri = _
New System.Uri("http://antwrp.gsfc.nasa.gov/apod/astropix.html")

Private Sub CallUrl(ByVal MyUrl As System.Uri)
Try
Me.Cursor = Cursors.WaitCursor
With webBrowser1
.Navigate(MyUrl.AbsoluteUri, Nothing, Nothing, Nothing)
End With
Me.Cursor = Cursors.Default
Catch
NotClosing = False
End Try
End Sub

Private Sub Button1Click(sender As Object, e As System.EventArgs)
Success = False
button1.Text = "&Please wait..."
button1.Enabled = False

NotClosing = True 'Schliessen verhindern

If pictureBox1.Image IsNot Nothing Then pictureBox1.Image = Nothing
CallUrl(url)
End Sub

Private Sub WebBrowser1DocumentCompleted(sender As Object, _
e As System.Windows.Forms.WebBrowserDocumentCompletedEventArgs)

Try
Do
Application.DoEvents()
System.Threading.Thread.Sleep(100)
Loop Until WebBrowser1.ReadyState = 4
Me.Text = e.Url.ToString() + " [" + WebBrowser1.ReadyState.ToString() + "]"
Dim Result As String = ExtractRequieredImgTag(webBrowser1)
Me.Cursor = Cursors.WaitCursor
If Result <> "" Then
MessageBox.Show(Result + System.Environment.NewLine + _
"konnte ermittelt werden, und wird jetzt heruntergeladen.", "Info")
Dim _filename As String = _
System.IO.Path.GetFileNameWithoutExtension(Result)
Dim _extension As String = System.IO.Path.GetExtension(Result)
Debug.WriteLine(_filename)
Debug.WriteLine(_extension)
Dim Root As String = My.Computer.FileSystem.CurrentDirectory
If Root.EndsWith("\") = True Then
Root = Root
Else
Root &= "\"
End If

Dim DirExist As Boolean = System.IO.Directory.Exists(Root + "image")
If DirExist = False Then
System.IO.Directory.CreateDirectory(Root + "image")
End If
If System.IO.Directory.Exists(Root + "image") = True Then
Dim dir As String = Root + "image"

If dir.EndsWith("\") = True Then
dir = dir
Else
dir &= "\"
End If
'
Debug.WriteLine(dir + _filename + _extension)
'
wc.DownloadFileAsync(New System.Uri(Result), _
dir + _filename + _extension)
'
'
Filename = dir + _filename + _extension
'
End If

End If
Catch ex As Exception
NotClosing = False
Me.Cursor = Cursors.Default
Throw (New Exception("Error: " + Err.GetException().Message))
End Try
Me.Cursor = Cursors.Default
End Sub

Private Sub wcDownloadFileCompleted(ByVal sender As Object, _
ByVal e As System.ComponentModel.AsyncCompletedEventArgs) _
Handles wc.DownloadFileCompleted

Me.Text = "Download beendet..."

NotClosing = False'Schliessen wieder zulassen

Me.Cursor = Cursors.WaitCursor
Dim s() As String = _
{"<html>", _
"<head>", _
"</html>", _
"</head>", _
"<title>", _
"</title>", _
"<body>", _
"</body>", _
"<img src=", _
">", _
"width=", _
"height=", _
"alt=", _
"border=", _
"<center>", _
"</center>"}

If System.IO.File.Exists(Filename) Then
Dim img As System.Drawing.Image = Nothing
Try
img = System.Drawing.Image.FromFile(Filename)
Dim width As Integer = img.Width
Dim height As Integer = img.Height
Debug.WriteLine(width.ToString() + " " + height.ToString())
'
Dim hImage As Image = CreateThumbnail(img, pictureBox1.Width, _
pictureBox1.Height)
If (hImage IsNot Nothing) Then
pictureBox1.Image = hImage
'
Success = True
'
toolTip1.SetToolTip(pictureBox1, "Bild versenden...")
Else
pictureBox1.Image = Nothing
End If
'
Dim MyPath As String = System.IO.Path.GetDirectoryName(Filename)
If MyPath.EndsWith("\") = True Then
MyPath = MyPath
Else
MyPath &= "\"
End If
Dim Extension As String = System.IO.Path.GetExtension(Filename)

Dim HtmlFilename As String = _
System.IO.Path.GetFileNameWithoutExtension(Filename)
HtmlFilename = HtmlFilename.Replace(" ", "")
Dim ComplettePath As String = MyPath + HtmlFilename + ".htm"

Dim sw As StreamWriter = New StreamWriter(ComplettePath)
sw.Write(s(0) + System.Environment.NewLine)
sw.Write(s(1) + System.Environment.NewLine)
sw.Write(s(4))
sw.Write(HtmlFilename + ".htm" + " " + _
System.DateTime.Now.ToLongDateString)
sw.Write(s(5) + System.Environment.NewLine)
sw.Write(s(3) + System.Environment.NewLine)
sw.Write(s(6) + System.Environment.NewLine)
sw.Write(s(14) + System.Environment.NewLine)
sw.Write("<font size=" + """" + "2" + """" + _
" " + "face=" + """" + "arial" + """" + ">" + _
System.Environment.NewLine)
sw.Write(System.DateTime.Now.ToShortDateString + " " + _
HtmlFilename + Extension + _
System.Environment.NewLine)
sw.Write("</font>" + System.Environment.NewLine)
sw.Write("<br><br>" + System.Environment.NewLine)
sw.Write("<a href=" + """" + "http://www.visual-basic5.de" + """" + _
" " + "target=" + """" + "_blank" + """" + ">" + _
System.Environment.NewLine)
sw.Write(s(8) + """" + HtmlFilename + Extension + """" + _
" " + s(10) + """" + width.ToString() + """" + _
" " + s(11) + """" + height.ToString() + """" + _
" " + s(12) + """" + "Download from: www.visual-basic5.de" + """" + _
" " + s(13) + """" + "0" + """" + s(9) + System.Environment.NewLine)
sw.Write("</a>" + System.Environment.NewLine)
sw.Write(s(15) + System.Environment.NewLine)
sw.Write(s(7)+ System.Environment.NewLine)
sw.Write(s(2)+ System.Environment.NewLine)
sw.Flush()
sw.Close()
If System.IO.File.Exists(ComplettePath) Then
Dim Result As Integer = MessageBox.Show("Datei:" + _
System.Environment.NewLine + _
ComplettePath + _
System.Environment.NewLine + _
"wurde angelegt. Soll die Datei angezeigt werden?", _
"Info", MessageBoxButtons.YesNo, _
MessageBoxIcon.Question)
If Result = MsgBoxResult.Yes Then
Try
Dim ProcessStart As New ProcessStartInfo
With ProcessStart
.FileName = "iexplore"
.Arguments = ComplettePath
End With
Process.Start(ProcessStart)
Catch ex As Exception
NotClosing = False 'Schliessen wieder zulassen
MessageBox.Show(ex.Message.ToString(), "Info")
End Try
End If
'
Call CenterCursorOverButton(pictureBox1)
'
End If
Me.Cursor = Cursors.Default
Catch ex As Exception
NotClosing = False 'Schliessen wieder zulassen
MessageBox.Show(ex.Message.ToString(), "Info")
Finally
If (Not img Is Nothing) Then img.Dispose()
button1.Enabled = True
button1.Text = "&Download Image from the Day"
Me.Cursor = Cursors.Default
End Try
Else
Me.Cursor = Cursors.Default
MessageBox.Show( _
"Quelldatei zur Anlage der .html Datei wurde nicht gefunden.", _
"Info")
End If
'
Application.DoEvents()
System.Threading.Thread.Sleep(1000)
Me.Text = "Download Space Image from the Day from Nasa Server: " + _
"http://antwrp.gsfc.nasa.gov"
Me.Cursor = Cursors.Default
End Sub

Private Sub CenterCursorOverButton(ByRef pb As pictureBox)
Dim p As New Point

p.X = CInt(pb.Left + CInt(pb.Width / 2))
p.Y = CInt(pb.Top + CInt(pb.Width / 2))
Call ClientToScreen(Me.Handle, p)
Call SetCursorPos(p.X, p.Y)
End Sub

Private Function CreateThumbnail(ByVal img As Image, ByVal w As Integer, _
ByVal h As Integer) As Image
Dim XFactor As Double, YFactor As Double
XFactor = (CType(w / CType(img.Width, Double), Double))
YFactor = (CType(h / CType(img.Height, Double), Double))
Dim tmp As Double
Dim XTarget As Integer, YTarget As Integer

If YFactor < XFactor Then
tmp = YFactor
XTarget = Convert.ToInt16((w - (img.Width * tmp)) / 2)
Else
tmp = XFactor
YTarget = Convert.ToInt16((h - (img.Height * tmp)) / 2)
End If

Dim Width As Integer = (CType((img.Width * tmp), Integer))
Dim Height As Integer = (CType((img.Height * tmp), Integer))
Dim hBitmap As Bitmap
Try
hBitmap = New Bitmap(w, h, PixelFormat.Format24bppRgb)
hBitmap.SetResolution(img.HorizontalResolution, img.VerticalResolution)
Dim hGraphics As Graphics = Graphics.FromImage(hBitmap)
With hGraphics
.Clear(Color.White)
.InterpolationMode = InterpolationMode.HighQualityBicubic
.DrawImage(img, New Rectangle(XTarget, YTarget, Width, Height), _
New Rectangle(0, 0, img.Width, img.Height), _
GraphicsUnit.Pixel)
.Dispose()
End With
Return hBitmap
Catch ex As Exception
NotClosing = False
End Try
Return Nothing
End Function

Private Sub wcDownloadProgressChanged(ByVal sender As Object, _
ByVal e As System.Net.DownloadProgressChangedEventArgs) _
Handles wc.DownloadProgressChanged
Me.Text = e.ProgressPercentage.ToString() + _
"% heruntergeladen | " + _
e.BytesReceived.ToString() + _
" Bytes von gesamt: " + _
e.TotalBytesToReceive.ToString() + " Bytes"
End Sub

Private Sub WebBrowser1Navigating(sender As Object, _
e As System.Windows.Forms.WebBrowserNavigatingEventArgs)
Me.Text = "Versuche Verbindung zu: " + e.Url.AbsoluteUri.ToString() + _
" aufzunehmen..."
Me.Cursor = Cursors.WaitCursor
End Sub

Private Sub WebBrowser1Navigated(sender As Object, _
e As System.Windows.Forms.WebBrowserNavigatedEventArgs)
Me.Text = "Verbindung zu: " + e.Url.AbsoluteUri.ToString() + _
" wurde hergestellt..."
Me.Cursor = Cursors.Default
End Sub

Private Function ExtractRequieredImgTag(ByVal wb As WebBrowser) As String
Dim Result As String = ""
Try
If (wb.Document IsNot Nothing) Then
With wb.Document
For Each Items As HtmlElement In wb.Document.GetElementsByTagName("IMG")
Result = Items.GetAttribute("SRC").ToString()
Next
End With

Return Result
Else
Return ""
End If
Catch
Return ""
End Try
Return ""
End Function

Private Sub MainFormLoad(sender As Object, e As System.EventArgs)
Me.Text = "Download Space Image from the Day from Nasa Server: " + _
"http://antwrp.gsfc.nasa.gov"
webBrowser1.Visible = False
With timer1
.Interval = 250
.Enabled = False
End With
label1.Visible = False
Me.Top = 0: Me.Left = 0
label2.Visible = False
End Sub

Private Sub PictureBox1Click(sender As Object, e As System.EventArgs)
If Success = True Then
Dim address As String = ""
Dim ipb As New MyInputBox()
Dim dr As DialogResult = ipb.ShowDialog()

If dr = DialogResult.OK Then
address = ipb.Input
End If
ipb.Dispose()

'
If address <> "" Then
If System.IO.File.Exists(Filename) Then
Me.Cursor = Cursors.WaitCursor
label1.Visible = True
timer1.Start()
pictureBox1.Enabled = False
button1.Enabled = False

NotClosing = True

Call SendMailWithAttachment(address, _
"helloserver@helloserver.de", _
"Tagesgrafik vom NASA Server", _
"Hallo hier die Tagesgrafik vom NASA Server...", _
Filename)
Me.Cursor = Cursors.Default
label1.Visible = False
timer1.Stop()
pictureBox1.Enabled = True
button1.Enabled = True
End If
Else
NotClosing = False
MessageBox.Show("Sie haben keine EMail-Adresse eingegeben...", "Info")
End If
End If
NotClosing = False
End Sub

Private Sub SendMailWithAttachment(ByVal SendTo As String, _
ByVal SendFrom As String, _
ByVal Subject As String, _
ByVal BodyText As String, _
ByVal Filename As String)

Try
If File.Exists(Filename) Then
Dim mm As New MailMessage
Dim ma As New MailAttachment(Filename)
Dim lst As IList
With mm
.To = SendTo
.From = SendFrom
.Subject = Subject
.BodyFormat = MailFormat.Text
.Body = BodyText
lst = .Attachments
End With
lst.Add(ma)
SmtpMail.Send(mm)
End If
Catch ex As Exception
MessageBox.Show(ex.Message.ToString(), "Info")
End Try
End Sub
Private Sub Timer1Tick(sender As Object, e As System.EventArgs)
Static n As Integer
n = n Xor 1
Select Case n
Case 0
label1.BackColor = Color.LightSteelBlue
Case 1
label1.BackColor = Color.CornflowerBlue
End Select
End Sub

Private Sub PictureBox1MouseLeave(sender As Object, e As System.EventArgs)
If (pictureBox1.Image IsNot Nothing) Then
label2.Visible = False
Me.Cursor = Cursors.Default
End If
End Sub

Private Sub PictureBox1MouseEnter(sender As Object, e As System.EventArgs)
If (pictureBox1.Image IsNot Nothing) Then
label2.Visible = True
Me.Cursor = Cursors.Hand
End If
End Sub

Private Sub MainFormFormClosing(sender As Object, _
e As System.Windows.Forms.FormClosingEventArgs)
If NotClosing = True Then
'Ist NotClosing = True dann kann die Form nicht geschlossen werden
e.Cancel = True 'Unterbindet das Beenden der Form
End If
End Sub
End Class
Public Module Win32Api

Public Declare Function SetCursorPos Lib "user32.dll" _
(ByVal X As Int32, _
ByVal Y As Int32) As Int32

Public Declare Function ClientToScreen Lib "user32.dll" _
(ByVal hWnd As IntPtr, _
ByRef p As Point) As Boolean
End Module
 IN MyInputBox
'InputBox
Imports System.Text.RegularExpressions
Public Partial Class MyInputBox
Public Sub New()
Me.InitializeComponent()
End Sub

Private Sub Button1Click(ByVal sender As Object, ByVal e As System.EventArgs)
DialogResult = DialogResult.OK
End Sub

Private Sub Button2Click(ByVal sender As Object, ByVal e As System.EventArgs)
DialogResult = DialogResult.Cancel
End Sub

Private Sub MyInputBoxLoad(sender As Object, e As System.EventArgs)
textBox1.Clear()
button1.Enabled = False
End Sub

Private Function IsCorrectlyEMailAddress(ByVal MailAddress As String) As Boolean
Dim query As String = _
"^[a-zA-Z][\w\.-]*[a-zA-Z0-9]@[a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$"
Dim [Regex] As Regex = New Regex(query)
Dim [Match] As Match = [Regex].Match(MailAddress)
Return [Match].Success
End Function

Public ReadOnly Property Input() As String
Get
Return textBox1.Text
End Get
End Property

Private Sub TextBox1TextChanged(sender As Object, e As System.EventArgs)
If IsCorrectlyEMailAddress(textBox1.Text) Then
label1.Text = ""
button1.Enabled = True
ElseIf textBox1.Text = "" Then
label1.Text = "Adresse eingeben"
button1.Enabled = False
Else
label1.Text = "Gueltige Adresse muss eingegeben werden"
button1.Enabled = False
End If
End Sub
End Class


optimiert fuer msi 800 x 600 © by prelles basics (heinz prelle) lenbachstrasse 42 , 30655 hannover germany
www.visual-basic5.de