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

Foro de elhacker.net

Programación

Programación General

.NET (C#, VB.NET, ASP) (Moderador: kub0x)

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

0 Usuarios y 3 Visitantes están viendo este tema.

Páginas: 1 ... 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 [62]

Autor

Tema: Librería de Snippets para VB.NET !! (Compartan aquí sus snippets) (Leído 662,216 veces)

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.985

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

« Respuesta #610 en: 9 Diciembre 2025, 09:16 am »

Un simple TypeConverter junto a un UITypeEditor (opcional) para representar un color en formato web.

Nota: los colores no se ven como deberían por la compresión de imagen del software que he usado para capturar el GIF animado xD

WebColorConverter.vb

Código

#Region " Option Statements "
 
Option Strict On
Option Explicit On
Option Infer Off
 
#End Region
 
#Region " Imports "
 
Imports System.ComponentModel
Imports System.Globalization
 
#End Region
 
Public Class WebColorConverter : Inherits ColorConverter
 
    <DebuggerStepThrough>
    Public Overrides Function GetStandardValuesSupported(context As ITypeDescriptorContext) As Boolean
 
        Return True
    End Function
 
    <DebuggerStepThrough>
    Public Overrides Function GetStandardValues(context As ITypeDescriptorContext) As StandardValuesCollection
 
        Dim collection As New Collection()
 
        For Each kc As KnownColor In [Enum].GetValues(GetType(KnownColor))
            Dim color As Color = Color.FromKnownColor(kc)
 
            If Not color.IsSystemColor AndAlso color.IsNamedColor Then
                collection.Add(color)
            End If
        Next
 
        Return New StandardValuesCollection(collection)
    End Function
 
    <DebuggerStepThrough>
    Public Overrides Function ConvertTo(context As ITypeDescriptorContext,
                                    culture As CultureInfo,
                                    value As Object,
                                    destinationType As Type) As Object
 
        If destinationType Is GetType(String) AndAlso TypeOf value Is Color Then
            Dim color As Color = DirectCast(value, Color)
            Dim html As String = If(color.A <> 255, $"#{color.A:X2}{color.R:X2}{color.G:X2}{color.B:X2}",
                                    ColorTranslator.ToHtml(Color.FromArgb(color.R, color.G, color.B)))
 
            Dim name As String = Nothing
            For Each knownColor As KnownColor In [Enum].GetValues(GetType(KnownColor))
                Dim k As Color = Color.FromKnownColor(knownColor)
                If k.A = color.A AndAlso
                   k.R = color.R AndAlso
                   k.G = color.G AndAlso
                   k.B = color.B AndAlso Not k.IsSystemColor Then
 
                    name = k.Name
                    Exit For
                End If
            Next
 
            Return If(name IsNot Nothing, $"{html} ({name})", html)
        End If
 
        Return MyBase.ConvertTo(context, culture, value, destinationType)
    End Function
 
    <DebuggerStepThrough>
    Public Overrides Function ConvertFrom(context As ITypeDescriptorContext,
                                          culture As CultureInfo,
                                          value As Object) As Object
 
        Dim s As String = TryCast(value, String)
        If s IsNot Nothing Then
            s = s.Trim()
 
            ' If input is like "xxx (Name)" remove the part in parentheses
            Dim idx As Integer = s.IndexOf("("c)
            If idx >= 0 Then
                s = s.Substring(0, idx).Trim()
            End If
 
            If s.StartsWith("#") Then
                Dim hx As String = s.Substring(1).Trim()
 
                ' Support #RRGGBB and #AARRGGBB
                If hx.Length = 6 Then
                    Dim r As Integer = Convert.ToInt32(hx.Substring(0, 2), 16)
                    Dim g As Integer = Convert.ToInt32(hx.Substring(2, 2), 16)
                    Dim b As Integer = Convert.ToInt32(hx.Substring(4, 2), 16)
                    Return Color.FromArgb(255, r, g, b)
 
                ElseIf hx.Length = 8 Then
                    Dim a As Integer = Convert.ToInt32(hx.Substring(0, 2), 16)
                    Dim r As Integer = Convert.ToInt32(hx.Substring(2, 2), 16)
                    Dim g As Integer = Convert.ToInt32(hx.Substring(4, 2), 16)
                    Dim b As Integer = Convert.ToInt32(hx.Substring(6, 2), 16)
                    Return Color.FromArgb(a, r, g, b)
 
                Else
                    ' Support short hex format (#RGB) by expanding to 6 digits
                    If hx.Length = 3 Then
                        Dim r As Integer = Convert.ToInt32(String.Concat(hx(0), hx(0)), 16)
                        Dim g As Integer = Convert.ToInt32(String.Concat(hx(1), hx(1)), 16)
                        Dim b As Integer = Convert.ToInt32(String.Concat(hx(2), hx(2)), 16)
                        Return Color.FromArgb(255, r, g, b)
                    End If
                End If
 
            Else
                ' Try ColorTranslator for standard names and "Transparent"
                Try
                    Dim c As Color = ColorTranslator.FromHtml(s)
                    ' ColorTranslator.FromHtml returns A=255 for known names; A=0 for "Transparent"
                    Return c
 
                Catch ex As Exception
                    ' Try KnownColor enum (e.g. user types "White" or "WhiteSmoke")
                    Try
                        Dim kc As KnownColor
                        If [Enum].TryParse(s, True, kc) Then
                            Return Color.FromKnownColor(kc)
                        End If
                    Catch
                        ' Continue to fallback
                    End Try
                End Try
            End If
 
            ' If everything fails, fallback to the base converter (throws or defaults)
        End If
 
        Return MyBase.ConvertFrom(context, culture, value)
    End Function
 
End Class

WebColorEditor.vb

Código

#Region " Option Statements "
 
Option Strict On
Option Explicit On
Option Infer Off
 
#End Region
 
#Region " Imports "
 
Imports System.ComponentModel
Imports System.Drawing.Design
 
#End Region
 
Public Class WebColorEditor : Inherits UITypeEditor
 
    <DebuggerStepThrough>
    Public Overrides Function GetEditStyle(context As ITypeDescriptorContext) As UITypeEditorEditStyle
 
        Return UITypeEditorEditStyle.None
    End Function
 
    <DebuggerStepThrough>
    Public Overrides Function GetPaintValueSupported(context As ITypeDescriptorContext) As Boolean
 
        Return True
    End Function
 
    <DebuggerStepThrough>
    Public Overrides Sub PaintValue(e As PaintValueEventArgs)
 
        Dim color As Color
 
        If TypeOf e.Value Is Color Then
            color = DirectCast(e.Value, Color)
        Else
            Exit Sub
        End If
 
        Using brush As New SolidBrush(color)
            e.Graphics.FillRectangle(brush, e.Bounds)
        End Using
    End Sub
 
End Class

Modo de empleo:

Código

Imports System.ComponentModel
Imports System.Drawing.Design
 
Public Class Form1
 
    Private ReadOnly ClassTest As New MyClassTest
 
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
 
        Me.PropertyGrid1.SelectedObject = Me.ClassTest
    End Sub
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
 
        Me.ClassTest.MyColor = Color.FromArgb(255, 116, 222, 4)
        Me.PropertyGrid1.Refresh()
    End Sub
End Class
 
Friend NotInheritable Class MyClassTest
 
    <TypeConverter(GetType(WebColorConverter))>
    <Editor(GetType(WebColorEditor), GetType(UITypeEditor))> ' El editor es opcional.
    Public Property MyColor As Color = Color.Transparent
 
End Class

Ejemplo de utilidad en la vida real: un programa open-source para mostrar en tiempo real el color del pixel actual en la pantalla (entre otras cosas):


« Última modificación: 9 Diciembre 2025, 09:30 am por Eleкtro »	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.985

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

« Respuesta #611 en: 11 Diciembre 2025, 16:42 pm »

Un par de funciones auxiliares relacionadas con la colorimetría...

Calcula el color promedio de un área rectangular especificada dentro de un Bitmap:

Código

''' <summary>
''' Calculates the average color of a specified rectangular area within a <see cref="Bitmap"/>.
''' </summary>
''' 
''' <param name="bmp">
''' The <see cref="Bitmap"/> from which to sample colors.
''' </param>
''' 
''' <param name="rectF">
''' The rectangular area (<see cref="RectangleF"/>) to sample. 
''' <para></para>
''' The rectangle is automatically clamped to the bitmap bounds.
''' </param>
''' 
''' <param name="background">
''' Optional background color for compositing.
''' <para></para>
''' If not provided or <see cref="Color.Empty"/>, <see cref="Color.Black"/> is assumed.
''' </param>
''' 
''' <returns>
''' A <see cref="Color"/> representing the average ARGB color of all pixels in the specified area.
''' <para></para>
''' If the rectangle is empty or outside the bitmap, returns <see cref="Color.Black"/>.
''' </returns>
<DebuggerStepThrough>
Public Shared Function GetAverageColor(bmp As Bitmap, rectF As RectangleF,
                                       Optional background As Color = Nothing) As Color
 
    Dim rect As Rectangle = Rectangle.Intersect(Rectangle.Round(rectF), New Rectangle(0, 0, bmp.Width, bmp.Height))
    If rect.Width <= 0 OrElse rect.Height <= 0 Then
        Return Color.Black
    End If
 
    Dim bgColor As Color = If(background = Color.Empty, Color.Black, background)
 
    Dim aSum As Double
    Dim rSum As Double
    Dim gSum As Double
    Dim bSum As Double = 0
    Dim count As Integer = rect.Width * rect.Height
 
    ' Lock the bitmap for direct memory access
    Dim bmpData As BitmapData = bmp.LockBits(rect, ImageLockMode.ReadOnly, bmp.PixelFormat)
    Dim bytesPerPixel As Integer = Image.GetPixelFormatSize(bmp.PixelFormat) \ 8
    Dim stride As Integer = bmpData.Stride
    Dim scan0 As IntPtr = bmpData.Scan0
 
    Dim buffer((stride * rect.Height) - 1) As Byte
    Marshal.Copy(scan0, buffer, 0, buffer.Length)
 
    For y As Integer = 0 To rect.Height - 1
        For x As Integer = 0 To rect.Width - 1
            Dim i As Integer = y * stride + x * bytesPerPixel
            Dim b As Byte = buffer(i)
            Dim g As Byte = buffer(i + 1)
            Dim r As Byte = buffer(i + 2)
            Dim a As Byte = If(bytesPerPixel >= 4, buffer(i + 3), CByte(255))
 
            Dim alphaFactor As Double = a / 255.0
            rSum += r * alphaFactor + bgColor.R * (1 - alphaFactor)
            gSum += g * alphaFactor + bgColor.G * (1 - alphaFactor)
            bSum += b * alphaFactor + bgColor.B * (1 - alphaFactor)
            aSum += a
        Next
    Next
 
    bmp.UnlockBits(bmpData)
 
    Dim avgA As Integer = CInt(aSum / count)
    Dim avgR As Integer = CInt(rSum / count)
    Dim avgG As Integer = CInt(gSum / count)
    Dim avgB As Integer = CInt(bSum / count)
 
    Return Color.FromArgb(avgA, avgR, avgG, avgB)
End Function

Calcula la luminancia percibida de un color, opcionalmente compuesta sobre un color de fondo:

Código

''' <summary>
''' Calculates the perceived luminance of a color, optionally composited over a background color.
''' </summary>
''' 
''' <param name="color">
''' The color whose luminance is to be calculated. Includes alpha channel.
''' </param>
''' 
''' <param name="background">
''' Optional background color for compositing.
''' <para></para>
''' If not provided or <see cref="Color.Empty"/>, <see cref="Color.Black"/> is assumed.
''' </param>
''' 
''' <returns>
''' A <see cref="Double"/> representing the relative luminance of the color in the range 0.0 (black) to 1.0 (white).
''' </returns>
<DebuggerStepThrough>
Public Shared Function GetLuminance(color As Color, Optional background As Color = Nothing) As Double
 
    Dim bgColor As Color = If(background = Color.Empty, Color.Black, background)
 
    Dim alpha As Double = color.A / 255.0
    Dim r As Double = color.R * alpha + bgColor.R * (1 - alpha)
    Dim g As Double = color.G * alpha + bgColor.G * (1 - alpha)
    Dim b As Double = color.B * alpha + bgColor.B * (1 - alpha)
 
    ' Standard luma weighting associated with Rec. 601 when deriving brightness from RGB.
    ' Y'601 = 0.299 R' + 0.587 G' + 0.114 B'.
    ' https://en.wikipedia.org/wiki/Rec._601
    ' https://gmao.gsfc.nasa.gov/media/gmaoftp/jkolassa/Matlab_scripts/colorspace.html
    Dim luminance As Double = (0.299 * r +
                               0.587 * g +
                               0.114 * b
                              ) / 255.0
 
    Return luminance
End Function


	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.985

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

« Respuesta #612 en: 11 Diciembre 2025, 16:49 pm »

Una forma universal y personalizable para reportar progreso en nuestro icono del área de notificación (system tray)...

Importante: recomiendo no usar más de dos caracteres para el texto. Con tres caracteres ya se achica mucho, y con más, se vuelve prácticamente imposible de leer. Hay muy poco espacio legible para un icono de 32x32px.

NotifyIconProgressBar.vb

Código

Public Structure NotifyIconProgressBar
 
    Public Height As Integer
    Public BackColor As Color
    Public ForeColor As Color
    Public FillColor As Color
    Public BorderColor As Color
    Public BorderWidth As Integer
 
    Public Shared ReadOnly Property Empty As NotifyIconProgressBar
        Get
            Return New NotifyIconProgressBar With {
                .Height = 0,
                .BackColor = Color.Empty,
                .ForeColor = Color.Empty,
                .FillColor = Color.Empty,
                .BorderColor = Color.Empty,
                .BorderWidth = 0
            }
        End Get
    End Property
 
End Structure

P/invokes:

Código

<DllImport("user32.dll", SetLastError:=True)>
Private Shared Function DestroyIcon(hIcon As IntPtr) As Boolean
End Function

El método principal:

Código

Imports System.Drawing.Drawing2D
Imports System.Drawing.Text
Imports System.Runtime.InteropServices
 
''' <summary>
''' Renders a progress bar overlay on a <see cref="NotifyIcon"/> and optionally draws text on it.
''' </summary>
''' 
''' <param name="ntfy">
''' The <see cref="NotifyIcon"/> whose icon will be updated with the rendered progress bar.
''' </param>
''' 
''' <param name="progressBar">
''' A <see cref="NotifyIconProgressBar"/> structure containing the bar's height, colors and border width.
''' </param>
''' 
''' <param name="value">
''' The current position of the progress bar.
''' </param>
''' 
''' <param name="maximumValue">
''' The maximum <paramref name="value"/> range of the progress bar.
''' </param>
''' 
''' <param name="text">
''' Optional text to display centered above the progress bar.
''' Must be 3 characters or fewer if provided.
''' </param>
<DebuggerStepThrough>
Public Shared Sub RenderNotifyIconProgressBar(ntfy As NotifyIcon, baseIcon As Icon, progressBar As NotifyIconProgressBar,
                                              value As Integer, maximumValue As Integer,
                                              Optional text As String = Nothing)
 
    If ntfy Is Nothing Then
        Throw New ArgumentNullException(NameOf(ntfy))
    End If
 
    If baseIcon Is Nothing Then
        Throw New ArgumentNullException(NameOf(baseIcon))
    End If
 
    If maximumValue <= 0 Then
        Throw New ArgumentOutOfRangeException(NameOf(maximumValue), $"{NameOf(maximumValue)} must be greater than zero.")
    End If
 
    If value < 0 OrElse (value > maximumValue) Then
        Throw New ArgumentOutOfRangeException(NameOf(value), $"{NameOf(value)} must be between zero and {NameOf(maximumValue)}.")
    End If
 
    Dim currentIcon As Icon = ntfy.Icon
 
    Using bmp As Bitmap = baseIcon.ToBitmap()
 
        Dim width As Integer = bmp.Width
        Dim height As Integer = bmp.Height
 
        If progressBar.Height <= 0 Then
            Throw New ArgumentOutOfRangeException(NameOf(progressBar.Height), $"{NameOf(progressBar.Height)} must be greater than zero.")
        End If
 
        If progressBar.Height > height Then
            Throw New ArgumentOutOfRangeException(NameOf(progressBar.Height), $"{NameOf(progressBar.Height)} ({progressBar.Height}) exceeds the icon height ({height}).")
        End If
 
        If progressBar.BorderWidth > height Then
            Throw New ArgumentOutOfRangeException(NameOf(progressBar.BorderWidth), $"{NameOf(progressBar.BorderWidth)} ({progressBar.BorderWidth}) exceeds the icon height ({height}).")
        End If
 
        Using g As Graphics = Graphics.FromImage(bmp)
            g.CompositingMode = CompositingMode.SourceOver
            g.CompositingQuality = CompositingQuality.HighQuality
            g.InterpolationMode = InterpolationMode.High
            g.PixelOffsetMode = PixelOffsetMode.Half
            g.SmoothingMode = SmoothingMode.AntiAlias
            g.TextRenderingHint = TextRenderingHint.ClearTypeGridFit
 
            Dim barY As Integer = height - progressBar.Height
 
            Using backgroundBrush As New SolidBrush(progressBar.BackColor)
                g.FillRectangle(backgroundBrush, 0, barY, width, progressBar.Height)
            End Using
 
            Using fillBrush As New SolidBrush(progressBar.FillColor)
                Dim percent As Single = CSng(value / maximumValue)
                Dim filledWidth As Integer = CInt(width * percent)
                g.FillRectangle(fillBrush, 0, barY, filledWidth, progressBar.Height)
            End Using
 
            If progressBar.BorderWidth > 0 Then
                Using borderPen As New Pen(progressBar.BorderColor, progressBar.BorderWidth)
                    g.DrawRectangle(borderPen, 0, barY, width - 1, progressBar.Height)
                End Using
            End If
 
            If Not String.IsNullOrWhiteSpace(text) Then
 
                Using fontFamily As New FontFamily("Segoe UI")
                    Dim fontStyle As FontStyle = FontStyle.Bold
 
                    Dim layoutRect As New RectangleF(0, 0, width, height)
                    Dim fontSizePx As Single = ComputeMaxFontSizeForRectangle(g, text, fontFamily, fontStyle, layoutRect)
 
                    Using font As New Font(fontFamily, fontSizePx, fontStyle, GraphicsUnit.Pixel)
 
                        Using gp As New GraphicsPath()
                            Dim sf As New StringFormat() With {
                                .Alignment = StringAlignment.Center,
                                .LineAlignment = StringAlignment.Center
                            }
                            gp.AddString(text, font.FontFamily, font.Style, font.Size, layoutRect, sf)
 
                            ' Outline then fill for best legibility
                            Using outlinePen As New Pen(Color.FromArgb(220, Color.Black), Math.Max(1.0F, fontSizePx * 0.18F))
                                outlinePen.LineJoin = LineJoin.Round
                                g.DrawPath(outlinePen, gp)
                            End Using
 
                            Using foregroundBrush As New SolidBrush(progressBar.ForeColor)
                                g.FillPath(foregroundBrush, gp)
                            End Using
                        End Using
                    End Using
                End Using
            End If
        End Using
 
        Dim hIcon As IntPtr = bmp.GetHicon()
        Using tempIcon As Icon = Icon.FromHandle(hIcon)
            Dim finalIcon As Icon = CType(tempIcon.Clone(), Icon)
            DestroyIcon(hIcon)
            ntfy.Icon = finalIcon
        End Using
 
        currentIcon.Dispose()
    End Using
End Sub

Función auxiliar necesaria:

Código

''' <summary>
''' Determines the largest font size that allows the specified text to fit entirely 
''' within the given rectangle when drawn using the provided <see cref="Graphics"/> object.
''' </summary>
''' 
''' <param name="g">
''' The source <see cref="Graphics"/> object used to measure the text.
''' </param>
''' 
''' <param name="text">
''' The text to measure.
''' </param>
''' 
''' <param name="fontFamily">
''' The font family to use (e.g., "Segoe UI").
''' </param>
''' 
''' <param name="fontStyle">
''' The font style (e.g., <see cref="FontStyle.Regular"/>).
''' </param>
''' 
''' <param name="layoutRectangle">
''' The rectangle within which the text must fit.
''' </param>
''' 
''' <param name="minimumSize">
''' The minimum allowed font size (in <see cref="GraphicsUnit.Pixel"/>).
''' <para></para>
''' If the text does not fit even at this size, the function returns this value.
''' <para></para>
''' Default value is <c>1.0</c>.
''' </param>
''' 
''' <param name="tolerance">
''' The precision threshold for how closely the function tries to fit the text in the rectangle, in <see cref="GraphicsUnit.Pixel"/>.
''' <para></para>
''' Smaller values gives more exact results but will require more time to compute.
''' <para></para>
''' Default value is <c>0.5</c>.
''' </param>
''' 
''' <returns>
''' The largest font size in <see cref="GraphicsUnit.Pixel"/> that fits the text inside the rectangle.
''' <para></para>
''' If the text cannot fit even at <paramref name="minimumSize"/>, that minimum value is returned.
''' </returns>
Public Shared Function ComputeMaxFontSizeForRectangle(g As Graphics, text As String,
                                                      fontFamily As FontFamily, fontStyle As FontStyle,
                                                      layoutRectangle As RectangleF,
                                                      Optional minimumSize As Single = 1.0F,
                                                      Optional tolerance As Single = 0.5F) As Single
 
    Dim minSize As Single = minimumSize
    Dim maxSize As Single = layoutRectangle.Height
    Dim bestFit As Single = minSize
 
    While (maxSize - minSize) > tolerance
        Dim midSize As Single = (minSize + maxSize) / 2
 
        Using testFont As New Font(fontFamily, midSize, fontStyle, GraphicsUnit.Pixel)
            Dim textSize As SizeF = g.MeasureString(text, testFont)
 
            If (textSize.Width <= layoutRectangle.Width) AndAlso
               (textSize.Height <= layoutRectangle.Height) Then
                bestFit = midSize
                minSize = midSize
            Else
                maxSize = midSize
            End If
        End Using
    End While
 
    Return Math.Max(minimumSize, bestFit)
End Function

Ejemplo de uso:

Código

Private Async Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
 
    Dim progressBar As New NotifyIconProgressBar With {
        .Height = 32,
        .BackColor = Color.Transparent,
        .ForeColor = Color.White,
        .FillColor = Color.LimeGreen
    }
 
    Dim ntfy As NotifyIcon = Me.NotifyIcon1
    Dim baseIcon As Icon = DirectCast(ntfy.Icon.Clone(), Icon)
 
    Dim maxValue As Integer = 100
    For i As Integer = 0 To maxValue
        RenderNotifyIconProgressBar(ntfy, baseIcon, progressBar, i, maxValue, CStr(i))
        Await Task.Delay(100)
    Next
End Sub


« Última modificación: 11 Diciembre 2025, 18:17 pm por Eleкtro »	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.985

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

« Respuesta #613 en: 18 Enero 2026, 22:14 pm »

FlexibleSettingsProvider

Un proveedor de configuración que permite almacenar el archivo de configuración de usuario "user.config" en un directorio y nombre de archivo personalizables, asegurando que la ubicación de la configuración se mantenga fija y predecible.

Este proveedor nos permite - si así lo queremos - establecer el directorio base de nuestra aplicación, haciendo que podamos portabilizar nuestra aplicación junto al archivo de configuración de usuario.

Código

#Region " Option Statements "
 
Option Explicit On
Option Strict On
Option Infer Off
 
#End Region
 
#Region " Imports "
 
Imports System.Collections.Specialized
Imports System.ComponentModel
Imports System.Configuration
Imports System.IO
Imports System.Reflection
Imports System.Runtime.InteropServices
Imports System.Security
Imports System.Security.AccessControl
Imports System.Security.Cryptography
Imports System.Security.Principal
Imports System.Text
 
#End Region
 
#Region " FlexibleSettingsProvider "
 
''' <summary>
''' A settings provider that allows to store the application's user configuration file 
''' in a user-defined directory path and file name, ensuring the configuration location remains 
''' predictable across application updates.
''' </summary>
''' 
''' <example> This is a code example.
''' <code language="VB">
''' '------------------------------------------------------------------------------
''' ' <auto-generated>
''' '     This code was generated by a tool.
''' '     Runtime Version:4.0.30319.42000
''' '
''' '     Changes to this file may cause incorrect behavior and will be lost if
''' '     the code is regenerated.
''' ' </auto-generated>
''' '------------------------------------------------------------------------------
''' Namespace My
'''     
'''     &lt;Global.System.Runtime.CompilerServices.CompilerGeneratedAttribute(),  _
'''      Global.System.CodeDom.Compiler.GeneratedCodeAttribute("Microsoft.VisualStudio.Editors.SettingsDesigner.SettingsSingleFileGenerator", "17.14.0.0"),  _
'''      Global.System.ComponentModel.EditorBrowsableAttribute(Global.System.ComponentModel.EditorBrowsableState.Advanced)&gt;  _
'''     Partial Friend NotInheritable Class MySettings
'''         Inherits Global.System.Configuration.ApplicationSettingsBase
'''         
'''         ' ...
'''     End Class
''' End Namespace
''' 
''' ' &#9940; DO NOT MODIFY THE AUTO-GENERATED DESIGNER FILE ABOVE. 
''' ' INSTEAD, PLACE THE FOLLOWING NAMESPACE IN A SEPARATE PART OF YOUR SOURCE CODE:
''' 
''' Namespace My
''' 
'''     &lt;Global.System.Configuration.SettingsProvider(GetType(FlexibleSettingsProvider))&gt;
'''     Partial Friend NotInheritable Class MySettings
''' 
'''         Public Sub New()
'''             FlexibleSettingsProvider.BaseDirectoryPath = ".\"
'''             FlexibleSettingsProvider.DirectoryName = ""
'''             FlexibleSettingsProvider.DirectoryNameFlags = SettingsDirectoryNameFlags.None
'''             FlexibleSettingsProvider.FileName = "user.config"
''' 
'''             Debug.WriteLine($"Effective config file path: {FlexibleSettingsProvider.EffectiveConfigFilePath}")
'''         End Sub
''' 
'''     End Class
''' End Namespace
''' </code>
''' </example>
''' 
''' <example> This is a code example.
''' <code language="CSharp">
''' 
''' //------------------------------------------------------------------------------
''' // <auto-generated>
''' //     This code was generated by a tool.
''' //     Runtime Version:4.0.30319.42000
''' //
''' //     Changes to this file may cause incorrect behavior and will be lost if
''' //     the code is regenerated.
''' // </auto-generated>
''' //------------------------------------------------------------------------------
'''
''' namespace WindowsFormsApp1.Properties {
'''     
'''     [global::System.Runtime.CompilerServices.CompilerGeneratedAttribute()]
'''     [global::System.CodeDom.Compiler.GeneratedCodeAttribute("Microsoft.VisualStudio.Editors.SettingsDesigner.SettingsSingleFileGenerator", "17.14.0.0")]
'''     internal sealed partial class Settings : global::System.Configuration.ApplicationSettingsBase {
'''         // ...
'''     }
''' }
''' 
''' // &#9940; DO NOT MODIFY THE AUTO-GENERATED DESIGNER FILE ABOVE. 
''' // INSTEAD, PLACE THE FOLLOWING NAMESPACE IN A SEPARATE PART OF YOUR SOURCE CODE:
''' 
''' namespace WindowsFormsApp1.Properties
''' {
'''     [SettingsProvider(typeof(FlexibleSettingsProvider))]
'''     internal sealed partial class Settings : global::System.Configuration.ApplicationSettingsBase
'''     {
'''         public Settings()
'''         {
'''             FlexibleSettingsProvider.BaseDirectoryPath = @".\";
'''             FlexibleSettingsProvider.DirectoryName = string.Empty;
'''             FlexibleSettingsProvider.DirectoryNameFlags = SettingsDirectoryNameFlags.None;
'''             FlexibleSettingsProvider.FileName = "user.config";
'''
'''             Debug.WriteLine($"Effective config file path: {FlexibleSettingsProvider.EffectiveConfigFilePath}");
'''         }
'''     }
''' }
''' </code>
''' </example>
Public Class FlexibleSettingsProvider : Inherits SettingsProvider
 
#Region " Private Fields "
 
    ''' <summary>
    ''' The default base directory path to use when the path specified by 
    ''' <see cref="FlexibleSettingsProvider.BaseDirectoryPath"/> is null or cannot be accessed.
    ''' </summary>
    Private Shared ReadOnly DefaultBaseDirectoryPath As String =
        Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) ' Note: THIS VALUE CANNOT BE NULL.
 
    ''' <summary>
    ''' The default configuration file name to use when the name specified by 
    ''' <see cref="FlexibleSettingsProvider.FileName"/> is null.
    ''' </summary>
    Private Shared ReadOnly DefaultFileName As String = "user.config" ' Note: THIS VALUE CANNOT BE NULL.
 
#End Region
 
#Region " Public Properties "
 
    ''' <summary>
    ''' Gets or sets the base directory path where the settings storage folder specified by 
    ''' <see cref="FlexibleSettingsProvider.DirectoryName"/> property will be created.
    ''' </summary>
    ''' 
    ''' <remarks>
    ''' This can be a relative path, for example <b>".\"</b>, which refers to the current application's base directory.
    ''' <para></para>
    ''' If this value is null or empty, <see cref="Environment.SpecialFolder.LocalApplicationData"/> directory path will be used.
    ''' <para></para>
    ''' Default value is <b>".\"</b>.
    ''' </remarks>
    Public Shared Property BaseDirectoryPath As String = ".\"
 
    ''' <summary>
    ''' Gets or sets the name of the settings storage folder that will be created under the 
    ''' base directory path specified by <see cref="FlexibleSettingsProvider.BaseDirectoryPath"/> property; 
    ''' For example, <b>"My Application"</b>.
    ''' </summary>
    ''' 
    ''' <remarks>
    ''' This value can be null, in which case this folder will not be created at all.
    ''' <para></para>
    ''' Default value is null.
    ''' </remarks>
    Public Shared Property DirectoryName As String = Nothing
 
    ''' <summary>
    ''' Gets or sets additional flags that allows to automatically append extra information to the 
    ''' settings storage folder name specified by <see cref="FlexibleSettingsProvider.DirectoryName"/> property.
    ''' <para></para>
    ''' Default value is <see cref="SettingsDirectoryNameFlags.None"/>.
    ''' </summary>
    Public Shared Property DirectoryNameFlags As SettingsDirectoryNameFlags = SettingsDirectoryNameFlags.None
 
    ''' <summary>
    ''' Gets or sets the name of the user configuration file to create inside the 
    ''' settings storage folder specified by <see cref="FlexibleSettingsProvider.DirectoryName"/> property.
    ''' <para></para>
    ''' If this value is null or empty, <b>"user.config"</b> is used.
    ''' <para></para>
    ''' Default value is <b>"user.config"</b>.
    ''' </summary>
    Public Shared Property FileName As String = FlexibleSettingsProvider.DefaultFileName
 
    ''' <summary>
    ''' Gets or sets the type of <see cref="HashAlgorithm"/> to use for appending the hash suffix to the 
    ''' settings storage folder name specified by <see cref="FlexibleSettingsProvider.DirectoryName"/> when 
    ''' <see cref="FlexibleSettingsProvider.DirectoryNameFlags"/> contains <see cref="SettingsDirectoryNameFlags.Hash"/> flag.
    ''' <para></para>
    ''' Default value is <see cref="MD5"/>.
    ''' </summary>
    Public Shared Property HashAlgorithmType As Type = GetType(MD5)
 
    ''' <summary>
    ''' Gets or sets the maximum character length to use for appending the hash suffix to the 
    ''' settings storage folder name specified by <see cref="FlexibleSettingsProvider.DirectoryName"/> when 
    ''' <see cref="FlexibleSettingsProvider.DirectoryNameFlags"/> contains <see cref="SettingsDirectoryNameFlags.Hash"/> flag.
    ''' <see cref="SettingsDirectoryNameFlags.Hash"/> flag.
    ''' <para></para>
    ''' Default value is <b>8</b>.
    ''' </summary>
    ''' 
    ''' <remarks>
    ''' Note: If the specified length exceeds the maximum length supported by the hash algorithm specified by
    ''' <see cref="FlexibleSettingsProvider.HashAlgorithmType"/> property, 
    ''' the value is automatically truncated to the maximum allowed.
    ''' </remarks>
    Public Shared Property HashLength As Integer = 8
 
    ''' <summary>
    ''' Gets the effective full path to the user configuration file 
    ''' using the current rules specified by 
    ''' <see cref="FlexibleSettingsProvider.BaseDirectoryPath"/>,
    ''' <see cref="FlexibleSettingsProvider.DirectoryName"/> ,
    ''' <see cref="FlexibleSettingsProvider.DirectoryNameFlags"/>,
    ''' <see cref="FlexibleSettingsProvider.FileName"/>,
    ''' <see cref="FlexibleSettingsProvider.HashAlgorithmType"/> and 
    ''' <see cref="FlexibleSettingsProvider.HashLength"/> properties; 
    ''' For example, <b>"C:\Users\{USERNAME}\AppData\Local\My Application\user.config"</b>
    ''' </summary>
    Public Shared ReadOnly Property EffectiveConfigFilePath As String
        <DebuggerStepThrough>
        Get
            Return FlexibleSettingsProvider.GetEffectiveConfigFilePath()
        End Get
    End Property
 
    ''' <summary>
    ''' Gets the name of the currently running application
    ''' using the current rules specified by 
    ''' <see cref="FlexibleSettingsProvider.DirectoryName"/> ,
    ''' <see cref="FlexibleSettingsProvider.DirectoryNameFlags"/>,
    ''' <see cref="FlexibleSettingsProvider.HashAlgorithmType"/> and 
    ''' <see cref="FlexibleSettingsProvider.HashLength"/> properties; 
    ''' For example, <b>"My Application"</b>.
    ''' </summary>
    <EditorBrowsable(EditorBrowsableState.Never)>
    Public Overrides Property ApplicationName As String
        <DebuggerStepThrough>
        Get
            Return FlexibleSettingsProvider.GetEffectiveDirectoryName()
        End Get
        <DebuggerStepThrough>
        Set(value As String)
            ' Intentionally ignored, and required.
        End Set
    End Property
 
    ''' <summary>
    ''' Gets a brief, friendly description of this <see cref="SettingsProvider"/>,
    ''' suitable for display in administrative tools or other user interfaces (UIs).
    ''' </summary>
    <EditorBrowsable(EditorBrowsableState.Never)>
    Public Overrides ReadOnly Property Description As String
        <DebuggerStepThrough>
        Get
            Return If(Not String.IsNullOrEmpty(Me._Description), Me._Description, Me.Name)
        End Get
    End Property
    ''' <summary>
    ''' ( Backing field of <see cref="Description"/> property.)
    ''' <para></para>
    ''' A brief, friendly description of this <see cref="SettingsProvider"/>,
    ''' suitable for display in administrative tools or other user interfaces (UIs).
    ''' </summary>
    Private ReadOnly _Description As String =
        "A settings provider that allows to store the application's user configuration file in a user-defined directory path and file name."
 
#End Region
 
#Region " Constructors "
 
    ''' <summary>
    ''' Initializes a new instance of the <see cref="FlexibleSettingsProvider"/> class.
    ''' </summary>
    <DebuggerNonUserCode>
    Public Sub New()
    End Sub
 
#End Region
 
#Region " Public Methods "
 
    ''' <summary>
    ''' Initializes the configuration builder.
    ''' </summary>
    ''' 
    ''' <param name="name">
    ''' The friendly name of the provider.
    ''' </param>
    ''' 
    ''' <param name="config">
    ''' A collection of the name/value pairs representing the provider-specific attributes 
    ''' specified in the configuration for this provider.
    ''' </param>
    <DebuggerStepperBoundary>
    Public Overrides Sub Initialize(name As String, config As NameValueCollection)
 
        If String.IsNullOrEmpty(name) Then
            name = NameOf(FlexibleSettingsProvider)
        End If
        MyBase.Initialize(name, config)
    End Sub
 
    ''' <summary>
    ''' Returns the collection of settings property values for the specified application instance and settings property group.
    ''' </summary>
    ''' 
    ''' <param name="context">
    ''' A <see cref="SettingsContext"/> describing the current application use.
    ''' </param>
    ''' 
    ''' <param name="properties">
    ''' A <see cref="SettingsPropertyCollection"/> containing the settings property group whose values are to be retrieved.
    ''' </param>
    ''' <returns>
    ''' A <see cref="SettingsPropertyValueCollection"/> containing the values for the specified settings property group.
    ''' </returns>
    <DebuggerStepperBoundary>
    Public Overrides Function GetPropertyValues(context As SettingsContext, properties As SettingsPropertyCollection) As SettingsPropertyValueCollection
 
        Dim values As New SettingsPropertyValueCollection()
 
        Dim doc As XDocument = Nothing
 
        Dim effectiveConfigFilePath As String = FlexibleSettingsProvider.EffectiveConfigFilePath()
 
        If File.Exists(effectiveConfigFilePath) Then
            Try
                Using fs As New FileStream(effectiveConfigFilePath, FileMode.Open, FileAccess.Read, FileShare.Read)
                    doc = XDocument.Load(fs)
                End Using
            Catch ex As Exception
                ' If file is corrupt / unreadable, recreate a fresh doc.
                doc = New XDocument(New XElement("settings"))
            End Try
        Else
            doc = New XDocument(New XElement("settings"))
        End If
 
        ' Ensure root exists.
        If doc.Root Is Nothing Then
            doc = New XDocument(New XElement("settings"))
        End If
 
        For Each prop As SettingsProperty In properties
            Dim el As XElement = doc.Root.Element(prop.Name)
            Dim value As Object = If(el IsNot Nothing, el.Value, prop.DefaultValue)
 
            Dim spv As New SettingsPropertyValue(prop) With {
                .SerializedValue = value
            }
            values.Add(spv)
        Next
 
        Return values
    End Function
 
    ''' <summary>
    ''' Sets the values of the specified group of property settings.
    ''' </summary>
    ''' 
    ''' <param name="context">
    ''' A <see cref="SettingsContext"/> describing the current application use.
    ''' </param>
    ''' 
    ''' <param name="values">
    ''' A <see cref="SettingsPropertyValueCollection"/> representing the group of property settings to set.
    ''' </param>
    <DebuggerStepperBoundary>
    Public Overrides Sub SetPropertyValues(context As SettingsContext, values As SettingsPropertyValueCollection)
 
        Dim effectiveConfigFilePath As String = FlexibleSettingsProvider.EffectiveConfigFilePath()
        Dim directoryPath As String = Path.GetDirectoryName(effectiveConfigFilePath)
        If Not Directory.Exists(directoryPath) Then
            Directory.CreateDirectory(directoryPath)
        End If
 
        Dim root As New XElement("settings")
 
        For Each val As SettingsPropertyValue In values
            Dim nodeName As String = If(val.Property IsNot Nothing AndAlso Not String.IsNullOrEmpty(val.Property.Name),
                                        val.Property.Name,
                                        "unknown")
 
            Dim nodeValue As String = If(val.SerializedValue Is Nothing, "", val.SerializedValue.ToString())
 
            root.Add(New XElement(nodeName, nodeValue))
        Next
 
        Dim doc As New XDocument(root)
 
        Using fs As New FileStream(effectiveConfigFilePath, FileMode.Create, FileAccess.Write, FileShare.Read)
            doc.Save(fs)
        End Using
    End Sub
 
#End Region
 
#Region " Private Methods "
 
    ''' <summary>
    ''' Resolves and returns the effective base directory path where the settings storage folder specified by 
    ''' <see cref="FlexibleSettingsProvider.DirectoryName"/> property will be created.
    ''' </summary>
    ''' 
    ''' <remarks>
    ''' This function determines the proper directory path by first using the value specified in
    ''' <see cref="FlexibleSettingsProvider.BaseDirectoryPath"/> property.
    ''' <para></para>
    ''' If that value is null, empty, whitespace, or the directory cannot be created, the path specified by 
    ''' <see cref="FlexibleSettingsProvider.DefaultBaseDirectoryPath"/> property is used instead.
    ''' </remarks>
    ''' 
    ''' <returns>
    ''' A string representing the effective base directory path.
    ''' </returns>
    ''' 
    ''' <exception cref="InvalidOperationException">
    ''' Thrown when the provier is unable to resolve a base directory path that 
    ''' exists and can grant read/write access to the current application.
    ''' <para></para>
    ''' This exception indicates that neither the directory specified by <see cref="FlexibleSettingsProvider.DirectoryName"/> property 
    ''' nor the fallback specified by <see cref="FlexibleSettingsProvider.DefaultBaseDirectoryPath"/> property 
    ''' can be used to read from and write to the location.
    ''' </exception>
    <DebuggerStepThrough>
    Private Shared Function GetEffectiveBaseDirectoryPath() As String
 
        Dim currentBaseDirectoryPath As String = FlexibleSettingsProvider.BaseDirectoryPath
 
        ' Expand to full path.
        If Not String.IsNullOrWhiteSpace(currentBaseDirectoryPath) Then
            currentBaseDirectoryPath = Path.GetFullPath(currentBaseDirectoryPath)
        End If
 
        ' Ensure the directory path is set.
        If String.IsNullOrWhiteSpace(currentBaseDirectoryPath) Then
            currentBaseDirectoryPath = FlexibleSettingsProvider.DefaultBaseDirectoryPath
        End If
 
        ' Try creating the directory.
        Try
            Directory.CreateDirectory(currentBaseDirectoryPath)
 
        Catch ' If failed, fallback to LocalAppData
            currentBaseDirectoryPath = FlexibleSettingsProvider.DefaultBaseDirectoryPath
            Try
                Directory.CreateDirectory(currentBaseDirectoryPath)
            Catch
                ' Ignore: write check will catch this later.
            End Try
 
        End Try
 
        ' Verify that we can read from and write to the directory path.
        If Not FlexibleSettingsProvider.CanReadAndWriteToDirectory(currentBaseDirectoryPath) Then
 
            Dim previousDirectoryPath As String = currentBaseDirectoryPath
 
            ' Switch to default directory path if not already using it.
            If currentBaseDirectoryPath <> FlexibleSettingsProvider.DefaultBaseDirectoryPath Then
                currentBaseDirectoryPath = FlexibleSettingsProvider.DefaultBaseDirectoryPath
            End If
 
            If currentBaseDirectoryPath <> previousDirectoryPath Then
                ' Throw if directory still not writable.
                If Not FlexibleSettingsProvider.CanReadAndWriteToDirectory(currentBaseDirectoryPath) Then
                    Throw New InvalidOperationException(
                        $"Cannot read from or write the user configuration file in directory: {currentBaseDirectoryPath}. Check user permissions.")
                End If
            End If
        End If
 
        Return currentBaseDirectoryPath
    End Function
 
    ''' <summary>
    ''' Resolves and returns the effective name of the settings storage folder that will be created under the 
    ''' base directory path specified by <see cref="FlexibleSettingsProvider.BaseDirectoryPath"/> property, 
    ''' applying the rules specified by <see cref="FlexibleSettingsProvider.DirectoryNameFlags"/>.
    ''' </summary>
    ''' 
    ''' <returns>
    ''' A string representing the fully constructed directory name after applying all configured naming rules;
    ''' For example, <b>"My Application"</b>.
    ''' </returns>
    <DebuggerStepThrough>
    Private Shared Function GetEffectiveDirectoryName() As String
 
        Dim appendApplicationName As Boolean =
            FlexibleSettingsProvider.DirectoryNameFlags.HasFlag(SettingsDirectoryNameFlags.ApplicationName)
 
        Dim appendAssemblyName As Boolean =
            FlexibleSettingsProvider.DirectoryNameFlags.HasFlag(SettingsDirectoryNameFlags.AssemblyName)
 
        Dim appendVersion As Boolean =
            FlexibleSettingsProvider.DirectoryNameFlags.HasFlag(SettingsDirectoryNameFlags.Version)
 
        Dim appendHash As Boolean =
            FlexibleSettingsProvider.DirectoryNameFlags.HasFlag(SettingsDirectoryNameFlags.Hash)
 
        Dim appendUserName As Boolean =
            FlexibleSettingsProvider.DirectoryNameFlags.HasFlag(SettingsDirectoryNameFlags.UserName)
 
        Dim name As String = FlexibleSettingsProvider.DirectoryName
 
        Dim sb As New StringBuilder(Math.Max(16, If(String.IsNullOrEmpty(name), 0, name.Length)))
 
        If Not String.IsNullOrWhiteSpace(name) Then
            sb.Append(name)
        End If
 
        If appendApplicationName Then
            Dim applicationName As String = My.Application.Info.ProductName
 
            If Not String.IsNullOrWhiteSpace(applicationName) Then
 
                sb.Append($"{If(sb.Length <> 0, "_", "")}{applicationName}")
            End If
        End If
 
        If appendAssemblyName Then
            Dim assemblyName As String = My.Application.Info.AssemblyName
 
            If Not String.IsNullOrWhiteSpace(assemblyName) Then
                sb.Append($"{If(sb.Length <> 0, "_", "")}{assemblyName}")
            End If
        End If
 
        If appendVersion Then
            Dim version As Version = My.Application.Info.Version
 
            If version IsNot Nothing Then
                sb.Append($"{If(sb.Length <> 0, "_", "")}{version}")
            End If
        End If
 
        If appendHash Then
            ' Derive a deterministic unique ID from the current assembly GUID.
            Dim asm As Assembly = If(Assembly.GetEntryAssembly(), Assembly.GetExecutingAssembly())
            If asm IsNot Nothing Then
                Dim guidAttr As GuidAttribute = asm.GetCustomAttribute(Of GuidAttribute)()
 
                Dim guid As Guid =
                    If(guidAttr IsNot Nothing,
                        New Guid(guidAttr.Value),
                        asm.ManifestModule.ModuleVersionId ' Fallback: Use the manifest module for the GUID extraction value.
                    )
 
                Dim hashSeed As String =
                    If(guid <> Guid.Empty,
                        guid.ToString("N"),
                        GetType(FlexibleSettingsProvider).FullName ' Fallback: Use the current type full name.
                    )
 
                Using hasher As HashAlgorithm = HashAlgorithm.Create(FlexibleSettingsProvider.HashAlgorithmType.Name)
                    Dim hashLength As Integer = Math.Min(FlexibleSettingsProvider.HashLength, (hasher.HashSize \ 4))
                    Dim hashString As String = FlexibleSettingsProvider.ComputeDeterministicHashOfString(hasher, hashSeed, hashLength)
 
                    sb.Append($"{If(sb.Length <> 0, "_", "")}{hashString}")
                End Using
            End If
        End If
 
        If appendUserName Then
            Dim userName As String = Environment.UserName
 
            If Not String.IsNullOrWhiteSpace(userName) Then
                sb.Append($"{If(sb.Length <> 0, "_", "")}{userName}")
            End If
        End If
 
        Return sb.ToString()
    End Function
 
    ''' <summary>
    ''' Resolves and returns the effective file name used for the user settings configuration file.
    ''' </summary>
    ''' 
    ''' <returns>
    ''' A string representing the effective file name; For example, <b>"user.config"</b>.
    ''' </returns>
    <DebuggerStepThrough>
    Private Shared Function GetEffectiveFileName() As String
 
        Return If(Not String.IsNullOrWhiteSpace(FlexibleSettingsProvider.FileName),
                  FlexibleSettingsProvider.FileName,
                  FlexibleSettingsProvider.DefaultFileName)
    End Function
 
    ''' <summary>
    ''' Resolves and returns the effective full path to the user configuration file.
    ''' </summary>
    ''' 
    ''' <returns>
    ''' A string representing the full path to the user configuration file;
    ''' For example, <b>"C:\Users\{USERNAME}\AppData\Local\My Application\user.config"</b>.
    ''' </returns>
    <DebuggerStepThrough>
    Private Shared Function GetEffectiveConfigFilePath() As String
 
        Dim baseDirectoryPath As String = FlexibleSettingsProvider.GetEffectiveBaseDirectoryPath()
        Dim directoryName As String = FlexibleSettingsProvider.GetEffectiveDirectoryName()
        Dim fileName As String = FlexibleSettingsProvider.GetEffectiveFileName()
 
        Return Path.Combine(baseDirectoryPath, directoryName, fileName)
    End Function
 
    ''' <summary>
    ''' Checks whether the application has read and write permissions in the specified directory.
    ''' </summary>
    ''' 
    ''' <param name="directoryPath">
    ''' The directory path to check for read and write access.
    ''' </param>
    ''' 
    ''' <returns>
    ''' <see langword="True"/> if the application has read and write permissions in the directory; 
    ''' otherwise <see langword="False"/>.
    ''' </returns>
    <DebuggerStepThrough>
    Private Shared Function CanReadAndWriteToDirectory(directoryPath As String) As Boolean
 
        If String.IsNullOrWhiteSpace(directoryPath) Then
            Throw New ArgumentNullException(NameOf(directoryPath))
        End If
 
        If Not Directory.Exists(directoryPath) Then
            Throw New DirectoryNotFoundException($"Directory not found: {directoryPath}")
        End If
 
        Try
            Dim directoryInfo As New DirectoryInfo(directoryPath)
            Dim acl As DirectorySecurity = directoryInfo.GetAccessControl()
            Dim rules As AuthorizationRuleCollection =
                acl.GetAccessRules(includeExplicit:=True, includeInherited:=True, targetType:=GetType(SecurityIdentifier))
 
            Dim identity As WindowsIdentity = WindowsIdentity.GetCurrent()
            If identity Is Nothing Then
                Return False
            End If
 
            ' Collect SIDs for current user and groups.
            Dim sids As New HashSet(Of SecurityIdentifier)()
            If identity.User IsNot Nothing Then
                sids.Add(identity.User)
            End If
            For Each grp As IdentityReference In identity.Groups
                Dim sid As SecurityIdentifier = TryCast(grp, SecurityIdentifier)
                If sid IsNot Nothing Then
                    sids.Add(sid)
                End If
            Next
 
            ' Define the specific bits we require for read and write.
            ' Note: We intentionally DO NOT include Delete/DeleteSubdirectoriesAndFiles here,
            ' because a deny on Delete should not block basic read/write operations.
            Dim requiredRead As FileSystemRights = FileSystemRights.ReadData Or FileSystemRights.ListDirectory Or FileSystemRights.Read
            Dim requiredWrite As FileSystemRights = FileSystemRights.WriteData Or FileSystemRights.AppendData Or FileSystemRights.Write
 
            ' Accumulate allow and deny masks for relevant SIDs.
            Dim accumulatedAllow As FileSystemRights = 0
            Dim accumulatedDeny As FileSystemRights = 0
 
            For Each ruleObj As AuthorizationRule In rules
                Dim rule As FileSystemAccessRule = TryCast(ruleObj, FileSystemAccessRule)
                If rule Is Nothing Then
                    Continue For
                End If
 
                Dim sid As SecurityIdentifier = TryCast(rule.IdentityReference, SecurityIdentifier)
                If sid Is Nothing OrElse Not sids.Contains(sid) Then
                    Continue For
                End If
 
                Dim rights As FileSystemRights = rule.FileSystemRights
 
                If rule.AccessControlType = AccessControlType.Deny Then
                    accumulatedDeny = accumulatedDeny Or rights
 
                ElseIf rule.AccessControlType = AccessControlType.Allow Then
                    accumulatedAllow = accumulatedAllow Or rights
 
                End If
            Next
 
            ' If any required read/write bit is explicitly denied, cannot read/write.
            If (accumulatedDeny And (requiredRead Or requiredWrite)) <> 0 Then
                Return False
            End If
 
            ' Check that all required read bits are allowed.
            If (accumulatedAllow And requiredRead) <> requiredRead Then
                Return False
            End If
 
            ' Check that all required write bits are allowed.
            Return (accumulatedAllow And requiredWrite) = requiredWrite
 
        Catch ex As UnauthorizedAccessException
            ' Explicitly cannot access the directory.
            Return False
 
        Catch ex As SecurityException
            ' Security policy prevents access.
            Return False
 
        Catch ex As Exception
            ' Unexpected error.
            Return False
 
        End Try
    End Function
 
    ''' <summary>
    ''' Computes a deterministic hash of the given input string using the specified hash algorithm type.
    ''' </summary>
    ''' 
    ''' <param name="algorithm">
    ''' The hash algorithm instance to use (e.g., <see cref="MD5"/>, <see cref="SHA256"/>).
    ''' </param>
    ''' 
    ''' <param name="value">
    ''' The input string to compute the hash from.
    ''' </param>
    ''' 
    ''' <param name="length">
    ''' The desired total length of the resulting hexadecimal string.
    ''' <para></para>
    ''' If the computed hash is shorter than this length, the result is padded with '0' characters.
    ''' <para></para>
    ''' If the length is not a multiple of two, the final nibble of the next byte is used for the extra character.
    ''' </param>
    ''' 
    ''' <returns>
    ''' A string of exactly <paramref name="length"/> hexadecimal characters representing the hash of the input string.
    ''' <para></para>
    ''' This is deterministic: the same input and algorithm always produce the same output.
    ''' </returns>
    <DebuggerStepThrough>
    Private Shared Function ComputeDeterministicHashOfString(algorithm As HashAlgorithm,
                                                             value As String,
                                                             length As Integer) As String
 
        Dim bytes() As Byte = Encoding.UTF8.GetBytes(value)
        Dim hash() As Byte = algorithm.ComputeHash(bytes)
 
        Dim sb As New StringBuilder(length)
 
        ' Convert full bytes to hex, up to requested length.
        For i As Integer = 0 To Math.Min((length \ 2) - 1, hash.Length - 1)
            sb.Append(hash(i).ToString("X2"))
        Next
 
        ' If length is odd, append the high nibble of the next byte.
        If length Mod 2 = 1 AndAlso hash.Length > (length \ 2) Then
            sb.Append((hash(length \ 2) >> 4).ToString("X"))
        End If
 
        ' Pad with zeros if the hash is shorter than requested length.
        Dim remaining As Integer = length - sb.Length
        If remaining > 0 Then
            sb.Append(New String("0"c, remaining))
        End If
 
        Return sb.ToString()
    End Function
 
#End Region
 
End Class
 
#End Region
 
#Region " Enumerations "
 
''' <summary>
''' Specifies flags that allows to automatically append extra information to the 
''' settings storage folder name specified by <see cref="FlexibleSettingsProvider.DirectoryName"/> property.
''' </summary>
<Flags>
Public Enum SettingsDirectoryNameFlags
 
    ''' <summary>
    ''' No additional information is appended to the directory name.
    ''' </summary>
    None = 0
 
    ''' <summary>
    ''' Appends the current application name to the directory name.
    ''' </summary>
    ApplicationName = 1 << 0
 
    ''' <summary>
    ''' Appends the current assembly name to the directory name.
    ''' </summary>
    AssemblyName = 1 << 1
 
    ''' <summary>
    ''' Appends the current application version to the directory name.
    ''' </summary>
    Version = 1 << 2
 
    ''' <summary>
    ''' Appends a deterministic hash to the directory name.
    ''' </summary>
    Hash = 1 << 3
 
    ''' <summary>
    ''' Appends the current user name to the directory name.
    ''' </summary>
    UserName = 1 << 4
 
End Enum
 
#End Region

El modo de empleo es muy sencillo.

Por un lado, tenemos el siguiente namespace con código auto-generado por el diseñador de forms, bien, esto NO DEBEMOS TOCARLO PARA NADA:

Código

'------------------------------------------------------------------------------
' <auto-generated>
'     This code was generated by a tool.
'     Runtime Version:4.0.30319.42000
'
'     Changes to this file may cause incorrect behavior and will be lost if
'     the code is regenerated.
' </auto-generated>
'------------------------------------------------------------------------------
Namespace My
 
    <Global.System.Runtime.CompilerServices.CompilerGeneratedAttribute(),  _
     Global.System.CodeDom.Compiler.GeneratedCodeAttribute("Microsoft.VisualStudio.Editors.SettingsDesigner.SettingsSingleFileGenerator", "17.14.0.0"),  _
     Global.System.ComponentModel.EditorBrowsableAttribute(Global.System.ComponentModel.EditorBrowsableState.Advanced)>  _
    Partial Friend NotInheritable Class MySettings
        Inherits Global.System.Configuration.ApplicationSettingsBase
 
        ' ...
    End Class
End Namespace

En lugar de eso, simplemente añadiremos el siguiente código en cualquier otra parte de nuestro código fuente, estableciendo la clase de atributo SettingsProvider para asignar nuestro proveedor de configuración, y aplicando el valor que queramos para las propiedades del proveedor:

Código

Namespace My
 
    <Global.System.Configuration.SettingsProvider(GetType(FlexibleSettingsProvider))>
    Partial Friend NotInheritable Class MySettings
 
        Public Sub New()
            FlexibleSettingsProvider.BaseDirectoryPath = ".\"
            FlexibleSettingsProvider.DirectoryName = Nothing
            FlexibleSettingsProvider.DirectoryNameFlags = SettingsDirectoryNameFlags.None
            FlexibleSettingsProvider.FileName = "user.config"
 
            Debug.WriteLine($"Effective config file path: {FlexibleSettingsProvider.EffectiveConfigFilePath}")
        End Sub
 
    End Class
End Namespace

Con este ejemplo en específico, el archivo "user.config" se guardará en el directorio base de nuestra aplicación.

En c#, podemos replicar el mismo procedimiento, pero con la clase Settings como en el siguiente ejemplo:

Código

namespace WindowsFormsApp1.Properties
{
    [SettingsProvider(typeof(FlexibleSettingsProvider))]
    internal sealed partial class Settings : global::System.Configuration.ApplicationSettingsBase
    {
        public Settings()
        {
            FlexibleSettingsProvider.BaseDirectoryPath = @".\";
            FlexibleSettingsProvider.DirectoryName = null;
            FlexibleSettingsProvider.DirectoryNameFlags = SettingsDirectoryNameFlags.None;
            FlexibleSettingsProvider.FileName = "user.config";
 
            Debug.WriteLine($"Effective config file path: {FlexibleSettingsProvider.EffectiveConfigFilePath}");
        }
    }
}

Por si todavía no ha quedado claro, sí, este código hace magía, tan solo necesitamos configurar la ruta del directorio y el nombre del archivo, y todo lo demás funcionará exactamente igual (o casi, casi igual) que como si estuvieramos dejando que la infraestructura de Microsoft gestione el directorio y el archivo de configuración para leer y escribir en él, pero evitando que se generen mil y una carpetas tras cada pequeña actualización de nuestra aplicación.


« Última modificación: 20 Enero 2026, 11:42 am por Eleкtro »	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.985

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

« Respuesta #614 en: 30 Enero 2026, 02:00 am »

Dos funciones que devuelven una colección ordenada de directorios que contienen aplicaciones versionadas dentro de un directorio base específico.

Por ejemplo, dado un directorio base que contiene carpetas de aplicaciones Squirrel como "app-1.0.0", "app-1.2.3" y "app-2.0.0", estas funciones devolverán la lista de esos directorios ordenados por versión, de forma ascendente, de manera que puedas acceder fácilmente al directorio más antiguo (app-1.0.0) o al más reciente (app-2.0.0), o eliminar los más antiguos, etc.

Otro ejemplo, sería con el directorio de Google Chrome. Por ejemplo, si tuvieramos un directorio base "C:\Program Files\Google Chrome\App\Chrome-bin" con las carpetas de instalación de Google Chrome como "100.0.4896.127", "101.0.4951.64" y "102.0.5005.63", estas funciones devolverían los directorios ordenados por versión.

Código

''' <summary>
''' Returns a collection of application versioned directories 
''' found within the specified base directory, sorted by version.
''' </summary>
''' 
''' <example> This is a code example.
''' <code language="VB">
''' Dim baseDir As String = "C:\Program Files\Squirrel Application"
''' Dim namePrefix As String = "app-" ' Case: "app-1.0.0"
''' Dim nameSuffix As String = Nothing
''' 
''' Dim versionedDirs As SortedList(Of Version, DirectoryInfo) = 
'''     GetVersionedDirectories(baseDir, namePrefix, nameSuffix)
''' 
''' Dim oldest As DirectoryInfo = versionedDirs.First.Value
''' Dim newest As DirectoryInfo = versionedDirs.Last.Value
''' 
''' Console.WriteLine($"Oldest versioned directory name: {oldest.Name}")
''' Console.WriteLine($"Newest versioned directory name: {newest.Name}")
''' </code>
''' </example>
''' 
''' <param name="baseDir">
''' The base directory that contains application versioned directories (for example: "<b>app-1.0.0</b>").
''' </param>
''' 
''' <param name="namePrefix">
''' Optional. If specified, only directory names that begin with this prefix are included.
''' <para></para>
''' Default value is null.
''' </param>
'''
''' <param name="nameSuffix">
''' Optional. If specified, only directory names that ends with this suffix are included.
''' <para></para>
''' Default value is null.
''' </param>
''' 
''' <returns>
''' A <see cref="SortedList(Of Version, DirectoryInfo)"/> where the keys are
''' <see cref="Version"/> objects parsed from the directory names, and the values
''' are the corresponding <see cref="DirectoryInfo"/> objects.
''' <para></para>
''' The collection is sorted in ascending order by version, 
''' so <see cref="Enumerable.First"/> returns the oldest application version directory, 
''' and <see cref="Enumerable.Last"/> returns the newest.
''' </returns>
''' 
''' <exception cref="ArgumentNullException">
''' Thrown when the specified <paramref name="baseDir"/> is null.
''' </exception>
''' 
''' <exception cref="DirectoryNotFoundException">
''' Thrown when the specified <paramref name="baseDir"/> does not exist.
''' </exception>
<DebuggerStepThrough>
Public Shared Function GetVersionedDirectories(baseDir As String,
                                               Optional namePrefix As String = Nothing,
                                               Optional nameSuffix As String = Nothing
                                              ) As SortedList(Of Version, DirectoryInfo)
 
    Dim prefixText As String = If(String.IsNullOrEmpty(namePrefix), "", Regex.Escape(namePrefix))
    Dim suffixText As String = If(String.IsNullOrEmpty(nameSuffix), "", Regex.Escape(nameSuffix))
    Dim versionGroup As String = "(?<version>\d+(\.\d+){0,3})"
 
    Dim pattern As String = $"^{prefixText}{versionGroup}{suffixText}$"
    Dim searchRegex As New Regex(pattern, RegexOptions.IgnoreCase Or RegexOptions.Compiled)
 
    Return GetVersionedDirectories(baseDir, searchRegex)
End Function
 
''' <summary>
''' Returns a collection of application versioned directories 
''' found within the specified base directory, sorted by version.
''' </summary>
''' 
''' <example> This is a code example.
''' <code language="VB">
''' Dim baseDir As String = "C:\Program Files\Squirrel Application"
''' Dim pattern As String = "^app-(?&lt;version&gt;\d+(\.\d+){0,3})$" ' Case: "app-1.0.0"
''' Dim searchRegex As New Regex(pattern, RegexOptions.IgnoreCase Or RegexOptions.Compiled)
''' 
''' Dim versionedDirs As SortedList(Of Version, DirectoryInfo) = 
'''     GetVersionedDirectories(baseDir, searchRegex)
''' 
''' Dim oldest As DirectoryInfo = versionedDirs.First.Value
''' Dim newest As DirectoryInfo = versionedDirs.Last.Value
''' 
''' Console.WriteLine($"Oldest versioned directory name: {oldest.Name}")
''' Console.WriteLine($"Newest versioned directory name: {newest.Name}")
''' </code>
''' </example>
''' 
''' <param name="baseDir">
''' The base directory that contains application versioned directories (for example: "<b>app-1.0.0</b>").
''' </param>
''' 
''' <param name="searchRegex">
''' A <see cref="Regex"/> used to filter the directory names.
''' <para></para>
''' &#9888;&#65039; This regex must contain a named group called <b>version</b>, 
''' which will be used to extract the version number from the directory name.
''' <para></para>
''' For example: <c>"^app-(?&lt;version&gt;\d+(\.\d+){0,3})$"</c>
''' </param>
''' 
''' <returns>
''' A <see cref="SortedList(Of Version, DirectoryInfo)"/> where the keys are
''' <see cref="Version"/> objects parsed from the directory names, and the values
''' are the corresponding <see cref="DirectoryInfo"/> objects.
''' <para></para>
''' The collection is sorted in ascending order by version, 
''' so <see cref="Enumerable.First"/> returns the oldest application version directory, 
''' and <see cref="Enumerable.Last"/> returns the newest.
''' </returns>
''' 
''' <exception cref="ArgumentNullException">
''' Thrown when the specified <paramref name="baseDir"/> or <paramref name="searchRegex"/> is null.
''' </exception>
''' 
''' <exception cref="ArgumentException">
''' Thrown when the pattern of the specified <paramref name="searchRegex"/> does not contain a named group 'version'.
''' </exception>
''' 
''' <exception cref="DirectoryNotFoundException">
''' Thrown when the specified <paramref name="baseDir"/> does not exist.
''' </exception>
<DebuggerStepThrough>
Public Shared Function GetVersionedDirectories(baseDir As String,
                                               searchRegex As Regex
                                              ) As SortedList(Of Version, DirectoryInfo)
 
    If String.IsNullOrWhiteSpace(baseDir) Then
        Throw New ArgumentNullException(NameOf(baseDir))
    End If
 
    If searchRegex Is Nothing Then
        Throw New ArgumentNullException(NameOf(searchRegex))
    End If
 
    If Not searchRegex.GetGroupNames().Contains("version") Then
        Throw New ArgumentException("The provided regex pattern must contain a named group 'version'.", NameOf(searchRegex))
    End If
 
    If Not Directory.Exists(baseDir) Then
        Throw New DirectoryNotFoundException(baseDir)
    End If
 
    Dim topLevelDirs As DirectoryInfo() =
        New DirectoryInfo(baseDir).
            GetDirectories("*", SearchOption.TopDirectoryOnly)
 
    Dim versionedDirs As New SortedList(Of Version, DirectoryInfo)(
        topLevelDirs.Length, Comparer(Of Version).Default
    )
 
    For Each topLevelDir As DirectoryInfo In topLevelDirs
 
        Dim match As Match = searchRegex.Match(topLevelDir.Name)
        If match.Success Then
            Dim versionPart As String = match.Groups("version").Value
            Dim ver As Version = Nothing
            If Version.TryParse(versionPart, ver) Then
                If Not versionedDirs.ContainsKey(ver) Then
                    versionedDirs.Add(ver, topLevelDir)
                End If
            End If
        End If
    Next
 
    Return versionedDirs
End Function

Tiene dos formas de empleo. La primera es mediante un prefijo y/o sufijo, siendo ambos opcionales:

Código

Dim baseDir As String = "C:\Program Files\Squirrel Application"
Dim namePrefix As String = "app-" ' Case: "app-1.0.0"
Dim nameSuffix As String = Nothing
 
Dim versionedDirs As SortedList(Of Version, DirectoryInfo) =
    GetVersionedDirectories(baseDir, namePrefix, nameSuffix)
 
Dim oldest As DirectoryInfo = versionedDirs.First.Value
Dim newest As DirectoryInfo = versionedDirs.Last.Value
 
Console.WriteLine($"Oldest versioned directory name: {oldest.Name}")
Console.WriteLine($"Newest versioned directory name: {newest.Name}")

La segunda forma de utilizarlo es mediante una expresión regular que debe incluir un grupo nombrado como "version":

Código

Dim baseDir As String = "C:\Program Files\Squirrel Application"
Dim pattern As String = "^app-(?<version>\d+(\.\d+){0,3})$" ' Case: "app-1.0.0"
Dim searchRegex As New Regex(pattern, RegexOptions.IgnoreCase Or RegexOptions.Compiled)
 
Dim versionedDirs As SortedList(Of Version, DirectoryInfo) = 
    GetVersionedDirectories(baseDir, searchRegex)
 
Dim oldest As DirectoryInfo = versionedDirs.First.Value
Dim newest As DirectoryInfo = versionedDirs.Last.Value
 
Console.WriteLine($"Oldest versioned directory name: {oldest.Name}")
Console.WriteLine($"Newest versioned directory name: {newest.Name}")


« Última modificación: 30 Enero 2026, 02:14 am por Eleкtro »	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.985

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

« Respuesta #615 en: 1 Febrero 2026, 12:13 pm »

Dos simples funciones para obtener los elementos interactivos de la barra de tareas de Windows y del área de notificación, utilizando la API de Microsoft UI Automation.

Espacios de nombres importados:

Código

Imports System.Windows.Automation

Referencias de ensamblados requeridas:

Código:

UIAutomationClient
UIAutomationTypes

Función pública GetTaskbarApplicationButtons
Propósito: Esta función se encarga de obtener los botones correspondientes a aplicaciones en la barra de tareas de Windows, excluyendo explícitamente elementos del sistema operativo que no representan aplicaciones como tal, como el botón "Inicio" y "Vista de tareas".
Valor devuelto: Un AutomationElementCollection con los botones de aplicaciones detectados, o Nothing si el contenedor no está disponible o no es accesible mediante UI Automation, o si no existe ningún botón correspondiente a aplicaciones.

Código

''' <summary>
''' Retrieves the current application buttons on the Windows taskbar.
''' </summary>
''' 
''' <returns>
''' An <see cref="AutomationElementCollection"/> containing <see cref="AutomationElement"/> objects
''' for each application button found on the taskbar.
''' </returns>
''' 
''' <remarks>
''' This excludes the Start button, other system buttons, and system tray elements. 
''' <para></para>
''' Only buttons corresponding to applications are returned. This also includes pinned buttons.
''' </remarks>
<DebuggerStepThrough>
Public Shared Function GetTaskbarApplicationButtons() As AutomationElementCollection
 
    Dim taskListClassNames As String() = {"ReBarWindow32", "MSTaskListWClass"}
    Return GetButtonsFromTaskbarChild(taskListClassNames)
End Function

Función pública GetSystemTrayButtons
Propósito: Esta función permite obtener los botones del área de notificación (system tray) ubicada en la barra de tareas.
Valor devuelto: Un AutomationElementCollection que contiene los botones del área de notificación, o Nothing si el contenedor no está disponible o no es accesible mediante UI Automation.

Código

''' <summary>
''' Retrieves the current buttons in the system tray (notification area) on the Windows taskbar.
''' </summary>
''' 
''' <returns>
''' An <see cref="AutomationElementCollection"/> containing <see cref="AutomationElement"/> objects
''' for each system tray button (notification area icon) found.
''' </returns>
<DebuggerStepThrough>
Public Shared Function GetSystemTrayButtons() As AutomationElementCollection
 
    Dim trayNotifyClassNames As String() = {"TrayNotifyWnd"}
    Return GetButtonsFromTaskbarChild(trayNotifyClassNames)
End Function

Función privada GetButtonsFromTaskbarChild
Propósito: Esta función actúa como método auxiliar genérico que encapsula la lógica común necesaria para las funciones GetTaskbarApplicationButtons y GetSystemTrayButtons.

Código

''' <summary>
''' Retrieves all button elements from a specific child of the Windows taskbar, identified by its class name(s).
''' </summary>
''' 
''' <param name="classNames">
''' An array of class names to search for among the immediate children of the taskbar.
''' <para></para>
''' The first matching child will be used as the container for buttons.
''' </param>
''' 
''' <returns>
''' An <see cref="AutomationElementCollection"/> containing all <see cref="ControlType.Button"/> elements
''' found within the first child that matches one of the specified class names.
''' <para></para>
''' Returns null if the taskbar window cannot be found, if the specified child class is not present,
''' or if UI Automation is unable to access the elements.
''' </returns>
<DebuggerStepThrough>
Private Shared Function GetButtonsFromTaskbarChild(classNames As String()) As AutomationElementCollection
 
    Dim shellHwnd As IntPtr = NativeMethods.FindWindow("Shell_TrayWnd", Nothing)
    If shellHwnd = IntPtr.Zero Then
        Return Nothing
    End If
 
    Dim taskbarRoot As AutomationElement = AutomationElement.FromHandle(shellHwnd)
    If taskbarRoot Is Nothing Then
        Return Nothing
    End If
 
    Dim taskbarChildren As AutomationElementCollection = taskbarRoot.FindAll(TreeScope.Children, Condition.TrueCondition)
 
    Dim targetChild As AutomationElement = Nothing
 
    ' Find the child whose class matches the specified names.
    For Each child As AutomationElement In taskbarChildren
        Dim className As String = String.Empty
        Try
            className = child.Current.ClassName
        Catch ex As ElementNotAvailableException
            Continue For
        End Try
 
        If classNames.Any(Function(c As String) String.Equals(c, className, StringComparison.OrdinalIgnoreCase)) Then
            targetChild = child
            Exit For
        End If
    Next
 
    If targetChild Is Nothing Then
        Return Nothing
    End If
 
    Dim buttonCondition As New PropertyCondition(AutomationElement.ControlTypeProperty, ControlType.Button)
 
    Return targetChild.FindAll(TreeScope.Descendants, buttonCondition)
End Function

Módulo NativeMethods
Propósito: Sirve como una capa de interoperabilidad (P/Invoke) entre el código administrado en VB.NET y la API nativa de Windows, proporcionando el acceso a las funciones del sistema requeridas por la función GetButtonsFromTaskbarChild.

Código

Friend Module NativeMethods
 
    <Runtime.InteropServices.DllImport("user32.dll", SetLastError:=True, CharSet:=Runtime.InteropServices.CharSet.Unicode)>
    Friend Function FindWindow(
        className As String,
        windowName As String
    ) As IntPtr
 
End Module

Ejemplo de uso:

Código

Dim taskbarAppButtons As AutomationElementCollection = GetTaskbarApplicationButtons()
For Each el As AutomationElement In taskbarAppButtons
    Dim info As AutomationElementInformation = el.Current
 
    Console.WriteLine($"Name: {info.Name}")
    Console.WriteLine($"Class Name: {info.ClassName}")
    Console.WriteLine($"Has Keyboard Focus: {info.HasKeyboardFocus}")
    Console.WriteLine($"Bounding Rectangle: {info.BoundingRectangle}")
    Console.WriteLine("")
Next


« Última modificación: 1 Febrero 2026, 12:25 pm por Eleкtro »	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.985

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

« Respuesta #616 en: 13 Abril 2026, 18:14 pm »

Esta función sirve para resaltar (highlight) elementos de una página web utilizando la API de Selenium, inyectando un pequeño código javascript en la página. Muy útil para automatización, por ejemplo, para señalar mostrando una guía visual de los elementos en los que hace click.

La función provee 11 parámetros opcionales de personalización, entre ellos para la duración del efecto de resaltado, poder mostrar una flecha que rebota, la posición de la flecha, y poder mostrar un texto, el color de flecha y texto, tamaño de flecha y texto, color de fondo y opacidad.

Tanto el highlight como la flecha (un gráfico SVG) son efectos muy chulos.

Si la ventana del navegador se redimensiona, el highlight y la flecha actualizan su posición de forma automática.

Vaya por delante que el script de javascript lo ha escrito una IA, y se ha ido perfeccionando durante varias consultas, solucionando problemas e imperfecciones hasta llegar al estado actual.

Requisitos:

https://www.nuget.org/packages/selenium.webdriver

...y un navegador soportado por el webdriver.

Código

''' <summary>
''' Draws an animated highlight overlay over the specified web element 
''' using javascript executed via <see cref="IJavaScriptExecutor"/>.
''' <para></para>
''' The overlay is automatically removed from the DOM after <paramref name="durationMs"/> milliseconds.
''' </summary>
''' 
''' <example> This is a code example.
''' <code language="VB">
''' Dim elemment As IWebElement = driver.FindElement(By.Id("submit-btn"))
''' HighlightElement(driver, elemment,
'''                  labelText:="Click here",
'''                  labelForeColor:="red",
'''                  showArrow:=True,
'''                  arrowSize:=24,
'''                  arrowAlignment:=ContentAlignment.MiddleLeft,
'''                  arrowColor:="red",
'''                  borderColor:="red",
'''                  fillColor:="white",
'''                  fillOpacity:=0.4,
'''                  durationMs:=3000)
''' </code>
''' </example>
''' 
''' <param name="driver">
''' Active <see cref="IWebDriver"/> instance. Must implement
''' <see cref="IJavaScriptExecutor"/>; otherwise an <see cref="InvalidCastException"/> will be thrown.
''' </param>
''' 
''' <param name="element">
''' The DOM element to highlight. Its position is determined at runtime
''' via <c>getBoundingClientRect()</c>, accounting for current scroll offsets.
''' </param>
''' 
''' <param name="labelText">
''' Optional. The text displayed centered inside the overlay box.
''' </param>
''' 
''' <param name="labelFontSize">
''' Optional. The initial font size for <paramref name="labelText"/>, in pixels. 
''' <para></para>
''' Note: The font size auto-shrinks down up to 6px if the text overflows the element's bounds.
''' <para></para>
''' Default value is <c>14</c>.
''' </param>
''' 
''' <param name="labelForeColor">
''' Optional. The CSS color value for the label text (e.g. <c>"black"</c>, <c>"#fff"</c>). 
''' <para></para>
''' Default value is <c>"black"</c>.
''' </param>
''' 
''' <param name="showArrow">
''' Optional. A value indicating whether to render an animated arrow pointing
''' toward the element from the side set by <paramref name="arrowAlignment"/> parameter.
''' </param>
''' 
''' <param name="arrowAlignment">
''' Optional. A <see cref="ContentAlignment"/> value that controls which side of the element
''' the arrow appears on and the direction it points.
''' <para></para>
''' Note: This value has no effect if <paramref name="showArrow"/> is <see langword="False"/>
''' <para></para>
''' Default value is <see cref="ContentAlignment.MiddleLeft"/>.
''' </param>
''' 
''' <param name="arrowSize">
''' Optional. The square size (width x height) of the arrow bounding box, in pixels. 
''' <para></para>
''' Default value is <c>30</c>.
''' </param>
''' 
''' <param name="arrowColor">
''' Optional. The CSS color value for the arrow (e.g. <c>"black"</c>, <c>"#fff"</c>). 
''' <para></para>
''' Default value is <c>"darkred"</c>.
''' </param>
''' 
''' <param name="borderColor">
''' Optional. The CSS color value for the overlay border (e.g. <c>"black"</c>, <c>"#fff"</c>). 
''' <para></para>
''' Default value is <c>"red"</c>.
''' </param>
''' 
''' <param name="fillColor">
''' Optional. The CSS color value to fill the overlay background (e.g. <c>"black"</c>, <c>"#fff"</c>). 
''' <para></para>
''' Default value is <c>"white"</c>.
''' </param>
''' 
''' <param name="fillOpacity">
''' Optional. The opacity of the background overlay, from <c>0.0</c> (transparent) to <c>1.0</c> (opaque).
''' <para></para>
''' Default value is <c>0.4</c>.
''' </param>
''' 
''' <param name="durationMs">
''' Optional. The duration before the overlay (and arrow, if shown) are removed from the DOM, in milliseconds.
''' <para></para>
''' Default value is <c>3000</c> (3 seconds).
''' </param>
<DebuggerStepThrough>
Public Shared Function HighlightElement(driver As IWebDriver,
                                        element As IWebElement,
                                        Optional labelText As String = Nothing,
                                        Optional labelFontSize As Integer = 14,
                                        Optional labelForeColor As String = "black",
                                        Optional showArrow As Boolean = True,
                                        Optional arrowAlignment As ContentAlignment = ContentAlignment.MiddleLeft,
                                        Optional arrowSize As Integer = 30,
                                        Optional arrowColor As String = "darkred",
                                        Optional borderColor As String = "red",
                                        Optional fillColor As String = "white",
                                        Optional fillOpacity As Double = 0.4,
                                        Optional durationMs As Integer = 3000) As Boolean
 
    ArgumentNullException.ThrowIfNull(driver)
 
    ArgumentNullException.ThrowIfNull(element)
 
    Try
        Dim probeHandle As String = driver.CurrentWindowHandle
    Catch ex As Exception
        Throw New InvalidOperationException("WebDriver session is no longer available.", ex)
    End Try
 
    Try
        Dim probeTag As String = element.TagName
        If Not element.Displayed Then
            Return False
        End If
 
    Catch ex As StaleElementReferenceException
        Throw New InvalidOperationException("Target element is stale or detached from the DOM.", ex)
 
    Catch ex As WebDriverException
        Throw New InvalidOperationException("Target element is not accessible through the WebDriver.", ex)
 
    End Try
 
    Dim js As IJavaScriptExecutor = TryCast(driver, IJavaScriptExecutor)
    If js Is Nothing Then
        Throw New NotSupportedException("The provided IWebDriver does not implement IJavaScriptExecutor.")
    End If
 
    Dim script As String = "
try {
    return (function(el, 
                     labelText, labelFontSize, labelForeColor,
                     showArrow, arrowAlignment, arrowSize, arrowColor,
                     borderColor, fillColor, fillOpacity,
                     durationMs) {
 
    if (!el || !(el instanceof Element) || !el.isConnected) { return 'no-element'; }
 
    let r  = el.getBoundingClientRect();
    if (!r || (r.width === 0 && r.height === 0)) { return 'zero-rect'; }
 
    let sx = window.scrollX, sy = window.scrollY;
    let cx = r.left + sx + r.width  / 2;
    let cy = r.top  + sy + r.height / 2;
 
    // Overlay box — positioned and sized to wrap the element with a small padding
    let overlay = document.createElement('div');
    overlay.style.cssText = [
        'position:absolute',
        'left:'   + (r.left + sx - 5) + 'px',
        'top:'    + (r.top  + sy - 5) + 'px',
        'width:'  + (r.width  + 10)   + 'px',
        'height:' + (r.height + 10)   + 'px',
        'border:3px solid ' + borderColor,
        'border-radius:8px',
        'box-shadow:0 0 20px ' + borderColor,
        'z-index:999998',
        'pointer-events:none',
        'display:flex',
        'align-items:center',
        'justify-content:center',
        'box-sizing:border-box',
        'overflow:hidden'
    ].join(';');
    document.body.appendChild(overlay);
 
    // Fill div — opacity only affects background, not the border
    let fill = document.createElement('div');
    fill.style.cssText = 'position:absolute;' +
                         'inset:0;' +
                         'background:' + fillColor + ';' +
                         'opacity:' + fillOpacity + ';' +
                         'z-index:0;';
    overlay.appendChild(fill);
 
    // Label — auto-shrinks font size until text fits inside the overlay
    let lbl = null;
    if (labelText) {
        let lbl = document.createElement('div');
        lbl.textContent = labelText;
        lbl.style.cssText = 'position:relative;' +
                            'z-index:1;' +
                            'width:100%;' +
                            'box-sizing:border-box;' +
                            'white-space:normal;' +
                            'word-break:break-word;' +
                            'text-align:center;' +
                            'color:' + labelForeColor + ';' +
                            'font-size:' + labelFontSize + 'px;' +
                            'font-weight:bold;' +
                            'padding:2px 4px;' +
                            'border-radius:4px;';
        overlay.appendChild(lbl);
        let fs = labelFontSize;
        while (fs > 6 && lbl.scrollHeight > overlay.clientHeight) {
            fs--;
            lbl.style.fontSize = fs + 'px';
        }
    }
 
    // Arrow — SVG polygon rotated via CSS to point toward the element from its position.
    // Two nested divs: arrowWrap handles position + bounce animation,
    // arrowInner handles rotation so both transforms don't conflict.
    let arrowWrap = null;
    if (showArrow) {
        let styleTag = document.createElement('style');
        styleTag.textContent =
            '@keyframes bML {from{transform:translateX( 0px)} to{transform:translateX(-8px)}}' +
            '@keyframes bMR {from{transform:translateX( 0px)} to{transform:translateX( 8px)}}' +
            '@keyframes bTC {from{transform:translateY( 0px)} to{transform:translateY(-8px)}}' +
            '@keyframes bBC {from{transform:translateY( 0px)} to{transform:translateY( 8px)}}' +
            '@keyframes bTL {from{transform:translate(0,0)} to{transform:translate(-6px,-6px)}}' +
            '@keyframes bTR {from{transform:translate(0,0)} to{transform:translate( 6px,-6px)}}' +
            '@keyframes bBL {from{transform:translate(0,0)} to{transform:translate(-6px, 6px)}}' +
            '@keyframes bBR {from{transform:translate(0,0)} to{transform:translate( 6px, 6px)}}';
        document.head.appendChild(styleTag);
 
        // rot: CSS rotation so the arrow always points TOWARD the element from its side.
        // anim: bounce keyframe name matching the arrow's side.
        // Both are constant for the lifetime of the highlight — assigned once here,
        // never inside updatePosition (which would restart the animation every tick).
        let staticCfg = {
            'MiddleLeft'   : { rot:  '0', anim:'bML' },
            'MiddleRight'  : { rot:'180', anim:'bMR' },
            'TopCenter'    : { rot: '90', anim:'bTC' },
            'BottomCenter' : { rot:'270', anim:'bBC' },
            'TopLeft'      : { rot: '45', anim:'bTL' },
            'TopRight'     : { rot:'135', anim:'bTR' },
            'BottomLeft'   : { rot:'315', anim:'bBL' },
            'BottomRight'  : { rot:'225', anim:'bBR' }
        }[arrowAlignment] || { rot:'0', anim:'bML' };
 
        arrowWrap = document.createElement('div');
        arrowWrap.style.cssText = 'position:absolute;' +
                                  'width:' + arrowSize + 'px;' +
                                  'height:' + arrowSize + 'px;' +
                                  'z-index:999999;pointer-events:none;';
        arrowWrap.style.animation = staticCfg.anim + ' 0.4s ease-in-out infinite alternate';
 
        arrowInner = document.createElement('div');
        arrowInner.style.cssText = 'width:' + arrowSize + 'px;' +
                                   'height:' + arrowSize + 'px;' +
                                   'transform:rotate(' + staticCfg.rot + 'deg);' +
                                   'transform-origin:center center;';
 
        // Arrow shape: rectangular shaft + concave arrowhead.
        arrowInner.innerHTML = '<svg viewBox=\'0 0 48 40\' width=\'' + arrowSize + '\' height=\'' + arrowSize + '\' xmlns=\'http://www.w3.org/2000/svg\'>' +
                               '<polygon points=\'0,16 30,16 24,4 48,20 24,36 30,24 0,24\' fill=\'' + arrowColor + '\'/>' +
                               '</svg>';
 
        arrowWrap.appendChild(arrowInner);
        document.body.appendChild(arrowWrap);
    }
 
    // updatePosition — recalculates overlay and arrow placement on every tick,
    // so the highlight stays glued to the element when the user scrolls,
    // resizes the window, or the page reflows dynamically.
    function updatePosition() {
        try {
            if (!el || !el.isConnected) { return; }
 
            let r  = el.getBoundingClientRect();
            let sx = window.scrollX, sy = window.scrollY;
 
            overlay.style.left   = (r.left + sx - 5) + 'px';
            overlay.style.top    = (r.top  + sy - 5) + 'px';
            overlay.style.width  = (r.width  + 10) + 'px';
            overlay.style.height = (r.height + 10) + 'px';
 
            // Auto-shrink the label font size until it fits inside the overlay,
            // recomputed on each tick because the box can be resized by the user.
            if (lbl) {
                let fs = labelFontSize;
                lbl.style.fontSize = fs + 'px';
                while (fs > 6 && lbl.scrollHeight > overlay.clientHeight) {
                    fs--;
                    lbl.style.fontSize = fs + 'px';
                }
            }
 
            if (arrowWrap && arrowInner) {
                // ax/ay: absolute position of the arrow bounding box, recomputed each tick.
                // d: diagonal inset — compensates the 45° rotation so the visible tip sits
                //    exactly `marginDiagonal` pixels away from the element border, regardless of arrowSize.
                // marginStraight: clearance for MiddleLeft/MiddleRight/TopCenter/BottomCenter.
                // marginDiagonal: clearance for TopLeft/TopRight/BottomLeft/BottomRight.
                let cx             = r.left + sx + r.width  / 2;
                let cy             = r.top  + sy + r.height / 2;
                let d              = arrowSize * (0.5 - Math.SQRT2 / 4);
                let marginStraight = 8;
                let marginDiagonal = 4;
                let cfg = {
                    'MiddleLeft'   : { ax: r.left   + sx - arrowSize - marginStraight,     ay: cy - arrowSize / 2 },
                    'MiddleRight'  : { ax: r.right  + sx + marginStraight,                 ay: cy - arrowSize / 2 },
                    'TopCenter'    : { ax: cx - arrowSize / 2,                             ay: r.top    + sy - arrowSize - marginStraight },
                    'BottomCenter' : { ax: cx - arrowSize / 2,                             ay: r.bottom + sy + marginStraight },
                    'TopLeft'      : { ax: r.left   + sx - arrowSize + d - marginDiagonal, ay: r.top    + sy - arrowSize + d - marginDiagonal },
                    'TopRight'     : { ax: r.right  + sx - d + marginDiagonal,             ay: r.top    + sy - arrowSize + d - marginDiagonal },
                    'BottomLeft'   : { ax: r.left   + sx - arrowSize + d - marginDiagonal, ay: r.bottom + sy - d + marginDiagonal },
                    'BottomRight'  : { ax: r.right  + sx - d + marginDiagonal,             ay: r.bottom + sy - d + marginDiagonal }
                }[arrowAlignment] || {
                    ax: r.left + sx - arrowSize - marginStraight, ay: cy - arrowSize / 2
                };
 
                arrowWrap.style.left = cfg.ax + 'px';
                arrowWrap.style.top  = cfg.ay + 'px';
                // Note: animation and rotation are set ONCE outside this function —
                // reassigning them each tick would restart the CSS animation and
                // freeze the arrow on its first frame.
            }
        } catch (e) { /* swallow — next tick will retry */ }
    }
 
    updatePosition();
    let intervalId = setInterval(updatePosition, 100);
 
    // Cleanup — remove all injected DOM nodes after the specified duration
    setTimeout(function() {
        overlay.remove();
        if (arrowWrap) arrowWrap.remove();
    }, durationMs);
 
      return 'ok';
})(arguments[0], arguments[1], arguments[2], arguments[3], arguments[4],
   arguments[5], arguments[6], arguments[7], arguments[8], arguments[9],
   arguments[10], arguments[11]);
 
} catch (e) {
  return 'js-error:' + (e && e.message ? e.message : String(e));
}
"
 
    Dim result As Object
    Try
        result = js.ExecuteScript(script, element,
                              labelText, labelFontSize, labelForeColor,
                              showArrow, arrowAlignment.ToString(), arrowSize, arrowColor,
                              borderColor, fillColor, fillOpacity.ToString(CultureInfo.InvariantCulture),
                              durationMs)
 
    Catch ex As StaleElementReferenceException
        Throw New InvalidOperationException("Element became stale during highlight script execution.", ex)
 
    Catch ex As WebDriverException
        Throw New InvalidOperationException("WebDriver failed to execute the highlight script.", ex)
 
    End Try
 
    Dim status As String = If(result?.ToString(), String.Empty)
 
    Select Case status
        Case "ok"
            Return True
 
        Case "no-element", "zero-rect"
            Return False
 
        Case Else
            If status.StartsWith("js-error:", StringComparison.Ordinal) Then
                Throw New InvalidOperationException($"Highlight javascript failed in the browser: {status.Substring(9)}")
            End If
 
            Throw New InvalidOperationException($"Highlight javascript returned an unexpected status: '{status}'.")
    End Select
 
End Function

Ejemplo de uso:

Código

Dim elemment As IWebElement = driver.FindElement(By.Id("submit-btn"))
HighlightElement(driver, elemment,
                 labelText:="Click here",
                 labelForeColor:="red",
                 showArrow:=True,
                 arrowSize:=24,
                 arrowAlignment:=ContentAlignment.MiddleLeft,
                 arrowColor:="red",
                 borderColor:="red",
                 fillColor:="white",
                 fillOpacity:=0.4,
                 durationMs:=3000)


« Última modificación: 13 Abril 2026, 18:25 pm por Eleкtro »	En línea

Páginas: 1 ... 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 [62]

Ir a:

Mensajes similares
	Asunto	Iniciado por	Respuestas	Vistas	Último mensaje
	Librería de Snippets en C/C++ « 1 2 3 4 » Programación C/C++	z3nth10n	31	32,268	2 Agosto 2013, 17:13 pm por 0xDani
	[APORTE] [VBS] Snippets para manipular reglas de bloqueo del firewall de Windows Scripting	Eleкtro	1	5,711	3 Febrero 2014, 20:19 pm por Eleкtro
	Librería de Snippets para Delphi « 1 2 » Programación General	crack81	15	29,309	25 Marzo 2016, 18:39 pm por crack81
	Una organización en Github para subir, proyectos, snippets y otros? Sugerencias y dudas sobre el Foro	z3nth10n	0	4,505	21 Febrero 2017, 10:47 am por z3nth10n
	índice de la Librería de Snippets para VB.NET !! .NET (C#, VB.NET, ASP)	Eleкtro	7	9,278	4 Julio 2018, 21:35 pm por Eleкtro