[Leeched] Visual Basic Tutorials

Shell("C:\Windows\System32\rundll32.exe DwmApi #105")

Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
  (ByVal lpCommandString As String, ByVal lpReturnString As String, _
  ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Public Sub OpenCDDoor()
Dim retval As Long
retval = mciSendString("set CDAudio door open", "", 0, 0)
End Sub

Public Sub CloseCDDoor()
Dim retval As Long
retval = mciSendString("set CDAudio door closed", "", 0, 0)
End Sub

Imports System.Runtime.InteropServices

Public WM_SYSCOMMAND As Integer = &H112
Public SC_MONITORPOWER As Integer = &HF170

<DllImport("user32.dll")> _
Private Shared Function SendMessage(ByVal hWnd As Integer, ByVal hMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
End Function

Public Sub TurnOn()
Dim x As Int32
'Main is the main form of the application. You can change it to any form of the application.
x = Main.Handle
SendMessage(x, WM_SYSCOMMAND, SC_MONITORPOWER, -1)
End Sub

Public Sub TurnOff()
Dim x As Int32
'Main is the main form of the application. You can change it to any form of the application.
x = Main.Handle
SendMessage(x, WM_SYSCOMMAND, SC_MONITORPOWER, 2)
End Sub

Public Sub LowState()
Dim x As Int32
'Main is the main form of the application. You can change it to any form of the application.
x = Main.Handle
SendMessage(x, WM_SYSCOMMAND, SC_MONITORPOWER, 1)
End Sub

Imports System.Drawing.Imaging

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Integer, ByVal uParam As Integer, ByVal lpvParam As String, ByVal fuWinIni As Integer) As Integer

Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_UPDATEINIFILE = &H1

Dim pic As New PictureBox

Dim ImageToSet  As String="Full location of the image"
Dim imagePath1 As String = Application.StartupPath & "\wall.bmp"
pic.Image = Image.FromFile(ImageToSet)
pic.Image.Save(imagePath1, ImageFormat.Bmp)
'Set the parameters to change the wallpaper to the image you selected:
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, imagePath1, SPIF_UPDATEINIFILE)
My.Computer.FileSystem.DeleteFile(imagePath1)

Private Const VK_NUMLOCK As Integer = &H90
Private Const VK_SCROLL As Integer = &H91
Private Const VK_CAPITAL As Integer = &H14
Private Const KEYEVENTF_EXTENDEDKEY As Integer = &H1
Private Const KEYEVENTF_KEYUP As Integer = &H2

Private Declare Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Integer, _
ByVal dwExtraInfo As Integer _
)

Public Sub NumLock()
keybd_event(VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0)
' Release the key
keybd_event(VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
End Sub

Public Sub CapsLock()
keybd_event(VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0)
' Release the key
keybd_event(VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
End Sub

Public Sub ScrollLock()
keybd_event(VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0)
' Release the key
keybd_event(VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
End Sub

'This will turn on NumLock if it is turned off.
If Not My.Computer.Keyboard.NumLock Then
NumLock()
End If

Dim x as integer

Function Encode(ByVal str As String)
Dim res As String = ""
If Not str = vbNullString Then
For i As Integer = 0 To str.Length - 1
If x = 2 Then
Dim n As Integer = Asc(Mid(str, i + 1, 1)) + x
res += Chr(n)
x = 4
ElseIf x = 4 Then
Dim n As Integer = Asc(Mid(str, i + 1, 1)) + x
res += Chr(n)
x = 1
Else
Dim n As Integer = Asc(Mid(str, i + 1, 1)) + x
res += Chr(n)
x = 2
End If
Next
End If
x = 2
Return res
End Function

Function Decode(Str as string)
Dim res As String = ""
If Not str = vbNullString Then
For i As Integer = 0 To str.Length - 1
If x = 2 Then
Dim n As Integer = Asc(Mid(str, i + 1, 1)) - x
res += Chr(n)
x = 4
ElseIf x = 4 Then
Dim n As Integer = Asc(Mid(str, i + 1, 1)) - x
res += Chr(n)
x = 1
Else
Dim n As Integer = Asc(Mid(str, i + 1, 1)) - x
res += Chr(n)
x = 2
End If
Next
End If
x = 2
Return res
End Function

Msgbox(Encode("JOIN THIS CHAT ABOUT VB ;)"))
'Will return "LSJP$UJMT"GICX!CFPWX!XF!=-"

Msgbox(Decode("LSJP$UJMT"GICX!CFPWX!XF!=-"))
'Will return "JOIN THIS CHAT ABOUT VB ;)"

Imports System.Net
Imports System.IO

Function GetPage(ByVal pageUrl As String) As String
Dim s As String = ""
Try
Dim request As HttpWebRequest = WebRequest.Create(pageUrl)
Dim response As HttpWebResponse = request.GetResponse()
Using reader As StreamReader = New StreamReader(response.GetResponseStream())
s = reader.ReadToEnd()
End Using
Catch ex As Exception
Throw New Exception("Failed to get source code !!!")
End Try
Return s

Function GetTitle(ByVal URL As String)
Dim result As String = "Couldn't extract title !!"
Try
If Not URL = vbNullString Then
Dim c As String = GetPage(URL)
Dim a1 As Integer = c.IndexOf("<title>") + 8
Dim a2 As Integer = c.IndexOf("</title>", a1)
Dim title As String = Mid(c, a1, a2 - a1).Replace("YouTube", "")
title = title.Trim
title = title.Remove(0, 2)
result = title
End If
Catch ex As Exception
End Try
Return result
End Function

Function getDownloadLink(ByVal URL As String)
Dim result As String = "Couldn't extract link !!"
Try
If Not URL = vbNullString Then
Dim c As String = GetPage(URL)
Dim a1 As Integer = c.IndexOf("'VIDEO_ID': '") + 14
Dim a2 As Integer = c.IndexOf("'", a1) + 1
Dim id As String = Mid(c, a1, a2 - a1)
Dim a3 As Integer = c.IndexOf("""t"": """) + 7
Dim a4 As Integer = c.IndexOf("""", a3) + 1
Dim t As String = Mid(c, a3, a4 - a3)
result = id & "&t=" & t
End If
Catch ex As Exception
End Try
Return result
End Function

System.Diagnostics.Process.Start("http://www.youtube.com/get_video?video_id=" & getDownloadLink("http://www.youtube.com/watch?v=u_0q0kL03Lg"))

Imports System.Net.Mail

Dim attachments As New ListBox

OFD.Filter = "All Files (*.*)|*.*"
If Not OFD.ShowDialog = Windows.Forms.DialogResult.Cancel Then
For Each n As String In OFD.FileNames
attachments.Items.Add(n)
Next
End If
lblAtt.Text = "Attachments [" & attachments.Items.Count & "]:"

'Check the textboxes:

If Not senderID.Text.EndsWith("@gmail.com") Then
MsgBox("You must enter your Gmail ID to send an email.")
Exit Sub
End If
If pass.Text = vbNullString Then
MsgBox("You must enter your password for the given ID.")
Exit Sub
End If
If recievers.Text = vbNullString Then
MsgBox("Please enter recipients of the email.")
Exit Sub
End If
If subj.Text = vbNullString Then
subj.Text = "No Subject"
End If
If emailbody.Text = vbNullString Then
emailbody.Text = "No Body"
End If

'If there are any attachments, calculate their size:
Dim attchsz As Integer = 0
If attachments.Items.Count > 0 Then
For Each n As String In attachments.Items
attchsz += CInt(My.Computer.FileSystem.GetFileInfo(n).Length / 1024 / 1024)
Next
End If
If attchsz > 10 Then
MsgBox("You have crossed the size limit of the email attachment.")
Exit Sub
End If

'Try to send the mail:

Try

'Create a new mail message:
Dim msg As New MailMessage(senderID.Text, recievers.Text, subj.Text, emailbody.Text)

'If there are any carbon copies, attach them:
If Not CCs.Text = vbNullString Then
msg.CC.Add(CCs.Text)
End If

'If there are any blind carbon copies, attach them:
If Not BCCs.Text = vbNullString Then
msg.Bcc.Add(BCCs.Text)
End If

'If there are any attachments, attach them:
If attachments.Items.Count > 0 Then
For Each z As String In attachments.Items
msg.Attachments.Add(New Net.Mail.Attachment(z))
Next
End If

'Now enter the client info for your email.
'I got the Google's smtp server and port number on the web.

Dim client As New SmtpClient("smtp.gmail.com", 587)

'Validate user...
Dim Credentials As New System.Net.NetworkCredential(senderID.Text, pass.Text)
client.Credentials = Credentials

'Some sites require secure sockets layer connection. Google is one of them, so enable the ssl:

client.EnableSsl = True

'Finally send the message:
client.Send(msg)

Catch ex As Exception
'If error occurs, report it to the user:
MsgBox("Error sending email !!" & vbCrLf & ex.Message)
Exit Sub
End Try
'If the mail is sent successfully, inform the user.
MsgBox("Your email has been sent.")