PROGRAMAR EN VBA MACROS PARA EXCEL: Enviar Whatsapp con Excel
Mostrando las entradas con la etiqueta Enviar Whatsapp con Excel. Mostrar todas las entradas
Mostrando las entradas con la etiqueta Enviar Whatsapp con Excel. Mostrar todas las entradas

Como Enviar Imagenes en Whatsapp con Excel






Son varios los suscriptores del canal y foros que solicitaban el Envío de Imágenes o Fotos en Whatsapp desde Excel, pues bien en este ejemplo se muestra precisamente eso, Como Enviar Fotos en Whatsapp Desde Excel.

En este play list se muestran otros ejemplos relacionados con el Envío de Whatsapp desde Excel, suscribe al canal y solicita el ejemplo que te sea útil para automatizar tus hojas de Excel.

Si te estás iniciando en la operación de Excel o requieres afirmar conocimientos, recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.

  

Suscribe a nuestro canal para que YouTube te avise cuando se suba nuevo contenido al canal, en el vídeo encontrarás una explicación gráfica y detallada del ejemplo que se muestra en este post.









 


En este ejemplo se muestra como seleccionar una imagen y enviarla por Whatsapp utilizando Excel, para lograr lo mencionado se necesita ingresar el número de teléfono al que se requiere enviar el Whatsapp, el texto a enviar y seleccionar la imagen que se requiere enviar; el texto a enviar no es necesario, pero si se ingresa aparecerá debajo de la imagen enviada.

Cuando se descarga el ejemplo se muestra un botón presionando el mismo muestra el formulario que permite ingresar el número de teléfono, luego el texto que en este caso no es obligatorio y la imagen a enviar.

Excel utiliza la API Oficial de Whatsapp para enviar el mensaje de Whatsapp a través de Excel, el requisito es que se debe tener Whatsapp WEB activado, para ello visita el sitio oficial de Whatsapp que te ayudará a activarlo; lo cual es muy fácil ya que ingresando al sitio muestra un código QR, tu debes ingresar a Whatsapp desde tu Smartphone luego a Ajustes luego a Whatsapp Web y escanear el código que se muestra en pantalla.

Se debe escribir en el Textbox8 que es el primer Textbox de la izquierda, se puede ingresar directamente el número sin el + o se puede escribir en el textbox del lado derecho para que busque en la base de datos haciendo click en el textbox emergente seleccionar el contacto.

Por defecto al mostrar el formulario se muestra un mensaje predeterminado a enviar, eso obvio que se puede modificar por el mensaje que se requiera enviar, este paso no es necesario si solo se requiere enviar la imagen sin ningún texto, en caso que se ingrese aparecerá debajo de la imagen enviada.

Posteriormente se debe seleccionar la imagen que se requiere enviar, seleccionando de un Explorador de Archivos de Windows que se muestra al presionar el botón con tres puntitos, la dirección se guarda en una variable pública que luego se usa en la macro.

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizá sea de utilidad también

Como Enviar Whatsapp Desde Excel


Como Enviar Whatsapp en Forma Masiva con Excel

Como Enviar Whatsapp desde Excel en Forma Masiva Con Buscador de Contacto

Como Enviar Whatsapp Personalizados en Forma Masiva Desde Excel

Teniendo ya cargado los datos necesarios se debe presionar el botón con el símbolo de Whatsapp para enviar el mensaje desde Excel, este contiene el siguiente código:

Set imag = ActiveSheet.Pictures.Insert(direima)
'UserForm1.Hide
With imag
.Copy
.Delete
End With

El código anterior  inserta la imagen seleccionada en la hoja de Excel haciendo un objeto con esa imagen, luego copia la imagen quedando en el portapapeles e inmediatamente la elimina, luego con los siguientes códigos carga en variable el número de teléfono y el mensaje, todas estás variables son públicas porque son usadas posteriormente en otro procedimiento, que es el que envía Whatsapp y es llamado con el código Call EnviaWhatsapp.

telwhatsapp = UserForm1.TextBox8
textwhatsapp = UserForm1.TextBox1
Call EnviaWhatsapp


En el módulo1 se encuentre la macro que envía el Whatsapp utiliza SenKey, que sirve para enviar un impulso que equivale a presionar una tecla, en primer lugar Excel navega hasta la URL de la API de Whatsapp WEB, enviando en la URL el Número y el Texto a enviar, con los siguientes códigos:

mylinkwhatsapp = "https://api.whatsapp.com/send?phone=" & telwhatsapp & "&text=" & textwhatsapp

ActiveWorkbook.FollowHyperlink mylinkwhatsapp



Con los códigos anteriores la macro ya habrá ingresado a la URL de la API de Whatsapp, luego se detiene la macro unos segundos para esperar que la página WEB se cargue, eso se hace con el siguiente código, en el ejemplo se espera 5 segundos, dependiendo de la rapidez que cada uno posea de internet puede disminuirse el tiempo a 2 o 3 segundos, esto se hace tanto en este como en el resto de los códigos donde se detiene la macro para esperar que se cargue bien la página:


Application.Wait (Now + TimeValue("00:00:05"))

Luego se envía impulso, similar a presionar la tecla TABULADOR, se realiza dos veces, para pasar a otros objetos de la página y llegar hasta la tecla Send de la página Web de la API de Whatsapp

ActiveWindow.Application.SendKeys "{TAB}"

Application.Wait (Now + TimeValue("00:00:01"))


ActiveWindow.Application.SendKeys "{TAB}"


Application.Wait (Now + TimeValue("00:00:05"))


Luego se espera 5 segundos y se envía el impulso de la tecla Enter que hace enviar el Whatsapp, esperando en ese caso 18 segundos para que se carguen los Chats de Whatsapp, apareciendo el texto que se requiere enviar en el espacio destinado a tal fin en la Aplicación Web de Whatsapp 

ActiveWindow.Application.SendKeys "(~)" 'envia enter para enviar mensaje

Application.Wait (Now + TimeValue("00:00:18"))


Ahora se procede a copiar la imagen que se copio al principio de la macro y que se mantenía en el portapapeles, para ello se envía el impulso equivalente a presionar "Ctrl V", que sirve para pegar, el código es el siguiente:


ActiveWindow.Application.SendKeys "(^v)"

Pór último se envía los impulsos de teclado correspondiente a la tecla Enter, envía la imagen seleccionada y termina la macro, los códigos son los siguientes: 


ActiveWindow.Application.SendKeys "(~)"


Application.Wait (Now + TimeValue("00:00:01"))

ActiveWindow.Application.SendKeys "(~)"

El código completo del ejemplo Como Enviar Imágenes o Fotos de Whatsapp con Excel se muestra a continuación, y posteriormente se encuentra el link para la descarga del archivo de ejemplo la cual es totalmente GRATIS, previamente considera la posibilidad de donar para que se puedan seguir agregando más ejemplos gratuitos.

Código que se inserta en un Formulario de Excel

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********




Private Sub CommandButton1_Click()
'*********** by marcrodos **** https://programarexcel.com  ***  https://www.youtube.com/c/programarexcel?sub_confirmation=1 ********

Set imag = ActiveSheet.Pictures.Insert(direima)
'UserForm1.Hide
With imag
.Copy
.Delete
End With
telwhatsapp = UserForm1.TextBox8
textwhatsapp = UserForm1.TextBox1
Call EnviaWhatsapp
End Sub


Private Sub CommandButton2_Click()
direima = Application.GetOpenFilename("Archivos JPG PNG BMP  (*.jpg*;*.png*;*.bmp*), *.jpg*;*.png*;*.bmp*")
TextBox10 = direima
End Sub


Private Sub ListBox3_Click()
On Error Resume Next
ctlsaltachange = 1
UserForm1.TextBox8 = Empty
fila = UserForm1.ListBox3.ListIndex
UserForm1.TextBox8 = UserForm1.ListBox3.List(fila, 1)
UserForm1.TextBox9 = UserForm1.ListBox3.List(fila, 0) & " " & UserForm1.ListBox3.List(fila, 1) & " " & UserForm1.ListBox3.List(fila, 2)


UserForm1.ListBox3.Visible = False

If TextBox9 = Empty Then
UserForm1.Label2.Visible = True 'hace visible el label
Else
UserForm1.Label2.Visible = False
End If

If TextBox8 = Empty Then
UserForm1.Label1.Visible = True 'hace visible el label
Else
UserForm1.Label1.Visible = False
End If

ctlsaltachange = 0
End Sub

Private Sub TextBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = TextBox2
End Sub
Private Sub TextBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = TextBox3
End Sub

Private Sub TextBox4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
TextBox1 = TextBox4
End Sub

Private Sub TextBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = "Expte: " & UserForm1.TextBox2 & " Caratula " & UserForm1.TextBox3
TextBox1 = TextBox5
End Sub

Private Sub TextBox6_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = "Expte: " & UserForm1.TextBox2 & " Caratula " & UserForm1.TextBox3
TextBox1 = TextBox6
End Sub

Private Sub TextBox7_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = "Expte: " & UserForm1.TextBox2 & " Caratula " & UserForm1.TextBox3
TextBox1 = TextBox7
End Sub

Private Sub TextBox8_Change()
If TextBox8 = Empty Then
UserForm1.Label1.Visible = True 'hace visible el label
Else
UserForm1.Label1.Visible = False
End If
End Sub


Private Sub TextBox9_Change()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Dim cn As ADODB.Connection, rs As ADODB.Recordset

'If ctlsaltachange = 1 Then Exit Sub

If TextBox9 = Empty Then
UserForm1.Label2.Visible = True 'hace visible el label
Else
UserForm1.Label2.Visible = False
End If

If Len(UserForm1.TextBox9) <= 2 Then
UserForm1.ListBox3.Visible = False
Exit Sub
Else
UserForm1.ListBox3.Visible = True
End If

Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set a = Sheets("Hoja1")

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;"""

If Len(UserForm1.TextBox9) > 2 Then
sql = "SELECT * FROM [" & "Hoja1$" & "] WHERE Ucase(" & a.Range("A1") & ") LIKE Ucase('%" & UserForm1.TextBox9 & "%') ORDER BY Nombre ASC"
Set rs = cn.Execute(sql)

UserForm1.ListBox3.Clear

Set rs = cn.Execute(sql)
If rs.EOF = True Then
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
UserForm1.ListBox3.Visible = False
Exit Sub
Else

UserForm1.ListBox3.Column = 3
UserForm1.ListBox3.ColumnWidths = "100 pt;70 pt;80 pt"

rs.MoveFirst
Do While Not rs.EOF
    UserForm1.ListBox3.AddItem rs.Fields(0).Value
    UserForm1.ListBox3.List(UserForm1.ListBox3.ListCount - 1, 1) = rs.Fields(1).Value
    UserForm1.ListBox3.List(UserForm1.ListBox3.ListCount - 1, 2) = rs.Fields(2).Value
   ' Userform1.ListBox3.List(Userform1.ListBox3.ListCount - 1, 3) = rs.Fields(4).Value
   ' Userform1.ListBox3.List(Userform1.ListBox3.ListCount - 1, 4) = rs.Fields(5).Value
   ' Userform1.ListBox3.List(Userform1.ListBox3.ListCount - 1, 5) = rs.Fields(6).Value
    rs.MoveNext
Loop
End If

End If
Set rs = Nothing
cn.Close
Set cn = Nothing

'Si solo hay un dato coincidente directamente lo busca y carga sus datos, al seleccionarlo se ejecuta el evento click del listbox
If UserForm1.ListBox3.ListCount - 1 = 0 Then
'El código 1 salta la programacion del evento change del combobox16 porque sino cuando la macro modifica se vuelve a ejecutar y se obtiene resultado no deseado
'saltacbo16 = 1
'La macro al seleccionar el item autoaticamente ejecuta la programacion del evento click que es la busqueda del dato y que
'es lo que interesa en esta programación, por eso no se llama luego al evento listbox_click sino se ejecuta dos veces.
UserForm1.ListBox3.Selected(0) = True
'Call ListBox3_Click
UserForm1.ListBox3.Visible = False
'Se hace perder el foco al combobox16, porque sino se ejecuta la codificación del After_Update
'Userform1.TextBox2.SetFocus
End If
'salir:
'Vuelve la variable a estado 0 para que se pueda ejecutar el evento change con otro registro
'saltacbo16 = 0
Application.ScreenUpdating = True
Application.ScreenUpdating = True

End Sub
Private Sub UserForm_Initialize()
ExpteWhatsapp = "SUSCRIBE https://www.youtube.com/c/programarexcel?sub_confirmation=1"
UserForm1.TextBox1 = ExpteWhatsapp
UserForm1.TextBox2 = "Estimado recuerda " & ExpteWhatsapp & " activa la campanita y YouTube te avisara cuando se suba nuevo contenido "
UserForm1.TextBox3 = "Automatiza tus Libros Excel, tutoriales semanales, recuerda " & ExpteWhatsapp & " todas las semanas ideas sobre como automatizar tus libros Excel "
UserForm1.TextBox4 = "Mis datos son:" & Chr(13) & " https://www.youtube.com/c/programarexcel?sub_confirmation=1 " & Chr(13) & " comenta, dale LIKE si te fue útil"
UserForm1.TextBox5 = "Recuerda darle LIKE Y COMENTAR SI FUE UTIL: " & Chr(13) & "RECUERDA " & ExpteWhatsapp
UserForm1.TextBox6 = "Su próxima factura de ProgramarExcel.com vence el: " & Chr(13) & "14/06/2020 "
UserForm1.TextBox7 = "https://programarexcel.com Descarga cientos de ejemplos de Macros de Excel GRATIS, aporta al canal si puedes, sino con like, comentario y suscripción es suficiente"
End Sub


Código que se inserta en un módulo

#If VBA7 And Win64 Then

'Si es de 64 bits

Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr

Public Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Public Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr

Public Declare PtrSafe Function SetWindowLongPtr Lib "USER32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr

Public Declare PtrSafe Function DrawMenuBar Lib "USER32" (ByVal hwnd As Long) As LongPtr

Public Declare PtrSafe Function RegOpenKeyA Lib "advapire32.dll" (ByVal hKey As LongPtr, ByVal lpSubKey As String, phkResult As LongPtr) As LongPtr

#Else

'Si es de 32 bits

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Public Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Declare Function DrawMenuBar Lib "USER32" (ByVal hwnd As Long) As Long

Public Declare Function RegOpenKeyA Lib "advapire32.dll" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

#End If

Public telwhatsapp, textwhatsapp, direima

Sub Muestra()

UserForm1.Show

End Sub

Sub EnviaWhatsapp()

Application.ScreenUpdating = False

Application.DisplayAlerts = False


'*********** by marcrodos **** https://programarexcel.com  ***  https://www.youtube.com/c/programarexcel?sub_confirmation=1 ********


If telwhatsapp = Empty Or textwhatsapp = Empty Then

MsgBox ("Debe ingresar número de telefono y texto para enviar Whatsapp"), vbCritical, "AVISO"

Exit Sub

End If


mylinkwhatsapp = "https://api.whatsapp.com/send?phone=" & telwhatsapp & "&text=" & textwhatsapp

ActiveWorkbook.FollowHyperlink mylinkwhatsapp


Application.Wait (Now + TimeValue("00:00:05"))

ActiveWindow.Application.SendKeys "{TAB}"

Application.Wait (Now + TimeValue("00:00:01"))

ActiveWindow.Application.SendKeys "{TAB}"

Application.Wait (Now + TimeValue("00:00:05"))

ActiveWindow.Application.SendKeys "(~)" 'énvia enter para enviar mensaje

Application.Wait (Now + TimeValue("00:00:18"))

ActiveWindow.Application.SendKeys "(^v)"

ActiveWindow.Application.SendKeys "(~)"

Application.Wait (Now + TimeValue("00:00:01"))

ActiveWindow.Application.SendKeys "(~)"

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛


Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Como Enviar Whatsapp Personalizado en Forma Masiva con Excel






A pedido de un suscriptor de nuestro canal de YuoTube se presenta Como Enviar Mensaje Personalizado de Whatsapp en Forma Masiva a Cada Contacto Registrado en Excel, ya se ha tratado el tema de utilizar Excel para enviar mensajes de Whatsapp en el link se podrán observar los ejemplos anteriores sobre Envío de Whatsapp con Excel.

Recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.

  

Suscribe a nuestro canal para que YouTube te avise cuando se suba nuevo contenido al canal, en el vídeo encontrarás una explicación gráfica y detallada del ejemplo que se muestra en este post.






 


Para proceder a Enviar un Mensaje Personalizado de Whatsapp con Excel, básicamente se realiza un bucle y se aplica el procedimiento ya visto para enviar mensajes de Whatsapp desde Excel, al descargar el ejemplo se pude observar un listado o pequeña base de datos con los contactos en la columna A, los respectivos números de teléfono en la columna B y el mensaje personalizado que se le enviará a cada contacto en la Columna C.

El requisito necesario para poder enviar Whatsapp con Excel es tener previamente habilitado WebWhatsapp, desde acá se obtiene el aplicativo; la macro utiliza la API oficial de Whatsapp para poder enviar mensajes a través de Excel, no es necesario tener cargado en contacto en el teléfono para poder enviarle un mensaje Whatsapp con Excel.

El bucle se inicia en la fila dos hasta la última fila con datos de la Columna A, se cargan en las variables uf, la última fila con datos; en la variable telwhatsapp, el teléfono del contacto y en texwhatsapp el mensaje propiamente dicho, se usan los siguientes códigos:

uf = a.Range("A" & Rows.Count).End(xlupo).Row

For x = 2 To uf
telwhatsapp = a.Cells(x, "B")
textwhatsapp = a.Cells(x, "C")

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizá sea de utilidad también

Como Llenar Listbox con más de 10 columnas


Como Cargar Listbox con Datos Provenientes de Varias Hojas

Como hacer un link o hiperlink a google maps con Excel

Obtenido el número de teléfono para enviar Whatsapp se la macro navega hasta el link de la API de Whatsapp, cargando el número de teléfono y el mensaje, con el siguiente código:

mylinkwhatsapp = "https://api.whatsapp.com/send?phone=" & telwhatsapp & "&text=" & textwhatsapp
ActiveWorkbook.FollowHyperlink mylinkwhatsapp

Atento a que WebWhatsapp no es compatible con InternetExplorer dificulta la comunicación con el lenguaje de VBA - Excel, por lo que se apela a SenKey, esto envía los impulsos de teclas necesarios para poder lograr enviar el mensaje.

Como la aplicación de Whatsapp Web se va cargando con cada comando que se envía desde Excel, se debe esperar unos segundos para que se cargue la página Web, es decir se debe deterner la macro una vez cargada la página se procede a enviar el siguiente código, la rápidez con la que se envía el Whatsapp va a variar dependiendo de la velocidad de internet con la que se cuente, es por ello que cada uno debe modificar el tiempo en base a la velocidad de internet que posea, modificando las siguientes lineas:

Application.Wait (Now + TimeValue("00:00:05"))

En el código anterior 05 representa que la macro espera 5 segundos hasta que la página se cargue y mande el próximo comando, esto se puede modificar en más o menos, dependiendo de la velocidad de internet que se posea.

Sugiero ver el vídeo explicativo del ejemplo llamado Como Enviar Masivamente Whatsapp Personalizados desde Excel, seguidamente se muestra el código y al final está el link para descargar el ejemplo de Excel que envía Whastapp.


Código que se inserta en un Modulo de Excel

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********



#If VBA7 And Win64 Then
'Si es de 64 bits
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
Public Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "USER32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function DrawMenuBar Lib "USER32" (ByVal hwnd As Long) As LongPtr
Public Declare PtrSafe Function RegOpenKeyA Lib "advapire32.dll" (ByVal hKey As LongPtr, ByVal lpSubKey As String, phkResult As LongPtr) As LongPtr
#Else
'Si es de 32 bits
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "USER32" (ByVal hwnd As Long) As Long
Public Declare Function RegOpenKeyA Lib "advapire32.dll" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
#End If
Public telwhatsapp, textwhatsapp

'*********** by marcrodos **** https://programarexcel.com  ***  https://www.youtube.com/c/programarexcel?sub_confirmation=1 ********

Sub EnviaWhatsapp()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set a = Sheets("Hoja1")
uf = a.Range("A" & Rows.Count).End(xlupo).Row

For x = 2 To uf
telwhatsapp = a.Cells(x, "B")
textwhatsapp = a.Cells(x, "C")

mylinkwhatsapp = "https://api.whatsapp.com/send?phone=" & telwhatsapp & "&text=" & textwhatsapp
ActiveWorkbook.FollowHyperlink mylinkwhatsapp

Application.Wait (Now + TimeValue("00:00:05"))
ActiveWindow.Application.SendKeys "{TAB}"
Application.Wait (Now + TimeValue("00:00:01"))
ActiveWindow.Application.SendKeys "{TAB}"
Application.Wait (Now + TimeValue("00:00:05"))
ActiveWindow.Application.SendKeys "(~)" 'énvia enter para enviar mensaje
Application.Wait (Now + TimeValue("00:00:18"))
ActiveWindow.Application.SendKeys "(~)"
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub macro1(control As IRibbonControl)
On Error Resume Next
respuesta = MsgBox("¿Seguro desea enviar Whatsapp a los contactos listados?", vbCritical + vbYesNo)
If respuesta = 6 Then
Call EnviaWhatsapp
End If
End Sub

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Como Enviar Whatsapp en Forma Masiva desde Excel con Buscador Contacto






En este ejemplos se presenta una macro solicitada por un suscriptor de nuestro canal de YouTube, el cual requería enviar Whatsapp desde Excel en forma masiva, pero que contenga un buscador de contactos, en esta macro se responde lo solicitado adicionando un buscador avanzado de datos de Excel.

Este libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.

  

El vídeo explica en forma más detallada el ejemplo contenido en este post, suscribe a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes.









 


El ejemplo se puede descargar en forma totalmente gratuita desde el final del post, cuando se abre el libro, se observa un botón que presionando muestra un formulario, el cual contiene un buscador avanzado que permite encontrar los contactos en la base de datos e ir marcándolos para enviar un whatsapp masivo desde Excel a todos los contactos seleccionados.


⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛
Quizá sea de utilidad también

Como crear una factura con excel, guardarla, guardar en PDF e enviar por mail


Como auto eliminar archivo previo copiar el fichero

Como hacer un bucle for ... next con letras del abecedario en vez de números

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛



⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛

Escribiendo en el textbox que se encuentra en el formulario, los datos de los contactos, al ingresar las primeras 3 letras empieza a buscar en la base de datos y carga los registros que tengan coincidencias con lo escrito en el listbox, que está oculto y solo se hace visible para mostrar los resultados del filtro.

Seleccionado el item (contacto) del listbox automáticamente busca el registro en el listbox de la derecha marcándose el contacto como a quien se le debe enviar Whatsapp desde Excel.

El listbox se oculta y muestra solamente en el caso que la búsqueda haya sido satisfactoria, es decir si encontró algún dato que coincida con lo escrito, lo mismo sucede con el label que se encuentra encima del textbox que se oculta en caso que el textbox sea distinto de vacío y muestra cuanto el textbox está vacío.

Una vez seleccionados todos los contactos a los cuales se les requiere enviar el Whatsapp, presionando el botón de la aplicación, botón verde, se procede a enviar un mensaje a cada uno de los contactos seleccionados, en envío será más o menos rápido dependiendo de la velocidad de internet.

Para enviar el Whatsapp se requiere que esté activado Whatsapp Web, estando activado la macro leerá todos los registros marcados en el listbox de la derecha enviando un mensaje de Whatsapp a todos aquellos seleccionados solamente, desde luego se puede seleccionar directamente si hacer uso del buscador de contactos, el cual es más útil cuando la base de datos es extensa.

Para buscar el dato escrito en el textbox y compararlo con el contacto que está en la columna A de la base de datos, se utiliza SQL, conectándose con el mismo libro a través de una conexión ADODB y mediante sentencias SQL se procede a obtener los datos coincidentes con lo escribo para mostrar en el listbox, sugiero descargar el ejemplo y ver el vídeo donde se verá la macro en acción, donde además se tiene una explicación más detallada de los códigos.

Considera aportar para sostener el sitio si está dentro de tus posibilidades, a continuación se muestra el código completo del ejemplo Como Enviar Whatsapp en Forma Masiva desde Excel con Buscador de Contacto.

Código que se inserta en un formulario

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********

Private Sub CommandButton1_Click()
Dim Num As New Collection, dato, conta As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'Crea una colección de datos del listbox
Set aa = UserForm1.ListBox1
For x = 0 To aa.ListCount - 1
If aa.Selected(x) = True Then
Num.Add aa.List(x, 1)
End If
Next x
conta = 0
For Each dato In Num
conta = conta + 1
telwhatsapp = dato
textwhatsapp = UserForm1.TextBox1
Call EnviaWhatsapp
Next dato
MsgBox ("Se envió Whatsapp a  " & conta & " contactos"), vbInformation, "REPORTE"
cancont = 0 'devuelve el a cero cuando se seleccionan varios contactos para que en el listbox no los borre nuevamente
End Sub


Private Sub Label2_Click()
TextBox9.SetFocus
End Sub

Private Sub ListBox3_Click()
On Error Resume Next

UserForm1.TextBox8 = Empty
fila = UserForm1.ListBox3.ListIndex

UserForm1.TextBox8 = UserForm1.ListBox3.List(fila, 0) & " " & UserForm1.ListBox3.List(fila, 1) & " " & UserForm1.ListBox3.List(fila, 2)
UserForm1.TextBox9 = Clear
contacto = UserForm1.ListBox3.List(fila, 0)

UserForm1.ListBox3.Visible = False

If TextBox9 = Empty Then
UserForm1.Label2.Visible = True 'hace visible el label
Else
UserForm1.Label2.Visible = False
End If

If TextBox8 = Empty Then
UserForm1.Label1.Visible = True 'hace visible el label
Else
UserForm1.Label1.Visible = False
End If

Set a = UserForm1.ListBox1
For x = 1 To a.ListCount - 1
If cancont = 1 Then GoTo sale:
If a.Selected(x) = True Then a.Selected(x) = False
sale:
If a.List(x, 0) = contacto Then a.Selected(x) = True
Next x
cancont = 1 'Hace que no se desmarque los contactos ya marcados
End Sub

Private Sub CommandButton2_Click()
Set a = UserForm1.ListBox1
For x = 1 To a.ListCount - 1
If a.Selected(x) = True Then
a.Selected(x) = False
GoTo sal:
End If
If a.Selected(x) = False Then a.Selected(x) = True
sal:
Next x
End Sub



Private Sub TextBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = TextBox2
End Sub
Private Sub TextBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = TextBox3
End Sub

Private Sub TextBox4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
TextBox1 = TextBox4
End Sub

Private Sub TextBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = "Expte: " & UserForm1.TextBox2 & " Caratula " & UserForm1.TextBox3
TextBox1 = TextBox5
End Sub

Private Sub TextBox6_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = "Expte: " & UserForm1.TextBox2 & " Caratula " & UserForm1.TextBox3
TextBox1 = TextBox6
End Sub

Private Sub TextBox7_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Clear
UserForm1.TextBox1 = "Expte: " & UserForm1.TextBox2 & " Caratula " & UserForm1.TextBox3
TextBox1 = TextBox7
End Sub

Private Sub TextBox8_Change()
If TextBox8 = Empty Then
UserForm1.Label1.Visible = True 'hace visible el label
Else
UserForm1.Label1.Visible = False
End If
End Sub


Private Sub TextBox9_Change()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Dim cn As ADODB.Connection, rs As ADODB.Recordset

If TextBox9 = Empty Then
UserForm1.Label2.Visible = True 'hace visible el label
Else
UserForm1.Label2.Visible = False
End If

If Len(UserForm1.TextBox9) <= 2 Then
UserForm1.ListBox3.Visible = False
Exit Sub
Else
UserForm1.ListBox3.Visible = True
End If

Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set a = Sheets("Hoja1")

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;"""

If Len(UserForm1.TextBox9) > 2 Then
sql = "SELECT * FROM [" & "Hoja1$" & "] WHERE Ucase(" & a.Range("A1") & ") LIKE Ucase('%" & UserForm1.TextBox9 & "%') ORDER BY Contacto ASC"
Set rs = cn.Execute(sql)

UserForm1.ListBox3.Clear


If rs.EOF = True Then
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
UserForm1.ListBox3.Visible = False
Exit Sub
Else

UserForm1.ListBox3.Column = 3
UserForm1.ListBox3.ColumnWidths = "100 pt;70 pt;80 pt"

rs.MoveFirst
Do While Not rs.EOF
    UserForm1.ListBox3.AddItem rs.Fields(0).Value
    UserForm1.ListBox3.List(UserForm1.ListBox3.ListCount - 1, 1) = rs.Fields(1).Value
    UserForm1.ListBox3.List(UserForm1.ListBox3.ListCount - 1, 2) = rs.Fields(2).Value
    rs.MoveNext
Loop
End If

End If
Set rs = Nothing
cn.Close
Set cn = Nothing

'Si solo hay un dato coincidente directamente lo busca y carga sus datos, al seleccionarlo se ejecuta el evento click del listbox
If UserForm1.ListBox3.ListCount - 1 = 0 Then
UserForm1.ListBox3.Selected(0) = True
UserForm1.ListBox3.Visible = False
End If
Application.ScreenUpdating = True
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Initialize()
Dim cn As ADODB.Connection, rs As ADODB.Recordset, sql As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next


ExpteWhatsapp = "SUSCRIBE https://www.youtube.com/c/programarexcel?sub_confirmation=1"
UserForm1.TextBox1 = ExpteWhatsapp
UserForm1.TextBox2 = "Estimado recuerda " & ExpteWhatsapp & " activa la campanita y YouTube te avisara cuando se suba nuevo contenido "
UserForm1.TextBox3 = "Automatiza tus Libros Excel, tutoriales semanales, recuerda " & ExpteWhatsapp & " todas las semanas ideas sobre como automatizar tus libros Excel "
UserForm1.TextBox4 = "Mis datos son:" & Chr(13) & " https://www.youtube.com/c/programarexcel?sub_confirmation=1 " & Chr(13) & " comenta, dale LIKE si te fue útil"
UserForm1.TextBox5 = "Recuerda darle LIKE Y COMENTAR SI FUE UTIL: " & Chr(13) & "RECUERDA " & ExpteWhatsapp
UserForm1.TextBox6 = "Su próxima factura de ProgramarExcel.com vence el: " & Chr(13) & "14/06/2020 "
UserForm1.TextBox7 = "https://programarexcel.com Descarga cientos de ejemplos de Macros de Excel GRATIS, aporta al canal si puedes, sino con like, comentario y suscripción es suficiente"


UserForm1.ListBox1.ColumnCount = 2
UserForm1.ListBox1.ColumnWidths = "80 pt; 60 pt"

Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set a = Sheets("Hoja1")

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;"""
sql = "SELECT * FROM [" & "Hoja1$" & "]"

Set rs = cn.Execute(sql)
If rs.EOF = True Then
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
Exit Sub
Else
UserForm1.ListBox1 = Clear
'Adiciona un item al listbox reservado para la cabecera
UserForm1.ListBox1.AddItem

rs.MoveFirst
Do While Not rs.EOF
    UserForm1.ListBox1.AddItem rs.Fields(0).Value
    UserForm1.ListBox1.List(UserForm1.ListBox1.ListCount - 1, 1) = rs.Fields(1).Value
    rs.MoveNext
Loop

'Carga los datos de la cabecera en listbox
For ii = 0 To rs.Fields.Count - 1
UserForm1.ListBox1.List(0, ii) = rs.Fields(ii).Name
Next ii

'Selecciona todos los items
For x = 1 To UserForm1.ListBox1.ListCount - 1
UserForm1.ListBox1.Selected(x) = True
Next x
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub



Código que se inserta en un módulo

'**************https://programarexcel.com  **** https://youtube.com/programarexcel*********

Public telwhatsapp, textwhatsapp, cancont
Sub Muestra()
UserForm1.Show
End Sub
Sub EnviaWhatsapp()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If telwhatsapp = Empty Or textwhatsapp = Empty Then
MsgBox ("Debe ingresar número de telefono y texto para enviar Whatsapp"), vbCritical, "AVISO"
Exit Sub
End If

mylinkwhatsapp = "https://api.whatsapp.com/send?phone=" & telwhatsapp & "&text=" & textwhatsapp
ActiveWorkbook.FollowHyperlink mylinkwhatsapp

Application.Wait (Now + TimeValue("00:00:05"))
ActiveWindow.Application.SendKeys "{TAB}"
Application.Wait (Now + TimeValue("00:00:01"))
ActiveWindow.Application.SendKeys "{TAB}"
Application.Wait (Now + TimeValue("00:00:05"))
ActiveWindow.Application.SendKeys "(~)" 'énvia enter para enviar mensaje
Application.Wait (Now + TimeValue("00:00:18"))
ActiveWindow.Application.SendKeys "(~)"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛⇛


Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends