crear lista en hoja de todas las carpetas que tiene un archivo

Hola Hector Miguel
sigue sin funcionar mi ra e probado as tabien poniendo como unidad C: y nada
-

Public fso As New FileSystemObject, Carpeta As Folder, SubCarpeta As
Folders, _
Sub_Dir As Variant, TotalCarpetas As Integer, Elemento As Integer,
_
Carpetas() As Variant, Matriz() As Variant
Sub ListarCarpetas():
Application.ScreenUpdating = False
Dim Iniciar_en As String
Iniciar_en = "C:\"
Elemento = 0: Range(ActiveCell, ActiveCell.Offset(,
1)).EntireColumn.ClearContents
ActiveCell = "Existen " & ContarCarpetas(Iniciar_en) & " subcarpetas en "
& Iniciar_en
For Elemento = 1 To UBound(Carpetas): ActiveCell.Offset(Elemento) =
Carpetas(Elemento): Next
ActiveCell.EntireColumn.AutoFit: Application.ScreenUpdating = True
End Sub

Private Function ContarCarpetas(ByVal RutaDeInicio As String) As Integer
If Right(RutaDeInicio, 1) <> "\" Then RutaDeInicio = RutaDeInicio & "\"
On Error GoTo Horrores
Set fso = CreateObject("Scripting.FileSystemObject")
Set Carpeta = fso.GetFolder(RutaDeInicio): Set SubCarpeta =
Carpeta.SubFolders
ReDim Preserve Carpetas(Elemento): Carpetas(Elemento) = Carpeta.Path
Elemento = Elemento + 1: TotalCarpetas = SubCarpeta.Count
For Each Sub_Dir In SubCarpeta
TotalCarpetas = TotalCarpetas + ContarCarpetas(RutaDeInicio &
Sub_Dir.Name)
Next
FinDeFuncion:
ContarCarpetas = TotalCarpetas
Set SubCarpeta = Nothing: Set Carpeta = Nothing: Set fso = Nothing: Exit
Function
Horrores:
Resume FinDeFuncion
End Function
-
lo de crear label es para hacer a la aplicacion mas visible que quede mejor.
encontre esta macro que es de un juego llamado (JawBreak)
que crea apartir de 5 bolas hasta 30 filas y 30 columnas te lo paso haber
que te parece.es asi +- lo que necesito lo unico añadiendo la imagen y el
texto al label.
un userfor llamado frmGame con un label llamado labMask (muy importante debe
ser transparente o tro label llamado labBackdrop
5 label llamados labCube1,labCube2,labCube3,labCube4,labCube5
-este es el
codigo--
Option Explicit
Private Const CUBEGAME_MARKERSIZE = 18 ' size of marble
Private Const CUBEGAME_WIDTH = 10 ' number of marbles across
Private Const CUBEGAME_HEIGHT = 10 ' number of marbles up
Private Const CUBEGAME_PREFIX = "labMarker_"

Private m_intMinRow As Integer
Private m_intMaxCol As Integer
Private m_intBoard(CUBEGAME_HEIGHT, CUBEGAME_WIDTH) As Integer
Private m_intPreviousBoard(CUBEGAME_HEIGHT, CUBEGAME_WIDTH) As Integer
Private m_intStartBoard(CUBEGAME_HEIGHT, CUBEGAME_WIDTH) As Integer
Private m_blnSelected(CUBEGAME_HEIGHT, CUBEGAME_WIDTH) As Boolean
Private m_intCubeRow As Integer
Private m_intCubeCol As Integer
Private m_lngScore As Long
Private m_lngPoint As Long
Private m_lngMark As Long
Private m_blnSelection As Boolean
Private m_lngColours(5) As Long
Private m_lngTempScore As Long
Private m_lngPreviousScore As Long

Private Sub m_BuildBallBoard()

Dim intRow As Integer
Dim intCol As Integer
Dim strName As String
Dim labTemp As MSForms.Label
Dim strUseName As String
Dim sngTop As Single
Dim sngLeft As Single

sngTop = labBackdrop.Top
For intRow = 0 To CUBEGAME_HEIGHT
sngLeft = 0
For intCol = 0 To CUBEGAME_WIDTH
strName = CUBEGAME_PREFIX & Format$(intRow, "00") &
Format$(intCol, "00")
Set labTemp = Controls(strName)
labTemp.Move sngLeft, sngTop, CUBEGAME_MARKERSIZE,
CUBEGAME_MARKERSIZE
strUseName = "labCube" & m_intBoard(intRow, intCol)
With Controls(strUseName)
labTemp.Tag = strUseName
labTemp.Picture = .Picture
labTemp.BackColor = QBColor(15)
labTemp.BackStyle = .BackStyle
labTemp.SpecialEffect = .SpecialEffect
End With
sngLeft = sngLeft + CUBEGAME_MARKERSIZE
Next
sngTop = sngTop + CUBEGAME_MARKERSIZE
Next
For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
strName = "labMarker_" & Format$(intRow, "00") & Format$(intCol,
"00")
Controls(strName).Visible = True
Next
Next
labMask.ZOrder
End Sub
Private Function m_GameOver() As Boolean
'
' Test remaining cubes for further moves
' if at least when then continue
' if none then game over
'
Dim intRow As Integer
Dim intCol As Integer
Dim lngCount As Long

For intCol = 0 To CUBEGAME_WIDTH
For intRow = CUBEGAME_HEIGHT To 0 Step -1
If m_intBoard(intRow, intCol) > 0 Then
lngCount = 0
m_Connection intRow, intCol, m_intBoard(intRow, intCol),
lngCount
If lngCount > 1 Then
m_GameOver = False
Exit Function
End If
m_ResetSelection
End If
Next
Next
m_GameOver = True

End Function

Private Sub m_RestartGame()

Dim intRow As Integer
Dim intCol As Integer

m_ResetScores
m_ResetSelection

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
m_intBoard(intRow, intCol) = m_intStartBoard(intRow, intCol)
Next
Next

m_UpdateBallBoard

End Sub

Private Sub m_SaveBoard()

Dim intRow As Integer
Dim intCol As Integer

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
m_intPreviousBoard(intRow, intCol) = m_intBoard(intRow, intCol)
Next
Next
m_lngPreviousScore = m_lngScore

End Sub
Private Sub m_UndoMove()

Dim intRow As Integer
Dim intCol As Integer

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
m_intBoard(intRow, intCol) = m_intPreviousBoard(intRow, intCol)
Next
Next
m_ResetSelection
m_lngScore = m_lngPreviousScore
labScore.Caption = Format(m_lngScore, "0")

m_UpdateBallBoard

End Sub

Private Sub m_UpdateBallBoard()

Dim intRow As Integer
Dim intCol As Integer
Dim strName As String
Dim labTemp As MSForms.Label
Dim strUseName As String

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
strName = CUBEGAME_PREFIX & Format$(intRow, "00") &
Format$(intCol, "00")
Set labTemp = Controls(strName)
strUseName = "labCube" & m_intBoard(intRow, intCol)
If m_intBoard(intRow, intCol) > 0 Then
With Controls(strUseName)
If labTemp.Tag <> strUseName Then
labTemp.Picture = .Picture
labTemp.BackStyle = 0
labTemp.SpecialEffect = .SpecialEffect
labTemp.Tag = strUseName
End If
End With
labTemp.BackStyle = fmBackStyleTransparent
If Not labTemp.Visible Then labTemp.Visible = True
Else
labTemp.Visible = False
End If
Next
Next
End Sub

Private Sub m_AddMarkers()

Dim intRow As Integer
Dim intCol As Integer
Dim labTemp As MSForms.Label
Dim strName As String

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
strName = CUBEGAME_PREFIX & Format$(intRow, "00") &
Format$(intCol, "00")
Set labTemp = Me.Controls.Add("Forms.Label.1", strName, False)
Next
Next

End Sub

Private Sub m_CheckSelection()
'
'
'
Dim lngCount As Long

m_ResetSelection
If m_intBoard(m_intCubeRow, m_intCubeCol) > 0 Then
m_Connection m_intCubeRow, m_intCubeCol, m_intBoard(m_intCubeRow,
m_intCubeCol), lngCount
If lngCount > 1 Then
m_blnSelection = True
m_ApplySelection
m_lngTempScore = m_PointScore(lngCount)
Else
m_blnSelection = False
End If
Else
m_blnSelection = False
End If

End Sub
Private Sub m_Connection(Row As Integer, Col As Integer, OldValue As
Integer, Count As Long)
'
' Check Current Cell is OldValue if not then quit
' Else
' set to newvalue and then check cell above
' check cell to left
' check cell below
' check cell to right
'
If m_intBoard(Row, Col) <> OldValue Then Exit Sub

m_blnSelected(Row, Col) = True
Count = Count + 1

If Row > m_intMinRow Then
' check above
If Not m_blnSelected(Row - 1, Col) Then
m_Connection Row - 1, Col, OldValue, Count
End If
End If

If Col < m_intMaxCol Then
' check to right
If Not m_blnSelected(Row, Col + 1) Then
m_Connection Row, Col + 1, OldValue, Count
End If
End If

If Row < CUBEGAME_HEIGHT Then
' check below
If Not m_blnSelected(Row + 1, Col) Then
m_Connection Row + 1, Col, OldValue, Count
End If
End If

If Col > 0 Then
' check to left
If Not m_blnSelected(Row, Col - 1) Then
m_Connection Row, Col - 1, OldValue, Count
End If
End If

End Sub
Private Sub m_CreateBoard()

Dim intRow As Integer
Dim intCol As Integer
Dim intMarker As Integer

Randomize
For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
intMarker = Int((Rnd() * 5) + 1)
m_intBoard(intRow, intCol) = intMarker
m_intStartBoard(intRow, intCol) = intMarker
Next
Next

End Sub

Private Sub m_NewGame()

m_intMinRow = 0
m_intMaxCol = CUBEGAME_WIDTH

m_ResizeBoard
m_ResetScores
m_CreateBoard

m_BuildBallBoard

m_blnSelection = False
Me.MousePointer = fmMousePointerDefault

End Sub
Private Function m_PointScore(Count As Long) As Long

If Count = 0 Then
m_PointScore = 0
Else
m_PointScore = ((Count - 1) * (Count - 2)) + 2
End If

End Function

Private Sub m_RemoveSelection()
'
Dim intRow As Integer
Dim intCol As Integer
Dim intIndex As Integer
Dim blnEmpty As Boolean

m_SaveBoard

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
If m_blnSelected(intRow, intCol) Then
m_intBoard(intRow, intCol) = -1
End If
Next
Next

For intCol = CUBEGAME_WIDTH To 0 Step -1
intRow = CUBEGAME_HEIGHT
Do While intRow > 0
If m_intBoard(intRow, intCol) = -1 Then
For intIndex = intRow To 1 Step -1
m_intBoard(intIndex, intCol) = m_intBoard(intIndex - 1,
intCol)
Next
m_intBoard(0, intCol) = 0
Else
intRow = intRow - 1
End If
Loop
Next

intCol = CUBEGAME_WIDTH - 1
Do While intCol >= 0
blnEmpty = True
For intRow = CUBEGAME_HEIGHT To 0 Step -1
If m_intBoard(intRow, intCol) > 0 Then
blnEmpty = False
Exit For
End If
Next
If blnEmpty Then
For intIndex = intCol To CUBEGAME_WIDTH - 1
For intRow = 0 To CUBEGAME_HEIGHT
m_intBoard(intRow, intIndex) = m_intBoard(intRow,
intIndex + 1)
Next
Next
For intRow = 0 To CUBEGAME_HEIGHT
m_intBoard(intRow, CUBEGAME_WIDTH) = 0
Next
End If
intCol = intCol - 1
Loop

m_UpdateBallBoard

m_lngScore = m_lngScore + m_lngTempScore
m_lngTempScore = 0
End Sub
Private Sub m_ResetScores()

m_lngMark = 0

End Sub

Private Sub m_ResetSelection()
Dim intRow As Integer
Dim intCol As Integer

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
m_blnSelected(intRow, intCol) = False
Next
Next
End Sub
Private Sub m_ClearSelection()
Dim intRow As Integer
Dim intCol As Integer
Dim strName As String

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
If m_blnSelected(intRow, intCol) Then
strName = CUBEGAME_PREFIX & Format$(intRow, "00") &
Format$(intCol, "00")
Controls(strName).BackStyle = 0
End If
Next
Next

End Sub

Private Sub m_ApplySelection()
Dim intRow As Integer
Dim intCol As Integer
Dim strName As String

For intRow = 0 To CUBEGAME_HEIGHT
For intCol = 0 To CUBEGAME_WIDTH
If m_blnSelected(intRow, intCol) Then
strName = "labMarker_" & Format$(intRow, "00") &
Format$(intCol, "00")
Controls(strName).BackStyle = 1
End If
Next
Next

End Sub

Private Sub m_ResizeBoard()

Dim sngWidth As Single
Dim sngHeight As Single
Dim sngMinWidth As Single


sngWidth = (CUBEGAME_MARKERSIZE * (CUBEGAME_WIDTH + 1)) + 6
If sngWidth < sngMinWidth Then sngWidth = sngMinWidth

sngHeight = CUBEGAME_MARKERSIZE * (CUBEGAME_HEIGHT + 1)
labBackdrop.Move 0, 0, sngWidth, sngHeight
labMask.Move 0, 0, sngWidth, sngHeight

End Sub
Private Sub Label4_Click()

End Sub

Private Sub labMask_Click()
If m_blnSelection Then
If m_blnSelected(m_intCubeRow, m_intCubeCol) Then
m_RemoveSelection
Else
m_ClearSelection
End If
m_blnSelection = False
Else
m_CheckSelection
End If
End Sub

Private Sub labMask_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If m_blnSelection Then
m_RemoveSelection
m_blnSelection = False
End If
End Sub

Private Sub labMask_MouseDown(ByVal Button As Integer, ByVal Shift As
Integer, ByVal x As Single, ByVal Y As Single)

If Button = 1 Then
m_intCubeCol = Int(x / CUBEGAME_MARKERSIZE)
m_intCubeRow = Int(Y / CUBEGAME_MARKERSIZE)
End If

End Sub

Private Sub UserForm_Initialize()
' ball colours
m_lngColours(1) = 16744576
m_lngColours(2) = 255
m_lngColours(3) = 16776960
m_lngColours(4) = 16711935
m_lngColours(5) = 65535
labCube1.Visible = False
labCube2.Visible = False
labCube3.Visible = False
labCube4.Visible = False
labCube5.Visible = False
labMask.Caption = ""
m_AddMarkers
m_NewGame

End Sub




un saludo y muchas gracias
Daniel


"Héctor Miguel" escribió en el mensaje
news:O$

hola, daniel !

cuando tengas la solucion de lo del error me lo comentas.

1) el error se refiere a que la ruta que se pasa como inicial NO existe
;)
en el ejemplo estoy utilizando un supuesto de: -> Iniciar_en = "c:\mis
documentos\"
-> es necesario que tu establezcas la ruta donde se iniciara la
busqueda de directorios :D
[aunque ya te lo habia comentado en el punto 3] ;)

2) con relacion al tema de las imagenes y el 'monton' de labels [aun
dentro de un formulario]...
-> creo que seria mejor utilizar solo un combobox con las opciones de
imagenes...
y un solo control de imagen que muestre segun seleccion en el
bo -?-

-> ademas de que en el codigo estas usando un objeto 'FileSearch' [y tiene
sus... 'imponderables'] ;)
tampoco acabo de entender la necesidad de poner hipervinculos en las
celdas de la hoja -?-
por lo que serviria si comentas 'que' es lo que *realmente* buscas como
objetivo final con tantos labels e imagenes -???-

saludos,
hector.

__ el resto de la consulta __

a la pregunta esta que me hiciste
1) supongo que 'la fila de nombres'... de algun modo/lugar/origen/...
'llego' al listbox...
-> podrias exponer este 'detalle' ?... [de preferencia, +/-
exactamente] :))
con el codigo que te espuse crea una lista con todos los archivos que hay
en la carpeta
en la hoja en la olumna A pone el tamaño en bit y en la B la ruta
completa del archivo luego
con ListBox1.RowSource = ("$b$2:$b$1000") las rutas las muestro en el
listbox1.

a la pregunta :
2) si el 'origen' de los nombres [y las rutas de sus archivos de imagen]
'viene' de algun listado en hoja de excel...
-> cual seria la necesidad de 'duplicarlos' [pero ahora] como objetos
incrustados en alguna hoja ?
-> y ademas incrustar el mismo numero de nombres/rutas con sus objetos
imagen ?
No los label quiero que se creen en el userform no en la hoja de calculo
como objetos incrustados.
tanta cantidad de label como archivos haiga en el listbox.
y que en el caption del label aparezca la ruta y en el icono la imagen.

a la pregunta:
3) que significa 'colocar los label en columnas de 10' ???
-> de cuantos objetos INCRUSTADOS en hojas [labels y fotos] estariamos
hablando en total ???
me refiero que en el userform colocar los label de filas de 10 dejando
espacio entre cada uno ,no poner todos en el mismo sitio
Ej. si tengo 100 archivos que haiga 10 filas con 10 label cada fila.

hola, daniel !

[perdon que insista, pero]...
-> podrias comentar 'que' es lo que *realmente* buscas como objetivo final con tantos labels e imagenes -???-

saludos,
hector.