Re : valider envoi mail.
Je viens de découvrir cette page sur le web , je n'ai testé que la première macro et elle fonctionne , reste à tester les autres.
amicalement
La Vouivre
Excel et le WEB
Excel et le WEB
Envoi un Mail: l'adresse est dans la cellule D1, le sujet dans la D2 et le texte dans la D3
'Tester avec Outlook Express 5.
Sub EnvoiUnMail()
Dim MailAd As String
Dim Msg As String
Dim Subj As String
Dim URLto As String
MailAd = Range("d1")
Subj = Range("d2")
Msg = Msg & Range("d3")
URLto = "mailto:" & MailAd & "?subject=" & Subj & "&body=" & Msg
ActiveWorkbook.FollowHyperlink Address:=URLto
End Sub
Envoie la feuille 1 par Mail
Sub EnvoiFeuilMail()
Dim Wbk As Workbook
ThisWorkbook.Sheets("Feuil1").Copy
Set Wbk = ActiveWorkbook
SendKeys "{E}"
Wbk.SendMail "dj@free.fr", "Feuille du contrat à signer", True
'true pour un avis de reception
Wbk.Close savechanges:=False
Set Wbk = Nothing
End Sub
Envoie le classeur actif à plusieurs destinataires. Plage A1:A10
Vous pouvez ajouter des adresses, il suffit de modifier:
la référence de la plage A1:A11
la boucle 1 To 11
et le tableau Array(myadress(11) etc..
Sub EnvoiClasseurAd()
Dim myadress(1 To 10)
Set mylst = ActiveSheet.Range("a1:a10")
Count = 1
For Each Envoi In mylst
If Len(Envoi) Then myadress(Count) = Envoi: Count = Count + 1
Next
ActiveWorkbook.SendMail Recipients:=Array(myadress(1), myadress(2), _
myadress(3), myadress(4), myadress(5), myadress(6), myadress(7), _
myadress(8), myadress(9), myadress(10)), Subject:=" Voilà le classeur demandé"
End Sub
Exporte un graphique en image JPG
Sub GraphJPG()
Dim MyChart As Chart
Set MyChart = ActiveSheet.ChartObjects(1).Chart
MyChart.Export FileName:="C:\ajeter\graph1.jpg", filtername:="JPG"
End Sub
Exportation en .gif de la plage sélectionnée - Graphique y compris.
Laurent L.
Sub exportgif()
Dim Plage As Range
Set Plage = Application.InputBox(Prompt:="Sélectionner votre zone: (Ex. A1:B10) ", _
Title:="Sélection de zone ", Default:="$A$1", Type:=8)
Application.ScreenUpdating = False
Workbooks.Add
Plage.CopyPicture
ActiveSheet.Paste
With ActiveSheet.ChartObjects.Add(0, 0, _
Selection.Width, Selection.Height).Chart
.Paste
.Export "C:\ajeter\Test.gif", "GIF"
End With
ActiveWorkbook.Close False
End Sub
Enregistre une plage en fichier HTML de Charlie Balch
VBA HTML Conversion Code for Excel
Voir la macro de Charlie
Teste si une connection est active
Auteur inconnu
Public Const ERROR_SUCCESS = 0&
Public Const APINULL = 0&
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public ReturnCode As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal lpReserved As Long, lpType As Long, _
lpData As Any, lpcbData As Long) As Long
Private Declare Function InternetAutodial Lib "Wininet" _
(ByVal dwFlags As Long, ByVal hwndParent As Long) As Long
Private Declare Function InternetAutodialHangup Lib "wininet.dll" _
(ByVal dwReserved As Long) As Long
Public Function ActiveConnection() As Boolean
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
ActiveConnection = False
lpSubKey = "System\CurrentControlSet\Services\RemoteAccess"
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, phkResult)
If ReturnCode = ERROR_SUCCESS Then
hKey = phkResult
lpValueName = "Remote Connection"
lpReserved = APINULL
lpType = APINULL
lpData = APINULL
lpcbData = APINULL
ReturnCode = RegQueryValueEx _
(hKey, lpValueName, lpReserved, lpType, ByVal lpData, lpcbData)
lpcbData = Len(lpData)
ReturnCode = RegQueryValueEx _
(hKey, lpValueName, lpReserved, lpType, lpData, lpcbData)
If ReturnCode = ERROR_SUCCESS Then
If lpData = 0 Then
ActiveConnection = False
Else
ActiveConnection = True
End If
End If
RegCloseKey (hKey)
End If
End Function
Le test de connection
Sub test()
If ActiveConnection = True Then
Call MsgBox("Vous avez une connection active.", vbInformation)
Else
Call MsgBox("Vous n'avez pas de connection active.", vbInformation)
End If
End Sub
Avec XP
Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
(ByRef lpSFlags As Long, ByVal dwReserved As Long) As Long
Public Function IsConnectedToInternet(Optional ConnectMode As Integer) As Boolean
Dim lResult As Long
IsConnectedToInternet = InternetGetConnectedState(lResult, 0&)
ConnectMode = lResult
End Function
Sub test2()
If IsConnectedToInternet = True Then
Call MsgBox("Vous avez une connection active.", vbInformation)
Else
Call MsgBox("Vous n'avez pas de connection active.", vbInformation)
End If
End Sub
Lance la connection
Private Declare Function InternetAutodial Lib "Wininet" _
(ByVal dwFlags As Long, ByVal hwndParent As Long) As Long
Private Declare Function InternetAutodialHangup Lib "wininet.dll" _
(ByVal dwReserved As Long) As Long
Sub Connecte()
InternetAutodial 1, 0
End Sub
Arrête la connection
Sub DéConnecte()
InternetAutodialHangup (0&)
End Sub
Envoyer un message avec Outlook Express (testé avec Excel 2003)
La variable Dest contient l'adresse de courrier électronique.
La variable Sujt contient le sujet du message.
La variable Msg contient le corps du message.
Sub MailAvecOE()
Dim Dest As String
Dim Sujt As String
Dim Msg As String
Dest = "dj@free.fr"
Sujt = "Test d'envoi avec Excel"
Msg = "Bonjour, Excel vous envoie un message avec OE"
Shell "C:\Program Files\Outlook Express\msimn.exe " & _
"/mailurl:mailto:" & Dest & "?subject=" & Sujt & "&Body=" & Msg & ""
End Sub
Envoyer un message avec un classeur en fichier joint(testé avec Excel 2003)
Sub MailAvecOEClasseur()
Dim Dest, Sujt, Msg As String
Dim TheFile
TheFile = "c:\temp\monfich.xls"
Dest = "dj@free.fr"
Sujt = "Test d'envoi avec Excel"
Msg = "Bonjour, Excel vous envoie un message et un classeur avec OE"
Shell "C:\Program Files\Outlook Express\msimn.exe " & _
"/mailurl:mailto:" & Dest & "?subject=" & Sujt & "&Body=" & Msg & ""
SendKeys "%I" & "p" & TheFile & "~" & "%s"
End Sub
Signification des caractères après "SendKeys":
* %I et P = Insertion de la pièce jointe dans Outlook Express. (%=Alt)
* ~ = Validation. (~=Entrée)
* %S = Envoyer.
Comment envoyer une feuille dans un message en VBA?(testé avec Excel 2003)
Sub MailFeuilleOE()
Dim Dest, Sujt, Msg As String
Dim RepName
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:="C:\temp\test.xls"
RepName = "C:\temp\test.xls"
Dest = "dj@free.fr"
Sujt = "Test d'envoi d'une feuille avec Excel"
Msg = "Bonjour, Excel vous envoie une feuille avec OE"
Shell "C:\Program Files\Outlook Express\msimn.exe " & _
"/mailurl:mailto:" & Dest & "?subject=" & Sujt & "&Body=" & Msg & ""
SendKeys "%I" & "p" & RepName & "~" & "%s"
ActiveWorkbook.Close
End Sub
Comment envoyer une plage de cellules dans un message en VBA?(testé avec Excel 2003)
Cette macro envoie la plage A1:A10, vous pouvez évidement modifier cette ligne Range("A1:A10").Copy
pour envoyer une autre plage de cellules.
Sub EnvoiSelectionparMail()
Dim Dest, Sujt, Msg As String
Dim TheFile
Range("A1:A10").Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:="C:\temp\test.xls"
TheFile = "C:\temp\test.xls"
Dest = "dj@free.fr"
Sujt = "Test d'envoi avec Excel"
Msg = "Bonjour, Excel vous envoie une plage de cellules avec OE"
Shell "C:\Program Files\Outlook Express\msimn.exe " & _
"/mailurl:mailto:" & Dest & "?subject=" & Sujt & "&Body=" & Msg & ""
SendKeys "%I" & "p" & TheFile & "~" & "%s"
ActiveWorkbook.Close
End Sub
Un message à plusieurs destinataires ( Excel 2003)
La liste des destinaires est dans la plage A1:A10
Sub MailingListe()
Dim Dest As String
Dim Sujt As String
Dim Msg As String
For Each Lescellules In Range("A1:A10")
Dest = Lescellules.Value
Sujt = "Test d'envoi avec Excel"
Msg = "Bonjour, Excel vous envoie un message avec OE" _
& vbNewLine & "Daniel.j"
Shell "C:\Program Files\Outlook Express\msimn.exe " & _
"/mailurl:mailto:" & Dest & "?subject=" & Sujt & "&Body=" & Msg & ""
SendKeys "%s"
Next
'et si le texte du message est dans une zone de texte :
Msg = Worksheets("le nom de ta feuille").Shapes("Zone de texte 1").TextFrame.Characters.Text
End Sub
Ouvre une page web avec le navigateur par défaut
Private 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
Private Const SW_SHOWNORMAL As Long = 1
Sub LanceNavigateurPardefaut()
Dim Lurl As String
Lurl = "http://dj.joss.free.fr/sommaire.htm"
ShellExecute hwnd, "open", Lurl, vbNullString, vbNullString, SW_SHOWNORMAL
End Sub
Ouvre une page web et l'enregistre dans un nouveau classeur
Private Declare Function InternetAutodial Lib "Wininet" _
(ByVal dwFlags As Long, ByVal hwndParent As Long) As Long
Private Declare Function InternetAutodialHangup Lib "wininet.dll" _
(ByVal dwReserved As Long) As Long
Sub OuvreHTM()
InternetAutodial 1, 0
On Error Resume Next
Workbooks.OpenText "http:/dj.joss.free.fr/sommaire.htm", xlWindows, _
1, xlDelimited, ConsecutiveDelimiter:=False, Tab:=True
If Err Then MsgBox Err.Description: Exit Sub
On Error GoTo 0
ChDir "C:\ajeter\" 'a modifier
ActiveWorkbook.SaveAs Filename:="lapage.xls"
End Sub
'Arrête la connection
Sub DéConnecte()
InternetAutodialHangup (0&)
End Sub
