Macro para splash form de avence de proceso
------------------------------
Buen dia
Necesito otra vez de su ayuda
Si pueden ayudar con un splash form de avence proceso como se ve en la imagen
Que cada item con su check (en rojo) vaya apareciendo conforme la barra va avanzando hasta llegar al 100 %
Visita:
Cursos de Excel y Macros
---
Qué error te aparece.
Si tu máquina es a 32 bits, entonces quita PtrSafe en esta línea:
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
----
Cursos de Excel:
https://www.youtube.com/watch?v=w7MYL3wDgH4&t=3s
https://www.youtube.com/watch?v=dy9w9zbkCaw&t=644s
https://www.youtube.com/watch?v=7Xhs04vhrtg&t=188s
---
Cursos de Macros:
https://www.youtube.com/watch?v=PupmVvM16-8&t=1s
https://www.youtube.com/watch?v=f_x8pstpNqc&t=3s
https://www.youtube.com/watch?v=5k0szqErdXg&t=689s
---
Sal u dos Dante Amor
es de 64 bits
¿Pero qué mensaje de error te aparece?
Si pudieras poner toda la información.
La macro completa y el archivo que estás utilizando. Eso ayudaría.
no sale ninguno, simplemente se traba y se cierra, cuando esta corriendo el banner
Option Explicit Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr) Sub SplashForm() '****************************************************** '** Date: 2/13/209 '** Developer: Raymond Mills '** Excel, Access and Word VBA Consulting '** www.ExcelandVBACraftsman.com '** to discuss a projects feasibility '** Call: 484 574 3190 '** Subject: Splash Greeting Form '****************************************************** Dim sMsg(7, 2) As String, sMisc As String Dim x As Integer, i As Integer, j As Integer, w As Integer ' build the message ... sMsg(0, 0) = "Unleash the power of Excel VBA " sMsg(1, 0) = "Improve Quality and Consistency " sMsg(2, 0) = "Speed the Process " sMsg(3, 0) = "Improve Accuracy " sMsg(4, 0) = "Get Immediate Metrics " sMsg(5, 0) = "Improve Reliability " sMsg(6, 0) = "Reduce Cost " sMsg(7, 0) = "Reduce Key Person Dependency " ' build the control names ... For i = 1 To 7 sMsg(i, 1) = "lblc" & i sMsg(i, 2) = "lbl" & i Next i ' build the form ... Load frmBanner frmBanner.lblRolling.Caption = "" frmBanner.Show 'loop through our bullet points ... For w = 0 To 7 j = Len(sMsg(w, 0)) i = 1: x = 1 Do Until i = 500 ' note 500 is a random number that i know we wont reach ... sMisc = Left(sMsg(w, 0), x) frmBanner.lblRolling.Caption = sMisc Sleep 75 If (i + x) = j + 1 Then Exit Do x = x + 1 frmBanner.Repaint Loop ' Make the bullet points and checkmarks visible ... If w <> 0 Then frmBanner.Label2.Width = 40 * w frmBanner.Label4 = 13 * w & "%" frmBanner.Controls(sMsg(w, 1)).Visible = True frmBanner.Controls(sMsg(w, 2)).Visible = True frmBanner.Repaint End If Next w frmBanner.lblRolling.Caption = "" Sleep 1000 ' clean up and close ... frmBanner.Hide Unload frmBanner End Sub
Así, yo no puedo ayudarte, te estoy pidiendo tu macro y tu archivo.
talvez podés cambiar los items como se ve en la imagen
y que la barra llegue al 100%
gracias
Pero ninguno de los userform que pusiste en los archivos coincide con la imagen ...
es el mismo, el codigo es el mismo
solo que mi idea es que se vea asi como en la imagen
sino se puede pues esta bien
gracias
Te paso el código actualizado y el archivo
Funciona para mí. Si tienes problemas, probablemente sea tu versión de excel.
Option Explicit Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr) Sub SplashForm() '****************************************************** '** Date: 2/13/209 '** Developer: Raymond Mills '** Excel, Access and Word VBA Consulting '** www.ExcelandVBACraftsman.com '** to discuss a projects feasibility '** Call: 484 574 3190 '** Subject: Splash Greeting Form '****************************************************** Dim sMsg(10, 2) As String, sMisc As String Dim x As Integer, i As Integer, j As Integer, w As Integer ' build the message ... sMsg(0, 0) = "Creando Inventario de: " sMsg(1, 0) = "Medicamentos " sMsg(2, 0) = "Planificación " sMsg(3, 0) = "Quirúrgico " sMsg(4, 0) = "TB " sMsg(5, 0) = "Sanemiento " sMsg(6, 0) = "Biológico " sMsg(7, 0) = "Laboratorio " sMsg(8, 0) = "Vectores " sMsg(9, 0) = "Oficina " sMsg(10, 0) = "Limpieza " ' build the control names ... For i = 1 To UBound(sMsg) sMsg(i, 1) = "lblc" & i sMsg(i, 2) = "lbl" & i Next i ' ' build the form ... Load frmBanner frmBanner.lblRolling.Caption = "" frmBanner.Show 'loop through our bullet points ... For w = 0 To UBound(sMsg) j = Len(sMsg(w, 0)) '+ Len(sMsg(0, 0)) - Len(sMsg(w, 0)) i = 1: x = 1 Do Until i = 500 ' note 500 is a random number that i know we wont reach ... sMisc = Left(sMsg(w, 0), x) frmBanner.lblRolling.Caption = sMisc Sleep 75 If (i + x) >= j + 1 Then Exit Do x = x + 1 DoEvents Loop ' Make the bullet points and checkmarks visible ... If w <> 0 Then frmBanner.Label2.Width = 30 * w frmBanner.Label4 = (100 / UBound(sMsg)) * w & "%" frmBanner.Controls(sMsg(w, 1)).Visible = True frmBanner.Controls(sMsg(w, 2)).Visible = True frmBanner.Controls(sMsg(w, 2)).Caption = sMsg(w, 0) DoEvents End If Next w frmBanner.lblRolling.Caption = "" Sleep 1000 ' Clean up and close ... Unload frmBanner End Sub
excel vba dictionary parte 1 - YouTube
Excel vba dictionary parte 2 - YouTube
Excel vba dictionary parte 3 - YouTube
Prueba con mi archivo:
https://drive.google.com/file/d/1bC7XcKHA8Cyy2BKKPK9ArUPzMdw7J-Xz/view?usp=sharing
Sal u dos Dante Amor
