'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

http://charlie.balch.org/hdoc/exceltohtml.html

Voir la macro de Charlie  

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