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

[Eleкtro]

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!

[Eleкtro]

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 (vbnet) [Seleccionar] Expandir


''' ----------------------------------------------------------------------------------------------------
''' <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 (vbnet) [Seleccionar] Expandir

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 (vbnet) [Seleccionar] Expandir

   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 (vbnet) [Seleccionar] Expandir

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.

[Eleкtro]

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 (vbnet) [Seleccionar] Expandir

   
   ''' ----------------------------------------------------------------------------------------------------
   ''' <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

[**Aincrad**]

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 (vbnet) [Seleccionar] Expandir

'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

[Eleкtro]

¿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 (vbnet) [Seleccionar] Expandir

#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 (vbnet) [Seleccionar] Expandir

Imports ElektroKit.Interop.IPC
Imports System.Linq

Código (vbnet) [Seleccionar] Expandir

' 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 (vbnet) [Seleccionar] Expandir

' ----------------------- '
' 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 (vbnet) [Seleccionar] Expandir

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

[z3nth10n]

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 (vbnet) [Seleccionar] Expandir

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 (csharp) [Seleccionar] Expandir

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.

[z3nth10n]

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 (vbnet) [Seleccionar] Expandir


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:

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.

[Serapis]

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 [Seleccionar] Expandir


// 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 [Seleccionar] Expandir


// 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 [Seleccionar] Expandir


// 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 [Seleccionar] Expandir


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

[z3nth10n]

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.

[Eleкtro]

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.

Código (vbnet) [Seleccionar] Expandir

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

Código (vbnet) [Seleccionar] Expandir

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 (vbnet) [Seleccionar] Expandir

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 (vbnet) [Seleccionar] Expandir

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