Un Reto: Mensaje de texto rotativo

[hugui]

Hola amigos,

Necesito un pequeño programa para generar mensajes "rotativos".
El programa deberá tomar un texto, analizarlo y generar todas las combinaciones posibles.

Un sencillo ejemplo, sobre el formato del texto:

El {gran|inmenso} árbol, es muy {viejo|antiguo}.

A partir del anterior ejemplo, estas son todas las combinaciones:

A. El gran árbol, es muy viejo.
B. El inmenso árbol, es muy viejo.
C. El gran árbol, es muy antiguo.
D. El inmenso árbol, es muy antiguo.

Si notan, en este sencillo ejemplo, los datos variantes son solo palabras; separadas por "|" y encerradas entre "{}".

Lo que necesito es algo así, pero que soporte parrafos; y dentro de los párrafos, debe soportar palabras; como el ejemplo anterior.


Por ejemplo, a partir de este mensaje...

Estimado amigo,

{Muy buenos días|Hola como andas|Hola como andas}, espero que {sigas|estes} bien.
Te escribo para {invitarte|que vengas|que no faltes} a mi fiesta de fin de año, que se realizará el proximo domingo, en casa.
{No es necesario que traigas nada, simplemente ven y trae a la {familia|flia|family}|Ven y trae a la familia}.

{Los esperamos|Te envio un abrazo|Un saludo}

...estas son solo dos combinaciones posibles...



Ejemplo 1

Estimado amigo,

Muy buenos días, espero que sigas bien.
Te escribo para que vengas a mi fiesta de fin de año, que se realizará el proximo domingo, en casa.
No es necesario que traigas nada, simplemente ven y trae a la familia.

Los esperamos

Ejemplo 2

Estimad amigo,

Hola como andas, espero que estes bien.
Te escribo para invitarte a mi fiesta de fin de año, que se realizará el proximo domingo, en casa.
Ven y trae a la familia.

Te envio un abrazo

Entonces, eso es lo que necesito, con exactamente esta forma de identificar los "pedazos de textos variantes".


Espero se entienda
¿Quién lo puede hacer?


Muchas gracias,
Hugui

PD: Si algunos de los capos que andan por este foro, me puede ayudar personalmente, estoy dispuesto a pagar...

[pkj]

Si me pagas te lo pinto y doy cera

A ver si esto te sirve esto:

He puesto un listbox oculto (List1) para no complicarme. Asegurate de agregarlo.

Código :

Function AutoTexto(ByVal TextoBase As String) As String
  Dim PosicionInicio As Long
  Dim PosicionFin As Long
  List1.Clear
Repite:
  PosicionInicio = InStr(PosicionInicio + 1, TextoBase, "{")
  If PosicionInicio <> 0 Then
    PosicionFin = InStr(PosicionInicio + 1, TextoBase, "}")
    If PosicionFin > PosicionInicio Then
      List1.AddItem Mid$(TextoBase, PosicionInicio + 1, PosicionFin - PosicionInicio - 1)
      TextoBase = Left$(TextoBase, PosicionInicio - 1) & "TextoVariable" & List1.ListCount & Mid$(TextoBase, PosicionFin + 1)
      PosicionInicio = 0      
      GoTo Repite
    End If
  End If
  Dim Opciones() As String
  Dim Eleccion As String
  Dim F As Long
  Randomize Timer
  For F = 0 To List1.ListCount - 1
    Opciones = Split(List1.List(F), "|")
    Eleccion = Opciones(Rnd * UBound(Opciones))
    TextoBase = Replace(TextoBase, "TextoVariable" & F + 1, Eleccion)
  Next F
  AutoTexto = TextoBase
End Function
 

Para usarlo en un command button pongo el texto origen en un textbox (Text1) y el resultado lo muestro en un msgbox:

Lo ejecuto varias veces para notar los cambios.

Código :

Private Sub Command1_Click()
  MsgBox AutoTexto(Text1.Text) & vbCrLf & AutoTexto(Text1.Text) & vbCrLf & AutoTexto(Text1.Text) & vbCrLf & AutoTexto(Text1.Text) & vbCrLf & AutoTexto(Text1.Text)
End Sub
 

El tema de incluir opciones dentro de opciones no lo he visto hasta que me ha dado problemas en las pruebas. De momento no se permite.

PD: Este es el texto origen que he usado en las pruebas (dentro del Text1):

Código :

{Muy buenos días|Hola como andas|Hola como estás}, espero que {sigas|estes} bien.
Te escribo para {invitarte|que vengas|que no faltes} a mi fiesta de fin de año, que se realizará el proximo domingo, en casa.
{No es necesario que traigas nada, simplemente ven y trae a la familia|Ven y trae a la familia}.
 
{Los esperamos|Te envio un abrazo|Un saludo}
 

Que se dé bien.

[hugui]

Hola pkj,

Buenas, estube revisando tu ejemplo, la verdad que me gusta.

Sabía que alguien me hiba a poder ayudar con esto... en definitiva, avisame cuanto me cobras por hacer algo bien bien echo, sin controles adicionales, simplemente una función, bien bien echa... yo pienso que casi lo tenes... pero falta un poquito más...


¿Lo podes hacer para este fin de semana? y ¿Cuánto me cobras por este código?

Cualquier pregunta, avisame...

Un saludo,
Hugui

[pkj]

El quitar el ListBox es simple y el código es un regalo.
Si necesitas mejorarlo comentalo. Puede que se me ocurra algo o alguien te lo complete.

Código :

Function AutoTexto(ByVal TextoBase As String) As String
  Dim PosicionInicio As Long
  Dim PosicionFin As Long
  Dim Lista() As String
  Dim Contador As Long
Repite:
  PosicionInicio = InStr(PosicionInicio + 1, TextoBase, "{")
  If PosicionInicio <> 0 Then
    PosicionFin = InStr(PosicionInicio + 1, TextoBase, "}")
    If PosicionFin > PosicionInicio Then
      Contador = Contador + 1
      ReDim Preserve Lista(Contador)
      Lista(Contador) = Mid$(TextoBase, PosicionInicio + 1, PosicionFin - PosicionInicio - 1)
      TextoBase = Left$(TextoBase, PosicionInicio - 1) & "TextoVariable" & Contador & Mid$(TextoBase, PosicionFin + 1)
      PosicionInicio = 0
      GoTo Repite
    End If
  End If
  Dim Opciones() As String
  Dim Eleccion As String
  Dim F As Long
  Randomize Timer
  For F = 1 To UBound(Lista)
    Opciones = Split(Lista(F), "|")
    Eleccion = Opciones(Rnd * UBound(Opciones))
    TextoBase = Replace(TextoBase, "TextoVariable" & F, Eleccion)
  Next F
  AutoTexto = TextoBase
End Function
 

Saludos

[hugui]

Estimado pkj,

Hola otra vez, muchas gracias por tu ayuda y por el regalo (Aunque mi intensión es pagar algunos dólares por esto, ya que es complicado para mi)

Más tarde lo voy a ver con tiempo, para saber si con esto es suficiente... quizás sí.


Desde ya, muchas... muchas gracias.

Un saludo,
Hugui

[pkj]

Te agradezco tu honradez, pero lo he pasado demasiado bien como para cobrar.

EDITO ESTE MENSAJE PARA EVITAR ACUMULACION DE CÓDIGO SIMILAR Y REEMPLAZO LA FUNCION

El caso es que estaba seguro de que la solución no era tan dificil partiendo de lo que ya había hecho, y al final he acabado haciendo justo lo que pedias para que sea más práctica la función.

Resumen:
Función que devuelve un texto aleatorio a partir de un texto base que contenga una o varias partes opcionales.
Para marcar 2 o más partes como opcionales se introducen entre {} y se separan con |
Una opción puede contener otras partes opcionales y estas partes a otras casi sin límite siempre que se encapsulen correctamente.
Ejemplo:

Código :

Dim Texto As String
Dim Resultado As String
Texto = "Ven y trae a {quien {quieras|tu {elijas|desees}}|la familia|los amigos}"
Resultado = AutoTexto(Texto)
MsgBox Resultado
 

Código :

Function AutoTexto(ByVal TextoBase As String) As String
  On Local Error Resume Next
  AutoTexto = TextoBase
  Do
    Dim PosicionInicio As Long
    PosicionInicio = InStr(PosicionInicio + 1, AutoTexto, "{")
    If PosicionInicio <> 0 Then
      Dim PosicionFin As Long
      PosicionFin = InStr(PosicionInicio + 1, AutoTexto, "}")
      If PosicionFin > PosicionInicio Then
        Dim BuscaMas As Long
        BuscaMas = PosicionInicio
        Do
          BuscaMas = InStr(BuscaMas + 1, AutoTexto, "{")
          If BuscaMas > 0 And BuscaMas < PosicionFin Then
            PosicionFin = InStr(PosicionFin + 1, AutoTexto, "}")
            If PosicionFin = 0 Then Exit Do
          Else
            Exit Do
          End If
        Loop
        If PosicionFin = 0 Then Exit Do
        Dim Contador As Long
        Contador = Contador + 1
        Dim Lista() As String
        ReDim Preserve Lista(Contador)
        Lista(Contador) = Mid$(AutoTexto, PosicionInicio + 1, PosicionFin - PosicionInicio - 1)
        AutoTexto = Left$(AutoTexto, PosicionInicio - 1) & "TextoVariable" & Format(Contador, "000000") & Mid$(AutoTexto, PosicionFin + 1)
        PosicionInicio = 0
      Else
        Exit Do
      End If
    Else
      Exit Do
    End If
  Loop
  Dim F As Long
  For F = 1 To Contador
    If InStr(1, Lista(F), "{") <> 0 And InStr(1, Lista(F), "}") <> 0 And InStr(1, Lista(F), "}") > InStr(1, Lista(F), "{") Then
      Lista(F) = AutoTexto(Lista(F))
    End If
    Dim Opciones() As String
    Opciones = Split(Lista(F), "|")
    Randomize Timer
    Dim Eleccion As String
    If Trim$(Replace(Lista(F), "|", "")) <> "" Then
      Do
        Eleccion = Opciones(Rnd * UBound(Opciones))
        If Trim$(Eleccion) <> "" Then Exit Do
      Loop
    Else
      Eleccion = Opciones(Rnd * UBound(Opciones))
    End If
    AutoTexto = Replace(AutoTexto, "TextoVariable" & Format(F, "000000"), Eleccion)
  Next F
  On Local Error GoTo 0
End Function
 

EDITO ESTE MENSAJE PARA EVITAR ACUMULACION DE CÓDIGO SIMILAR Y REEMPLAZO LA FUNCION

Ha sido divertido.
Como curiosidad te cuento que cuando ya había probado esta nueva versión y estaba a punto de publicarla se me ocurrió ampliar la parte final del texto de prueba y por suerte decidí probarlo en el programa antes de guardar el mensaje, y resulta que fallaba estrepitosamente.
He tardado un buen rato y estaba a punto de perder la paciencia cuando al fin he encontrado el tonto fallo.
De todas formas he pasado un rato muy entretenido, he creado una función que cualquier día me puede servir para algo y espero haber echado una mano que tambien alegra la vida.

Si aparece un nuevo fallo comentadlo.

Saludos.

[pkj]

Mejorada la función anterior. He editado el mensaje anterior pero aviso aquí para que se note por si alguien tiene interés.

Saludos

PD: Como soy cabezón le he seguido dando vueltas, y cuando se me ha ocurrido quitar una de las llaves del texto para simular un fallo de encapsulado de opciones, el resultado ha sido un bucle infinito.

De modo que una vez solucionado aviso que vuelvo a editar el mensaje anterior para incluir la comprobación necesaria.

PD2: Muchas pruebas y alguna comprobación añadida por si acaso y esto parece haber quedado muy estable.

PD3: Nueva mejora del código. Edito por última vez (espero).

[hugui]

Estimado amigo,

¡Infinitas gracias, por todo lo anterior!



¿Te puedo pedir una ayuda más?

Te comento, estaba pensando en colorear los "{" y "}"... pero por la complejidad que tu le agregaste (eso de los subniveles infinitos) creo que es mejor colorear fragmento por fragmento... distinguiendo cuando un fragmento está dentro de otro... con distintos colores... algo que a mi, me puede llevar toda la semana y quizás el resto del mes... pero ahora que te conozco un poquito, me imagino, a vos te puede salir al instante...

Un ejemplo sería este:

Ven y trae a {quien {quieras|tu {elijas|desees}}|la familia|los amigos}

Ya con esto quedaría perfectamente identificado que parte es que parte, con colores distintos...


¡¡Desde ya muchas gracias, de verdad!!

Un saludo,
Hugui

[pkj]

A ver que te parece esto.
Tiene el problema del parpadeo, sobre todo porque la sub que colorea el texto es bastante lenta, pero el resultado de momento es el buscado.
Me he limitado a 5 colores, pero verás que es facil añadir mas.

RT1 es el RichTextBox

Código :

Option Explicit
Dim Colores(5) As ColorConstants
 
Private Sub Form_Load()
  Colores(0) = vbBlack
  Colores(1) = vbBlue
  Colores(2) = vbRed
  Colores(3) = vbGreen
  Colores(4) = vbMagenta
  Colores(5) = vbYellow
  Me.Show
End Sub
 
Private Sub RT1_Change()
  Dim Pos As Long
  With RT1
    .Visible = False
    Pos = .SelStart
    CambiaColores RT1
    .SelStart = Pos
    .Visible = True
    .SetFocus
  End With
 End Sub
 
Sub CambiaColores(RTB As RichTextBox)
  Dim F As Long
  Dim Contador As Long
  With RTB
  For F = 1 To Len(.Text)
    If Mid$(.Text, F, 1) = "{" Then
      Contador = Contador + 1
      If Contador > 5 Then Contador = 5
      .SelStart = F - 1
      .SelLength = 1
      .SelColor = Colores(Contador)
    ElseIf Mid$(.Text, F, 1) = "}" Then
      .SelStart = F - 1
      .SelLength = 1
      .SelColor = Colores(Contador)
      Contador = Contador - 1
      If Contador < 0 Then Contador = 0
    Else
      .SelStart = F - 1
      .SelLength = 1
      .SelColor = Colores(Contador)
    End If
  Next F
  End With
End Sub
 

Saludos

[hugui]

Hola,

borro este mensaje, porque esta de mÁs...

Un saludo,
hugui

[pkj]

Ya he creado una versión de la sub CambiaColores bastante más rápida. A ver si no aparecen bugs.

Código vb:

Sub CambiaColores(RTB As RichTextBox)
  Dim Pos As Long
  Dim PosAbre As Long
  Dim PosCierra As Long
  Dim Contador As Long
  With RTB
    Do
      PosAbre = InStr(Pos + 1, RTB.Text, "{")
      PosCierra = InStr(Pos + 1, RTB.Text, "}")
      If PosAbre > 0 And (PosAbre < PosCierra Or PosCierra = 0) Then
        .SelStart = Pos
        .SelLength = PosAbre - Pos - 1
        .SelColor = Colores(Contador)
        If Contador < 5 Then Contador = Contador + 1
        .SelStart = PosAbre - 1
        .SelLength = 1
        .SelColor = Colores(Contador)
        Pos = PosAbre
      ElseIf PosCierra > 0 Then
        .SelStart = Pos
        .SelLength = PosCierra - Pos
        .SelColor = Colores(Contador)
        If Contador > 0 Then Contador = Contador - 1
        Pos = PosCierra
      Else
        .SelStart = Pos
        .SelLength = Len(RTB.Text)
        .SelColor = Colores(Contador)
        Exit Do
      End If
    Loop
  End With
End Sub
 

A ver si alguien publica un "aleatori-libro" de aventuras

Saludos

[hugui]

Estimado amigo pkj,

Te agradezco tu ayuda, de verdad.
Esto funciona muy bien, si ejecuto esto desde un botón.

Pero ¿Cómo podría hacer para que siga funcionando igual de bien, mientras escribo en el RichTextBox?

Lo puse en el evento Change y se corre el cursor, ó no me deja escribir...

Mi intensión es ir escribiendo normalmente y "programando" una carta, con la ventaja de ver el coloreo en tiempo real... todo un problema, ya lo sé... pero no lo puedo solucionar... igual sigo intentando.

Muchas gracias de verdad, estoy aprendiendo mucho.

Un saludo,
Hugui

PD: GRACIAS

[pkj]

Solo tienes que usar el evento change que puse como ejemplo, cambiando RT1 por el nombre de tu RichTextBox:

Private Sub RT1_Change()
Dim Pos As Long
With RT1
.Visible = False
Pos = .SelStart
CambiaColores RT1
.SelStart = Pos
.Visible = True
.SetFocus
End With
End Sub

[hugui]

Hola pkj,

Gracias, no me había dado cuenta, se ve que estoy con mi cabeza en otro lado...

Te agradezco nuevamente por tu paciencia... gracias, gracias, gracias.



Hugui