Librería de Snippets para VB.NET !! (Compartan aquí sus snippets)

[Eleкtro]

Unos snippets para monitorizar unidades...

Recopilar información de las unidades conectadas en ese momento:

Código (vbnet) [Seleccionar] Expandir

#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

Código (vbnet) [Seleccionar] Expandir

#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.

Código (vbnet) [Seleccionar] Expandir

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

[Eleкtro]

Calcula el CRC32 checksum de un archivo

Código (vbnet) [Seleccionar] Expandir

#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

[Eleкtro]

Hexadecimal a Array de Bytes:

Código (vbnet) [Seleccionar] Expandir

#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:

Código (vbnet) [Seleccionar] Expandir

#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:

Código (vbnet) [Seleccionar] Expandir

#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

[Eleкtro]

Modificar permisos de carpetas:

Código (vbnet) [Seleccionar] Expandir

#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

[Eleкtro]

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:

Código (vbnet) [Seleccionar] Expandir

#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:

Código (vbnet) [Seleccionar] Expandir

#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:

Código (vbnet) [Seleccionar] Expandir

#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:

Código [Seleccionar] Expandir

Fade_Master_Volume(Desde el volumen, Hasta el volumen, En "X" Milisegundos, Forzar/NoForzar el devanecimiento)

Código (vbnet) [Seleccionar] Expandir

#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

[Eleкtro]

Checkar si un número está entre un rango de números.

PD: Si conocen un método mejor porfavor postéenlo

Código (vbnet) [Seleccionar] Expandir

#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:

Código (vbnet) [Seleccionar] Expandir

#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

[Eleкtro]

Obtener la edición de Windows (Sólo para windows VISTA o superior)

Código (vbnet) [Seleccionar] Expandir

#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

[Eleкtro]

· Función para modificar el color del borde de un control.



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:

Código (vbnet) [Seleccionar] Expandir

#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

[Eleкtro]

· 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:

Código (vbnet) [Seleccionar] Expandir

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:

Código (vbnet) [Seleccionar] Expandir

   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í)

Código (vbnet) [Seleccionar] Expandir

#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

[Eleкtro]

· String a hexadecimal:

Código (vbnet) [Seleccionar] Expandir

#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:

Código (vbnet) [Seleccionar] Expandir

#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)

Código (vbnet) [Seleccionar] Expandir

    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