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

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 1 Visitante están viendo este tema.

Páginas: 1 ... 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 [54] 55 56 57 58 59 60

Autor

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

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.874

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

« Respuesta #530 en: 9 Mayo 2018, 07:48 am »

Cita de: NEBIRE en 9 Mayo 2018, 01:47 am

Una búsqeuda rápida me ofrece este pdf, que puede servirte... (no lo he descargado).
https://www.vmware.com/support/developer/vix-api/vix170_vmrun_command.pdf

Gracias @NEBIRE, pero te puedes imaginar que yo también estuve buscando y encontré el mismo PDF en Google

, lamentablemente no me ayudó.

Gracias de nuevo.

TL;DR (Too Long; ~~Didn't~~ Don't Read):

Por cierto, quiero aclarar que no suelo apoyar nunca el hecho de depender en el uso de aplicaciones command-line, considero que el auténtico reto sería crear un wrapper de la librería nativa vix.dll en .NET, pero a ver quien tiene los c@jones de hacerlo... con la inmensa cantidad de miembros y funciones exportadas a implementar que tiene, y teniendo en cuenta que en cada release de VMWare modifican cosas y quedan algunos miembros obsoletos y otros nuevos, o que reemplacen la librería por una nueva donde la anterior queda completamente inservible (como sucedió con vixcom.dll). Sería un trabajo en vano, una absurda pérdida de tiempo.

Nah, mucho más viable, seguro y estable es recurrir al uso del programita/wrapper vmrun.exe, que aunque inevitablemente sea bastante más lento en términos de tiempo de ejecución (puesto que es un executable), al menos su estructura "no cambia" con el tiempo, por que ya se encargan los de VMWare de adaptar el programa para que funcione (obvio) con los nuevos cambios que introduzcan a la librería vix.dll, y nosotros como usuarios o programadores en el peor de los casos solo necesitariamos hacer un par de adaptaciones en la sintaxis de los argumentos a enviar a vmrun.exe y todo listo para funcionar con nuevas releases de VMWare.

Claro que, para los que puedan programar diréctamente en C/C++ ya sería otro cantar... aunque seguiría siendo bastante tedioso usar la librería (no hay más que mirar los samples de código que provee VMWare en el directorios de la API de VIX, 200 lineas de código solo para ejecutar una operación de encendido y/o apagado de la VM), pero bueno, programando en C/C++ supongo que sería más aceptable usar la librería vix.dll en lugar de usar vmrun.exe, supongo.

saludos!


« Última modificación: 9 Mayo 2018, 08:22 am por Eleкtro »	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.874

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

« Respuesta #531 en: 17 Mayo 2018, 14:23 pm »

Determinar si un tamaño/resolución pertenece a una relación de aspecto específica.

No creo que haya nada que añadir a la descripción. Solo diré que la utilidad que le encuentro a esto personálmente es para realizar con mayor seguridad en operaciones de captura de imagen en ventanas externas (para evitar posibles fallos humanos de especificar una resolución incorrecta).

Código

''' ----------------------------------------------------------------------------------------------------
''' <summary>
''' Determine whether the source resolution belongs to the specified aspect ratio.
''' </summary>
''' ----------------------------------------------------------------------------------------------------
''' <param name="resolution">
''' The source resolution.
''' </param>
''' 
''' <param name="aspectRatio">
''' The aspect ratio.
''' </param>
''' ----------------------------------------------------------------------------------------------------
''' <returns>
''' <see langword="True"/> if the source resolution belongs to the specified aspect ratio; otherwise, <see langword="False"/>.
''' </returns>
''' ----------------------------------------------------------------------------------------------------
Public Shared Function ResolutionIsOfAspectRatio(ByVal resolution As Size, ByVal aspectRatio As Point) As Boolean
 
    Return (resolution.Width / aspectRatio.X) * aspectRatio.Y = resolution.Height
 
End Function

Ejemplo de uso:

Código

Dim resolution As New Size(width:=1920, height:=1080)
Dim aspectRatio As New Point(x:=16, y:=9)
 
Dim result As Boolean = ResolutionIsOfAspectRatio(resolution, aspectRatio)
 
Console.WriteLine(result)

Escalar/Adaptar la posición y tamaño de un Rectangle, según el factor de porcentage resultante entre la diferencia de dos tamaños.

Para que lo entiendan mejor:

Imaginemos que tenemos un Rectangle con posición (X,Y): 100,100 y tamaño (width,height): 100,100, y esos valores han sido especificados así para ser usado sobre una superficie de 800x600. Por ejemplo podemos decir que se trata de un Rectangle que sirve para capturar una porción específica de una ventana que tenga ese tamaño, 800x600.

Pues bien, lo que hace esta función es adaptar la posición y el tamaño de ese Rectangle, a un tamaño/superficie diferente, por ejemplo adaptarlo de 800x600 a 1024x1024.

Espero que se haya entendido bien, de todas formas abajo les dejo un ejemplo de como usarlo...

Código

    Public Module RectangleExtensions
 
#Region " Public Extension Methods "
 
        ''' ----------------------------------------------------------------------------------------------------
        ''' <summary>
        ''' Scale the size and position of the source <see cref="Rectangle"/> 
        ''' by the difference of the specified sizes.
        ''' </summary>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <param name="sender">
        ''' The source <see cref="Rectangle"/>.
        ''' </param>
        ''' 
        ''' <param name="fromSize">
        ''' The source <see cref="Size"/>.
        ''' </param>
        ''' 
        ''' <param name="toSize">
        ''' The target <see cref="Size"/>.
        ''' </param>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <returns>
        ''' The resulting <see cref="Rectangle"/>.
        ''' </returns>
        ''' ----------------------------------------------------------------------------------------------------
        <DebuggerStepThrough>
        <Extension>
        <EditorBrowsable(EditorBrowsableState.Always)>
        Public Function ScaleBySizeDifference(ByVal sender As Rectangle,
                                              ByVal fromSize As Size,
                                              ByVal toSize As Size) As Rectangle
 
            Dim percentChangeX As Double = (toSize.Width / fromSize.Width)
            Dim percentChangeY As Double = (toSize.Height / fromSize.Height)
 
            Return New Rectangle With {
                    .X = CInt(sender.X * percentChangeX),
                    .Y = CInt(sender.Y * percentChangeY),
                    .Width = CInt(sender.Width * percentChangeX),
                    .Height = CInt(sender.Height * percentChangeY)
                }
 
        End Function
 
        ''' ----------------------------------------------------------------------------------------------------
        ''' <summary>
        ''' Scale the size and position of the source <see cref="RectangleF"/> 
        ''' by the difference of the specified sizes.
        ''' </summary>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <param name="sender">
        ''' The source <see cref="RectangleF"/>.
        ''' </param>
        ''' 
        ''' <param name="fromSize">
        ''' The source <see cref="SizeF"/>.
        ''' </param>
        ''' 
        ''' <param name="toSize">
        ''' The target <see cref="SizeF"/>.
        ''' </param>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <returns>
        ''' The resulting <see cref="RectangleF"/>.
        ''' </returns>
        ''' ----------------------------------------------------------------------------------------------------
        <DebuggerStepThrough>
        <Extension>
        <EditorBrowsable(EditorBrowsableState.Always)>
        Public Function ScaleBySizeDifference(ByVal sender As RectangleF,
                                              ByVal fromSize As SizeF,
                                              ByVal toSize As SizeF) As RectangleF
 
            Dim percentChangeX As Double = (toSize.Width / fromSize.Width)
            Dim percentChangeY As Double = (toSize.Height / fromSize.Height)
 
            Return New RectangleF With {
                .X = CSng(sender.X * percentChangeX),
                .Y = CSng(sender.Y * percentChangeY),
                .Width = CSng(sender.Width * percentChangeX),
                .Height = CSng(sender.Height * percentChangeY)
            }
 
        End Function
 
#End Region
 
    End Module

Ejemplo de uso:

Código

Dim oldSize As New Size(640, 480)
Dim oldRect As New Rectangle(New Point(100, 100), New Size(639, 479))
 
Dim newSize As New Size(800, 600)
Dim newRect As Rectangle = ScaleBySizeDifference(oldRect, oldSize, newSize)
 
Console.WriteLine(String.Format("oldRect: {0}", oldRect.ToString())) ' {X=100,Y=100,Width=639,Height=479}
Console.WriteLine(String.Format("newRect: {0}", newRect.ToString())) ' {X=125,Y=125,Width=798,Height=598}

Saludos.


« Última modificación: 17 Mayo 2018, 14:28 pm por Eleкtro »	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.874

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

« Respuesta #532 en: 24 Mayo 2018, 03:48 am »

GENERAR UNA FECHA ALEATORIA, EN UN RANGO ESPECÍFICO.

Sencillos pero prácticos miembros para generar fechas aleatorias. Le encontrarán alguna utilidad.

Código

 
    ''' ----------------------------------------------------------------------------------------------------
    ''' <summary>
    ''' Contains date and time related utilities.
    ''' </summary>
    ''' ----------------------------------------------------------------------------------------------------
    <ImmutableObject(True)>
    Public NotInheritable Class DateTimeUtil
 
#Region " Private Fields "
 
        ''' ----------------------------------------------------------------------------------------------------
        ''' <summary>
        ''' A <see cref="Random"/> instance to generate random secuences of numbers.
        ''' </summary>
        ''' ----------------------------------------------------------------------------------------------------
        Private Shared rng As Random
 
#End Region
 
#Region " Constructors "
 
        ''' ----------------------------------------------------------------------------------------------------
        ''' <summary>
        ''' Prevents a default instance of the <see cref="DateTimeUtil"/> class from being created.
        ''' </summary>
        ''' ----------------------------------------------------------------------------------------------------
        <DebuggerNonUserCode>
        Private Sub New()
        End Sub
 
#End Region
 
#Region " Public Methods "
 
        ''' ----------------------------------------------------------------------------------------------------
        ''' <summary>
        ''' Gets a random <see cref="Date"/> in range between the specified two dates.
        ''' </summary>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <example> This is a code example.
        ''' <code>
        ''' Dim minDate As Date = Date.MinValue
        ''' Dim maxDate As Date = Date.MaxValue
        ''' Dim ramdomDate As Date = GetRandomDateTime(minDate, maxDate)
        ''' 
        ''' Console.WriteLine(randomDate.ToString())
        ''' </code>
        ''' </example>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <param name="dateMin">
        ''' The minimum <see cref="Date"/>.
        ''' </param>
        ''' 
        ''' <param name="dateMax">
        ''' The maximum <see cref="Date"/>.
        ''' </param>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <returns>
        ''' The resulting <see cref="Date"/>.
        ''' </returns>
        ''' ----------------------------------------------------------------------------------------------------
        <DebuggerStepThrough>
        Public Shared Function GetRandomDateTime(ByVal dateMin As Date, ByVal dateMax As Date) As Date
 
            If (DateTimeUtil.rng Is Nothing) Then
                DateTimeUtil.rng = New Random(Seed:=Environment.TickCount)
            End If
 
            ' Generate random date with 00:00:00 time.
            Dim daysRange As Integer = dateMax.Subtract(dateMin).Days
            Dim dt As Date = dateMin.AddDays(DateTimeUtil.rng.Next(daysRange))
 
            ' Generate random time.
            Dim hours As Integer = DateTimeUtil.rng.Next(dateMax.TimeOfDay.Hours + 1)
            Dim minutes As Integer = DateTimeUtil.rng.Next(dateMax.TimeOfDay.Minutes + 1)
            Dim seconds As Integer = DateTimeUtil.rng.Next(dateMax.TimeOfDay.Seconds + 1)
            Dim milliseconds As Integer = DateTimeUtil.rng.Next(dateMax.TimeOfDay.Milliseconds + 1)
 
            ' Return the resulting date.
            Return New Date(dt.Year, dt.Month, dt.Day, hours, minutes, seconds, milliseconds, dt.Kind)
 
        End Function
 
        ''' ----------------------------------------------------------------------------------------------------
        ''' <summary>
        ''' Gets a random <see cref="Date"/> in range between <see cref="DateTime.MinValue"/> and the specified date.
        ''' </summary>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <example> This is a code example.
        ''' <code>
        ''' Dim maxDate As Date = Date.MaxValue
        ''' Dim ramdomDate As Date = GetRandomDateTime(maxDate)
        ''' 
        ''' Console.WriteLine(randomDate.ToString())
        ''' </code>
        ''' </example>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <param name="dateMax">
        ''' The maximum <see cref="Date"/>.
        ''' </param>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <returns>
        ''' The resulting <see cref="Date"/>.
        ''' </returns>
        ''' ----------------------------------------------------------------------------------------------------
        <DebuggerStepThrough>
        Public Shared Function GetRandomDateTime(ByVal dateMax As Date) As Date
            Return DateTimeUtil.GetRandomDateTime(Date.MinValue, dateMax)
        End Function
 
        ''' ----------------------------------------------------------------------------------------------------
        ''' <summary>
        ''' Gets a random <see cref="Date"/> in range between <see cref="DateTime.MinValue"/> and <see cref="DateTime.MaxValue"/>.
        ''' </summary>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <example> This is a code example.
        ''' <code>
        ''' Dim ramdomDate As Date = GetRandomDateTime()
        ''' 
        ''' Console.WriteLine(randomDate.ToString())
        ''' </code>
        ''' </example>
        ''' ----------------------------------------------------------------------------------------------------
        ''' <returns>
        ''' The resulting <see cref="Date"/>.
        ''' </returns>
        ''' ----------------------------------------------------------------------------------------------------
        <DebuggerStepThrough>
        Public Shared Function GetRandomDateTime() As Date
            Return DateTimeUtil.GetRandomDateTime(Date.MinValue, Date.MaxValue)
        End Function
 
#End Region
 
    End Class


	En línea

**Aincrad**

Desconectado

Mensajes: 682

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

« Respuesta #533 en: 24 Junio 2018, 05:03 am »

mi código no es como el de todo los gurus de aquí , pero lo publico para el que le sirva.

Bueno el siguiente código hará que puedan mostrar un formulario en la esquina de la pantalla , como si fuera una notificación.

[EDITADO] (Se ha corregido el error que daba y ahora son menos lineas de código)

Código

 'Para usarlo
 'FormNotificacion(NOMBRE DE SU FORMULARIO a mostrar)
 
   Private Sub FormNotificacion(ByVal formulario As Object)
        Dim fh As Form = TryCast(formulario, Form)
        fh.ShowInTaskbar = False
        fh.Show()
        fh.Location = New Point(CInt((Screen.PrimaryScreen.WorkingArea.Width / 1) - (formulario.Width / 1)), CInt((Screen.PrimaryScreen.WorkingArea.Height / 1) - (formulario.Height / 1)))
    End Sub


« Última modificación: 3 Julio 2018, 22:16 pm por Aincrad »	En línea

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.874

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

« Respuesta #534 en: 29 Agosto 2018, 03:14 am »

¿Cómo silenciar el volumen de un proceso externo y/o cambiar su nivel de volumen?.

El siguiente código contiene varias definiciones nativas de la API de WASAPI, y una clase por nombre "AudioUtil" la cual contiene varios métodos estáticos que sirven como wrappers de esta API para lograr nuestro objetivo de forma sencilla y reutilizable.

Simplemente copiar y pegar directamente todo este bloque de código en una nueva clase:

Código

#Region " Option Statements "
 
Option Strict On
Option Explicit On
Option Infer Off
 
#End Region
 
#Region " Imports "
 
Imports System.ComponentModel
Imports System.Globalization
Imports System.Runtime.InteropServices
 
Imports ElektroKit.Interop.Win32
 
#End Region
 
#Region " Interoperability "
 
Namespace ElektroKit.Interop
 
#Region " Win32 API "
 
    Namespace Win32
 
#Region " EDataFlow "
 
        ''' <summary>
        ''' Defines constants that indicate the direction in which audio data flows between an audio endpoint device and an application.
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/mmdeviceapi/ne-mmdeviceapi-__midl___midl_itf_mmdeviceapi_0000_0000_0001"/>
        ''' </remarks>
        Public Enum EDataFlow As Integer
            Render
            Capture
            All
            EDataFlow_enum_count
        End Enum
 
#End Region
 
#Region " ERole "
 
        ''' <summary>
        ''' Defines constants that indicate the role that the system has assigned to an audio endpoint device.
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/mmdeviceapi/ne-mmdeviceapi-__midl___midl_itf_mmdeviceapi_0000_0000_0002"/>
        ''' </remarks>
        Public Enum ERole As Integer
            Console
            Multimedia
            Communications
            ERole_enum_count
        End Enum
 
#End Region
 
#Region " MMDeviceEnumerator "
 
        ''' <summary>
        ''' <c>CLSID_MMDeviceEnumerator</c>.
        ''' </summary>
        <ComImport>
        <Guid("BCDE0395-E52F-467C-8E3D-C4579291692E")>
        Public Class MMDeviceEnumerator
        End Class
 
#End Region
 
#Region " IMMDeviceEnumerator "
 
        ''' <summary>
        ''' Provides methods for enumerating multimedia device resources. 
        ''' <para></para>
        ''' In the current implementation of the MMDevice API, 
        ''' the only device resources that this interface can enumerate are audio endpoint devices. 
        ''' <para></para>
        ''' A client obtains a reference to an <see cref="IMMDeviceEnumerator"/> interface by calling the CoCreateInstance.
        ''' <para></para>
        ''' The device resources enumerated by the methods in the IMMDeviceEnumerator interface are represented as 
        ''' collections of objects with <see cref="IMMDevice"/> interfaces. 
        ''' <para></para>
        ''' A collection has an IMMDeviceCollection interface. 
        ''' The IMMDeviceEnumerator.EnumAudioEndpoints method creates a device collection.
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/mmdeviceapi/nn-mmdeviceapi-immdeviceenumerator"/>
        ''' </remarks>
        <ComImport>
        <InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
        <Guid("A95664D2-9614-4F35-A746-DE8DB63617E6")>
        Public Interface IMMDeviceEnumerator
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented1() As Integer
 
            <PreserveSig>
            Function GetDefaultAudioEndpoint(<[In]> <MarshalAs(UnmanagedType.I4)> ByVal dataFlow As EDataFlow,
                                             <[In]> <MarshalAs(UnmanagedType.I4)> ByVal role As ERole,
                                             <Out> <MarshalAs(UnmanagedType.Interface)> ByRef refDevice As IMMDevice) As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            Function NotImplemented2() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            Function NotImplemented3() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            Function NotImplemented4() As Integer
 
        End Interface
 
#End Region
 
#Region " IMMDevice "
 
        ''' <summary>
        ''' Provides methods for enumerating multimedia device resources. 
        ''' <para></para>
        ''' In the current implementation of the MMDevice API, 
        ''' the only device resources that this interface can enumerate are audio endpoint devices. 
        ''' <para></para>
        ''' A client obtains a reference to an <see cref="IMMDeviceEnumerator"/> interface by calling the CoCreateInstance.
        ''' <para></para>
        ''' The device resources enumerated by the methods in the IMMDeviceEnumerator interface are represented as 
        ''' collections of objects with <see cref="IMMDevice"/> interfaces. 
        ''' <para></para>
        ''' A collection has an IMMDeviceCollection interface. 
        ''' The IMMDeviceEnumerator.EnumAudioEndpoints method creates a device collection.
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/mmdeviceapi/nn-mmdeviceapi-immdevice"/>
        ''' </remarks>
        <ComImport>
        <InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
        <Guid("D666063F-1587-4E43-81F1-B948E807363F")>
        Public Interface IMMDevice
 
            <PreserveSig>
            Function Activate(ByRef ref¡d As Guid, ByVal clsCtx As Integer, ByVal activationParams As IntPtr,
                              <MarshalAs(UnmanagedType.IUnknown)> ByRef refInterface As Object) As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented1() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented2() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented3() As Integer
 
        End Interface
 
#End Region
 
#Region " IAudioSessionControl "
 
        ''' <summary>
        ''' Enables a client to configure the control parameters for an audio session and to monitor events in the session. 
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audiopolicy/nn-audiopolicy-iaudiosessioncontrol"/>
        ''' </remarks>
        <ComImport>
        <InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
        <Guid("F4B1A599-7266-4319-A8CA-E70ACB11E8CD")>
        Public Interface IAudioSessionControl
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented1() As Integer
 
            <PreserveSig>
            Function GetDisplayName(<Out> <MarshalAs(UnmanagedType.LPWStr)> ByRef refDisplayName As String) As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented2() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented3() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented4() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented5() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented6() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented7() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented8() As Integer
 
        End Interface
 
#End Region
 
#Region " IAudioSessionControl2 "
 
        ''' <summary>
        ''' Enables a client to configure the control parameters for an audio session and to monitor events in the session. 
        ''' <para></para>
        ''' The IAudioClient.Initialize method initializes a stream object and assigns the stream to an audio session.
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audiopolicy/nn-audiopolicy-iaudiosessioncontrol"/>
        ''' </remarks>
        <ComImport>
        <InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
        <Guid("BFB7FF88-7239-4FC9-8FA2-07C950BE9C6D")>
        Public Interface IAudioSessionControl2
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented1() As Integer
 
            <PreserveSig>
            Function GetDisplayName(<Out> <MarshalAs(UnmanagedType.LPWStr)> ByRef refDisplayName As String) As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented2() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented3() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented4() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented5() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented6() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented7() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented8() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented9() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented10() As Integer
 
            <PreserveSig>
            Function GetProcessId(<Out> ByRef refValue As UInteger) As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented11() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented12() As Integer
 
        End Interface
 
#End Region
 
#Region " IAudioSessionEnumerator "
 
        ''' <summary>
        ''' Enumerates audio sessions on an audio device.
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audiopolicy/nn-audiopolicy-iaudiosessionenumerator"/>
        ''' </remarks>
        <ComImport>
        <InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
        <Guid("E2F5BB11-0570-40CA-ACDD-3AA01277DEE8")>
        Public Interface IAudioSessionEnumerator
 
            <PreserveSig>
            Function GetCount(ByRef refSessionCount As Integer) As Integer
 
            <PreserveSig>
            Function GetSession(ByVal sessionCount As Integer, ByRef refSession As IAudioSessionControl) As Integer
 
        End Interface
 
#End Region
 
#Region " IAudioSessionManager2 "
 
        ''' <summary>
        ''' Enables an application to manage submixes for the audio device. 
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audiopolicy/nn-audiopolicy-iaudiosessionmanager2"/>
        ''' </remarks>
        <ComImport>
        <InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
        <Guid("77AA99A0-1BD6-484F-8BC7-2C654C9A9B6F")>
        Public Interface IAudioSessionManager2
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented1() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented2() As Integer
 
            <PreserveSig>
            Function GetSessionEnumerator(<Out> <MarshalAs(UnmanagedType.Interface)> ByRef refSessionEnum As IAudioSessionEnumerator) As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented3() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented4() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented5() As Integer
 
            <EditorBrowsable(EditorBrowsableState.Never)>
            <PreserveSig>
            Function NotImplemented6() As Integer
 
        End Interface
 
#End Region
 
#Region " ISimpleAudioVolume "
 
        ''' <summary>
        ''' Enables a client to control the master volume level of an audio session. 
        ''' </summary>
        ''' <remarks>
        ''' <see href="https://docs.microsoft.com/en-us/windows/desktop/api/audioclient/nn-audioclient-isimpleaudiovolume"/>
        ''' </remarks>
        <ComImport>
        <InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
        <Guid("87CE5498-68D6-44E5-9215-6DA47EF883D8")>
        Public Interface ISimpleAudioVolume
 
            <PreserveSig>
            Function SetMasterVolume(<[In]> <MarshalAs(UnmanagedType.R4)> ByVal levelNormalization As Single,
                                 <[In]> <MarshalAs(UnmanagedType.LPStruct)> ByVal eventContext As Guid) As Integer
 
            <PreserveSig>
            Function GetMasterVolume(<Out> <MarshalAs(UnmanagedType.R4)> ByRef refLevelNormalization As Single) As Integer
 
            <PreserveSig>
            Function SetMute(<[In]> <MarshalAs(UnmanagedType.Bool)> ByVal isMuted As Boolean,
                         <[In]> <MarshalAs(UnmanagedType.LPStruct)> ByVal eventContext As Guid) As Integer
 
            <PreserveSig>
            Function GetMute(<Out> <MarshalAs(UnmanagedType.Bool)> ByRef refIsMuted As Boolean) As Integer
 
        End Interface
 
#End Region
 
    End Namespace
 
#End Region
 
#Region " Inter-process Communication "
 
    Namespace IPC
 
        ''' ----------------------------------------------------------------------------------------------------
        ''' <summary>
        ''' Contains audio related utilities to apply on external processes.
        ''' </summary>
        ''' ----------------------------------------------------------------------------------------------------
        Public NotInheritable Class AudioUtil
 
#Region " Constructors "
 
            ''' ----------------------------------------------------------------------------------------------------
            ''' <summary>
            ''' Prevents a default instance of the <see cref="AudioUtil"/> class from being created.
            ''' </summary>
            ''' ----------------------------------------------------------------------------------------------------
            <DebuggerNonUserCode>
            Private Sub New()
            End Sub
 
#End Region
 
#Region " Public Methods "
 
            ''' ----------------------------------------------------------------------------------------------------
            ''' <summary>
            ''' Mute the audio volume of the specified process.
            ''' </summary>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <param name="pr">
            ''' The <see cref="Process"/>.
            ''' </param>
            ''' ----------------------------------------------------------------------------------------------------
            Public Shared Sub MuteApplication(ByVal pr As Process)
 
                Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
                If (volume IsNot Nothing) Then
                    Dim guid As Guid = Guid.Empty
                    volume.SetMute(True, guid)
                End If
 
            End Sub
 
            ''' ----------------------------------------------------------------------------------------------------
            ''' <summary>
            ''' Unmute the audio volume of the specified process.
            ''' </summary>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <param name="pr">
            ''' The <see cref="Process"/>.
            ''' </param>
            ''' ----------------------------------------------------------------------------------------------------
            Public Shared Sub UnmuteApplication(ByVal pr As Process)
 
                Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
                If (volume IsNot Nothing) Then
                    Dim guid As Guid = Guid.Empty
                    volume.SetMute(False, guid)
                End If
 
            End Sub
 
            ''' ----------------------------------------------------------------------------------------------------
            ''' <summary>
            ''' Gets a value that determine whether the audio volume of the specified application is muted.
            ''' </summary>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <param name="pr">
            ''' The <see cref="Process"/>.
            ''' </param>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <returns>
            ''' Returns <see langword="True"/> if the application is muted, <see langword="False"/> otherwise.
            ''' </returns>
            ''' ----------------------------------------------------------------------------------------------------
            Public Shared Function IsApplicationMuted(ByVal pr As Process) As Boolean
 
                Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
                If (volume IsNot Nothing) Then
                    Dim isMuted As Boolean
                    volume.GetMute(isMuted)
                    Return isMuted
                End If
 
                Return False
 
            End Function
 
            ''' ----------------------------------------------------------------------------------------------------
            ''' <summary>
            ''' Gets the audio volume level of the specified process.
            ''' </summary>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <param name="pr">
            ''' The <see cref="Process"/>.
            ''' </param>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <returns>
            ''' The audio volume, expressed in the range between 0 and 100.
            ''' </returns>
            ''' ----------------------------------------------------------------------------------------------------
            <DebuggerStepThrough>
            Public Shared Function GetApplicationVolume(ByVal pr As Process) As Integer
 
                Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
                If (volume IsNot Nothing) Then
                    Dim levelNormalization As Single = Nothing
                    volume.GetMasterVolume(levelNormalization)
                    Return CInt(levelNormalization * 100)
                End If
 
                Return 100
 
            End Function
 
            ''' ----------------------------------------------------------------------------------------------------
            ''' <summary>
            ''' Sets the audio volume level for the specified process.
            ''' </summary>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <param name="pr">
            ''' The <see cref="Process"/>.
            ''' </param>
            ''' 
            ''' <param name="volumeLevel">
            ''' The new volume level, expressed in the range between 0 and 100. 
            ''' </param>
            ''' ----------------------------------------------------------------------------------------------------
            <DebuggerStepThrough>
            Public Shared Sub SetApplicationVolume(ByVal pr As Process, ByVal volumeLevel As Integer)
 
                If (volumeLevel < 0) OrElse (volumeLevel > 100) Then
                    Throw New ArgumentOutOfRangeException(paramName:=NameOf(volumeLevel),
                                                      actualValue:=volumeLevel,
                                                      message:=String.Format(CultureInfo.CurrentCulture,
                                                               "A value of '{0}' is not valid for '{1}'. '{1}' must be between 0 and 100.",
                                                               volumeLevel, NameOf(volumeLevel)))
                End If
 
                Dim volume As ISimpleAudioVolume = AudioUtil.GetVolumeObject(pr)
                If (volume IsNot Nothing) Then
                    Dim guid As Guid = Guid.Empty
                    volume.SetMasterVolume((volumeLevel / 100.0F), guid)
                End If
 
            End Sub
 
#End Region
 
#Region " Private Methods "
 
            ''' ----------------------------------------------------------------------------------------------------
            ''' <summary>
            ''' Enumerate all the <see cref="IAudioSessionControl2"/> of the default (<see cref="IMMDevice"/>) audio device.
            ''' </summary>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <remarks>
            ''' Credits to @Simon Mourier: <see href="https://stackoverflow.com/a/14322736/1248295"/>
            ''' </remarks>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <returns>
            ''' The resulting <see cref="IEnumerable(Of IAudioSessionControl2)"/>.
            ''' </returns>
            ''' ----------------------------------------------------------------------------------------------------
            <DebuggerStepperBoundary>
            Private Shared Iterator Function EnumerateAudioSessionControls() As IEnumerable(Of IAudioSessionControl2)
 
                ' Get the (1st render + multimedia) aodio device.
                Dim deviceEnumerator As IMMDeviceEnumerator = DirectCast(New MMDeviceEnumerator(), IMMDeviceEnumerator)
                Dim device As IMMDevice = Nothing
                deviceEnumerator.GetDefaultAudioEndpoint(EDataFlow.Render, ERole.Multimedia, device)
 
                ' Activate the session manager.
                Dim IID_IAudioSessionManager2 As Guid = GetType(IAudioSessionManager2).GUID
                Dim obj As Object = Nothing
                device.Activate(IID_IAudioSessionManager2, 0, IntPtr.Zero, obj)
                Dim manager As IAudioSessionManager2 = DirectCast(obj, IAudioSessionManager2)
 
                ' Enumerate sessions for on this device.
                Dim sessionEnumerator As IAudioSessionEnumerator = Nothing
                manager.GetSessionEnumerator(sessionEnumerator)
                Dim sessionCount As Integer
                sessionEnumerator.GetCount(sessionCount)
 
                For i As Integer = 0 To (sessionCount - 1)
                    Dim ctl As IAudioSessionControl = Nothing
                    Dim ctl2 As IAudioSessionControl2
                    sessionEnumerator.GetSession(i, ctl)
                    ctl2 = DirectCast(ctl, IAudioSessionControl2)
                    Yield ctl2
                    Marshal.ReleaseComObject(ctl2)
                    Marshal.ReleaseComObject(ctl)
                Next i
 
                Marshal.ReleaseComObject(sessionEnumerator)
                Marshal.ReleaseComObject(manager)
                Marshal.ReleaseComObject(device)
                Marshal.ReleaseComObject(deviceEnumerator)
            End Function
 
            ''' ----------------------------------------------------------------------------------------------------
            ''' <summary>
            ''' Searchs and returns the corresponding <see cref="ISimpleAudioVolume"/> for the specified <see cref="Process"/>.
            ''' </summary>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <remarks>
            ''' Credits to @Simon Mourier: <see href="https://stackoverflow.com/a/14322736/1248295"/>
            ''' </remarks>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <param name="pr">
            ''' The <see cref="Process"/>.
            ''' </param>
            ''' ----------------------------------------------------------------------------------------------------
            ''' <returns>
            ''' The resulting <see cref="ISimpleAudioVolume"/>, 
            ''' or <see langword="Nothing"/> if a <see cref="ISimpleAudioVolume"/> is not found for the specified process.
            ''' </returns>
            ''' ----------------------------------------------------------------------------------------------------
            <DebuggerStepperBoundary>
            Private Shared Function GetVolumeObject(ByVal pr As Process) As ISimpleAudioVolume
 
                For Each ctl As IAudioSessionControl2 In AudioUtil.EnumerateAudioSessionControls()
                    Dim pId As UInteger
                    ctl.GetProcessId(pId)
 
                    If (pId = pr.Id) Then
                        Return DirectCast(ctl, ISimpleAudioVolume)
                    End If
                Next ctl
 
                Return Nothing
 
            End Function
 
#End Region
 
        End Class
 
    End Namespace
 
#End Region
 
End Namespace
 
#End Region

Ejemplos de uso:

Código

Imports ElektroKit.Interop.IPC
Imports System.Linq

Código

' Get the process we want to modify. 
' Note the process must have an audio mixer available to be able mute it and/or to modify its volume level.
' In other words, the process must have an audio signal enabled, like for example a videogame or a music player, or any other process with an audio output.
Dim pr As Process = Process.GetProcessesByName("process name").SingleOrDefault()

Código

' ----------------------- '
' GET OR SET VOLUME LEVEL '
' ----------------------- '
 
Dim volumeLevel As Integer ' resulting value of this variable will be in range of 0% to 100%.
 
' Get current process volume level.
volumeLevel = AudioUtil.GetApplicationVolume(pr)
Console.WriteLine(String.Format("Current volume level: {0}%", volumeLevel))
 
' Set process volume level to a new value.
AudioUtil.SetApplicationVolume(pr, 50) ' 50%
volumeLevel = AudioUtil.GetApplicationVolume(pr)
Console.WriteLine(String.Format("New volume level: {0}%", volumeLevel))

Código

' ------------------------ '
' MUTE OR UNMUTE A PROCESS '
' ------------------------ '
 
Dim isMuted As Boolean
 
' Mute the aplication.
AudioUtil.MuteApplication(pr)
isMuted = AudioUtil.IsApplicationMuted(pr)
Console.WriteLine(String.Format("Is appliaction properly muted: {0}", isMuted))
 
' Mute the aplication.
AudioUtil.UnmuteApplication(pr)
isMuted = AudioUtil.IsApplicationMuted(pr)
Console.WriteLine(String.Format("Is appliaction properly unmuted?: {0}", Not isMuted))

Eso es todo.


	En línea

z3nth10n

Desconectado

Mensajes: 1.583

"Jack of all trades, master of none." - Zenthion

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

« Respuesta #535 en: 18 Octubre 2018, 09:28 am »

Como rellenar un array siguiendo el algoritmo Flood Fill usando HashSet

https://es.wikipedia.org/wiki/Algoritmo_de_relleno_por_difusi%C3%B3n

Código

Imports System.Collections.Generic
Imports System.Linq
Imports System.Runtime.CompilerServices
Imports System.Runtime.InteropServices
 
Module F
    <Extension()>
    Sub FloodFill(Of T)(ByVal source As T(), ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, ByVal height As Integer, ByVal target As T, ByVal replacement As T)
        Dim i As Integer = 0
        FloodFill(source, x, y, width, height, target, replacement, i)
    End Sub
 
    <Extension()>
    Sub FloodFill(Of T)(ByVal source As T(), ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, ByVal height As Integer, ByVal target As T, ByVal replacement As T, <Out> ByRef i As Integer)
        i = 0
        Dim queue As HashSet(Of Integer) = New HashSet(Of Integer)()
        queue.Add(Pn(x, y, width))
 
        While queue.Count > 0
            Dim _i As Integer = queue.First(), _x As Integer = _i Mod width, _y As Integer = _i / width
            queue.Remove(_i)
            If source(_i).Equals(target) Then source(_i) = replacement
 
            For offsetX As Integer = -1 To 2 - 1
 
                For offsetY As Integer = -1 To 2 - 1
                    If offsetX = 0 AndAlso offsetY = 0 OrElse offsetX = offsetY OrElse offsetX = -offsetY OrElse -offsetX = offsetY Then Continue For
                    Dim targetIndex As Integer = Pn(_x + offsetX, _y + offsetY, width)
                    Dim _tx As Integer = targetIndex Mod width, _ty As Integer = targetIndex / width
                    If _tx < 0 OrElse _ty < 0 OrElse _tx >= width OrElse _ty >= height Then Continue For
 
                    If Not queue.Contains(targetIndex) AndAlso source(targetIndex).Equals(target) Then
                        queue.Add(targetIndex)
                        i += 1
                    End If
                Next
            Next
        End While
    End Sub
 
    Function Pn(ByVal x As Integer, ByVal y As Integer, ByVal w As Integer) As Integer
        Return x + (y * w)
    End Function
End Module

Código

using System.Collections.Generic;
using System.Linq;
 
public static class F
{
    /// <summary>
           /// Floods the fill.
           /// </summary>
           /// <typeparam name="T"></typeparam>
           /// <param name="source">The source.</param>
           /// <param name="x">The x.</param>
           /// <param name="y">The y.</param>
           /// <param name="width">The width.</param>
           /// <param name="height">The height.</param>
           /// <param name="target">The target to replace.</param>
           /// <param name="replacement">The replacement.</param>
    public static void FloodFill<T>(this T[] source, int x, int y, int width, int height, T target, T replacement)
    {
        int i = 0;
 
        FloodFill(source, x, y, width, height, target, replacement, out i);
    }
 
    /// <summary>
           /// Floods the array following Flood Fill algorithm
           /// </summary>
           /// <typeparam name="T"></typeparam>
           /// <param name="source">The source.</param>
           /// <param name="x">The x.</param>
           /// <param name="y">The y.</param>
           /// <param name="width">The width.</param>
           /// <param name="height">The height.</param>
           /// <param name="target">The target to replace.</param>
           /// <param name="replacement">The replacement.</param>
           /// <param name="i">The iterations made (if you want to debug).</param>
    public static void FloodFill<T>(this T[] source, int x, int y, int width, int height, T target, T replacement, out int i)
    {
        i = 0;
 
        // Queue of pixels to process. :silbar:
        HashSet<int> queue = new HashSet<int>();
 
        queue.Add(Pn(x, y, width));
 
        while (queue.Count > 0)
        {
            int _i = queue.First(),
              _x = _i % width,
              _y = _i / width;
 
            queue.Remove(_i);
 
            if (source[_i].Equals(target))
                source[_i] = replacement;
 
            for (int offsetX = -1; offsetX < 2; offsetX++)
                for (int offsetY = -1; offsetY < 2; offsetY++)
                {
                    // do not check origin or diagonal neighbours
                    if (offsetX == 0 && offsetY == 0 || offsetX == offsetY || offsetX == -offsetY || -offsetX == offsetY)
                        continue;
 
                    int targetIndex = Pn(_x + offsetX, _y + offsetY, width);
                    int _tx = targetIndex % width,
                      _ty = targetIndex / width;
 
                    // skip out of bounds point
                    if (_tx < 0 || _ty < 0 || _tx >= width || _ty >= height)
                        continue;
 
                    if (!queue.Contains(targetIndex) && source[targetIndex].Equals(target))
                    {
                        queue.Add(targetIndex);
                        ++i;
                    }
                }
        }
    }
 
    public static int Pn(int x, int y, int w)
    {
        return x + (y * w);
    }
}

EDIT: Añadidos using + función PN + codigo en VB.NET que para eso son los snippets de VB

Prueba de concepto: https://dotnetfiddle.net/ZacRiB

Un saludo.


« Última modificación: 18 Octubre 2018, 20:30 pm por z3nth10n »	En línea

---

UTA - Portando GTA San Andreas a Unity3D.

⏩ Interesados hablad por Discord.

z3nth10n

Desconectado

Mensajes: 1.583

"Jack of all trades, master of none." - Zenthion

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

« Respuesta #536 en: 18 Octubre 2018, 19:51 pm »

Leer los pixeles de una imagen y contarlos siguiendo un diccionario estático de colores

Básicamente, la funcionalidad que tiene esto, es definir un diccionario estático de colores (con una enumeración donde se especifiquen los apartados que hay (si fuese necesario)), se itera todo pixel a pixel, y cada color se compara con la muestra sacando el porcentaje de similitud, si la similitud es del 90% o mayor se da por hecho que ese color pertenece a x enumeración del diccionario.

Para más INRI, le he añadido la utilidad de que se pueda leer desde Internet, lo que cambia si queremos leerlo desde el disco es que tenemos que llamar únicamente a System.IO.File.ReadAllBytes.

Aquí el codigo: https://github.com/z3nth10n/GTA-ColorCount/blob/master/CountColors/Program.cs

Nota: Tiene una versión compilada (para el que lo quiera probar).
Nota2: No está optimizado (memory leak & no se ha mirado si se puede optimizar desde el punto de vista de procesamiento de cpu), asi que, si se elige guardar puede llegar a ocupar 1GB en memoria (la imagen tiene 7000x5000, en bruto son unos 140MB (7000x5000x4 (ARGB)) en memoria.)

Codigo en VB.NET:

Código

Imports System
Imports System.Net
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Imports System.IO
Imports System.Collections.Generic
Imports System.Linq
Imports Color = zenthion.Color
Imports System.Diagnostics
Imports System.Reflection
 
Public Enum GroundType
	Building
	Asphalt
	LightPavement
	Pavement
	Grass
	DryGrass
	Sand
	Dirt
	Mud
	Water
	Rails
	Tunnel
	BadCodingDark
	BadCodingLight
	BuildingLight
End Enum
 
Public Enum OrderingType
	ByColor
	[ByVal]
	ByName
End Enum
 
Public Class Program
	Public Shared colorToCompare As Color = Color.white
	Public Shared orderingType As OrderingType = OrderingType.ByVal
	Public Shared isDarkened As Boolean = False, isPosterized As Boolean = False, isOrdered As Boolean = True, saveTexture As Boolean = False
 
	Private Shared ReadOnly Property SavingPath() As String
		Get
			Return Path.Combine(Path.GetDirectoryName(System.Reflection.Assembly.GetExecutingAssembly().Location), "texture.png")
		End Get
	End Property
 
	Public Shared Sub Main()
		Dim imageBytes() As Byte = Nothing
 
		' OriginalTexture: http://i.imgur.com/g9fRYbm.png
		' TextureColor: https://image.ibb.co/dP3Nvf/texture-Color.png
 
		Dim url As String = "https://image.ibb.co/dP3Nvf/texture-Color.png"
 
		Using webClient = New WebClient()
			imageBytes = webClient.DownloadData(url)
		End Using
 
		Dim sw As Stopwatch = Stopwatch.StartNew()
 
		isDarkened = url = "https://image.ibb.co/dP3Nvf/texture-Color.png"
 
 
		Dim colors As IEnumerable(Of Color) = Nothing
 
		Dim bitmap As Bitmap = Nothing
		Dim dict = GetColorCount(bitmap, imageBytes, (If(isDarkened, F.DarkenedMapColors, F.mapColors)).Values.AsEnumerable(), colors, isPosterized)
 
		Console.WriteLine(DebugDict(dict))
		Console.WriteLine("Num of colors: {0}", dict.Keys.Count)
 
		If saveTexture Then
			colors.ToArray().SaveBitmap(7000, 5000, SavingPath)
		End If
 
		bitmap.Dispose()
		sw.Stop()
 
		Console.WriteLine("Ellapsed: {0} s", (sw.ElapsedMilliseconds / 1000F).ToString("F2"))
 
		Console.Read()
	End Sub
 
	Private Shared Function DebugDict(ByVal dict As Dictionary(Of Color, Integer)) As String
		Dim num = dict.Select(Function(x) New With {Key .Name = x.Key.GetGroundType(isPosterized), Key .Similarity = x.Key.ColorSimilaryPerc(colorToCompare), Key .Val = x.Value, Key .ColR = x.Key.r, Key .ColG = x.Key.g, Key .ColB = x.Key.b}).GroupBy(Function(x) x.Name).Select(Function(x) New With {Key .Name = x.Key, Key .Similarity = x.Average(Function(y) y.Similarity), Key .Val = x.Sum(Function(y) y.Val), Key .Col = New Color(CByte(x.Average(Function(y) y.ColR)), CByte(x.Average(Function(y) y.ColG)), CByte(x.Average(Function(y) y.ColB)))})
 
		Dim num1 = num
 
		If isOrdered Then
			num1 = If(orderingType = OrderingType.ByName, num.OrderBy(Function(x) x.Name), num.OrderByDescending(Function(x)If(orderingType = OrderingType.ByColor, x.Col.ColorSimilaryPerc(colorToCompare), x.Val)))
		End If
 
		Dim num2 = num1.Select(Function(x) String.Format("[{2}] {0}: {1}", x.Name, x.Val.ToString("N0"), x.Similarity.ToString("F2")))
 
		Return String.Join(Environment.NewLine, num2)
	End Function
 
	Public Shared Function GetColorCount(ByRef image As Bitmap, ByVal arr() As Byte, ByVal colors As IEnumerable(Of Color), <System.Runtime.InteropServices.Out()> ByRef imageColors As IEnumerable(Of Color), Optional ByVal isPosterized As Boolean = False) As Dictionary(Of Color, Integer)
		Dim count As New Dictionary(Of Color, Integer)()
 
		Using stream As Stream = New MemoryStream(arr)
			image = CType(System.Drawing.Image.FromStream(stream), Bitmap)
		End Using
 
		'Color[]
		imageColors = image.ToColor() '.ToArray();
 
		'Parallel.ForEach(Partitioner.Create(imageColors, true).GetOrderableDynamicPartitions(), colorItem =>
		For Each colorItem As Color In imageColors
			' .Value
			Dim thresholedColor As Color = If((Not isPosterized), colorItem.GetSimilarColor(colors), colorItem) '.RoundColorOff(65);
 
			If Not count.ContainsKey(thresholedColor) Then
				count.Add(thresholedColor, 1)
			Else
				count(thresholedColor) += 1
			End If
		Next colorItem
 
		Dim posterizedColors As Dictionary(Of Color, Integer) = If(isPosterized, New Dictionary(Of Color, Integer)(), count)
 
		If isPosterized Then
			For Each kv In count
				Dim pColor As Color = kv.Key.Posterize(16)
 
				If Not posterizedColors.ContainsKey(pColor) Then
					posterizedColors.Add(pColor, kv.Value)
				Else
					posterizedColors(pColor) += kv.Value
				End If
			Next kv
		End If
 
		Return posterizedColors
	End Function
End Class
 
Public Module F
	Public mapColors As New Dictionary(Of GroundType, Color)() From {
		{ GroundType.Building, Color.white },
		{ GroundType.Asphalt, Color.black },
		{ GroundType.LightPavement, New Color(206, 207, 206, 255) },
		{ GroundType.Pavement, New Color(156, 154, 156, 255) },
		{ GroundType.Grass, New Color(57, 107, 41, 255) },
		{ GroundType.DryGrass, New Color(123, 148, 57, 255) },
		{ GroundType.Sand, New Color(231, 190, 107, 255) },
		{ GroundType.Dirt, New Color(156, 134, 115, 255) },
		{ GroundType.Mud, New Color(123, 101, 90, 255) },
		{ GroundType.Water, New Color(115, 138, 173, 255) },
		{ GroundType.Rails, New Color(74, 4, 0, 255) },
		{ GroundType.Tunnel, New Color(107, 105, 99, 255) },
		{ GroundType.BadCodingDark, New Color(127, 0, 0, 255) },
		{ GroundType.BadCodingLight, New Color(255, 127, 127, 255) }
	}
 
	Private _darkened As Dictionary(Of GroundType, Color)
 
	Public ReadOnly Property DarkenedMapColors() As Dictionary(Of GroundType, Color)
		Get
			If _darkened Is Nothing Then
				_darkened = GetDarkenedMapColors()
			End If
 
			Return _darkened
		End Get
	End Property
 
	Private BmpStride As Integer = 0
 
	Private Function GetDarkenedMapColors() As Dictionary(Of GroundType, Color)
		' We will take the last 2 elements
 
		Dim last2 = mapColors.Skip(mapColors.Count - 2)
 
		Dim exceptLast2 = mapColors.Take(mapColors.Count - 2)
 
		Dim dict As New Dictionary(Of GroundType, Color)()
 
		dict.AddRange(exceptLast2.Select(Function(x) New KeyValuePair(Of GroundType, Color)(x.Key, x.Value.Lerp(Color.black,.5F))))
 
		dict.Add(GroundType.BuildingLight, Color.white)
 
		dict.AddRange(last2)
 
		Return dict
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Sub AddRange(Of TKey, TValue)(ByVal dic As Dictionary(Of TKey, TValue), ByVal dicToAdd As IEnumerable(Of KeyValuePair(Of TKey, TValue)))
		dicToAdd.ForEach(Sub(x) dic.Add(x.Key, x.Value))
	End Sub
 
	<System.Runtime.CompilerServices.Extension> _
	Public Sub ForEach(Of T)(ByVal source As IEnumerable(Of T), ByVal action As Action(Of T))
		For Each item In source
			action(item)
		Next item
	End Sub
 
'INSTANT VB NOTE: The parameter color was renamed since it may cause conflicts with calls to static members of the user-defined type with this name:
	<System.Runtime.CompilerServices.Extension> _
	Public Function Posterize(ByVal color_Renamed As Color, ByVal level As Byte) As Color
		Dim r As Byte = 0, g As Byte = 0, b As Byte = 0
 
		Dim value As Double = color_Renamed.r \ 255.0
		value *= level - 1
		value = Math.Round(value)
		value /= level - 1
 
		r = CByte(value * 255)
		value = color_Renamed.g \ 255.0
		value *= level - 1
		value = Math.Round(value)
		value /= level - 1
 
		g = CByte(value * 255)
		value = color_Renamed.b \ 255.0
		value *= level - 1
		value = Math.Round(value)
		value /= level - 1
 
		b = CByte(value * 255)
 
		Return New Color(r, g, b, 255)
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Function GetGroundType(ByVal c As Color, ByVal isPosterized As Boolean) As String
		Dim mapToUse = If(Program.isDarkened, DarkenedMapColors, mapColors)
		Dim kvColor As KeyValuePair(Of GroundType, Color) = mapToUse.FirstOrDefault(Function(x)If(isPosterized, x.Value.ColorSimilaryPerc(c) >.9F, x.Value = c))
 
		If Not kvColor.Equals(Nothing) Then
			Return kvColor.Key.ToString()
		Else
			Return c.ToString()
		End If
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Function GetSimilarColor(ByVal c1 As Color, ByVal cs As IEnumerable(Of Color)) As Color
		Return cs.OrderBy(Function(x) x.ColorThreshold(c1)).FirstOrDefault()
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Function ColorThreshold(ByVal c1 As Color, ByVal c2 As Color) As Integer
		Return (Math.Abs(c1.r - c2.r) + Math.Abs(c1.g - c2.g) + Math.Abs(c1.b - c2.b))
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Function ColorSimilaryPerc(ByVal a As Color, ByVal b As Color) As Single
		Return 1F - (a.ColorThreshold(b) / (256F * 3))
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Function RoundColorOff(ByVal c As Color, Optional ByVal roundTo As Byte = 5) As Color
		Return New Color(c.r.RoundOff(roundTo), c.g.RoundOff(roundTo), c.b.RoundOff(roundTo), 255)
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Function RoundOff(ByVal i As Byte, Optional ByVal roundTo As Byte = 5) As Byte
		Return CByte(CByte(Math.Ceiling(i / CDbl(roundTo))) * roundTo)
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Iterator Function ToColor(ByVal bmp As Bitmap) As IEnumerable(Of Color)
		Dim rect As New Rectangle(0, 0, bmp.Width, bmp.Height)
		Dim bmpData As BitmapData = bmp.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, bmp.PixelFormat)
 
		Dim ptr As IntPtr = bmpData.Scan0
 
		Dim bytes As Integer = bmpData.Stride * bmp.Height
		Dim rgbValues(bytes - 1) As Byte
 
		' Copy the RGB values into the array.
		Marshal.Copy(ptr, rgbValues, 0, bytes)
 
		BmpStride = bmpData.Stride
 
		For column As Integer = 0 To bmpData.Height - 1
			For row As Integer = 0 To bmpData.Width - 1
				' Little endian
				Dim b As Byte = CByte(rgbValues((column * BmpStride) + (row * 4)))
				Dim g As Byte = CByte(rgbValues((column * BmpStride) + (row * 4) + 1))
				Dim r As Byte = CByte(rgbValues((column * BmpStride) + (row * 4) + 2))
 
				Yield New Color(r, g, b, 255)
			Next row
		Next column
 
		' Unlock the bits.
		bmp.UnlockBits(bmpData)
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Sub SaveBitmap(ByVal bmp() As Color, ByVal width As Integer, ByVal height As Integer, ByVal path As String)
		Dim stride As Integer = BmpStride
		Dim rgbValues((BmpStride * height) - 1) As Byte
 
		For column As Integer = 0 To height - 1
			For row As Integer = 0 To width - 1
				Dim i As Integer = Pn(row, column, width)
 
				' Little endian
				rgbValues((column * BmpStride) + (row * 4)) = bmp(i).b
				rgbValues((column * BmpStride) + (row * 4) + 1) = bmp(i).g
				rgbValues((column * BmpStride) + (row * 4) + 2) = bmp(i).r
				rgbValues((column * BmpStride) + (row * 4) + 3) = bmp(i).a
			Next row
		Next column
 
				Using image As New Bitmap(width, height, width * 4, PixelFormat.Format32bppArgb, Marshal.UnsafeAddrOfPinnedArrayElement(rgbValues, 0))
					image.Save(path)
				End Using
	End Sub
 
	Public Function Pn(ByVal x As Integer, ByVal y As Integer, ByVal w As Integer) As Integer
		Return x + (y * w)
	End Function
End Module
 
Public Module Mathf
	<System.Runtime.CompilerServices.Extension> _
	Public Function Clamp(Of T As IComparable(Of T))(ByVal val As T, ByVal min As T, ByVal max As T) As T
		If val.CompareTo(min) < 0 Then
			Return min
		ElseIf val.CompareTo(max) > 0 Then
			Return max
		Else
			Return val
		End If
	End Function
 
	' Interpolates between /a/ and /b/ by /t/. /t/ is clamped between 0 and 1.
	Public Function Lerp(ByVal a As Single, ByVal b As Single, ByVal t As Single) As Single
		Return a + (b - a) * Clamp01(t)
	End Function
 
	' Clamps value between 0 and 1 and returns value
	Public Function Clamp01(ByVal value As Single) As Single
		If value < 0F Then
			Return 0F
		ElseIf value > 1F Then
			Return 1F
		Else
			Return value
		End If
	End Function
End Module
 
Namespace zenthion
	''' <summary>
	''' Struct Color
	''' </summary>
	''' <seealso cref="System.ICloneable" />
	<Serializable>
	Public Structure Color
		Implements ICloneable
 
		''' <summary>
		''' Clones this instance.
		''' </summary>
		''' <returns>System.Object.</returns>
		Public Function Clone() As Object Implements ICloneable.Clone
			Return MemberwiseClone()
		End Function
 
		''' <summary>
		''' The r
		''' </summary>
		Public r, g, b, a As Byte
 
		''' <summary>
		''' Gets the white.
		''' </summary>
		''' <value>The white.</value>
		Public Shared ReadOnly Property white() As Color
			Get
				Return New Color(255, 255, 255)
			End Get
		End Property
 
		''' <summary>
		''' Gets the red.
		''' </summary>
		''' <value>The red.</value>
		Public Shared ReadOnly Property red() As Color
			Get
				Return New Color(255, 0, 0)
			End Get
		End Property
 
		''' <summary>
		''' Gets the green.
		''' </summary>
		''' <value>The green.</value>
		Public Shared ReadOnly Property green() As Color
			Get
				Return New Color(0, 255, 0)
			End Get
		End Property
 
		''' <summary>
		''' Gets the blue.
		''' </summary>
		''' <value>The blue.</value>
		Public Shared ReadOnly Property blue() As Color
			Get
				Return New Color(0, 0, 255)
			End Get
		End Property
 
		''' <summary>
		''' Gets the yellow.
		''' </summary>
		''' <value>The yellow.</value>
		Public Shared ReadOnly Property yellow() As Color
			Get
				Return New Color(255, 255, 0)
			End Get
		End Property
 
		''' <summary>
		''' Gets the gray.
		''' </summary>
		''' <value>The gray.</value>
		Public Shared ReadOnly Property gray() As Color
			Get
				Return New Color(128, 128, 128)
			End Get
		End Property
 
		''' <summary>
		''' Gets the black.
		''' </summary>
		''' <value>The black.</value>
		Public Shared ReadOnly Property black() As Color
			Get
				Return New Color(0, 0, 0)
			End Get
		End Property
 
		''' <summary>
		''' Gets the transparent.
		''' </summary>
		''' <value>The transparent.</value>
		Public Shared ReadOnly Property transparent() As Color
			Get
				Return New Color(0, 0, 0, 0)
			End Get
		End Property
 
		''' <summary>
		''' Initializes a new instance of the <see cref="Color"/> struct.
		''' </summary>
		''' <param name="r">The r.</param>
		''' <param name="g">The g.</param>
		''' <param name="b">The b.</param>
		Public Sub New(ByVal r As Byte, ByVal g As Byte, ByVal b As Byte)
			Me.r = r
			Me.g = g
			Me.b = b
			a = Byte.MaxValue
		End Sub
 
		''' <summary>
		''' Initializes a new instance of the <see cref="Color"/> struct.
		''' </summary>
		''' <param name="r">The r.</param>
		''' <param name="g">The g.</param>
		''' <param name="b">The b.</param>
		''' <param name="a">a.</param>
		Public Sub New(ByVal r As Byte, ByVal g As Byte, ByVal b As Byte, ByVal a As Byte)
			Me.r = r
			Me.g = g
			Me.b = b
			Me.a = a
		End Sub
 
		''' <summary>
		''' Implements the ==.
		''' </summary>
		''' <param name="c1">The c1.</param>
		''' <param name="c2">The c2.</param>
		''' <returns>The result of the operator.</returns>
		Public Shared Operator =(ByVal c1 As Color, ByVal c2 As Color) As Boolean
			Return c1.r = c2.r AndAlso c1.g = c2.g AndAlso c1.b = c2.b AndAlso c1.a = c2.a
		End Operator
 
		''' <summary>
		''' Implements the !=.
		''' </summary>
		''' <param name="c1">The c1.</param>
		''' <param name="c2">The c2.</param>
		''' <returns>The result of the operator.</returns>
		Public Shared Operator <>(ByVal c1 As Color, ByVal c2 As Color) As Boolean
			Return Not(c1.r = c2.r AndAlso c1.g = c2.g AndAlso c1.b = c2.b AndAlso c1.a = c2.a)
		End Operator
 
		''' <summary>
		''' Returns a hash code for this instance.
		''' </summary>
		''' <returns>A hash code for this instance, suitable for use in hashing algorithms and data structures like a hash table.</returns>
		Public Overrides Function GetHashCode() As Integer
			Return GetHashCode()
		End Function
 
		''' <summary>
		''' Determines whether the specified <see cref="System.Object" /> is equal to this instance.
		''' </summary>
		''' <param name="obj">The <see cref="System.Object" /> to compare with this instance.</param>
		''' <returns><c>true</c> if the specified <see cref="System.Object" /> is equal to this instance; otherwise, <c>false</c>.</returns>
		Public Overrides Function Equals(ByVal obj As Object) As Boolean
			Dim c As Color = DirectCast(obj, Color)
			Return r = c.r AndAlso g = c.g AndAlso b = c.b
		End Function
 
		''' <summary>
		''' Implements the -.
		''' </summary>
		''' <param name="c1">The c1.</param>
		''' <param name="c2">The c2.</param>
		''' <returns>The result of the operator.</returns>
		Public Shared Operator -(ByVal c1 As Color, ByVal c2 As Color) As Color
			Return New Color(CByte(Mathf.Clamp(c1.r - c2.r, 0, 255)), CByte(Mathf.Clamp(c2.g - c2.g, 0, 255)), CByte(Mathf.Clamp(c2.b - c2.b, 0, 255)))
		End Operator
 
		''' <summary>
		''' Implements the +.
		''' </summary>
		''' <param name="c1">The c1.</param>
		''' <param name="c2">The c2.</param>
		''' <returns>The result of the operator.</returns>
		Public Shared Operator +(ByVal c1 As Color, ByVal c2 As Color) As Color
			Return New Color(CByte(Mathf.Clamp(c1.r + c2.r, 0, 255)), CByte(Mathf.Clamp(c2.g + c2.g, 0, 255)), CByte(Mathf.Clamp(c2.b + c2.b, 0, 255)))
		End Operator
 
		''' <summary>
		''' Lerps the specified c2.
		''' </summary>
		''' <param name="c2">The c2.</param>
		''' <param name="t">The t.</param>
		''' <returns>Color.</returns>
		Public Function Lerp(ByVal c2 As Color, ByVal t As Single) As Color
			Return New Color(CByte(Mathf.Lerp(r, c2.r, t)), CByte(Mathf.Lerp(g, c2.g, t)), CByte(Mathf.Lerp(b, c2.b, t)))
		End Function
 
		''' <summary>
		''' Inverts this instance.
		''' </summary>
		''' <returns>Color.</returns>
		Public Function Invert() As Color
			Return New Color(CByte(Mathf.Clamp(Byte.MaxValue - r, 0, 255)), CByte(Mathf.Clamp(Byte.MaxValue - g, 0, 255)), CByte(Mathf.Clamp(Byte.MaxValue - b, 0, 255)))
		End Function
 
		''' <summary>
		''' Returns a <see cref="System.String" /> that represents this instance.
		''' </summary>
		''' <returns>A <see cref="System.String" /> that represents this instance.</returns>
		Public Overrides Function ToString() As String
			If Me = white Then
				Return "white"
			ElseIf Me = transparent Then
				Return "transparent"
			ElseIf Me = red Then
				Return "red"
			ElseIf Me = blue Then
				Return "blue"
			ElseIf Me = black Then
				Return "black"
			ElseIf Me = green Then
				Return "green"
			ElseIf Me = yellow Then
				Return "yellow"
			Else
				Return String.Format("({0}, {1}, {2}, {3})", r, g, b, a)
			End If
		End Function
 
		''' <summary>
		''' Fills the specified x.
		''' </summary>
		''' <param name="x">The x.</param>
		''' <param name="y">The y.</param>
		''' <returns>Color[].</returns>
		Public Shared Iterator Function Fill(ByVal x As Integer, ByVal y As Integer) As IEnumerable(Of Color)
			For i As Integer = 0 To (x * y) - 1
				Yield black
			Next i
		End Function
	End Structure
End Namespace

Nota: A pesar de haber sido convertido con un conversor se ha comprobado en: https://dotnetfiddle.net/1vbkgG
Nota2: La idea era que se ejecutase de forma online y si le poneis una imagen más pequeña deberia sacar los pixeles, pero como digo no se puede, por tema de web clouds y recursos compartidos.
Nota3: Le he metido esta imagen (https://vignette.wikia.nocookie.net/gta-myths/images/8/80/Gtasa-blank.png/revision/latest?cb=20161204212845) pero me da un error que ahora mismo no me puedo parar a comprobar:

Citar

Run-time exception (line -1): Arithmetic operation resulted in an overflow.

Stack Trace:

[System.OverflowException: Arithmetic operation resulted in an overflow.]
   at F.ColorThreshold(Color c1, Color c2)
   at F._Closure$__3._Lambda$__15(Color x)
   at System.Linq.EnumerableSorter`2.ComputeKeys(TElement[] elements, Int32 count)
   at System.Linq.EnumerableSorter`1.Sort(TElement[] elements, Int32 count)
   at System.Linq.OrderedEnumerable`1.<GetEnumerator>d__1.MoveNext()
   at System.Linq.Enumerable.FirstOrDefault[TSource](IEnumerable`1 source)
   at F.GetSimilarColor(Color c1, IEnumerable`1 cs)
   at Program.GetColorCount(Bitmap& image, Byte[] arr, IEnumerable`1 colors, IEnumerable`1& imageColors, Boolean isPosterized)
   at Program.Main()

Y creo que eso es todo.

Un saludo.

PD: La razón de que el código esté mitad comentado y mitad sin comentar es porque la parte de la clase Color es una implementación propia de la clase Color que hice hace tiempo y la introducí en mi Lerp2API.
PD2: Este código (el del ColorThreshold y lo de GetSimilarity, todo lo demás lo he escrito esta mañana y tarde) realmente lo estaba usando en mi proyecto de San Andreas Unity (de los últimos commits que hice antes de irme de este y empezar uno nuevo a solas).
PD3: Todo esto es parte de un proceso de depuración un tanto largo que me ha servido para constrastar de donde me venían unos valores. Para ser más concretos, tengo un algoritmo que saca los contornos de los edificios que he estado optimizando (el cual empecé en 2016, y después de un año he retomado), y bueno, yo esperaba que me devolviese unos 2600 edificios, pero se me han devuelto unos 1027k y hay unos 1029k pixeles en la última imagen que he puesto (lo podéis comprobar vosotros mismos), así que ya se por donde seguir. Espero que vosotros también hagáis lo mismo con lo que escribo.


« Última modificación: 18 Octubre 2018, 19:57 pm por z3nth10n »	En línea

---

UTA - Portando GTA San Andreas a Unity3D.

⏩ Interesados hablad por Discord.

Serapis

Colaborador

Desconectado

Mensajes: 3.391

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

« Respuesta #537 en: 19 Octubre 2018, 03:32 am »

mmm... no estoy seguro de haberte entendido, del todo... luego copio el código y mañana trato de ejecutarlo y ya veré... pero de entrada me parece que intentas contar colores?. o intentas contar áreas que tienen un color (esto último luego de abrir el fichero 'texture-Color.png".

Así que ateniéndome solo a tus comentarios.
Con el algoritmo counting-sort, puedes tener la cantidad de colores únicos que contienen una imagen... necesitas un array de 17Mb.
Después puedes clasificarlos. Si solo aparecen por ejemplo 1millón de colores distintos, solo tienes que reclasificar 1 millons (hacer tu comparación de similaridad, en vez de hacerlo con toda los 7.000x5.000 = 35millones)... counting sort, es el algoritmo más rápido de ordenamiento para números enteros, además tampoco es exactamente dicho algorimo, sino una simplificación pués nos basta saber la existencia de cada único elemento (sin duplicados)

Así que si precisas una clasificación basada en el parecido, es más práctico (que lo que has hecho) aplicar una función que derive los colores que tu dés por sentado que pertenecen a una categoría al color que representa esa categoría... (quiero decir, es más práctico si no te basta con saber qué colores aparecen, si no que además debas hacer algo con ellos después en la imagen). Así al final toda la imagen tendría solo tantos colores como categorías tengas. Por supuesto debe quedar claro previamente que pasa con los colores que pudieran correponder por igual a más de una categoría (el gris puede llevarse a la categoría de negro, lo mismo que a la del blanco, pués equidista de ambos). Es decir, un color no debe estar en mas de una categoría...

Aquí las funciones que harían todo lo antedicho...

Código:

// la función recibe el array de píxeles (4bytes por píxel) y devuelve la cantidad de únicos por referencia y el array de colores únicos. 
// es una simplificación de counting-sort (ya que no requerimos ordenarlos, sólo conocer los únicos).
array entero = funcion GetColoresUnicos(in array entero pixeles(), out entero Cantidad)
    array de entero ColoresUnicos(0 a 1677725) //255 para señalar que existe y 0 para no.
    entero k

    bucle para k desde 0 hasta pixeles.length -1
          ColoresUnicos(pixeles(k)) = 255 // por si se quiere hace rpasar por bleao en alguna operación posterior.
    siguiente  
    
    devolver ColoresUnicos  
fin funcion

Listo ya tienes un array donde el índice es el propio color del píxel, y si el valor contenido es 1, dicho color (el valor del índice) existe en la imagen, si vale 0, no.
por ejemplo sea: ColoresUnicos(10145634) que vale 255, ese color (el 10145634, en Hex:9ACF62), existe en la imagen.

Ahora clasificas estos colores únicos según tu criterio de similaridad... y será enormemente más rápido que todo ese código que tienes...
Veamos por ejemplo que tienes 25 categorías... asignas un color a ellos... y pongamos que descansan en un array ColCategorias(0 a 24)

Código:

// Ahora el array de colores únicos se truncará para que cada color existente (valor 255), 
//    pase a tener el color de la categoría a la que pertenece
funcion ReclasificarColores(in-out array entero colUnicos() )
    entero k, byte x

    bucle para k desde 0 hasta 16777215
        Si colUnicos(k) > 0)  // es decir si existe en la imagen
            // esta función debe devolver un valor en el rango 0-24, que es el índice de un color de la categoría...            
            x = Similaridad(colUnicos(k)) 
            colUnicos(k) = colCategoria(x)
            // o bien devolver directamente el color y se asigna entonces a 
            // colUnicos(k) = Similaridad(colUnicos(k)) 
        fin si
     fin bucle
fin funcion

Ahora que ya están todos los colores (únicos) existentes en la imagen, modificado al color de cuya categoría es reepresentativo.... solo resta aplicarlo a la imagen (si fuera el caso)...

Código:

// Cambia cada color d ela imagen, por el que corresponde a su categoría.
funcion SegmentarImagenEnColores(in array entero pixeles(), in array entero colUnicos() )
    entero k

    bucle para k desde 0 hasta pixeles.lenght -1
        pixeles(k) = colUnicos(pixeles(k))
    siguiente
fin funcion

Y fin... vuelves a depositar el array de píxeles en la imagen (si no interceptaste directamente su puntero en memoria), y refrescas la imagen. Ya la tienes segmentada en tus 25 colores (de ejemplo).
Aparte de las 3 funciones dadas en pseudocódigo, te falta solo incorporar la función de similaridad, la cual dependerá de ciertos parámetros, que deenden de lo que uno aya a hacer... y que queda a tu esfuerzo, aunque creo haber visto que en el código pudieras tenerla ya implementada.
Y queda evidentemente la parte del código que carga la imagen y toma su array de píxeles y al final la devuelve (y si procede la guarda a disco)...

aquí lo que sería la función general...

Código:

funcion SegemtarImagenEnCategorias(string Ruta)
   entero cantidadColUnicos
   array entero pixeles()
   array entero colUnicos()
   array entero colCategoria()
   bitmap Imagen

   imagen = ReadImagen(ruta) 
   pixeles = GetPixeles(Imagen))
   cantidadColUnicos = GetColoresUnicos(pixeles, colUnicos) 
   imprimir cantidadColUnicos // solo por cuirosidad, aunque puede usarse para determinar cuando terminar en un bucle
   // se supone que estos colores ya está definidos de antemano, pueden tomarse desde
   //    fichero, desde recursos, insertos en el código como constantes, etc...
   colCategoria= RadFromFile(Ruta) 
   ReclasificarColores(colUnicos)
   SegmentarImagenEnColores(pixeles, colUnicos)
   SetPixeles(Imagen, pixeles)
   WriteImagen(ruta, imagen)
fin funcion

<hr>
Otra opción es simplemente aplicar funciones de segmentación, por ejemplo una convolución con un kernel como el siguiente (-1,1,-1, 1,0,1, -1,1,-1) genera la imagen que pongo justo bajo estas líneas...

O una función de 'relieve' donde realza el contraste cuando encuentra un cambio brusco de luminancia, y apaga-diluye el resto... la siguiente imagen corresponde a ese caso.

Ambas partiendo de la siguiente imagen (se hecha en falta spoilers en el foro). Claro que al hablar de edificios, pensaba que eran en 3 dimensiones, vamos como una ciudad, sin embargo, luego de ver la imagen png, veo que es más una imágen aérea de edificios, lo que sin duda arrojaría un mejor resultado que una en 3d, como esta de la que he partido...

Mañana con más tiempo le hecho un ojo al código...


	En línea

z3nth10n

Desconectado

Mensajes: 1.583

"Jack of all trades, master of none." - Zenthion

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

« Respuesta #538 en: 19 Octubre 2018, 08:50 am »

Te cuento de forma rápida lo que pretendo.

En el mapa hay x cantidad de colores predefinidos, tantos como enumeraciones tengas.

En este caso: Building, Asphalt, LightPavement, Pavement, Grass, DryGrass, Sand, Dirt, Mud, Water, Rails, Tunnel, BadCodingDark, BadCodingLight, BuildingLight, son 15.

Lo que pasa con esa imagen es hay micro variaciones de color. Quizás hay 100 tonos distintos de Grass con variaciones de pares en la escala RGB (es decir, nunca te vas a encontrar tonos que tengan un (0, 241, 0, 255), para el caso de un verde), y quizás con un rango total de ±10. Es decir, 5 posibilidades entre los 3 componentes: 5^3=125 tonos de verde.

Estos tonos son inperceptibles al ojo humano. Quizás se hizo por algun motivo (ya le metere saturación para ver si sigue algún patrón o algo. Estos de Rockstar te meten easter eggs hasta en los mapas).

Entonces lo que hago primero es iterar todos los colores. Mientras itero, voy comparando pixel a pixel, con los colores definidos en el diccionario, pero no los comparo literalmente (==), si no que saco un porcentaje de similitud. Y estás microvariaciones, como digo, como máximo su diferencia puede ser de ±10.

El porcentaje (con el mayor offset posible) sera en este caso: (255, 255, 255, 255) --> (245, 245, 245, 255) = 0.9609375 = 96,1% (un 3,9% de diferencia), vamos bien, ya que yo comparo con hasta un 10%, es decir una variación de ±25, es decir 25/2=12,5^3=1953 posibilidades, imagina.

Teniendo ese porcentaje, pues ya al debugear lo unico que hago es agrupar todos los colores (antes lo que hacia era posterizarlos, pero no me moló la idea, por eso hay un método de posterización) y sumar sus respectivas agrupaciones, pasamos de +1600 colores a unos 15 o menos (algunos no los detecta bien, otros directamente, no están presentes).

Un saludo.


	En línea

---

UTA - Portando GTA San Andreas a Unity3D.

⏩ Interesados hablad por Discord.

Eleкtro

Ex-Staff

Desconectado

Mensajes: 9.874

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

« Respuesta #539 en: 22 Noviembre 2018, 19:54 pm »

Cita de: z3nth10n en 18 Octubre 2018, 19:51 pm

Nota3: Le he metido esta imagen (https://vignette.wikia.nocookie.net/gta-myths/images/8/80/Gtasa-blank.png/revision/latest?cb=20161204212845) pero me da un error que ahora mismo no me puedo parar a comprobar:

Si tu mismo te das cuenta de que el propósito principal del código que tienes está incompleto, puesto que NO funciona correctamente con según que imágenes (más abajo te explico el fallo), ¿entonces por que lo compartes?. Algo incompleto o no del todo funcional sencillamente no sirve para reutilizarlo, es que no sirve.

Citar

Código

	<System.Runtime.CompilerServices.Extension> _
	Public Iterator Function ToColor(ByVal bmp As Bitmap) As IEnumerable(Of Color)
		Dim rect As New Rectangle(0, 0, bmp.Width, bmp.Height)
		Dim bmpData As BitmapData = bmp.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, bmp.PixelFormat)
 
		Dim ptr As IntPtr = bmpData.Scan0
 
		Dim bytes As Integer = bmpData.Stride * bmp.Height
		Dim rgbValues(bytes - 1) As Byte
 
		' Copy the RGB values into the array.
		Marshal.Copy(ptr, rgbValues, 0, bytes)
 
		BmpStride = bmpData.Stride
 
		For column As Integer = 0 To bmpData.Height - 1
			For row As Integer = 0 To bmpData.Width - 1
				' Little endian
				Dim b As Byte = CByte(rgbValues((column * BmpStride) + (row * 4)))
				Dim g As Byte = CByte(rgbValues((column * BmpStride) + (row * 4) + 1))
				Dim r As Byte = CByte(rgbValues((column * BmpStride) + (row * 4) + 2))
 
				Yield New Color(r, g, b, 255)
			Next row
		Next column
 
		' Unlock the bits.
		bmp.UnlockBits(bmpData)
	End Function
 
	<System.Runtime.CompilerServices.Extension> _
	Public Sub SaveBitmap(ByVal bmp() As Color, ByVal width As Integer, ByVal height As Integer, ByVal path As String)
		Dim stride As Integer = BmpStride
		Dim rgbValues((BmpStride * height) - 1) As Byte
 
		For column As Integer = 0 To height - 1
			For row As Integer = 0 To width - 1
				Dim i As Integer = Pn(row, column, width)
 
				' Little endian
				rgbValues((column * BmpStride) + (row * 4)) = bmp(i).b
				rgbValues((column * BmpStride) + (row * 4) + 1) = bmp(i).g
				rgbValues((column * BmpStride) + (row * 4) + 2) = bmp(i).r
				rgbValues((column * BmpStride) + (row * 4) + 3) = bmp(i).a
			Next row
		Next column
 
				Using image As New Bitmap(width, height, width * 4, PixelFormat.Format32bppArgb, Marshal.UnsafeAddrOfPinnedArrayElement(rgbValues, 0))
					image.Save(path)
				End Using
	End Sub
 
	Public Function Pn(ByVal x As Integer, ByVal y As Integer, ByVal w As Integer) As Integer
		Return x + (y * w)
	End Function
End Module

Primero de todo quiero comentar que eso no deberían ser extensiones de método puesto que estás usando objetos que no están declarados dentro del bloque de la extensión de método (BmpStride y rgbValues). No es código reutilizable tal y como está ahora mismo.

Bueno, vayamos al grano. Es lógico que el algoritmo te tire errores con la imagen del hipervínculo que has mencionado, puesto que tu algoritmo está hardcodeado para parsear imágenes de 32 BPP (4 bytes por pixel) en ese búcle que haces ahí, sin embargo, tu estás intentando tratar imágenes con otro formato de píxeles, 24 BPP en este caso (3 bytes por pixel), por lo tanto tu búcle generará una excepción del tipo IndexOutOfRangeException.

El error principal lo cometes aquí, al pasarle el argumento bmp.PixelFormat, el cual puede ser cualquier formato de píxeles dependiendo de la imagen original...

Citar

Código

Dim bmpData As BitmapData = bmp.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, bmp.PixelFormat)

En su lugar, debes convertir la imagen a 32 BPP simplemente pasándole el argumento PixelFormat.Format32bppArgb a la función LockBits:

Código

Dim bmpData As BitmapData = bmp.LockBits(rect, ImageLockMode.ReadOnly, PixelFormat.Format32bppArgb)

...o en su defecto, adaptar tu búcle para todos los tipos de formato de píxeles posibles.

Te muestro un ejemplo:

Código

Public Iterator Function GetColors(ByVal bmp As Bitmap) As IEnumerable(Of Color)
 
    ' Lock the bitmap bits.
    Dim pixelFormat As PixelFormat = PixelFormat.Format32bppArgb
    Dim bytesPerPixel As Integer = 4 ' PixelFormat.Format32bppArgb
    Dim rect As New Rectangle(Point.Empty, bmp.Size)
    Dim bmpData As BitmapData = bmp.LockBits(rect, ImageLockMode.ReadOnly, pixelFormat)
 
    ' Get the address of the first row.
    Dim address As IntPtr = bmpData.Scan0
 
    ' Hold the raw bytes of the bitmap. 
    Dim numBytes As Integer = (Math.Abs(bmpData.Stride) * rect.Height)
    Dim rawImageData As Byte() = New Byte(numBytes - 1) {}
    Marshal.Copy(address, rawImageData, 0, numBytes)
 
    ' Unlock the bitmap bits.
    bmp.UnlockBits(bmpData)
 
    ' Iterate the pixels.
    For i As Integer = 0 To (rawImageData.Length - bytesPerPixel) Step bytesPerPixel
 
        Yield Color.FromArgb(alpha:=rawImageData(i + 3),
                             red:=rawImageData(i + 2),
                             green:=rawImageData(i + 1),
                             blue:=rawImageData(i))
 
    Next i
 
End Function

En el otro método "SaveBitmap" deberías aplicar el mismo principio, ya que también asumes que es una imagen de 32 BPP.

Saludos


« Última modificación: 22 Noviembre 2018, 20:09 pm por Eleкtro (sin pilas) »	En línea

Páginas: 1 ... 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 [54] 55 56 57 58 59 60

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	25,870	2 Agosto 2013, 17:13 pm por 0xDani
	[APORTE] [VBS] Snippets para manipular reglas de bloqueo del firewall de Windows Scripting	Eleкtro	1	4,080	3 Febrero 2014, 20:19 pm por Eleкtro
	Librería de Snippets para Delphi « 1 2 » Programación General	crack81	15	21,149	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	3,071	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	6,539	4 Julio 2018, 21:35 pm por Eleкtro