.
Andaba buscando la manera de buscar en un Array de la forma mas RAPIDA posible y bueno, recordando el QuickSort arme este algoritmo que busca en un Array ordenado de forma Ascendente o Desendente un valor en el mismo lo hace de forma Extremadamente rapida...

Se lo dejo en Dos versiones... Recursiva y con un Do... Loop

Aqui se los dejo:

Forma Recursiva (Gasta memoria...)

 
'
'   /////////////////////////////////////////////////////////////
'   //                                                         //
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
option explicit
 
Public Function ExitsInArray(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean
Dim lng_lb                      As Long
Dim lng_Ub                      As Long
    lng_lb = LBound(vBuff&())
    lng_Ub = UBound(vBuff&())
    If vBuff&(lng_Ub) > vBuff&(lng_lb) Then
        ExitsInArray = ExitsInArrayR(vValue, vBuff&, lng_lb, lng_Ub, p)
    Else
        ExitsInArray = ExitsInArrayR(vValue, vBuff&, lng_Ub, lng_lb, p)
    End If
End Function
 
Public Function ExitsInArrayR(ByRef vValue As Long, ByRef vBuff() As Long, ByVal l As Long, ByVal u As Long, ByRef p As Long) As Boolean
    Select Case vValue
        Case vBuff&(l&)
            p& = l&
            ExitsInArrayR = True
        Case vBuff&(u&)
            p& = u&
            ExitsInArrayR = True
        Case Else
            p = (l& + u&) / 2
            If p <> l& And p& <> u& Then
                If vBuff&(p&) < vValue& Then
                    ExitsInArrayR = ExitsInArrayR(vValue, vBuff&(), p, u, p)
                ElseIf vBuff&(p&) > vValue& Then
                    ExitsInArrayR = ExitsInArrayR(vValue, vBuff&(), l, p, p)
                ElseIf vBuff&(p&) = vValue& Then
                    ExitsInArrayR = True
                End If
            End If
    End Select
End Function
 
 

Forma con Do ... Loop

 
'
'   /////////////////////////////////////////////////////////////
'   //                                                         //
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
option explicit
 
Public Function ExitsInArrayNR(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean
Dim lng_lb                      As Long
Dim lng_Ub                      As Long
    lng_lb = LBound(vBuff&())
    lng_Ub = UBound(vBuff&())
    If Not vBuff&(lng_Ub) > vBuff&(lng_lb) Then
        Dim t                           As Long
        t = lng_Ub
        lng_Ub = lng_lb
        lng_lb = t
    End If
    Do Until ExitsInArrayNR
        Select Case vValue
            Case vBuff&(lng_lb&)
                p& = lng_lb&
                ExitsInArrayNR = True
            Case vBuff&(lng_Ub&)
                p& = lng_Ub&
                ExitsInArrayNR = True
            Case Else
                p = (lng_lb& + lng_Ub&) / 2
                If p <> lng_lb& And p& <> lng_Ub& Then
                    If vBuff&(p&) < vValue& Then
                        lng_lb = p
                    ElseIf vBuff&(p&) > vValue& Then
                        lng_Ub = p
                    ElseIf vBuff&(p&) = vValue& Then
                        ExitsInArrayNR = True
                    End If
                Else
                    Exit Do
                End If
        End Select
    Loop
End Function
 
 

Prueba de Velocidad en comparacion a un Simple For Next...

 
'
'   /////////////////////////////////////////////////////////////
'   //                                                         //
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
Option Explicit
 
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Private Sub Form_Load()
Dim vBuff&(0 To 99999)
Dim i&, p&
Dim l&
Dim vStr$
    For i& = LBound(vBuff&()) To UBound(vBuff&())
        vBuff(i&) = (99999 * 3) - (i * 3)
    Next i&
    l& = GetTickCount()
    For i& = LBound(vBuff&()) To 999
        Call ExitsInArrayLento(i&, vBuff&(), p&)
    Next i&
    vStr$ = GetTickCount - l&
    l& = GetTickCount()
    For i& = LBound(vBuff&()) To 999
        ' // ExitsInArrayNR es un poquito mas rapido... que ExitsInArray
        Call ExitsInArray(i&, vBuff&(), p&)
    Next i&
    l& = GetTickCount - l&
    MsgBox "ExitsInArrayLento " & vStr$ & vbCrLf & _
           "ExitsInArray " & l
End Sub
 
 
Public Function ExitsInArray(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean
Dim lng_lb                      As Long
Dim lng_Ub                      As Long
    lng_lb = LBound(vBuff&())
    lng_Ub = UBound(vBuff&())
    If vBuff&(lng_Ub) > vBuff&(lng_lb) Then
        ExitsInArray = ExitsInArrayR(vValue, vBuff&, lng_lb, lng_Ub, p)
    Else
        ExitsInArray = ExitsInArrayR(vValue, vBuff&, lng_Ub, lng_lb, p)
    End If
End Function
 
Public Function ExitsInArrayR(ByRef vValue As Long, ByRef vBuff() As Long, ByVal l As Long, ByVal u As Long, ByRef p As Long) As Boolean
    Select Case vValue
        Case vBuff&(l&)
            p& = l&
            ExitsInArrayR = True
        Case vBuff&(u&)
            p& = u&
            ExitsInArrayR = True
        Case Else
            p = (l& + u&) / 2
            If p <> l& And p& <> u& Then
                If vBuff&(p&) < vValue& Then
                    ExitsInArrayR = ExitsInArrayR(vValue, vBuff&(), p, u, p)
                ElseIf vBuff&(p&) > vValue& Then
                    ExitsInArrayR = ExitsInArrayR(vValue, vBuff&(), l, p, p)
                ElseIf vBuff&(p&) = vValue& Then
                    ExitsInArrayR = True
                End If
            End If
    End Select
End Function
 
 
 
Public Function ExitsInArrayNR(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean
Dim lng_lb                      As Long
Dim lng_Ub                      As Long
    lng_lb = LBound(vBuff&())
    lng_Ub = UBound(vBuff&())
    If Not vBuff&(lng_Ub) > vBuff&(lng_lb) Then
        Dim t                           As Long
        t = lng_Ub
        lng_Ub = lng_lb
        lng_lb = t
    End If
    Do Until ExitsInArrayNR
        Select Case vValue
            Case vBuff&(lng_lb&)
                p& = lng_lb&
                ExitsInArrayNR = True
            Case vBuff&(lng_Ub&)
                p& = lng_Ub&
                ExitsInArrayNR = True
            Case Else
                p = (lng_lb& + lng_Ub&) / 2
                If p <> lng_lb& And p& <> lng_Ub& Then
                    If vBuff&(p&) < vValue& Then
                        lng_lb = p
                    ElseIf vBuff&(p&) > vValue& Then
                        lng_Ub = p
                    ElseIf vBuff&(p&) = vValue& Then
                        ExitsInArrayNR = True
                    End If
                Else
                    Exit Do
                End If
        End Select
    Loop
End Function
 
Private Function ExitsInArrayLento(ByRef Value As Long, ByRef ArrayCollection() As Long, Optional ByRef OutInIndex As Long) As Boolean
    For OutInIndex = LBound(ArrayCollection) To UBound(ArrayCollection)
        If ArrayCollection(OutInIndex) = Value Then
            ExitsInArrayLento = True
            Exit Function
        End If
    Next
End Function
 
 

Temibles Lunas!¡.
.

.
Que pasen una velada agradable 

Temibles Noches!¡.
.

.
Este UC lo vengo haciendo en pocos ratos que tengo, esta realizado con las APIS GDI, aun no esta optimisado, pero ya esta funcional,

Importante: La programacion de los eventos como MouseDown estan bajo los mensajes de windows, ya que si se ponen bajo los eventos del UC salen errores como "Expresion demasiado compleja"

* ListView colorido.
* Seleccion con Click + Control
* ScrollGhost (Funciona al mantener pulsado el mouse sobre alguna de las 4 regiones disponibles)
* QuickSort como motor de Ordenacion.
* tengo weba de escribir las demas Funciones... asi que veanlo...
*- Seleccion con Shift aun no agregado.
*-Aun no tiene soporte para iconos (despues lo agrego).

http://infrangelux.hostei.com/?option=com_content&view=article&id=22:src-uc-listviewex&catid=13:controlesdeusuario&Itemid=21&

algunas imagenes...





Temibles Lunas!¡.

.
Bueno ando con un rollo en el vb6 y es que ando creando un UC ( ya tiene mucho que llevo con esto pero no he tenido mucho tiempo para terminarlo ), mi problema es que en el UC resivo los mensajes con GetMessage y los dejo fluir con DispatchMessage pero he aqui el problema en DispatchMessage cundo termino el form donde tengo el UC se queda todo el programa en dicha linea y por esta linea no se puede cerrar el programa o form en cuestion.

En pocas palabras una alternativa a estas apis cual seria?, las he usado por que estas no me traban de forma innesesaria el programa, en cambio PeekMessage tengo que hacer un Bucle pero este a diferencia de las otras dos apis se le escapan mensajes, por ende no me sirve ademas que tengo que ponerle doevents y cosillas dentro del bucle para que no se coma el procesador.

Este es el codigo, lo programe para que dejara de procesar mensajes si le llegan los mensajes WM_CLOSE o WM_DESTROY, pero esto no me gusta mucho que digamos.

 
'   //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //
'   //  El Objetivo de este proceso es que el Control de Usuario sea Maleable,
'   //  de igual forma por que lo pienso pasar a C++ y esto me ayudara despues,
'   //  se que aqui no se tratan los mensajes si no mas bien en el Callback
'   //  WindProc() pero bueno, es solo una obtativa para vb6 de forma cutre
'   //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //
'   //  ----------------------------------------------------------------------  //
'   //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //
'   //  No es la manera mas Ortodoxa pero asi me evito usar TODO el Procesador...
'   //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //  //
 
Private Sub ProcessMessages()
Dim vMsg                                As Msg
Dim bool_MsgCancel                      As Boolean
Dim Button                              As Integer
Dim tPoint                              As POINTAPI
Dim Shift                               As Integer
 
    bool_MsgCancel = False
 
    Do While GetMessage(vMsg, 0, 0, 0) And bool_MsgCancel = False
        If vMsg.hwnd = UserControl.hwnd Or _
           vMsg.hwnd = VS.hwnd Or _
           vMsg.hwnd = HS.hwnd Then
 
            Select Case vMsg.message
 
                '   //  Mensajes del Mouse
                Case WM.WM_MOUSEWHEEL, WM.WM_MOUSEMOVE, _
                     WM.WM_LBUTTONDBLCLK, WM.WM_LBUTTONDOWN, WM.WM_LBUTTONUP, _
                     WM.WM_RBUTTONDBLCLK, WM.WM_RBUTTONDOWN, WM.WM_RBUTTONUP, _
                     WM.WM_MBUTTONDBLCLK, WM.WM_MBUTTONDOWN, WM.WM_MBUTTONUP
 
                    tPoint = GetCursorRegion
 
                    If vMsg.wParam = MK.MK_CONTROL Then
                        Shift = 2
                    ElseIf vMsg.wParam = MK.MK_SHIFT Then
                        Shift = 1
                    Else
                        Shift = 0
                    End If
 
                    Select Case vMsg.message
                        Case WM.WM_MOUSEWHEEL
                            Debug.Print "WM_MOUSEWHEEL"
                            If vMsg.wParam < 0 Then
                                If (DatosScrollGhost(1).Visible Or VS.Visible) Then
                                    Scroll_V = Priv_SV + int_hRow
                                End If
                            Else
                                If (DatosScrollGhost(0).Visible Or VS.Visible) Then
                                    Scroll_V = Priv_SV - int_hRow
                                End If
                            End If
 
                        Case WM.WM_LBUTTONDBLCLK
                            Debug.Print "WM_LBUTTONDBLCLK"
                            Call lvDblClick
                        Case WM.WM_RBUTTONDBLCLK
                            Debug.Print "WM_RBUTTONDBLCLK"
                            Call lvDblClick
                        Case WM.WM_MBUTTONDBLCLK
                            Debug.Print "WM_MBUTTONDBLCLK"
                            Call lvDblClick
 
                        Case WM.WM_LBUTTONDOWN
                            Debug.Print "WM_LBUTTONDOWN"
                            Button = 1
                            Call lvMouseDown(Button, Shift, tPoint.X, tPoint.Y)
                        Case WM.WM_RBUTTONDOWN
                            Debug.Print "WM_RBUTTONDOWN"
                            Button = 2
                            Call lvMouseDown(Button, Shift, tPoint.X, tPoint.Y)
                        Case WM.WM_MBUTTONDOWN
                            Debug.Print "WM_MBUTTONDOWN"
                            Button = 4
                            Call lvMouseDown(Button, Shift, tPoint.X, tPoint.Y)
 
                        Case WM.WM_LBUTTONUP, WM.WM_RBUTTONUP, WM.WM_MBUTTONUP
                            Debug.Print "WM_LBUTTONUP"
                            Call lvMouseUp(Button, Shift, tPoint.X, tPoint.Y)
                            Call lvClick
                            Button = 0
 
                        Case WM.WM_MOUSEMOVE
                            Debug.Print "WM_MOUSEMOVE"
                            Call lvMouseMove(Button, Shift, tPoint.X, tPoint.Y)
 
                    End Select
 
                '   //  Teclas Pulsadas...
                Case WM.WM_KEYDOWN
                    Debug.Print "WM_KEYDOWN", vMsg.wParam
                    Select Case vMsg.wParam
                        Case VK.VK_UP
                            If DatosScrollGhost(0).Visible Or VS.Visible Then
                                Scroll_V = Priv_SV - int_hRow   'Priv_SV - int_hRow
                            End If
 
                        Case VK.VK_Down
                            If DatosScrollGhost(1).Visible Or VS.Visible Then
                                Scroll_V = Priv_SV + int_hRow   'Priv_SV + int_hRow
                            End If
 
                        Case VK.VK_Left
                            If DatosScrollGhost(3).Visible Or HS.Visible Then
                                Scroll_H = Priv_SH - 20   'Priv_SH - 20
                            End If
 
                        Case VK.VK_RIGHT
                            If DatosScrollGhost(3).Visible Or HS.Visible Then
                                Scroll_H = Priv_SH + 20   'Priv_SH + 20
                            End If
 
                        Case VK.VK_HOME
                            Scroll_V = 0
 
                        Case VK.VK_END
                            If RowVisibleCount < CantRows Then
                                Scroll_V = (CantRows * int_hRow) - (RectLista.Bottom - RectLista.Top)
                            End If
 
                        Case VK.VK_SHIFT
                            cAoDSS = True
                            Shift = 1
 
                        Case VK.VK_CONTROL
                            cAoDSC = True
                            Shift = 2
 
                        Case VK.VK_PRIOR
                            Scroll_V = Priv_SV - RowVisibleCount * int_hRow
 
                        Case VK.VK_NEXT
                            Scroll_V = Priv_SV + RowVisibleCount * int_hRow
 
                    End Select
                    RaiseEvent KeyDown(Int(vMsg.wParam), Shift)
 
                Case WM.WM_KEYUP
                    Debug.Print "WM_KEYUP", vMsg.wParam
                    Select Case vMsg.wParam
                        Case VK.VK_SHIFT
                            cAoDSS = False
                            Shift = 0
 
                        Case VK.VK_CONTROL
                            cAoDSC = False
                            Shift = 0
                    End Select
                    RaiseEvent KeyUp(Int(vMsg.wParam), Shift)
                    RaiseEvent KeyPress(Int(vMsg.wParam))
 
                '   //  Mesajes de la Ventana
                Case WM.WM_ACTIVATE
                    Debug.Print "WM_ACTIVATE"
 
                Case WM.WM_CLOSE, WM.WM_DESTROY
                    Debug.Print "WM_CLOSE", "WM_DESTROY"
                    bool_MsgCancel = True
                    Exit Sub
 
                Case WM.WM_PAINT
                    If vMsg.wParam = 0 Then
                        Call Refresh
                    Else
                        Call RefreshCols(vMsg.lparam)
                    End If
 
                Case WM.WM_ENABLE
                    'wParam
                    '   Indicates whether the window has been enabled or disabled. This parameter is TRUE if the window has been enabled or FALSE if the window has been disabled.
                    'lparam
                    '   This parameter is not used.
                    Debug.Print "WM_ENABLE"
 
                Case Else
 
            End Select
 
        End If
        Call DispatchMessage(vMsg)
        'Call WaitMessage
    Loop
End Sub
 
 

P.D.: Que no sea por subclasificación... aun que si no tengo otra opcion...

Temibles Lunas!¡.

.
Linkear libreria     GDI32

Esto solo es una traduccion de VB6 a C++

Que hace? Solo dibuja miles de lineas aleatoriamente de distintos colores en el monitor ignorando todo ( o casi todo ).

Codigo Original:

(GDI32) Lineas Aleatorias On The Fly

https://foro.elhacker.net/programacion_visual_basic/lineas_al_aire-t281968.0.html;msg1389871#msg1389871

Este codigo trae corregido algunos errores que cometi en vb6... nada graves (el mi blog ya estan corregidos por obvias razones)

Codigo:

 
////////////////////////////////////////////////////////////////
// Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
//                                                            //
// Web: http://InfrAngeluX.Sytes.Net/                         //
//                                                            //
// |-> Pueden Distribuir Este Código siempre y cuando         //
// no se eliminen los créditos originales de este código      //
// No importando que sea modificado/editado o engrandecido    //
// o achicado, si es en base a este código                    //
////////////////////////////////////////////////////////////////
 
#include<iostream>
#include<windows.h>
 
using namespace std;
 
struct tLineas
{
    POINT PuntoIni;
    POINT PuntoEnd;
} *PtLineas;
 
 
HDC     HDC_dest;
RECT    RECT_wmonitor;
 
UINT NumeroAleatorio(UINT *l,UINT *u);
UINT NumeroAleatorio(UINT *l,UINT u);
UINT NumeroAleatorio(UINT l,UINT *u);
UINT NumeroAleatorio(UINT l,UINT u);
 
void Swap(UINT *l,UINT *u);
void Swap(UINT *l,UINT u);
void Swap(UINT l,UINT *u);
void Swap(UINT l,UINT u);
 
VOID CALLBACK TimerProc(HWND, UINT, UINT_PTR, DWORD);
VOID ProcessMessages();
 
int main()
{
 
    HDC_dest                = GetDC( NULL );
    SetTimer ( NULL , 0 , 10 , (TIMERPROC)TimerProc );
    ProcessMessages();
    ReleaseDC ( NULL , HDC_dest );
    return (1);
}
 
void Swap(UINT *l,UINT *u)
{
    UINT Ptmp = *l;
    *l = *u;
    *u = Ptmp;
}
 
UINT NumeroAleatorio(UINT l,UINT u)
{
    if ( l > u)
        Swap( &l , &u );
    return ( rand()%(u-l+1)+l );
}
 
VOID CALLBACK TimerProc(HWND hwnd,UINT uMsg,UINT_PTR idEvent,DWORD dwTime)
{
    tLineas     Linea;
    HPEN        hPen;
 
    RECT_wmonitor.bottom    = GetSystemMetrics( 1 );
    RECT_wmonitor.left      = 1;
    RECT_wmonitor.right     = GetSystemMetrics( 0 );
    RECT_wmonitor.top       = 1;
 
    Linea.PuntoIni.x = NumeroAleatorio((UINT)RECT_wmonitor.left,(UINT)RECT_wmonitor.right);
    Linea.PuntoIni.y = NumeroAleatorio((UINT)RECT_wmonitor.top,(UINT)RECT_wmonitor.bottom);
    Linea.PuntoEnd.x = NumeroAleatorio((UINT)RECT_wmonitor.left,(UINT)RECT_wmonitor.right);
    Linea.PuntoEnd.y = NumeroAleatorio((UINT)RECT_wmonitor.top,(UINT)RECT_wmonitor.bottom);
 
    hPen = CreatePen(0, 1, (COLORREF)NumeroAleatorio((UINT)0,(UINT)3000000));
    DeleteObject(SelectObject(HDC_dest, hPen));
    Ellipse (HDC_dest, Linea.PuntoIni.x - 2, Linea.PuntoIni.y - 2, Linea.PuntoIni.x + 2, Linea.PuntoIni.y + 2);
    Ellipse (HDC_dest, Linea.PuntoEnd.x - 2, Linea.PuntoEnd.y - 2, Linea.PuntoEnd.x + 2, Linea.PuntoEnd.y + 2);
    DeleteObject(hPen);
    hPen = CreatePen(0, 1, (COLORREF)NumeroAleatorio((UINT)0,(UINT)3000000));
    DeleteObject(SelectObject(HDC_dest, hPen));
    MoveToEx (HDC_dest, Linea.PuntoIni.x, Linea.PuntoIni.y, NULL);
    LineTo (HDC_dest, Linea.PuntoEnd.x, Linea.PuntoEnd.y);
    DeleteObject (hPen);
}
 
VOID ProcessMessages()
{
    MSG msg;
    while (GetMessage(&msg, NULL, NULL, NULL) != -1)
        DispatchMessage(&msg);
}
 
 

Temibles Lunas!¡.

.
Bueno le he estado buscando como salvaje desde hace tiempo a como linkeo en en IDE QT de NOKIA ( mingw ), no le encuentro las opciones para linkear librerias externas... y con el #PRAGMA ... me lo bota me dice que lo ha ignorado y a causa de esto me bota errores... caso omiso en VC++ o en CodeBlocks-10.05( que trae el mismo mingw y aquí no me da errores... pero quiero que funcione en el IDE de QT, ya que me parece muy bueno  por su Debugger que trae. ).

Dulces Lunas!¡.

.
El siguiente codigo me carga el maximo indice que es 1 cuando yo se que es 2000... cual es mi error?

 
 int *arreglo = new int[];
 int i = 2000;
 arreglo = (int*) malloc (i * sizeof(int));
 ::cout << ubound(arreglo) << ::endl;
 free(arreglo);
 getchar();
 
 

Codigo de Ubound()

 
unsigned long __stdcall ubound (int *arr) {
 return(sizeof(arr) / sizeof(arr[0]));
}
 
 

Dulce Lunas!¡.

Lh: No hagas doble post. Utiliza el botón modificar.

.
Despues de mucho probar y probar di con la solucion...

 
#define ubound(arr) ((sizeof(arr))/(sizeof(*arr)))
 
 

Dulce Infierno Lunar!¡.

.
Lo subi porque si lo ponia aqui como publicación sencillamente se pasa de los 100000 caracteres permitidos... ademas de que es muuuuuuy largo...

Descargar APIDirectX 8
http://infrangelux.sytes.net/FileX/index.php?dir=/BlackZeroX/Programacion/vb6/DirectX/8

Dulce Infierno Lunar!¡.

.
El siguiente codigo me costo un Ojo de la cara... es para convertir cualquier Numero a Texto Plano. lo hice por Hobby mas que por nesesidad, espero le saquen provecho!¡.

Como maximo mumero que puede leer son es: 999999999999999999999999999999

Novecientos noventa y nueve Octillónes novecientos noventa y nueve Sextillónes novecientos noventa y nueve Quintillónes novecientos noventa y nueve Cuatrillónes novecientos noventa y nueve Trillones novecientos noventa y nueve Billones novecientos noventa y nueve Mil novecientos noventa y nueve Millones novecientos noventa y nueve Mil novecientos noventa y nueve

Billon          10^12       <--( 5 ).
Trillon         10^18       <--( 4 ).
Cuatrillón      10^24       <--( 3 ).
Quintillón      10^30       <--( 2 ).
Sextillón       10^36       <--( 1 ).
Octillón        10^42       <--( 0 ).
<--Obviamente Los siguientes numeros no los tomaremos en cuenta-->
Gúgol           10^100      <--(-1 ).
Googolplex      10^10^Gúgol <--(-2 ).


http://infrangelux.sytes.net/Blog/index.php?option=com_content&view=article&id=8:arrtnum2string&catid=2:catprocmanager&Itemid=8

'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandecido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
Public Function Number2String(ByVal VInNumber As String) As String
'   //  Meximo  --> 999999999999999999999999999999 ' sección Octillón...
'   //  Billon          10^12       <--( 5 ).
'   //  Trillon         10^18       <--( 4 ).
'   //  Cuatrillón      10^24       <--( 3 ).
'   //  Quintillón      10^30       <--( 2 ).
'   //  Sextillón       10^36       <--( 1 ).
'   //  Octillón        10^42       <--( 0 ).
'   //  <--Obviamente Los siguientes numeros no los tomaremos en cuenta-->
'   //  Gúgol           10^100      <--(-1 ).
'   //  Googolplex      10^10^Gúgol <--(-2 ).
Dim Str_Temp                            As String
Dim Byt_Index                           As Byte
Dim Byt_Digito                          As Byte
Dim Byt_Centena                         As Byte
Dim Byt_Decena                          As Byte
Dim Byt_Unidad                          As Byte
Dim Str_Leyenda                         As String
Dim lng_LenStr                          As Long
Const clng_MaxLen = &H1E
 
    lng_LenStr = Len(VInNumber)
    If lng_LenStr > clng_MaxLen Or lng_LenStr = 0 Then Exit Function
    Str_Temp = String$(clng_MaxLen, "0")
    Mid(Str_Temp, clng_MaxLen - lng_LenStr + 1) = Mid$(VInNumber, 1, lng_LenStr)
 
    For Byt_Index = 1 To clng_MaxLen / 3
 
        Byt_Centena = CByte(Mid$(Str_Temp, Byt_Index * 3 - 2, 1))
        Byt_Decena = CByte(Mid$(Str_Temp, Byt_Index * 3 - 1, 1))
        Byt_Unidad = CByte(Mid$(Str_Temp, Byt_Index * 3, 1))
 
        Select Case Byt_Index
            Case 1
                If Byt_Centena + Byt_Decena = 0 And Byt_Unidad = 1 Then
                    Str_Leyenda = "Octillón "
                ElseIf Byt_Centena > 0 Or Byt_Decena > 0 Or Byt_Unidad > 1 Then
                    Str_Leyenda = "Octillónes "
                End If
            Case 2
                If Byt_Centena + Byt_Decena = 0 And Byt_Unidad = 1 Then
                    Str_Leyenda = "Sextillón "
                ElseIf Byt_Centena > 0 Or Byt_Decena > 0 Or Byt_Unidad > 1 Then
                    Str_Leyenda = "Sextillónes "
                End If
            Case 3
                If Byt_Centena + Byt_Decena = 0 And Byt_Unidad = 1 Then
                    Str_Leyenda = "Quintillón "
                ElseIf Byt_Centena > 0 Or Byt_Decena > 0 Or Byt_Unidad > 1 Then
                    Str_Leyenda = "Quintillónes "
                End If
            Case 4
                If Byt_Centena + Byt_Decena = 0 And Byt_Unidad = 1 Then
                    Str_Leyenda = "Cuatrillón "
                ElseIf Byt_Centena > 0 Or Byt_Decena > 0 Or Byt_Unidad > 1 Then
                    Str_Leyenda = "Cuatrillónes "
                End If
            Case 5
                If Byt_Centena + Byt_Decena = 0 And Byt_Unidad = 1 Then
                    Str_Leyenda = "Trillon "
                ElseIf Byt_Centena > 0 Or Byt_Decena > 0 Or Byt_Unidad > 1 Then
                    Str_Leyenda = "Trillones "
                End If
            Case 6
                If Byt_Centena + Byt_Decena = 0 And Byt_Unidad = 1 Then
                    Str_Leyenda = "Billón "
                ElseIf Byt_Centena > 0 Or Byt_Decena > 0 Or Byt_Unidad > 1 Then
                    Str_Leyenda = "Billones "
                End If
            Case 7
                If Byt_Centena + Byt_Decena + Byt_Unidad >= 1 And Val(Mid$(Str_Temp, 21, 3)) = 0 Then
                    Str_Leyenda = "Mil Millones "
                ElseIf Byt_Centena + Byt_Decena + Byt_Unidad >= 1 Then
                    Str_Leyenda = "Mil "
                End If
            Case 8
                If Byt_Centena + Byt_Decena = 0 And Byt_Unidad = 1 Then
                    Str_Leyenda = "Millón "
                ElseIf Byt_Centena > 0 Or Byt_Decena > 0 Or Byt_Unidad > 1 Then
                    Str_Leyenda = "Millones "
                End If
            Case 9
                If Byt_Centena + Byt_Decena + Byt_Unidad >= 1 Then Str_Leyenda = "Mil "
            Case 10
                If Byt_Centena + Byt_Decena + Byt_Unidad >= 1 Then Str_Leyenda = ""
        End Select
        Number2String = Number2String + Centena(Byt_Unidad, Byt_Decena, Byt_Centena) + Decena(Byt_Unidad, Byt_Decena) + Unidad(Byt_Unidad, Byt_Decena) + Str_Leyenda
        Str_Leyenda = ""
    Next
 
End Function
 
Private Function Centena(ByVal Byt_Uni As Byte, ByVal Byt_Decimal As Byte, ByVal Byt_Centena As Byte) As String
    Select Case Byt_Centena
        Case 1: If Byt_Decimal + Byt_Uni = 0 Then Centena = "cien " Else Centena = "ciento "
        Case 2: Centena = "doscientos "
        Case 3: Centena = "trescientos "
        Case 4: Centena = "cuatrocientos "
        Case 5: Centena = "quinientos "
        Case 6: Centena = "seiscientos "
        Case 7: Centena = "setecientos "
        Case 8: Centena = "ochocientos "
        Case 9: Centena = "novecientos "
    End Select
End Function
 
Private Function Decena(ByVal Byt_Uni As Byte, ByVal Byt_Decimal As Byte) As String
    Select Case Byt_Decimal
        Case 1
            Select Case Byt_Uni
                Case 0: Decena = "diez "
                Case 1: Decena = "once "
                Case 2: Decena = "doce "
                Case 3: Decena = "trece "
                Case 4: Decena = "catorce "
                Case 5: Decena = "quince "
                Case 6 To 9: Decena = "dieci "
            End Select
        Case 2
            If Byt_Uni = 0 Then
                Decena = "veinte "
            ElseIf Byt_Uni > 0 Then
                Decena = "veinti "
            End If
        Case 3: Decena = "treinta "
        Case 4: Decena = "cuarenta "
        Case 5: Decena = "cincuenta "
        Case 6: Decena = "sesenta "
        Case 7: Decena = "setenta "
        Case 8: Decena = "ochenta "
        Case 9: Decena = "noventa "
    End Select
    If Byt_Uni > 0 And Byt_Decimal > 2 Then Decena = Decena + "y "
End Function
 
Private Function Unidad(ByVal Byt_Uni As Byte, ByVal Byt_Decimal As Byte) As String
    If Byt_Decimal <> 1 Then
        Select Case Byt_Uni
            Case 1: Unidad = "un "
            Case 2: Unidad = "dos "
            Case 3: Unidad = "tres "
            Case 4: Unidad = "cuatro "
            Case 5: Unidad = "cinco "
        End Select
    End If
    Select Case Byt_Uni
            Case 6: Unidad = "seis "
            Case 7: Unidad = "siete "
            Case 8: Unidad = "ocho "
            Case 9: Unidad = "nueve "
    End Select
End Function
 
 

Dulce Infierno Lunar!¡.

.
Solo invierte los ejeus del mouse es decir si van para arrba iran para abajo y biceversab es lo mismo si van a la derecha se ira a la izquierda y biceversa.

OJO: Sustitui las Estructuras (PointAPI) por Arrays de Long para reducir mas el codigo xD

http://infrangelux.sytes.net/blog/index.php/component/content/article/5-hooks/2-srcinvertejesmouse.html
http://visual-coders.herobo.com/blog/?p=274

 
'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandecido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
Option Explicit
 
Public Const WH_MOUSE_LL = 14
Public Const WM_MOUSEMOVE = &H200
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long)
 
Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
 
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 
Private Ant_PosCur(0 To 1)              As Long
Private lng_HookProc                    As Long
Private Boo_Switch                      As Boolean
 
Public Sub InvertirMouse()
    If lng_HookProc = 0& Then
        Boo_Switch = False
        lng_HookProc = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, App.hInstance, 0)
    End If
End Sub
 
Public Sub DetenerInvertirMouse()
    If lng_HookProc Then
        Call UnhookWindowsHookEx(lng_HookProc)
        lng_HookProc = 0&
    End If
End Sub
 
Private Function MouseProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim Struc_PT(0 To 1)                    As Long
Dim lng_Index                           As Long
 
    If wParam = WM_MOUSEMOVE And Not Boo_Switch Then
 
        Boo_Switch = True
 
        Call CopyMemory(ByVal VarPtr(Struc_PT(0)), ByVal lParam, 8)
 
        For lng_Index = 0 To 1
            If Not Struc_PT(lng_Index) = Ant_PosCur(lng_Index) _
                And Ant_PosCur(lng_Index) > 0 _
                And Ant_PosCur(lng_Index) <= GetSystemMetrics(lng_Index) Then
                If Struc_PT(lng_Index) < Ant_PosCur(lng_Index) Then
                    Struc_PT(lng_Index) = Struc_PT(lng_Index) + ((Ant_PosCur(lng_Index) - Struc_PT(lng_Index)) * 2)
                ElseIf Struc_PT(lng_Index) > Ant_PosCur(lng_Index) Then
                    Struc_PT(lng_Index) = Struc_PT(lng_Index) - ((Struc_PT(lng_Index) - Ant_PosCur(lng_Index)) * 2)
                End If
            End If
        Next
 
        Call SetCursorPos(Struc_PT(0), Struc_PT(1))
        Call CopyMemory(ByVal VarPtr(Ant_PosCur(0)), ByVal VarPtr(Struc_PT(0)), 8)
        'Call CopyMemory(ByVal lParam, ByVal VarPtr(Struc_PT(0)), 8)    '   //  Esto solo actuyaliza lParam
 
        Boo_Switch = False
        MouseProc = &H1 '   //  CallNextHookEx(lng_HookProc, idHook, wParam, lParam)   '   //  Si dejo pasar ignorara la nueva posición...
    Else
        MouseProc = CallNextHookEx(lng_HookProc, idHook, wParam, lParam)
    End If
 
End Function 
 
 

Dulce Infierno Lunar!¡.