Jump to content
Sign in to follow this  
Alonso Ojeda

Combobox depedientes con descarga en listbot

Recommended Posts

Buenas, tengo una base de datos con 4 columnas que utilizo para reproducir música, la columna A=están los cantantes, en B= las canciones, en C=Los géneros y D=la dirección de la canción. realice un formulario con dos combobox dependiente, en el primero la lista es de la Columna C=(Géneros), al abrir escojo el genero y el 2do. me Trae la Columma A=Los Cantantes, una vez seleccionado el cantante en el listbox se me descarga todas las canciones de este. y selecciono y empieza a sonar. En el 1er. combobox el me trae los valores sin repetidos, pero no consigo un código que el 2do. haga lo mismo. este es el código que utilizo:

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const GWL_STYLE As Long = (-16)
Public dir

 

Private Sub CboGen_Change()
Dim fila As Integer
Dim uf As Integer
Dim d1, d2 As String
fila = 5
uf = RegMu.Range("A" & Rows.Count).End(xlUp).Row
CboArt.Clear
While RegMu.Cells(fila, 3) <> Empty
d1 = CboGen
d2 = RegMu.Cells(fila, 3)
If d1 = d2 Then
CboArt.AddItem RegMu.Cells(fila, 1)
End If
fila = fila + 1
Wend
End Sub


Private Sub CboArt_Change()
Application.ScreenUpdating = False
Dim fila, a As Integer
Dim dato, var As String
ListCanc.Clear
ListCanc.ColumnCount = 1

a = 0
fila = 5
While RegMu.Cells(fila, 1) <> Empty
      dato = CboArt
  var = RegMu.Cells(fila, 1)
   If var = dato Then
        dir = RegMu.Cells(fila, 1).Address(False, False)
        a = ListCanc.ListCount
        ListCanc.AddItem
        ListCanc.List(a, 0) = RegMu.Cells(fila, 2)
   End If
fila = fila + 1
Wend
Application.ScreenUpdating = True
End Sub


Private Sub ListCanc_Click()
Dim Cuenta As Integer
Dim Rango As Range
Dim I As Integer
Dim Valor As String
Dim fila As Integer
RegMu.Select
Range("A6").Activate
Cuenta = Me.ListCanc.ListCount
fila = 6
Set Rango = Range("A6").CurrentRegion

For I = 0 To Cuenta - 1

If Me.ListCanc.Selected(I) Then

Valor = Me.ListCanc.List(I)

Rango.Find(What:=Valor, LookAt:=xlWhole, After:=ActiveCell).Activate
ActiveCell.Offset(0, 2).Select
End If
Next I
FrmRegMus.WindowsMediaPlayer1.URL = ActiveCell.Value
End Sub


Private Sub UserForm_Activate()
    Dim lngMyHandle As Long, lngCurrentStyle As Long, lngNewStyle As Long
    If Application.Version < 9 Then
        lngMyHandle = FindWindow("THUNDERXFRAME", Me.Caption)
    Else
        lngMyHandle = FindWindow("THUNDERDFRAME", Me.Caption)
    End If
    lngCurrentStyle = GetWindowLong(lngMyHandle, GWL_STYLE)
    lngNewStyle = lngCurrentStyle Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
    SetWindowLong lngMyHandle, GWL_STYLE, lngNewStyle
End Sub


Private Sub UserForm_Initialize()
Dim sd As New Collection
Dim celda As Range
Dim dato As String
Dim r As String
Dim uf As Integer
Application.ScreenUpdating = False
On Error Resume Next
CboGen.Clear
RegMu.Select
Range("C6").Select
uf = Range("C" & Rows.Count).End(xlUp).Row
r = "C6:C" & uf
For Each celda In Range(r)
sd.Add celda.Value, CStr(celda.Value)
Next celda
For Each dato In sd
CboGen.AddItem dato
Next dato
Application.ScreenUpdating = True
End Sub
 

Share this post


Link to post
Share on other sites
Guest
This topic is now closed to further replies.
Sign in to follow this  



  • Si estás experimentando errores al acceder al foro, te recomendamos que modifiques la contraseña desde aquí (haciendo clic en el enlace "¿Olvidaste tu contraseña?").

    Próximamente  habrá mejoras en la web y es necesario cambiar la contraseña para acceder a los nuevos contenidos.

    Disculpa las molestias.

  • Recently Browsing

    No registered users viewing this page.

  • Latest Best Answers

×
×
  • Create New...

Important Information

Privacy Policy