Buscar

Email Elinv.
Búsqueda personalizada

lunes, 31 de marzo de 2014

Visual Basic 6.0 - Otra forma de conseguir sacar los duplicados y elementos nulos o vacíos de un array o matriz. Presentado por Elinv.


Elinv y visual basic net
visual basic for, for visual basic,visual basic 6,
visual basic 6.0,que es visual basic 6.0,visual basic 2008,
visual basic tutorial,visual basic express,microsoft visual basic,
visual basic studio 2008,visual basic 2005,visual basic,descargar

'Utilizando el Bloc de Notas, crea un archivo "Form1.frm" y pone en su interior el siguiente código.
'Integre todo a un proyecto Visual Basic 6.0 y pruébese.
'-------------------------------------------------------
VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H0000C0C0&
   Caption         =   "Form1"
   ClientHeight    =   5610
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   7815
   LinkTopic       =   "Form1"
   ScaleHeight     =   5610
   ScaleWidth      =   7815
   StartUpPosition =   3  'Windows Default
   Begin VB.ListBox List3 
      Height          =   4155
      Left            =   5160
      TabIndex        =   5
      Top             =   480
      Width           =   2175
   End
   Begin VB.ListBox List2 
      Height          =   4155
      Left            =   2760
      TabIndex        =   2
      Top             =   480
      Width           =   2175
   End
   Begin VB.ListBox List1 
      Height          =   4155
      Left            =   360
      TabIndex        =   1
      Top             =   480
      Width           =   2175
   End
   Begin VB.CommandButton Command1 
      BackColor       =   &H00FF0000&
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   3240
      Style           =   1  'Graphical
      TabIndex        =   0
      Top             =   4920
      Width           =   1335
   End
   Begin VB.Label Label3 
      BackColor       =   &H0000C0C0&
      Height          =   255
      Left            =   5160
      TabIndex        =   6
      Top             =   240
      Width           =   2055
   End
   Begin VB.Label Label1 
      BackColor       =   &H0000C0C0&
      Height          =   255
      Left            =   360
      TabIndex        =   4
      Top             =   240
      Width           =   2055
   End
   Begin VB.Label Label2 
      BackColor       =   &H0000C0C0&
      Height          =   255
      Left            =   2760
      TabIndex        =   3
      Top             =   240
      Width           =   2055
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Command1_Click()
    'Array
    Dim Arreglo() As String
    Dim x As Integer
    'Limpiamos los Lists
    List1.Clear
    List2.Clear
    'Agregamos elementos donde hay elementos duplicados
    ReDim Arreglo(11)
    Arreglo(0) = "Ananá"
    Arreglo(1) = "Uva"
    Arreglo(2) = "Pera"
    Arreglo(3) = "Manzana"
    Arreglo(4) = "Limón"
    Arreglo(5) = "Pera"
    Arreglo(6) = "Lechuga"
    Arreglo(7) = "Naranja"
    Arreglo(8) = "Limón"
    Arreglo(9) = " "
    Arreglo(10) = "Uva"
    Arreglo(11) = "Banana"
    'cargamos los datos en el listbox
    For x = 0 To UBound(Arreglo)
        List1.AddItem Arreglo(x)
    Next x
    Label1.Caption = List1.ListCount & " elementos!"
    'Llamamos a nuestra función
    quitarDuplicadoARRAY Arreglo
    'Recorremos el array con For Each
    'la variable de la colección debe ser de tipo Variant
    Dim elemento As Variant
    'Así mostramos como queda el array
    For Each elemento In Arreglo
        'enviamos todo al listbox 2
        List2.AddItem elemento
    Next
    Label2.Caption = List2.ListCount & " elementos!"
    'Así mostramos el array sin los elementos vacíos
    For Each elemento In Arreglo
        'enviamos todo al listbox 3
        If elemento <> "" And elemento <> " " Then List3.AddItem elemento
    Next
    Label3.Caption = List3.ListCount & " elementos!"
    
End Sub

'Quitar duplicado array
Private Sub quitarDuplicadoARRAY(ByRef miArray() As String)
    'Array temporal
    Dim tempArray() As String
    Dim x As Integer, y As Integer, z As Integer
    Dim i As Integer
    For i = LBound(miArray) To UBound(miArray)
        'Redimensionamos el Array temporal y preservamos el valor
        ReDim Preserve tempArray(i)
        'Asignamos al array temporal el valor del otro array
        tempArray(i) = miArray(i)
    Next
    'Ciclo de análisis
    For x = 0 To UBound(miArray)
        z = 0
        For y = 0 To UBound(miArray)
            'Si el elemento del array es igual al array temporal
            If miArray(x) = tempArray(z) And y <> x Then
                'Entonces Eliminamos el valor duplicado
                miArray(y) = ""
            End If
            z = z + 1
        Next y
    Next x
End Sub

Private Sub Form_Load()
    Me.Caption = "Eliminar elementos duplicados de una matriz!(Elinv)"
    Command1.Caption = "Ejecutar"
End Sub

Visual Basic 6.0 - Quitar duplicados y elementos vacíos de un array o matriz. Presentado por Elinv.


Elinv y visual basic net
visual basic for, for visual basic,visual basic 6,
visual basic 6.0,que es visual basic 6.0,visual basic 2008,
visual basic tutorial,visual basic express,microsoft visual basic,
visual basic studio 2008,visual basic 2005,visual basic,descargar


'Utilizando el Bloc de Notas, crea un archivo "Form1.frm" y pone en su interior el siguiente código, luego crea otro archivo "module1.frm" y copia el código del módulo en su interior.
'Integre todo a un proyecto Visual Basic 6.0 y pruébese.
'-------------------------------------------------------

VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H0000C0C0&
   Caption         =   "Form1"
   ClientHeight    =   5610
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   7815
   LinkTopic       =   "Form1"
   ScaleHeight     =   5610
   ScaleWidth      =   7815
   StartUpPosition =   3  'Windows Default
   Begin VB.ListBox List2 
      Height          =   4155
      Left            =   4080
      TabIndex        =   2
      Top             =   480
      Width           =   3255
   End
   Begin VB.ListBox List1 
      Height          =   4155
      Left            =   360
      TabIndex        =   1
      Top             =   480
      Width           =   3255
   End
   Begin VB.CommandButton Command1 
      BackColor       =   &H00FF0000&
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   3240
      Style           =   1  'Graphical
      TabIndex        =   0
      Top             =   4920
      Width           =   1335
   End
   Begin VB.Label Label1 
      BackColor       =   &H0000C0C0&
      Height          =   255
      Left            =   360
      TabIndex        =   4
      Top             =   240
      Width           =   2055
   End
   Begin VB.Label Label2 
      BackColor       =   &H0000C0C0&
      Height          =   255
      Left            =   4080
      TabIndex        =   3
      Top             =   240
      Width           =   2055
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Command1_Click()
    'Array
    Dim Arreglo() As String
    Dim x As Integer
    'Limpiamos los Lists
    List1.Clear
    List2.Clear
    'Agregamos elementos donde hay elementos duplicados
    ReDim Arreglo(11)
    Arreglo(0) = "Ananá"
    Arreglo(1) = "Uva"
    Arreglo(2) = "Pera"
    Arreglo(3) = "Manzana"
    Arreglo(4) = "Limón"
    Arreglo(5) = "Pera"
    Arreglo(6) = "Lechuga"
    Arreglo(7) = "Naranja"
    Arreglo(8) = "Limón"
    Arreglo(9) = " "
    Arreglo(10) = "Uva"
    Arreglo(11) = "Banana"
    'cargamos los datos en el listbox
    For x = 0 To UBound(Arreglo)
        List1.AddItem Arreglo(x)
    Next x
    Label1.Caption = List1.ListCount & " elementos!"
    'Llamamos a nuestra función
    sinDuplicadoARRAY Arreglo
    'Recorremos el array con For Each
    'la variable de la colección debe ser de tipo Variant
    Dim elemento As Variant
    For Each elemento In Arreglo
        'enviamos todo al listbox 2
        List2.AddItem elemento
    Next
    Label2.Caption = List2.ListCount & " elementos!"
End Sub

'Quitar duplicado array
Private Sub sinDuplicadoARRAY(ByRef miArray() As String)
    'Array temporal
    Dim tempArray() As String
    Dim i As Integer
    For i = LBound(miArray) To UBound(miArray)
        'Redimensionamos el Array temporal y preservamos el valor
        ReDim Preserve tempArray(i)
        'Asignamos al array temporal el valor del otro array
        tempArray(i) = miArray(i)
    Next
    
    Dim ind As Integer: ind = 0
    ReDim miArray(ind)
    'Ciclo de análisis
    Dim x As Integer, y As Integer
    For x = 0 To UBound(tempArray)
        Dim existe As Boolean: existe = False
        For y = 0 To UBound(miArray)
            'Si el elemento del array temporal se encuentra en nuestro array
            If tempArray(x) = miArray(y) Then
                existe = True
            End If
        Next y
        If existe = False Then
            If tempArray(x) <> " " Then
                ReDim Preserve miArray(ind)
                miArray(ind) = tempArray(x)
                ind = ind + 1
            End If
        End If
    Next x
End Sub

Private Sub Form_Load()
    Me.Caption = "Eliminar elementos duplicados de una matriz!(Elinv)"
    Command1.Caption = "Ejecutar"
    ColorBoton Command1, vbWhite
End Sub

'-------------------------------------------------------
'En un MODULO COPIE EL SIGUIENTE CODIGO....

'Código del MODULO
'-------------------------------------------------------
Option Explicit
Private colButtons  As New Collection
Private Const KeyConst = "K"
Private Const PROP_COLOR = "SMDColor"
Private Const PROP_HWNDPARENT = "SMDhWndParent"
Private Const PROP_LPWNDPROC = "SMDlpWndProc"
Private Const GWL_WNDPROC As Long = (-4)
Private Const ODA_SELECT As Long = &H2
Private Const ODS_SELECTED As Long = &H1
Private Const ODS_FOCUS As Long = &H10
Private Const ODS_BUTTONDOWN As Long = ODS_FOCUS Or ODS_SELECTED
Private Const WM_DESTROY As Long = &H2
Private Const WM_DRAWITEM As Long = &H2B
Private Const VER_PLATFORM_WIN32_NT As Long = 2

Private Type RECT
    Left        As Long
    Top         As Long
    Right       As Long
    Bottom      As Long
End Type

Private Type SIZE
    cx          As Long
    cy          As Long
End Type

Private Type DRAWITEMSTRUCT
    CtlType     As Long
    CtlID       As Long
    itemID      As Long
    itemAction  As Long
    itemState   As Long
    hWndItem    As Long
    hDC         As Long
    rcItem      As RECT
    itemData    As Long
End Type

Private Type OSVERSIONINFO
    OSVSize         As Long
    dwVerMajor      As Long
    dwVerMinor      As Long
    dwBuildNumber   As Long
    PlatformID      As Long
    szCSDVersion    As String * 128
End Type

Private Declare Function CallWindowProc Lib "user32" _
    Alias "CallWindowProcA" _
    (ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
    lParam As DRAWITEMSTRUCT) As Long

Private Declare Function GetParent Lib "user32" _
    (ByVal hWnd As Long) As Long

Private Declare Function GetProp Lib "user32" _
    Alias "GetPropA" _
    (ByVal hWnd As Long, _
    ByVal lpString As String) As Long

Private Declare Function GetTextExtentPoint32 Lib "gdi32" _
    Alias "GetTextExtentPoint32A" _
    (ByVal hDC As Long, _
    ByVal lpSz As String, _
    ByVal cbString As Long, _
    lpSize As SIZE) As Long

Private Declare Function RemoveProp Lib "user32" _
    Alias "RemovePropA" _
    (ByVal hWnd As Long, _
    ByVal lpString As String) As Long

Private Declare Function SetProp Lib "user32" _
    Alias "SetPropA" _
    (ByVal hWnd As Long, _
    ByVal lpString As String, _
    ByVal hData As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" _
    (ByVal hDC As Long, _
    ByVal crColor As Long) As Long

Private Declare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" _
    (ByVal hWnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private Declare Function TextOut Lib "gdi32" _
    Alias "TextOutA" _
    (ByVal hDC As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal lpString As String, _
    ByVal nCount As Long) As Long

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
    (lpVersionInformation As Any) As Long


Private Function FindButton(sKey As String) As Boolean
    Dim cmdButton As CommandButton
    On Error Resume Next
    Set cmdButton = colButtons.Item(sKey)
    FindButton = (Err.Number = 0)
End Function

Private Function GetKey(hWnd As Long) As String
    GetKey = KeyConst & hWnd
End Function

Private Function ProcessButton(ByVal hWnd As Long, _
    ByVal uMsg As Long, _
    ByVal wParam As Long, _
        lParam As DRAWITEMSTRUCT, _
        sKey As String) As Long
    
    Dim cmdButton       As CommandButton
    Dim bRC             As Boolean
    Dim lRC             As Long
    Dim x               As Long
    Dim y               As Long
    Dim lpWndProC       As Long
    Dim lButtonWidth    As Long
    Dim lButtonHeight   As Long
    Dim lPrevColor      As Long
    Dim lColor          As Long
    Dim TextSize        As SIZE
    Dim sCaption        As String
    
    Const PushOffset = 2
    
    Set cmdButton = colButtons.Item(sKey)
    sCaption = cmdButton.Caption
    
    lColor = GetProp(cmdButton.hWnd, PROP_COLOR)
    lPrevColor = SetTextColor(lParam.hDC, lColor)
    
    lRC = GetTextExtentPoint32(lParam.hDC, sCaption, Len(sCaption), TextSize)
    
    lButtonHeight = lParam.rcItem.Bottom - lParam.rcItem.Top
    lButtonWidth = lParam.rcItem.Right - lParam.rcItem.Left
    
    If ((lParam.itemState And ODS_BUTTONDOWN) = ODS_BUTTONDOWN) Then
        cmdButton.SetFocus
        DoEvents
        x = (lButtonWidth - TextSize.cx + PushOffset) \ 2
        y = (lButtonHeight - TextSize.cy + PushOffset) \ 2
    Else
        x = (lButtonWidth - TextSize.cx) \ 2
        y = (lButtonHeight - TextSize.cy) \ 2
    End If
    lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
    ProcessButton = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam)
    bRC = TextOut(lParam.hDC, x, y, sCaption, Len(sCaption))
    lRC = SetTextColor(lParam.hDC, lPrevColor)
    
ProcessButton_Exit:
    Set cmdButton = Nothing
    
End Function


Private Sub RemoveForm(hWndParent As Long)
    Dim hWndButton As Long
    Dim cnt As Integer
    UnsubclassForm hWndParent
    On Error GoTo RemoveForm_Exit
    For cnt = colButtons.Count - 1 To 0 Step -1
        hWndButton = colButtons(cnt).hWnd
        
        If GetProp(hWndButton, PROP_HWNDPARENT) = hWndParent Then
            RemoveProp hWndButton, PROP_COLOR
            RemoveProp hWndButton, PROP_HWNDPARENT
            colButtons.Remove cnt
        End If
        
    Next cnt
RemoveForm_Exit:
End Sub

Private Function UnsubclassForm(hWnd As Long) As Boolean
    Dim lpWndProC As Long
    lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
    If lpWndProC = 0 Then
        UnsubclassForm = False
    Else
        Call SetWindowLong(hWnd, GWL_WNDPROC, lpWndProC)
        RemoveProp hWnd, PROP_LPWNDPROC
        UnsubclassForm = True
    End If
End Function


Private Function ButtonColorProc(ByVal hWnd As Long, _
    ByVal uMsg As Long, _
    ByVal wParam As Long, _
        lParam As DRAWITEMSTRUCT) As Long
    Dim lpWndProC       As Long
    Dim bProcessButton  As Boolean
    Dim sButtonKey      As String
    bProcessButton = False
    If (uMsg = WM_DRAWITEM) Then
        sButtonKey = GetKey(lParam.hWndItem)
        bProcessButton = FindButton(sButtonKey)
    End If
    If bProcessButton Then
        ProcessButton hWnd, uMsg, wParam, lParam, sButtonKey
    Else
        lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
        ButtonColorProc = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam)
        If uMsg = WM_DESTROY Then RemoveForm hWnd
    End If
End Function


Public Function ColorBoton(Button As CommandButton, _
    Forecolor As Long) As Boolean
    Dim hWndParent      As Long
    Dim lpWndProC       As Long
    Dim sButtonKey      As String
    sButtonKey = GetKey(Button.hWnd)
    If FindButton(sButtonKey) Then
        SetProp Button.hWnd, PROP_COLOR, Forecolor
        Button.Refresh
    Else
        hWndParent = GetParent(Button.hWnd)
        If (hWndParent = 0) Then
            ColorBoton = False
            Exit Function
        End If
        colButtons.Add Button, sButtonKey
        SetProp Button.hWnd, PROP_COLOR, Forecolor
        SetProp Button.hWnd, PROP_HWNDPARENT, hWndParent
        lpWndProC = GetProp(hWndParent, PROP_LPWNDPROC)
        If (lpWndProC = 0) Then
            lpWndProC = SetWindowLong(hWndParent, _
            GWL_WNDPROC, AddressOf ButtonColorProc)
            SetProp hWndParent, PROP_LPWNDPROC, lpWndProC
        End If
    End If
    ColorBoton = True
End Function


Public Function UnregisterButton(Button As CommandButton) As Boolean
    Dim hWndParent As Long
    Dim sKeyButton As String
    sKeyButton = GetKey(Button.hWnd)
    If (FindButton(sKeyButton) = False) Then
        UnregisterButton = False
        Exit Function
    End If
    hWndParent = GetProp(Button.hWnd, PROP_HWNDPARENT)
    UnregisterButton = UnsubclassForm(hWndParent)
    colButtons.Remove sKeyButton
    RemoveProp Button.hWnd, PROP_COLOR
    RemoveProp Button.hWnd, PROP_HWNDPARENT
End Function


Private Function IsWinXPPlus() As Boolean
    Dim osv As OSVERSIONINFO
    osv.OSVSize = Len(osv)
    If GetVersionEx(osv) = 1 Then
        IsWinXPPlus = (osv.PlatformID = VER_PLATFORM_WIN32_NT) And _
            (osv.dwVerMajor >= 5 And osv.dwVerMinor >= 1)
    End If
End Function

'Modo de uso
'Private Sub Form_Load()
'    ColorBoton Command1, vbWhite
'End Sub